diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index ce44e17b163..00000000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,33 +0,0 @@ ---- -steps: - - simple_align: - cases: always - top_level_patterns: always - records: always - - imports: - align: none - post_qualify: true - - language_pragmas: - remove_redundant: false - - - trailing_whitespace: {} -columns: 100 -newline: native -language_extensions: - - DataKinds - - DeriveAnyClass - - DeriveGeneric - - DerivingStrategies - - DerivingVia - - ExistentialQuantification - - ExplicitNamespaces - - FlexibleContexts - - GeneralizedNewtypeDeriving - - MultiParamTypeClasses - - NamedFieldPuns - - ImportQualifiedPost - - PackageImports - - QuasiQuotes - - ScopedTypeVariables - - TemplateHaskell - - CPP diff --git a/cardano-constitution/src/Cardano/Constitution/Config.hs b/cardano-constitution/src/Cardano/Constitution/Config.hs index fe3c72016a7..77adb30608f 100644 --- a/cardano-constitution/src/Cardano/Constitution/Config.hs +++ b/cardano-constitution/src/Cardano/Constitution/Config.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} -module Cardano.Constitution.Config - ( defaultConstitutionConfig - , defaultPredMeanings - , module Export - ) where + +module Cardano.Constitution.Config ( + defaultConstitutionConfig, + defaultPredMeanings, + module Export, +) where import Cardano.Constitution.Config.Instance.FromJSON () import Cardano.Constitution.Config.Instance.TxLift () @@ -19,12 +20,12 @@ import Data.Aeson.THReader as Aeson -- | The default config read from "data/defaultConstitution.json" defaultConstitutionConfig :: ConstitutionConfig defaultConstitutionConfig = $$(Aeson.readJSONFromFile DFP.defaultConstitutionConfigFile) -{-# INLINABLE defaultConstitutionConfig #-} +{-# INLINEABLE defaultConstitutionConfig #-} -- | NOTE: **BE CAREFUL** of the ordering. Expected value is first arg, Proposed Value is second arg defaultPredMeanings :: PredKey -> PredMeaning a defaultPredMeanings = \case - MinValue -> (Tx.<=) - MaxValue -> (Tx.>=) - NotEqual -> (Tx./=) -{-# INLINABLE defaultPredMeanings #-} + MinValue -> (Tx.<=) + MaxValue -> (Tx.>=) + NotEqual -> (Tx./=) +{-# INLINEABLE defaultPredMeanings #-} diff --git a/cardano-constitution/src/Cardano/Constitution/Config/Instance/FromJSON.hs b/cardano-constitution/src/Cardano/Constitution/Config/Instance/FromJSON.hs index 87dd8721d06..5aa845daba5 100644 --- a/cardano-constitution/src/Cardano/Constitution/Config/Instance/FromJSON.hs +++ b/cardano-constitution/src/Cardano/Constitution/Config/Instance/FromJSON.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE LambdaCase #-} -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} + module Cardano.Constitution.Config.Instance.FromJSON () where import Cardano.Constitution.Config.Types @@ -24,59 +25,65 @@ import Text.Regex.TDFA as Rx -- | Replica ADTs of ParamValue & ConstitutionConfig , specialised only for FromJSON. -- Alternatively, we could generalise the aforementationed ADTs (needs barbies, breaks TxLifting) -data RawParamValue = - RawParamInteger (Predicates Integer) - | RawParamRational (Predicates Tx.Rational) - | RawParamList (M.Map Integer RawParamValue) - | RawParamAny +data RawParamValue + = RawParamInteger (Predicates Integer) + | RawParamRational (Predicates Tx.Rational) + | RawParamList (M.Map Integer RawParamValue) + | RawParamAny + newtype RawConstitutionConfig = RawConstitutionConfig (M.Map Integer RawParamValue) -- TODO: move to deriving-aeson instance FromJSON PredKey where - parseJSON = genericParseJSON (defaultOptions { constructorTagModifier = lowerInitialChar }) + parseJSON = genericParseJSON (defaultOptions {constructorTagModifier = lowerInitialChar}) -- TODO: move to deriving-aeson instance Aeson.FromJSONKey PredKey where - fromJSONKey = genericFromJSONKey (defaultJSONKeyOptions { keyModifier = lowerInitialChar }) + fromJSONKey = genericFromJSONKey (defaultJSONKeyOptions {keyModifier = lowerInitialChar}) instance FromJSON a => FromJSON (Predicates a) where - parseJSON val = do - -- TODO: ugly code, refactor - ms <- parseJSON @[Object] val - -- filter out "$comment" from all keymaps - let ms' = fmap (Object . Aeson.delete commentKey) ms - -- re-parse correctly this time - m <- parseJSON @[M.Map PredKey a] (Aeson.Array $ fromList ms') - when (any ((/= 1) . length) m) $ - fail "Only one predicate-key per predicate inside the predicate list" - pure $ Predicates $ - -- using toAscList here ensures that the inner map is sorted - M.toAscList - -- combine the duplicate predicates into a list of predicate values - -- entries with same key combine their values with (++) - $ M.unionsWith (<>) - $ fmap (fmap pure) m + parseJSON val = do + -- TODO: ugly code, refactor + ms <- parseJSON @[Object] val + -- filter out "$comment" from all keymaps + let ms' = fmap (Object . Aeson.delete commentKey) ms + -- re-parse correctly this time + m <- parseJSON @[M.Map PredKey a] (Aeson.Array $ fromList ms') + when (any ((/= 1) . length) m) $ + fail "Only one predicate-key per predicate inside the predicate list" + pure $ + Predicates $ + -- using toAscList here ensures that the inner map is sorted + M.toAscList + -- combine the duplicate predicates into a list of predicate values + -- entries with same key combine their values with (++) + $ + M.unionsWith (<>) $ + fmap (fmap pure) m instance FromJSON ConstitutionConfig where - parseJSON = - parseJSON -- first pass, parse raw - >=> - fromRaw -- second pass, flatten maps to lists, and check for contiguity + parseJSON = + parseJSON -- first pass, parse raw + >=> fromRaw -- second pass, flatten maps to lists, and check for contiguity -- 1st pass instance FromJSON RawConstitutionConfig where - parseJSON = fmap RawConstitutionConfig - . withObject "RawConstitutionConfig" (foldlM insertParam mempty . Aeson.toAscList) + parseJSON = + fmap RawConstitutionConfig + . withObject "RawConstitutionConfig" (foldlM insertParam mempty . Aeson.toAscList) where insertParam acc (outerKey, outerValue) = do - (index, msubIndex) <- parseParamKey outerKey - when (index < 0) $ fail "Negative Integer ParamKey given" - paramValue <- parseParamValue msubIndex outerValue - -- flipped version of Lens.at - M.alterF (\case - Nothing -> pure $ Just paramValue - Just paramValue' -> Just <$> mergeParamValues paramValue' paramValue - ) index acc + (index, msubIndex) <- parseParamKey outerKey + when (index < 0) $ fail "Negative Integer ParamKey given" + paramValue <- parseParamValue msubIndex outerValue + -- flipped version of Lens.at + M.alterF + ( \case + Nothing -> pure $ Just paramValue + Just paramValue' -> Just <$> mergeParamValues paramValue' paramValue + ) + index + acc -- second pass, flatten maps to lists, and check for contiguity fromRaw :: MonadFail m => RawConstitutionConfig -> m ConstitutionConfig @@ -84,75 +91,75 @@ fromRaw (RawConstitutionConfig rc) = ConstitutionConfig . M.toAscList <$> traver where flattenParamValue :: MonadFail m => RawParamValue -> m ParamValue flattenParamValue = \case - RawParamList m -> do - -- This is the CONTIGUOUS check. - when (not $ M.keys m `isPrefixOf` [0..]) $ fail "The sub-indices are not in order." - -- the M.elems will be in ascending order - ParamList <$> traverse flattenParamValue (M.elems m) - -- boilerplate follows - RawParamInteger x -> pure $ ParamInteger x - RawParamRational x -> pure $ ParamRational x - RawParamAny -> pure ParamAny + RawParamList m -> do + -- This is the CONTIGUOUS check. + when (not $ M.keys m `isPrefixOf` [0 ..]) $ fail "The sub-indices are not in order." + -- the M.elems will be in ascending order + ParamList <$> traverse flattenParamValue (M.elems m) + -- boilerplate follows + RawParamInteger x -> pure $ ParamInteger x + RawParamRational x -> pure $ ParamRational x + RawParamAny -> pure ParamAny -- MAYBE: use instead attoparsec-aeson.jsonWith/jsonNoDup to fail on parsing duplicate Keys, -- because right now Aeson silently ignores duplicated param entries (arbitrarily picks the last of duplicates) parseParamKey :: Aeson.Key -> Aeson.Parser (Integer, Maybe Integer) parseParamKey (Aeson.toString -> s) = do - -- MAYBE: fetch the regex pattern from the schema itself, it is easy - [[_, indexS,_,subIndexS]] :: [[String]] <- s Rx.=~~ ("^(0|[1-9][0-9]*)(\\[(0|[1-9][0-9]*)\\])?$" :: String) - indexI <- either fail pure $ readEitherSafe indexS - mSubIndexI <- - if null subIndexS - then pure Nothing - else Just <$> either fail pure (readEitherSafe subIndexS) - pure (indexI,mSubIndexI) + -- MAYBE: fetch the regex pattern from the schema itself, it is easy + [[_, indexS, _, subIndexS]] :: [[String]] <- s Rx.=~~ ("^(0|[1-9][0-9]*)(\\[(0|[1-9][0-9]*)\\])?$" :: String) + indexI <- either fail pure $ readEitherSafe indexS + mSubIndexI <- + if null subIndexS + then pure Nothing + else Just <$> either fail pure (readEitherSafe subIndexS) + pure (indexI, mSubIndexI) -- | If there is a subkey given, treat the param as a paramlist -- Otherwise, parse it based on the json's "type" parseParamValue :: Maybe ParamKey -> Value -> Parser RawParamValue parseParamValue = \case - Nothing -> parseTypedParamValue - -- if we parsed a sub-index, treat the param value as a `M.singleton subIndex value` - Just subIndex -> fmap (RawParamList . M.singleton subIndex) . parseTypedParamValue + Nothing -> parseTypedParamValue + -- if we parsed a sub-index, treat the param value as a `M.singleton subIndex value` + Just subIndex -> fmap (RawParamList . M.singleton subIndex) . parseTypedParamValue where - parseTypedParamValue :: Value -> Parser RawParamValue - parseTypedParamValue = withObject "RawParamValue" $ \o -> do - ty <- o .: typeKey - parseSynonymType ty o - - -- the base types we support - parseBaseType :: Key -> Object -> Parser RawParamValue - parseBaseType ty o = case ty of - "integer" -> RawParamInteger <$> (o .: predicatesKey) - -- NOTE: even if the Tx.Ratio.Rational constructor is not exposed, the 2 arguments to the constructor - -- will be normalized (co-primed) when Tx.lift is called on them. - -- SO there is no speed benefit to statically co-prime them ourselves for efficiency. - "rational" -> RawParamRational <$> (o .: predicatesKey) - "any" -> pure RawParamAny - _ -> fail "invalid type tag" - - -- synonyms to ease the transition from cddl - parseSynonymType = \case - "coin" -> parseBaseType "integer" - "uint.size4" -> parseBaseType "integer" - "uint.size2" -> parseBaseType "integer" - "uint" -> parseBaseType "integer" -- For ex units - "epoch_interval" -> parseBaseType "integer" -- Rename of uint.size4 - "unit_interval" -> parseBaseType "rational" - "nonnegative_interval" -> parseBaseType "rational" - "costMdls" -> parseBaseType "any" - x -> parseBaseType x -- didn't find synonym, try as basetype + parseTypedParamValue :: Value -> Parser RawParamValue + parseTypedParamValue = withObject "RawParamValue" $ \o -> do + ty <- o .: typeKey + parseSynonymType ty o + + -- the base types we support + parseBaseType :: Key -> Object -> Parser RawParamValue + parseBaseType ty o = case ty of + "integer" -> RawParamInteger <$> (o .: predicatesKey) + -- NOTE: even if the Tx.Ratio.Rational constructor is not exposed, the 2 arguments to the constructor + -- will be normalized (co-primed) when Tx.lift is called on them. + -- SO there is no speed benefit to statically co-prime them ourselves for efficiency. + "rational" -> RawParamRational <$> (o .: predicatesKey) + "any" -> pure RawParamAny + _ -> fail "invalid type tag" + + -- synonyms to ease the transition from cddl + parseSynonymType = \case + "coin" -> parseBaseType "integer" + "uint.size4" -> parseBaseType "integer" + "uint.size2" -> parseBaseType "integer" + "uint" -> parseBaseType "integer" -- For ex units + "epoch_interval" -> parseBaseType "integer" -- Rename of uint.size4 + "unit_interval" -> parseBaseType "rational" + "nonnegative_interval" -> parseBaseType "rational" + "costMdls" -> parseBaseType "any" + x -> parseBaseType x -- didn't find synonym, try as basetype -- | It is like an `mappend` when both inputs are ParamList's. mergeParamValues :: MonadFail m => RawParamValue -> RawParamValue -> m RawParamValue mergeParamValues (RawParamList m1) = \case - RawParamList m2 -> pure $ RawParamList $ m1 <> m2 - _ -> fail "param matched with subparam" + RawParamList m2 -> pure $ RawParamList $ m1 <> m2 + _ -> fail "param matched with subparam" mergeParamValues _ = \case - RawParamList _ -> fail "param matched with subparam" - -- in reality this cannot be triggered, because we would then have duplicate params - -- , which default aeson and json allow - _ -> fail "this should not happen" + RawParamList _ -> fail "param matched with subparam" + -- in reality this cannot be triggered, because we would then have duplicate params + -- , which default aeson and json allow + _ -> fail "this should not happen" predicatesKey, typeKey, commentKey :: Aeson.Key predicatesKey = "predicates" diff --git a/cardano-constitution/src/Cardano/Constitution/Config/Instance/TxLift.hs b/cardano-constitution/src/Cardano/Constitution/Config/Instance/TxLift.hs index f289e3762a1..be000afdc48 100644 --- a/cardano-constitution/src/Cardano/Constitution/Config/Instance/TxLift.hs +++ b/cardano-constitution/src/Cardano/Constitution/Config/Instance/TxLift.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Cardano.Constitution.Config.Instance.TxLift () where import Cardano.Constitution.Config.Types @@ -14,8 +15,9 @@ import PlutusTx.Lift.Class as Tx Tx.makeLift ''PredKey -deriving newtype instance (Tx.Typeable Tx.DefaultUni predValue, Tx.Lift Tx.DefaultUni predValue) - => Tx.Lift Tx.DefaultUni (Predicates predValue) +deriving newtype instance + (Tx.Typeable Tx.DefaultUni predValue, Tx.Lift Tx.DefaultUni predValue) => + Tx.Lift Tx.DefaultUni (Predicates predValue) Tx.makeTypeable (TH.ConT ''Tx.DefaultUni) ''Predicates Tx.makeLift ''ParamValue diff --git a/cardano-constitution/src/Cardano/Constitution/Config/Types.hs b/cardano-constitution/src/Cardano/Constitution/Config/Types.hs index 7b843fe573e..c6cf6a4a0b1 100644 --- a/cardano-constitution/src/Cardano/Constitution/Config/Types.hs +++ b/cardano-constitution/src/Cardano/Constitution/Config/Types.hs @@ -1,18 +1,19 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} -- editorconfig-checker-disable-file {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Constitution.Config.Types - ( PredKey(..) - , Predicate - , Predicates(..) - , PredMeaning - , Param - , ParamKey - , ParamValue(..) - , ConstitutionConfig(..) - ) where + +module Cardano.Constitution.Config.Types ( + PredKey (..), + Predicate, + Predicates (..), + PredMeaning, + Param, + ParamKey, + ParamValue (..), + ConstitutionConfig (..), +) where import GHC.Generics import Language.Haskell.TH.Syntax as TH @@ -23,46 +24,50 @@ import Prelude qualified as Haskell -- | The "unresolved" Predicate names, as read from JSON. At runtime, these PredKeys -- will each be resolved to actual `PredMeaning` functions. -data PredKey = - MinValue +data PredKey + = MinValue | MaxValue | NotEqual deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Haskell.Enum, Haskell.Bounded, Generic, TH.Lift) instance Tx.Eq PredKey where - {-# INLINABLE (==) #-} - -- See Note [No catch-all] - MinValue == MinValue = Haskell.True - MaxValue == MaxValue = Haskell.True - NotEqual == NotEqual = Haskell.True - MinValue == _ = Haskell.False - MaxValue == _ = Haskell.False - NotEqual == _ = Haskell.False + {-# INLINEABLE (==) #-} + -- See Note [No catch-all] + MinValue == MinValue = Haskell.True + MaxValue == MaxValue = Haskell.True + NotEqual == NotEqual = Haskell.True + MinValue == _ = Haskell.False + MaxValue == _ = Haskell.False + NotEqual == _ = Haskell.False -- | Polymorphic over the values. In reality, the value v is an Tx.Integer or Tx.Rational type Predicate v = (PredKey, [v]) -- | newtype so we can overload FromJSON -newtype Predicates v = Predicates { unPredicates :: [Predicate v] } - deriving stock (TH.Lift) - deriving newtype (Haskell.Eq, Haskell.Show) +newtype Predicates v = Predicates {unPredicates :: [Predicate v]} + deriving stock (TH.Lift) + deriving newtype (Haskell.Eq, Haskell.Show) -- | The "meaning" of a predicate, resolved from a `PredKey` (a string in JSON) -- to a Tx binary predicate function. -type PredMeaning a = Tx.Ord a - => a -- ^ the expected value, supplied from the config (json) - -> a -- ^ the proposed value, taken from the ScriptContext - -> Haskell.Bool -- ^ True means the proposed value meets the expectations. +type PredMeaning a = + Tx.Ord a => + -- | the expected value, supplied from the config (json) + a -> + -- | the proposed value, taken from the ScriptContext + a -> + -- | True means the proposed value meets the expectations. + Haskell.Bool -- | Promised to be a stable identifier (stable at least for a whole cardano era) type ParamKey = Haskell.Integer -data ParamValue = - ParamInteger (Predicates Haskell.Integer) - | ParamRational (Predicates Tx.Rational) - | ParamList [ParamValue] - | ParamAny - deriving stock (Haskell.Eq, Haskell.Show, TH.Lift) +data ParamValue + = ParamInteger (Predicates Haskell.Integer) + | ParamRational (Predicates Tx.Rational) + | ParamList [ParamValue] + | ParamAny + deriving stock (Haskell.Eq, Haskell.Show, TH.Lift) type Param = (ParamKey, ParamValue) @@ -77,9 +82,9 @@ and not when manually constructing a `ConstitutionConfig` ADT value. -} -- | See Note [Manually constructing a Configuration value] -newtype ConstitutionConfig = ConstitutionConfig { unConstitutionConfig :: [Param] } - deriving stock (TH.Lift) - deriving newtype (Haskell.Eq, Haskell.Show) +newtype ConstitutionConfig = ConstitutionConfig {unConstitutionConfig :: [Param]} + deriving stock (TH.Lift) + deriving newtype (Haskell.Eq, Haskell.Show) -- Taken from the older Reference impl: src/Cardano/Constitution/Validator/Reference/Types.hs instance TH.Lift Tx.Rational where diff --git a/cardano-constitution/src/Cardano/Constitution/Data/Validator.hs b/cardano-constitution/src/Cardano/Constitution/Data/Validator.hs index 93592c83a22..47d02749723 100644 --- a/cardano-constitution/src/Cardano/Constitution/Data/Validator.hs +++ b/cardano-constitution/src/Cardano/Constitution/Data/Validator.hs @@ -1,26 +1,28 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedLists #-} -module Cardano.Constitution.Data.Validator - ( module Export - , defaultValidators - , defaultValidatorsWithCodes - ) where + +module Cardano.Constitution.Data.Validator ( + module Export, + defaultValidators, + defaultValidatorsWithCodes, +) where import Cardano.Constitution.Validator.Data.Common as Export import Cardano.Constitution.Validator.Data.Sorted qualified as S import Cardano.Constitution.Validator.Data.Unsorted qualified as U ---import Cardano.Constitution.Validator.Reference.Script qualified as R + +-- import Cardano.Constitution.Validator.Reference.Script qualified as R import Data.Map.Strict qualified as M import PlutusTx.Code defaultValidatorsWithCodes :: M.Map String (ConstitutionValidator, CompiledCode ConstitutionValidator) defaultValidatorsWithCodes = - [ ("sorted", (S.defaultConstitutionValidator, S.defaultConstitutionCode)) - , ("unsorted", (U.defaultConstitutionValidator, U.defaultConstitutionCode)) - -- Disabled, 7 tests fail - -- , ("ref", (R.constitutionScript, R.compiledConstitutionScript)) - ] + [ ("sorted", (S.defaultConstitutionValidator, S.defaultConstitutionCode)) + , ("unsorted", (U.defaultConstitutionValidator, U.defaultConstitutionCode)) + -- Disabled, 7 tests fail + -- , ("ref", (R.constitutionScript, R.compiledConstitutionScript)) + ] defaultValidators :: M.Map String ConstitutionValidator defaultValidators = fmap fst defaultValidatorsWithCodes diff --git a/cardano-constitution/src/Cardano/Constitution/DataFilePaths.hs b/cardano-constitution/src/Cardano/Constitution/DataFilePaths.hs index 81db09a01fb..712ac68f026 100644 --- a/cardano-constitution/src/Cardano/Constitution/DataFilePaths.hs +++ b/cardano-constitution/src/Cardano/Constitution/DataFilePaths.hs @@ -1,7 +1,7 @@ -module Cardano.Constitution.DataFilePaths - ( defaultConstitutionConfigFile - , defaultConstitutionJSONSchemaFile - ) where +module Cardano.Constitution.DataFilePaths ( + defaultConstitutionConfigFile, + defaultConstitutionJSONSchemaFile, +) where import System.FilePath diff --git a/cardano-constitution/src/Cardano/Constitution/Validator.hs b/cardano-constitution/src/Cardano/Constitution/Validator.hs index bab2c35bf05..c178fcfb2ec 100644 --- a/cardano-constitution/src/Cardano/Constitution/Validator.hs +++ b/cardano-constitution/src/Cardano/Constitution/Validator.hs @@ -1,26 +1,28 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedLists #-} -module Cardano.Constitution.Validator - ( module Export - , defaultValidators - , defaultValidatorsWithCodes - ) where + +module Cardano.Constitution.Validator ( + module Export, + defaultValidators, + defaultValidatorsWithCodes, +) where import Cardano.Constitution.Validator.Common as Export import Cardano.Constitution.Validator.Sorted qualified as S import Cardano.Constitution.Validator.Unsorted qualified as U ---import Cardano.Constitution.Validator.Reference.Script qualified as R + +-- import Cardano.Constitution.Validator.Reference.Script qualified as R import Data.Map.Strict qualified as M import PlutusTx.Code defaultValidatorsWithCodes :: M.Map String (ConstitutionValidator, CompiledCode ConstitutionValidator) defaultValidatorsWithCodes = - [ ("sorted", (S.defaultConstitutionValidator, S.defaultConstitutionCode)) - , ("unsorted", (U.defaultConstitutionValidator, U.defaultConstitutionCode)) - -- Disabled, 7 tests fail - -- , ("ref", (R.constitutionScript, R.compiledConstitutionScript)) - ] + [ ("sorted", (S.defaultConstitutionValidator, S.defaultConstitutionCode)) + , ("unsorted", (U.defaultConstitutionValidator, U.defaultConstitutionCode)) + -- Disabled, 7 tests fail + -- , ("ref", (R.constitutionScript, R.compiledConstitutionScript)) + ] defaultValidators :: M.Map String ConstitutionValidator defaultValidators = fmap fst defaultValidatorsWithCodes diff --git a/cardano-constitution/src/Cardano/Constitution/Validator/Common.hs b/cardano-constitution/src/Cardano/Constitution/Validator/Common.hs index 0ebac7278a5..ff9420528ed 100644 --- a/cardano-constitution/src/Cardano/Constitution/Validator/Common.hs +++ b/cardano-constitution/src/Cardano/Constitution/Validator/Common.hs @@ -1,16 +1,17 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -module Cardano.Constitution.Validator.Common - ( withChangedParams - , ChangedParams - , ConstitutionValidator - , validateParamValue - ) where +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.Constitution.Validator.Common ( + withChangedParams, + ChangedParams, + ConstitutionValidator, + validateParamValue, +) where import Control.Category hiding ((.)) @@ -23,85 +24,94 @@ import PlutusTx.List as List import PlutusTx.NonCanonicalRational as NCRatio import PlutusTx.Prelude as Tx -type ConstitutionValidator = BuiltinData -- ^ ScriptContext, deep inside is the changed-parameters proposal - -> BuiltinUnit -- ^ No-error means the proposal conforms to the constitution +type ConstitutionValidator = + -- | ScriptContext, deep inside is the changed-parameters proposal + BuiltinData -> + -- | No-error means the proposal conforms to the constitution + BuiltinUnit -- OPTIMIZE: operate on BuiltinList directly, needs major refactoring of sorted&unsorted Validators type ChangedParams = [(BuiltinData, BuiltinData)] -{- HLINT ignore "Redundant lambda" -} -- I like to see until where it supposed to be first applied. -{- HLINT ignore "Collapse lambdas" -} -- I like to see and comment on each arg +{- HLINT ignore "Redundant lambda" -} +-- I like to see until where it supposed to be first applied. +{- HLINT ignore "Collapse lambdas" -} +-- I like to see and comment on each arg withChangedParams :: (ChangedParams -> Bool) -> ConstitutionValidator withChangedParams fun (scriptContextToValidGovAction -> validGovAction) = - case validGovAction of - Just cparams -> if fun cparams - then BI.unitval - else traceError "ChangedParams failed to validate" - Nothing -> BI.unitval -- this is a treasury withdrawal, we just accept it -{-# INLINABLE withChangedParams #-} + case validGovAction of + Just cparams -> + if fun cparams + then BI.unitval + else traceError "ChangedParams failed to validate" + Nothing -> BI.unitval -- this is a treasury withdrawal, we just accept it +{-# INLINEABLE withChangedParams #-} validateParamValue :: ParamValue -> BuiltinData -> Bool validateParamValue = \case - ParamInteger preds -> validatePreds preds . B.unsafeDataAsI - ParamRational preds -> validatePreds preds . coerce . unsafeFromBuiltinData @NonCanonicalRational - ParamList paramValues -> validateParamValues paramValues . BI.unsafeDataAsList - -- accept the actual proposed value without examining it - ParamAny -> const True + ParamInteger preds -> validatePreds preds . B.unsafeDataAsI + ParamRational preds -> validatePreds preds . coerce . unsafeFromBuiltinData @NonCanonicalRational + ParamList paramValues -> validateParamValues paramValues . BI.unsafeDataAsList + -- accept the actual proposed value without examining it + ParamAny -> const True where - validateParamValues :: [ParamValue] -> BI.BuiltinList BuiltinData -> Bool - validateParamValues = \case - (paramValueHd : paramValueTl) -> \actualValueData -> - -- if actualValueData is not a cons, it will error - validateParamValue paramValueHd (BI.head actualValueData) - && validateParamValues paramValueTl (BI.tail actualValueData) - -- if reached the end of list of param-values to check, ensure no more proposed data are left - [] -> B.fromOpaque . BI.null + validateParamValues :: [ParamValue] -> BI.BuiltinList BuiltinData -> Bool + validateParamValues = \case + (paramValueHd : paramValueTl) -> \actualValueData -> + -- if actualValueData is not a cons, it will error + validateParamValue paramValueHd (BI.head actualValueData) + && validateParamValues paramValueTl (BI.tail actualValueData) + -- if reached the end of list of param-values to check, ensure no more proposed data are left + [] -> B.fromOpaque . BI.null - validatePreds :: forall a. Tx.Ord a => Predicates a -> a -> Bool - validatePreds (Predicates preds) (validatePred -> validatePredAppliedToActual) = - List.all validatePredAppliedToActual preds + validatePreds :: forall a. Tx.Ord a => Predicates a -> a -> Bool + validatePreds (Predicates preds) (validatePred -> validatePredAppliedToActual) = + List.all validatePredAppliedToActual preds - validatePred :: forall a. Tx.Ord a => a -> Predicate a -> Bool - validatePred actualValue (predKey, expectedPredValues) = - List.all meaningWithActual expectedPredValues - where - -- we find the meaning (function) from the PredKey - meaning = defaultPredMeanings predKey - -- apply the meaning to actual value: expectedValue is 1st argument, actualValue is 2nd argument - meaningWithActual = (`meaning` actualValue) -{-# INLINABLE validateParamValue #-} + validatePred :: forall a. Tx.Ord a => a -> Predicate a -> Bool + validatePred actualValue (predKey, expectedPredValues) = + List.all meaningWithActual expectedPredValues + where + -- we find the meaning (function) from the PredKey + meaning = defaultPredMeanings predKey + -- apply the meaning to actual value: expectedValue is 1st argument, actualValue is 2nd argument + meaningWithActual = (`meaning` actualValue) +{-# INLINEABLE validateParamValue #-} scriptContextToValidGovAction :: BuiltinData -> Maybe ChangedParams -scriptContextToValidGovAction = scriptContextToScriptInfo - >>> scriptInfoToProposalProcedure - >>> proposalProcedureToGovernanceAction - >>> governanceActionToValidGovAction +scriptContextToValidGovAction = + scriptContextToScriptInfo + >>> scriptInfoToProposalProcedure + >>> proposalProcedureToGovernanceAction + >>> governanceActionToValidGovAction where scriptContextToScriptInfo :: BuiltinData -> BuiltinData -- aka ScriptContext -> ScriptInfo - scriptContextToScriptInfo = BI.unsafeDataAsConstr - >>> BI.snd - >>> BI.tail - >>> BI.tail - >>> BI.head + scriptContextToScriptInfo = + BI.unsafeDataAsConstr + >>> BI.snd + >>> BI.tail + >>> BI.tail + >>> BI.head scriptInfoToProposalProcedure :: BuiltinData -> BuiltinData scriptInfoToProposalProcedure (BI.unsafeDataAsConstr -> si) = - if BI.fst si `B.equalsInteger` 5 -- Constructor Index of `ProposingScript` + if BI.fst si `B.equalsInteger` 5 -- Constructor Index of `ProposingScript` then BI.head (BI.tail (BI.snd si)) else traceError "Not a ProposalProcedure. This should not ever happen, because ledger should guard before, against it." proposalProcedureToGovernanceAction :: BuiltinData -> BuiltinData - proposalProcedureToGovernanceAction = BI.unsafeDataAsConstr - >>> BI.snd - >>> BI.tail - >>> BI.tail - >>> BI.head + proposalProcedureToGovernanceAction = + BI.unsafeDataAsConstr + >>> BI.snd + >>> BI.tail + >>> BI.tail + >>> BI.head governanceActionToValidGovAction :: BuiltinData -> Maybe ChangedParams governanceActionToValidGovAction (BI.unsafeDataAsConstr -> govAction@(BI.fst -> govActionConstr)) - -- Constructor Index of `ChangedParams` is 0 - | govActionConstr `B.equalsInteger` 0 = Just (B.unsafeDataAsMap (BI.head (BI.tail (BI.snd govAction)))) - -- Constructor Index of `TreasuryWithdrawals` is 2 - | govActionConstr `B.equalsInteger` 2 = Nothing -- means treasurywithdrawal - | otherwise = traceError "Not a ChangedParams or TreasuryWithdrawals. This should not ever happen, because ledger should guard before, against it." -{-# INLINABLE scriptContextToValidGovAction #-} + -- Constructor Index of `ChangedParams` is 0 + | govActionConstr `B.equalsInteger` 0 = Just (B.unsafeDataAsMap (BI.head (BI.tail (BI.snd govAction)))) + -- Constructor Index of `TreasuryWithdrawals` is 2 + | govActionConstr `B.equalsInteger` 2 = Nothing -- means treasurywithdrawal + | otherwise = traceError "Not a ChangedParams or TreasuryWithdrawals. This should not ever happen, because ledger should guard before, against it." +{-# INLINEABLE scriptContextToValidGovAction #-} diff --git a/cardano-constitution/src/Cardano/Constitution/Validator/Data/Common.hs b/cardano-constitution/src/Cardano/Constitution/Validator/Data/Common.hs index fbbf082d7e7..e87a1c6f5eb 100644 --- a/cardano-constitution/src/Cardano/Constitution/Validator/Data/Common.hs +++ b/cardano-constitution/src/Cardano/Constitution/Validator/Data/Common.hs @@ -1,16 +1,17 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -module Cardano.Constitution.Validator.Data.Common - ( withChangedParams - , ChangedParams - , ConstitutionValidator - , validateParamValue - ) where +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.Constitution.Validator.Data.Common ( + withChangedParams, + ChangedParams, + ConstitutionValidator, + validateParamValue, +) where import Cardano.Constitution.Config import Data.Coerce @@ -21,72 +22,77 @@ import PlutusTx.List as List import PlutusTx.NonCanonicalRational as NCRatio import PlutusTx.Prelude as Tx -type ConstitutionValidator = ScriptContext -- ^ Deep inside is the changed-parameters proposal - -> BuiltinUnit -- ^ No-error means the proposal conforms to the constitution +type ConstitutionValidator = + -- | Deep inside is the changed-parameters proposal + ScriptContext -> + -- | No-error means the proposal conforms to the constitution + BuiltinUnit -- OPTIMIZE: operate on BuiltinList directly, needs major refactoring of sorted&unsorted Validators type ChangedParams = [(BuiltinData, BuiltinData)] -{- HLINT ignore "Redundant lambda" -} -- I like to see until where it supposed to be first applied. -{- HLINT ignore "Collapse lambdas" -} -- I like to see and comment on each arg +{- HLINT ignore "Redundant lambda" -} +-- I like to see until where it supposed to be first applied. +{- HLINT ignore "Collapse lambdas" -} +-- I like to see and comment on each arg withChangedParams :: (ChangedParams -> Bool) -> ConstitutionValidator withChangedParams fun (scriptContextToValidGovAction -> validGovAction) = - case validGovAction of - Just cparams -> if fun cparams - then BI.unitval - else traceError "ChangedParams failed to validate" - Nothing -> BI.unitval -- this is a treasury withdrawal, we just accept it -{-# INLINABLE withChangedParams #-} + case validGovAction of + Just cparams -> + if fun cparams + then BI.unitval + else traceError "ChangedParams failed to validate" + Nothing -> BI.unitval -- this is a treasury withdrawal, we just accept it +{-# INLINEABLE withChangedParams #-} validateParamValue :: ParamValue -> BuiltinData -> Bool validateParamValue = \case - ParamInteger preds -> validatePreds preds . B.unsafeDataAsI - ParamRational preds -> validatePreds preds . coerce . unsafeFromBuiltinData @NonCanonicalRational - ParamList paramValues -> validateParamValues paramValues . BI.unsafeDataAsList - -- accept the actual proposed value without examining it - ParamAny -> const True + ParamInteger preds -> validatePreds preds . B.unsafeDataAsI + ParamRational preds -> validatePreds preds . coerce . unsafeFromBuiltinData @NonCanonicalRational + ParamList paramValues -> validateParamValues paramValues . BI.unsafeDataAsList + -- accept the actual proposed value without examining it + ParamAny -> const True where - validateParamValues :: [ParamValue] -> BI.BuiltinList BuiltinData -> Bool - validateParamValues = \case - (paramValueHd : paramValueTl) -> \actualValueData -> - -- if actualValueData is not a cons, it will error - validateParamValue paramValueHd (BI.head actualValueData) - && validateParamValues paramValueTl (BI.tail actualValueData) - -- if reached the end of list of param-values to check, ensure no more proposed data are left - [] -> B.fromOpaque . BI.null + validateParamValues :: [ParamValue] -> BI.BuiltinList BuiltinData -> Bool + validateParamValues = \case + (paramValueHd : paramValueTl) -> \actualValueData -> + -- if actualValueData is not a cons, it will error + validateParamValue paramValueHd (BI.head actualValueData) + && validateParamValues paramValueTl (BI.tail actualValueData) + -- if reached the end of list of param-values to check, ensure no more proposed data are left + [] -> B.fromOpaque . BI.null - validatePreds :: forall a. Tx.Ord a => Predicates a -> a -> Bool - validatePreds (Predicates preds) (validatePred -> validatePredAppliedToActual) = - List.all validatePredAppliedToActual preds + validatePreds :: forall a. Tx.Ord a => Predicates a -> a -> Bool + validatePreds (Predicates preds) (validatePred -> validatePredAppliedToActual) = + List.all validatePredAppliedToActual preds - validatePred :: forall a. Tx.Ord a => a -> Predicate a -> Bool - validatePred actualValue (predKey, expectedPredValues) = - List.all meaningWithActual expectedPredValues - where - -- we find the meaning (function) from the PredKey - meaning = defaultPredMeanings predKey - -- apply the meaning to actual value: expectedValue is 1st argument, actualValue is 2nd argument - meaningWithActual = (`meaning` actualValue) -{-# INLINABLE validateParamValue #-} + validatePred :: forall a. Tx.Ord a => a -> Predicate a -> Bool + validatePred actualValue (predKey, expectedPredValues) = + List.all meaningWithActual expectedPredValues + where + -- we find the meaning (function) from the PredKey + meaning = defaultPredMeanings predKey + -- apply the meaning to actual value: expectedValue is 1st argument, actualValue is 2nd argument + meaningWithActual = (`meaning` actualValue) +{-# INLINEABLE validateParamValue #-} -scriptContextToValidGovAction :: ScriptContext-> Maybe ChangedParams +scriptContextToValidGovAction :: ScriptContext -> Maybe ChangedParams scriptContextToValidGovAction = - governanceActionToValidGovAction + governanceActionToValidGovAction . ppGovernanceAction . scriptInfoToProposalProcedure . scriptContextScriptInfo - where scriptInfoToProposalProcedure :: ScriptInfo -> ProposalProcedure scriptInfoToProposalProcedure si = - case si of - (ProposingScript _ pp) -> pp - _ -> traceError "Not a ProposalProcedure. This should not ever happen, because ledger should guard before, against it." + case si of + (ProposingScript _ pp) -> pp + _ -> traceError "Not a ProposalProcedure. This should not ever happen, because ledger should guard before, against it." governanceActionToValidGovAction :: GovernanceAction -> Maybe ChangedParams governanceActionToValidGovAction govAction = - case govAction of - (ParameterChange _ cparams _) -> Just . B.unsafeDataAsMap . toBuiltinData $ cparams - (TreasuryWithdrawals _ _) -> Nothing - _ -> traceError "Not a ChangedParams. This should not ever happen, because ledger should guard before, against it." -{-# INLINABLE scriptContextToValidGovAction #-} + case govAction of + (ParameterChange _ cparams _) -> Just . B.unsafeDataAsMap . toBuiltinData $ cparams + (TreasuryWithdrawals _ _) -> Nothing + _ -> traceError "Not a ChangedParams. This should not ever happen, because ledger should guard before, against it." +{-# INLINEABLE scriptContextToValidGovAction #-} diff --git a/cardano-constitution/src/Cardano/Constitution/Validator/Data/Sorted.hs b/cardano-constitution/src/Cardano/Constitution/Validator/Data/Sorted.hs index 78113b2cc8e..998d8633aee 100644 --- a/cardano-constitution/src/Cardano/Constitution/Validator/Data/Sorted.hs +++ b/cardano-constitution/src/Cardano/Constitution/Validator/Data/Sorted.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -- Following is for tx compilation -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -module Cardano.Constitution.Validator.Data.Sorted - ( constitutionValidator - , defaultConstitutionValidator - , mkConstitutionCode - , defaultConstitutionCode - ) where +module Cardano.Constitution.Validator.Data.Sorted ( + constitutionValidator, + defaultConstitutionValidator, + mkConstitutionCode, + defaultConstitutionCode, +) where import Cardano.Constitution.Config import Cardano.Constitution.Validator.Data.Common as Common @@ -28,24 +28,29 @@ import PlutusTx.Prelude as Tx -- | Expects a constitution-configuration, statically *OR* at runtime via Tx.liftCode constitutionValidator :: ConstitutionConfig -> ConstitutionValidator constitutionValidator (ConstitutionConfig cfg) = - Common.withChangedParams (runRules cfg) + Common.withChangedParams (runRules cfg) -- | The `runRules` is a loop that works element-wise from left-to-right on the 2 sorted maps. -runRules :: [Param] -- ^ the config (sorted by default) - -> ChangedParams -- ^ the params (came sorted by the ledger) - -> Bool -runRules ((expectedPid, paramValue) : cfgRest) - cparams@((B.unsafeDataAsI -> actualPid, actualValueData) : cparamsRest) = +runRules :: + -- | the config (sorted by default) + [Param] -> + -- | the params (came sorted by the ledger) + ChangedParams -> + Bool +runRules + ((expectedPid, paramValue) : cfgRest) + cparams@((B.unsafeDataAsI -> actualPid, actualValueData) : cparamsRest) = case actualPid `compare` expectedPid of - EQ -> - Common.validateParamValue paramValue actualValueData - -- drop both heads, and continue checking the next changed param - && runRules cfgRest cparamsRest - - GT -> -- skip configHead pointing to a parameter not being proposed - runRules cfgRest cparams - LT -> -- actualPid not found in json config, the constitution fails - False + EQ -> + Common.validateParamValue paramValue actualValueData + -- drop both heads, and continue checking the next changed param + && runRules cfgRest cparamsRest + GT -> + -- skip configHead pointing to a parameter not being proposed + runRules cfgRest cparams + LT -> + -- actualPid not found in json config, the constitution fails + False -- if no cparams left: success -- if cparams left: it means we reached the end of config without validating all cparams runRules _ cparams = List.null cparams @@ -54,14 +59,14 @@ runRules _ cparams = List.null cparams defaultConstitutionValidator :: ConstitutionValidator defaultConstitutionValidator = constitutionValidator defaultConstitutionConfig -{-| Make a constitution code by supplied the config at runtime. - -See Note [Manually constructing a Configuration value] --} +-- | Make a constitution code by supplied the config at runtime. +-- +-- See Note [Manually constructing a Configuration value] mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator -mkConstitutionCode cCfg = $$(compile [|| constitutionValidator ||]) - `unsafeApplyCode` liftCode plcVersion110 cCfg +mkConstitutionCode cCfg = + $$(compile [||constitutionValidator||]) + `unsafeApplyCode` liftCode plcVersion110 cCfg -- | The code of the constitution statically configured with the `defaultConstitutionConfig`. defaultConstitutionCode :: CompiledCode ConstitutionValidator -defaultConstitutionCode = $$(compile [|| defaultConstitutionValidator ||]) +defaultConstitutionCode = $$(compile [||defaultConstitutionValidator||]) diff --git a/cardano-constitution/src/Cardano/Constitution/Validator/Data/Unsorted.hs b/cardano-constitution/src/Cardano/Constitution/Validator/Data/Unsorted.hs index 0a59d8e893f..b150f0659cc 100644 --- a/cardano-constitution/src/Cardano/Constitution/Validator/Data/Unsorted.hs +++ b/cardano-constitution/src/Cardano/Constitution/Validator/Data/Unsorted.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -- Following is for tx compilation -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -module Cardano.Constitution.Validator.Data.Unsorted - ( constitutionValidator - , defaultConstitutionValidator - , mkConstitutionCode - , defaultConstitutionCode - ) where +module Cardano.Constitution.Validator.Data.Unsorted ( + constitutionValidator, + defaultConstitutionValidator, + mkConstitutionCode, + defaultConstitutionCode, +) where import Cardano.Constitution.Config import Cardano.Constitution.Validator.Data.Common as Common @@ -28,38 +28,40 @@ import PlutusTx.Prelude as Tx -- | Expects a constitution-configuration, statically *OR* at runtime via Tx.liftCode constitutionValidator :: ConstitutionConfig -> ConstitutionValidator -constitutionValidator cfg = Common.withChangedParams - (all (validateParam cfg)) +constitutionValidator cfg = + Common.withChangedParams + (all (validateParam cfg)) validateParam :: ConstitutionConfig -> (BuiltinData, BuiltinData) -> Bool validateParam (ConstitutionConfig cfg) (B.unsafeDataAsI -> actualPid, actualValueData) = - Common.validateParamValue - -- If param not found, it will error - (lookupUnsafe actualPid cfg) - actualValueData + Common.validateParamValue + -- If param not found, it will error + (lookupUnsafe actualPid cfg) + actualValueData -- | An unsafe version of PlutusTx.AssocMap.lookup, specialised to Integer keys lookupUnsafe :: Integer -> [(Integer, v)] -> v lookupUnsafe k = go - where - go [] = traceError "Unsorted lookup failed" - go ((k', i) : xs') = if k `B.equalsInteger` k' - then i - else go xs' + where + go [] = traceError "Unsorted lookup failed" + go ((k', i) : xs') = + if k `B.equalsInteger` k' + then i + else go xs' {-# INLINEABLE lookupUnsafe #-} -- | Statically configure the validator with the `defaultConstitutionConfig`. defaultConstitutionValidator :: ConstitutionValidator defaultConstitutionValidator = constitutionValidator defaultConstitutionConfig -{-| Make a constitution code by supplied the config at runtime. - -See Note [Manually constructing a Configuration value] --} +-- | Make a constitution code by supplied the config at runtime. +-- +-- See Note [Manually constructing a Configuration value] mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator -mkConstitutionCode cCfg = $$(compile [|| constitutionValidator ||]) - `unsafeApplyCode` liftCode plcVersion110 cCfg +mkConstitutionCode cCfg = + $$(compile [||constitutionValidator||]) + `unsafeApplyCode` liftCode plcVersion110 cCfg -- | The code of the constitution statically configured with the `defaultConstitutionConfig`. defaultConstitutionCode :: CompiledCode ConstitutionValidator -defaultConstitutionCode = $$(compile [|| defaultConstitutionValidator ||]) +defaultConstitutionCode = $$(compile [||defaultConstitutionValidator||]) diff --git a/cardano-constitution/src/Cardano/Constitution/Validator/Sorted.hs b/cardano-constitution/src/Cardano/Constitution/Validator/Sorted.hs index cdc2f4218ec..8f0ddaeb28a 100644 --- a/cardano-constitution/src/Cardano/Constitution/Validator/Sorted.hs +++ b/cardano-constitution/src/Cardano/Constitution/Validator/Sorted.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -- Following is for tx compilation -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -module Cardano.Constitution.Validator.Sorted - ( constitutionValidator - , defaultConstitutionValidator - , mkConstitutionCode - , defaultConstitutionCode - ) where +module Cardano.Constitution.Validator.Sorted ( + constitutionValidator, + defaultConstitutionValidator, + mkConstitutionCode, + defaultConstitutionCode, +) where import Cardano.Constitution.Config import Cardano.Constitution.Validator.Common as Common @@ -28,24 +28,29 @@ import PlutusTx.Prelude as Tx -- | Expects a constitution-configuration, statically *OR* at runtime via Tx.liftCode constitutionValidator :: ConstitutionConfig -> ConstitutionValidator constitutionValidator (ConstitutionConfig cfg) = - Common.withChangedParams (runRules cfg) + Common.withChangedParams (runRules cfg) -- | The `runRules` is a loop that works element-wise from left-to-right on the 2 sorted maps. -runRules :: [Param] -- ^ the config (sorted by default) - -> ChangedParams -- ^ the params (came sorted by the ledger) - -> Bool -runRules ((expectedPid, paramValue) : cfgRest) - cparams@((B.unsafeDataAsI -> actualPid, actualValueData) : cparamsRest) = +runRules :: + -- | the config (sorted by default) + [Param] -> + -- | the params (came sorted by the ledger) + ChangedParams -> + Bool +runRules + ((expectedPid, paramValue) : cfgRest) + cparams@((B.unsafeDataAsI -> actualPid, actualValueData) : cparamsRest) = case actualPid `compare` expectedPid of - EQ -> - Common.validateParamValue paramValue actualValueData - -- drop both heads, and continue checking the next changed param - && runRules cfgRest cparamsRest - - GT -> -- skip configHead pointing to a parameter not being proposed - runRules cfgRest cparams - LT -> -- actualPid not found in json config, the constitution fails - False + EQ -> + Common.validateParamValue paramValue actualValueData + -- drop both heads, and continue checking the next changed param + && runRules cfgRest cparamsRest + GT -> + -- skip configHead pointing to a parameter not being proposed + runRules cfgRest cparams + LT -> + -- actualPid not found in json config, the constitution fails + False -- if no cparams left: success -- if cparams left: it means we reached the end of config without validating all cparams runRules _ cparams = List.null cparams @@ -54,14 +59,14 @@ runRules _ cparams = List.null cparams defaultConstitutionValidator :: ConstitutionValidator defaultConstitutionValidator = constitutionValidator defaultConstitutionConfig -{-| Make a constitution code by supplied the config at runtime. - -See Note [Manually constructing a Configuration value] --} +-- | Make a constitution code by supplied the config at runtime. +-- +-- See Note [Manually constructing a Configuration value] mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator -mkConstitutionCode cCfg = $$(compile [|| constitutionValidator ||]) - `unsafeApplyCode` liftCode plcVersion110 cCfg +mkConstitutionCode cCfg = + $$(compile [||constitutionValidator||]) + `unsafeApplyCode` liftCode plcVersion110 cCfg -- | The code of the constitution statically configured with the `defaultConstitutionConfig`. defaultConstitutionCode :: CompiledCode ConstitutionValidator -defaultConstitutionCode = $$(compile [|| defaultConstitutionValidator ||]) +defaultConstitutionCode = $$(compile [||defaultConstitutionValidator||]) diff --git a/cardano-constitution/src/Cardano/Constitution/Validator/Unsorted.hs b/cardano-constitution/src/Cardano/Constitution/Validator/Unsorted.hs index a910f7fa8af..91fec78959f 100644 --- a/cardano-constitution/src/Cardano/Constitution/Validator/Unsorted.hs +++ b/cardano-constitution/src/Cardano/Constitution/Validator/Unsorted.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -- Following is for tx compilation -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} -module Cardano.Constitution.Validator.Unsorted - ( constitutionValidator - , defaultConstitutionValidator - , mkConstitutionCode - , defaultConstitutionCode - ) where +module Cardano.Constitution.Validator.Unsorted ( + constitutionValidator, + defaultConstitutionValidator, + mkConstitutionCode, + defaultConstitutionCode, +) where import Cardano.Constitution.Config import Cardano.Constitution.Validator.Common as Common @@ -28,38 +28,40 @@ import PlutusTx.Prelude as Tx -- | Expects a constitution-configuration, statically *OR* at runtime via Tx.liftCode constitutionValidator :: ConstitutionConfig -> ConstitutionValidator -constitutionValidator cfg = Common.withChangedParams - (all (validateParam cfg)) +constitutionValidator cfg = + Common.withChangedParams + (all (validateParam cfg)) validateParam :: ConstitutionConfig -> (BuiltinData, BuiltinData) -> Bool validateParam (ConstitutionConfig cfg) (B.unsafeDataAsI -> actualPid, actualValueData) = - Common.validateParamValue - -- If param not found, it will error - (lookupUnsafe actualPid cfg) - actualValueData + Common.validateParamValue + -- If param not found, it will error + (lookupUnsafe actualPid cfg) + actualValueData -- | An unsafe version of PlutusTx.AssocMap.lookup, specialised to Integer keys lookupUnsafe :: Integer -> [(Integer, v)] -> v lookupUnsafe k = go - where - go [] = traceError "Unsorted lookup failed" - go ((k', i) : xs') = if k `B.equalsInteger` k' - then i - else go xs' + where + go [] = traceError "Unsorted lookup failed" + go ((k', i) : xs') = + if k `B.equalsInteger` k' + then i + else go xs' {-# INLINEABLE lookupUnsafe #-} -- | Statically configure the validator with the `defaultConstitutionConfig`. defaultConstitutionValidator :: ConstitutionValidator defaultConstitutionValidator = constitutionValidator defaultConstitutionConfig -{-| Make a constitution code by supplied the config at runtime. - -See Note [Manually constructing a Configuration value] --} +-- | Make a constitution code by supplied the config at runtime. +-- +-- See Note [Manually constructing a Configuration value] mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator -mkConstitutionCode cCfg = $$(compile [|| constitutionValidator ||]) - `unsafeApplyCode` liftCode plcVersion110 cCfg +mkConstitutionCode cCfg = + $$(compile [||constitutionValidator||]) + `unsafeApplyCode` liftCode plcVersion110 cCfg -- | The code of the constitution statically configured with the `defaultConstitutionConfig`. defaultConstitutionCode :: CompiledCode ConstitutionValidator -defaultConstitutionCode = $$(compile [|| defaultConstitutionValidator ||]) +defaultConstitutionCode = $$(compile [||defaultConstitutionValidator||]) diff --git a/cardano-constitution/src/PlutusTx/NonCanonicalRational.hs b/cardano-constitution/src/PlutusTx/NonCanonicalRational.hs index ab5addf7834..b0cdb5a3a8b 100644 --- a/cardano-constitution/src/PlutusTx/NonCanonicalRational.hs +++ b/cardano-constitution/src/PlutusTx/NonCanonicalRational.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} -- editorconfig-checker-disable-file --- | Same representation as Tx.Ratio but uses a different BuiltinData encoding {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -module PlutusTx.NonCanonicalRational - ( NonCanonicalRational (..) - ) where + +-- | Same representation as Tx.Ratio but uses a different BuiltinData encoding +module PlutusTx.NonCanonicalRational ( + NonCanonicalRational (..), +) where import PlutusTx as Tx import PlutusTx.Builtins as B @@ -19,18 +20,19 @@ import PlutusTx.Trace (traceError) newtype NonCanonicalRational = NonCanonicalRational Tx.Rational instance ToData NonCanonicalRational where - {-# INLINABLE toBuiltinData #-} + {-# INLINEABLE toBuiltinData #-} toBuiltinData (NonCanonicalRational tx) = let num = Tx.numerator tx den = Tx.denominator tx - in toBuiltinData [num,den] + in toBuiltinData [num, den] instance UnsafeFromData NonCanonicalRational where - {-# INLINABLE unsafeFromBuiltinData #-} + {-# INLINEABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData (BI.unsafeDataAsList -> bl) = - -- this is the fastest way I found to convert to Rational - let bl' = BI.tail bl - in BI.ifThenElse (BI.null (BI.tail bl')) - (\() -> NonCanonicalRational (Tx.unsafeRatio (B.unsafeDataAsI (BI.head bl)) (B.unsafeDataAsI (BI.head bl')))) - (\() -> traceError "A Rational had too many list components") - () + -- this is the fastest way I found to convert to Rational + let bl' = BI.tail bl + in BI.ifThenElse + (BI.null (BI.tail bl')) + (\() -> NonCanonicalRational (Tx.unsafeRatio (B.unsafeDataAsI (BI.head bl)) (B.unsafeDataAsI (BI.head bl')))) + (\() -> traceError "A Rational had too many list components") + () diff --git a/cardano-constitution/test/Cardano/Constitution/Config/Tests.hs b/cardano-constitution/test/Cardano/Constitution/Config/Tests.hs index 2ca93e167ee..0f528875df2 100644 --- a/cardano-constitution/test/Cardano/Constitution/Config/Tests.hs +++ b/cardano-constitution/test/Cardano/Constitution/Config/Tests.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + -- | Test that the "examples"" inside the defaultConstitutionJSONSchema, -- can be parsed with aeson. Usually the json-schema validators ignore these examples. -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Cardano.Constitution.Config.Tests - ( tests - ) where +module Cardano.Constitution.Config.Tests ( + tests, +) where import Cardano.Constitution.Config import Cardano.Constitution.DataFilePaths as DFP @@ -19,7 +20,7 @@ import Test.Tasty.QuickCheck defaultConstitutionJSONSchema :: Aeson.Value defaultConstitutionJSONSchema = - $$(Aeson.readJSONFromFile DFP.defaultConstitutionJSONSchemaFile) + $$(Aeson.readJSONFromFile DFP.defaultConstitutionJSONSchemaFile) -- | All the examples in the JSON schema are parseable as a list of ConstitutionConfigs. -- Actually the examples 9005 and 9006 should not normally parse, @@ -29,12 +30,16 @@ examplesAsConfigsParser = withObject "toplevel" (.: "examples") -- all these are actually unit tests (by using QuickCheck.once) test_parseSchemaExamples :: Property -test_parseSchemaExamples = once $ +test_parseSchemaExamples = + once $ let res = parseEither examplesAsConfigsParser defaultConstitutionJSONSchema - in counterexample (fromLeft "cannot happen, must be left then" res) $ + in counterexample (fromLeft "cannot happen, must be left then" res) $ isRight res tests :: TestTreeWithTestState -tests = testGroup' "Config" $ fmap (const . uncurry testProperty) [ - ("parseSchemaExamples", test_parseSchemaExamples) - ] +tests = + testGroup' "Config" $ + fmap + (const . uncurry testProperty) + [ ("parseSchemaExamples", test_parseSchemaExamples) + ] diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests.hs b/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests.hs index 2d67485952e..f7bb435e8a5 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable-file {-# LANGUAGE GADTs #-} -module Cardano.Constitution.Validator.Data.GoldenTests - ( tests - ) where +module Cardano.Constitution.Validator.Data.GoldenTests ( + tests, +) where import Cardano.Constitution.Config import Cardano.Constitution.Data.Validator @@ -32,65 +32,103 @@ import Helpers.Guardrail -- The golden files may change, so use `--accept` in cabal `--test-options` to accept the changes **after reviewing them**. test_cbor, test_budget_small, test_budget_large, test_readable_pir, test_readable_uplc :: TestTree - -test_cbor = testGroup "Cbor" $ M.elems $ - (\vName (_, vCode) -> - -- The unit of measurement is in bytes - goldenVsString vName (mkPath vName ["cbor","size"]) $ - pure $ fromString $ show $ SBS.length $ V3.serialiseCompiledCode vCode - ) `M.mapWithKey` defaultValidatorsWithCodes - -test_budget_large = testGroup "BudgetLarge" $ M.elems $ - (\vName (_, vCode) -> - -- The unit of measurement is in execution steps. - -- See maxTxExSteps, maxTxExMem for limits for chain limits: - goldenVsString vName (mkPath vName ["large","budget"]) $ - pure $ fromString $ show $ runForBudget vCode $ V3.mkFakeParameterChangeContext getFakeLargeParamsChange -- mkLargeFakeProposal defaultConstitutionConfig - )`M.mapWithKey` defaultValidatorsWithCodes - -test_budget_small = testGroup "BudgetSmall" $ M.elems $ - (\vName (_, vCode) -> - -- The unit of measurement is in execution steps. - -- See maxTxExSteps, maxTxExMem for limits for chain limits: - goldenVsString vName (mkPath vName ["small","budget"]) $ - pure $ fromString $ show $ runForBudget vCode $ V3.mkSmallFakeProposal defaultConstitutionConfig - )`M.mapWithKey` defaultValidatorsWithCodes - -test_readable_pir = testGroup "ReadablePir" $ M.elems $ - (\vName (_, vCode) -> - goldenVsString vName (mkPath vName ["pir"]) $ - pure $ fromString $ show $ prettyPlcReadableSimple $ fromJust $ getPirNoAnn vCode - )`M.mapWithKey` defaultValidatorsWithCodes - -test_readable_uplc = testGroup "ReadableUplc" $ M.elems $ - (\vName (_, vCode) -> - goldenVsString vName (mkPath vName ["uplc"]) $ - pure $ fromString $ show $ prettyPlcReadableSimple $ getPlcNoAnn vCode - )`M.mapWithKey` defaultValidatorsWithCodes +test_cbor = + testGroup "Cbor" $ + M.elems $ + ( \vName (_, vCode) -> + -- The unit of measurement is in bytes + goldenVsString vName (mkPath vName ["cbor", "size"]) $ + pure $ + fromString $ + show $ + SBS.length $ + V3.serialiseCompiledCode vCode + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_budget_large = + testGroup "BudgetLarge" $ + M.elems $ + ( \vName (_, vCode) -> + -- The unit of measurement is in execution steps. + -- See maxTxExSteps, maxTxExMem for limits for chain limits: + goldenVsString vName (mkPath vName ["large", "budget"]) $ + pure $ + fromString $ + show $ + runForBudget vCode $ + V3.mkFakeParameterChangeContext getFakeLargeParamsChange -- mkLargeFakeProposal defaultConstitutionConfig + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_budget_small = + testGroup "BudgetSmall" $ + M.elems $ + ( \vName (_, vCode) -> + -- The unit of measurement is in execution steps. + -- See maxTxExSteps, maxTxExMem for limits for chain limits: + goldenVsString vName (mkPath vName ["small", "budget"]) $ + pure $ + fromString $ + show $ + runForBudget vCode $ + V3.mkSmallFakeProposal defaultConstitutionConfig + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_readable_pir = + testGroup "ReadablePir" $ + M.elems $ + ( \vName (_, vCode) -> + goldenVsString vName (mkPath vName ["pir"]) $ + pure $ + fromString $ + show $ + prettyPlcReadableSimple $ + fromJust $ + getPirNoAnn vCode + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_readable_uplc = + testGroup "ReadableUplc" $ + M.elems $ + ( \vName (_, vCode) -> + goldenVsString vName (mkPath vName ["uplc"]) $ + pure $ + fromString $ + show $ + prettyPlcReadableSimple $ + getPlcNoAnn vCode + ) + `M.mapWithKey` defaultValidatorsWithCodes tests :: TestTreeWithTestState -tests = testGroup' "Golden" $ fmap const - [ test_cbor - , test_budget_large - , test_budget_small - , test_readable_pir - , test_readable_uplc - ] +tests = + testGroup' "Golden" $ + fmap + const + [ test_cbor + , test_budget_large + , test_budget_small + , test_readable_pir + , test_readable_uplc + ] -- HELPERS mkPath :: String -> [String] -> FilePath -mkPath vName exts = foldl1 () ["test","Cardano","Constitution","Validator","Data","GoldenTests", foldl (<.>) vName ("golden" : exts)] +mkPath vName exts = foldl1 () ["test", "Cardano", "Constitution", "Validator", "Data", "GoldenTests", foldl (<.>) vName ("golden" : exts)] -runForBudget :: (ToData ctx) - => CompiledCode ConstitutionValidator - -> ctx - -> ExBudget +runForBudget :: + ToData ctx => + CompiledCode ConstitutionValidator -> + ctx -> + ExBudget runForBudget v ctx = - let vPs = UPLC._progTerm $ getPlcNoAnn $ v - `unsafeApplyCode` liftCode110 (unsafeFromBuiltinData . toBuiltinData $ ctx) - in case UPLC.runCekDeBruijn defaultCekParametersForTesting counting noEmitter vPs of - -- Here, we guard against the case that a ConstitutionValidator **FAILS EARLY** (for some reason), - -- resulting in misleading low budget costs. - UPLC.CekReport (UPLC.CekSuccessConstant (UPLC.Some (UPLC.ValueOf UPLC.DefaultUniUnit ()))) (UPLC.CountingSt budget) _ -> budget - _ -> error "For safety, we only compare budgets of successful executions." + let vPs = + UPLC._progTerm $ + getPlcNoAnn $ + v + `unsafeApplyCode` liftCode110 (unsafeFromBuiltinData . toBuiltinData $ ctx) + in case UPLC.runCekDeBruijn defaultCekParametersForTesting counting noEmitter vPs of + -- Here, we guard against the case that a ConstitutionValidator **FAILS EARLY** (for some reason), + -- resulting in misleading low budget costs. + UPLC.CekReport (UPLC.CekSuccessConstant (UPLC.Some (UPLC.ValueOf UPLC.DefaultUniUnit ()))) (UPLC.CountingSt budget) _ -> budget + _ -> error "For safety, we only compare budgets of successful executions." diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/Data/PropTests.hs b/cardano-constitution/test/Cardano/Constitution/Validator/Data/PropTests.hs index 703588d260d..d2ec306d87b 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/Data/PropTests.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/Data/PropTests.hs @@ -1,8 +1,9 @@ -- editorconfig-checker-disable-file {-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Constitution.Validator.Data.PropTests - ( tests - ) where + +module Cardano.Constitution.Validator.Data.PropTests ( + tests, +) where import Cardano.Constitution.Data.Validator import Cardano.Constitution.Validator.Data.TestsCommon @@ -23,19 +24,21 @@ prop_hsValidatorsAgreeAll = hsValidatorsAgree $ M.elems defaultValidators -- | Test (in Haskell) each validator in the list with the same random input, -- and make sure that all of the validators return the same result. -hsValidatorsAgree :: [ConstitutionValidator] - -> (V3.ArbitraryContext -> Property) +hsValidatorsAgree :: + [ConstitutionValidator] -> + (V3.ArbitraryContext -> Property) hsValidatorsAgree vs ctx = go vs - where - go (v1:v2:vrest) = ioProperty ((===) - <$> tryApplyOnData v1 ctx - <*> tryApplyOnData v2 ctx - ) - .&&. if null vrest - then property True -- done - else go (v2:vrest) - go _ = property False -- needs at least two validators, otherwise the property fails - + where + go (v1 : v2 : vrest) = + ioProperty + ( (===) + <$> tryApplyOnData v1 ctx + <*> tryApplyOnData v2 ctx + ) + .&&. if null vrest + then property True -- done + else go (v2 : vrest) + go _ = property False -- needs at least two validators, otherwise the property fails {- Given some random input, running each validator offline (in Haskell) and online (in Tx) yields the same result. This is different from `prop_hsValidatorsAgree`: it evals each validator individually @@ -44,28 +47,34 @@ with two different eval machines (Hs/Tx) and checks that the machines agree. prop_hsAgreesWithTxAll :: Property prop_hsAgreesWithTxAll = conjoin $ hsAgreesWithTx <$> M.elems defaultValidatorsWithCodes -hsAgreesWithTx :: (ConstitutionValidator, CompiledCode ConstitutionValidator) - -> (V3.ArbitraryContext -> Property) +hsAgreesWithTx :: + (ConstitutionValidator, CompiledCode ConstitutionValidator) -> + (V3.ArbitraryContext -> Property) hsAgreesWithTx (vHs, vCode) ctx = ioProperty $ do - resHs <- tryApplyOnData vHs ctx - let vPs = _progTerm $ getPlcNoAnn $ vCode - `unsafeApplyCode` liftCode110 (unsafeFromBuiltinData . toBuiltinData $ ctx) - resPs = runCekRes vPs + resHs <- tryApplyOnData vHs ctx + let vPs = + _progTerm $ + getPlcNoAnn $ + vCode + `unsafeApplyCode` liftCode110 (unsafeFromBuiltinData . toBuiltinData $ ctx) + resPs = runCekRes vPs - pure $ case (resHs, resPs) of - (Left _, Left _) -> property True - (Right okHs, Right okPs) -> liftCode110Norm okHs === okPs - _ -> property False + pure $ case (resHs, resPs) of + (Left _, Left _) -> property True + (Right okHs, Right okPs) -> liftCode110Norm okHs === okPs + _ -> property False tests :: TestTreeWithTestState -tests = testGroup' "Property" $ fmap const - [ - -- TODO This test is flaky and needs to be fixed before re-enabling - ignoreTest $ testProperty "hsValidatorsAgreeAll" prop_hsValidatorsAgreeAll - , testProperty "hsAgreesWithTxAll" prop_hsAgreesWithTxAll - ] +tests = + testGroup' "Property" $ + fmap + const + [ -- TODO This test is flaky and needs to be fixed before re-enabling + ignoreTest $ testProperty "hsValidatorsAgreeAll" prop_hsValidatorsAgreeAll + , testProperty "hsAgreesWithTxAll" prop_hsAgreesWithTxAll + ] -- for testing purposes instance Eq BI.BuiltinUnit where - -- not sure if needed to patternmatch everything here - BI.BuiltinUnit () == BI.BuiltinUnit () = True + -- not sure if needed to patternmatch everything here + BI.BuiltinUnit () == BI.BuiltinUnit () = True diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs b/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs index 455f9e9020c..cb02f89c7dc 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs @@ -1,15 +1,16 @@ -- editorconfig-checker-disable-file {-# LANGUAGE TypeOperators #-} -module Cardano.Constitution.Validator.Data.TestsCommon - ( applyOnData - , tryApplyOnData - , allVldtrsErred - , allVldtrsPassed - , runCekRes - , unsafeRunCekRes - , liftCode110 - , liftCode110Norm - ) where + +module Cardano.Constitution.Validator.Data.TestsCommon ( + applyOnData, + tryApplyOnData, + allVldtrsErred, + allVldtrsPassed, + runCekRes, + unsafeRunCekRes, + liftCode110, + liftCode110Norm, +) where import Cardano.Constitution.Validator.Data.Common import PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -24,45 +25,50 @@ import UntypedPlutusCore.Evaluation.Machine.Cek as UPLC import Control.Exception import Test.Tasty.QuickCheck -applyOnData :: (ToData ctx) - => ConstitutionValidator - -> ctx - -> BuiltinUnit +applyOnData :: + ToData ctx => + ConstitutionValidator -> + ctx -> + BuiltinUnit applyOnData v ctx = v (unsafeFromBuiltinData . Tx.toBuiltinData $ ctx) -- | Here we try to catch the calls to `Tx.error`. -tryApplyOnData :: (ToData ctx) - => ConstitutionValidator - -> ctx - -> IO (Either ErrorCall BuiltinUnit) +tryApplyOnData :: + ToData ctx => + ConstitutionValidator -> + ctx -> + IO (Either ErrorCall BuiltinUnit) -- TODO: I am not sure that this is enough to test both in Haskell and Tx side, since we may throw -- other kinds of errors , e.g. `PatternMatchFail` in Haskell-side? tryApplyOnData v ctx = try $ evaluate $ applyOnData v ctx -allVldtrsErred, allVldtrsPassed - :: (ToData ctx) - => [ConstitutionValidator] - -> ctx - -> Property +allVldtrsErred + , allVldtrsPassed :: + ToData ctx => + [ConstitutionValidator] -> + ctx -> + Property -- | All given validators have to err -allVldtrsErred vs ctx = conjoin $ +allVldtrsErred vs ctx = + conjoin $ fmap (\v -> ioProperty (isLeft <$> tryApplyOnData v ctx)) vs -{- | All given validators have to not err - -Doing (ioProperty . isRight . tryApplyEval) is probably redundant here, since QC will catch any exceptions --} +-- | All given validators have to not err +-- +-- Doing (ioProperty . isRight . tryApplyEval) is probably redundant here, since QC will catch any exceptions allVldtrsPassed vs ctx = conjoin $ fmap (B.fromOpaque . (`applyOnData` ctx)) vs -unsafeRunCekRes :: (t ~ Term NamedDeBruijn DefaultUni DefaultFun ()) - => t -> t -unsafeRunCekRes = unsafeFromRight . runCekRes +unsafeRunCekRes :: + t ~ Term NamedDeBruijn DefaultUni DefaultFun () => + t -> t +unsafeRunCekRes = unsafeFromRight . runCekRes -runCekRes :: (t ~ Term NamedDeBruijn DefaultUni DefaultFun ()) - => t -> Either (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) t +runCekRes :: + t ~ Term NamedDeBruijn DefaultUni DefaultFun () => + t -> Either (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) t runCekRes t = - UPLC.cekResultToEither . UPLC._cekReportResult $ + UPLC.cekResultToEither . UPLC._cekReportResult $ UPLC.runCekDeBruijn defaultCekParametersForTesting restrictingEnormous noEmitter t liftCode110 :: Lift DefaultUni a => a -> CompiledCode a diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/Data/UnitTests.hs b/cardano-constitution/test/Cardano/Constitution/Validator/Data/UnitTests.hs index 1bd8597e271..a659f33b951 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/Data/UnitTests.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/Data/UnitTests.hs @@ -1,13 +1,14 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -module Cardano.Constitution.Validator.Data.UnitTests - ( unitTests - , singleParamTests - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Constitution.Validator.Data.UnitTests ( + unitTests, + singleParamTests, +) where import Cardano.Constitution.Config () import Cardano.Constitution.Data.Validator @@ -35,7 +36,7 @@ import Test.Tasty.QuickCheck -- MC/DC coverage {- Note [Why de-duplicated ChangedParameters] -**ALL** The following ScriptContext examples *MUST* be de-duplicated Lists. +\**ALL** The following ScriptContext examples *MUST* be de-duplicated Lists. Otherwise, both the sorted and unsorted scripts will produce "wrong" results (for different reasons). See also Guarantee(2) in README.md @@ -47,169 +48,250 @@ See also Guarantee(2) in README.md -- We rely on guarantee (2) and (3) in README.md test_pos :: TestTreeWithTestState -test_pos = const $ testGroup "Positive" $ - fmap (\(n, c) -> testProperty n $ allVldtrsPassed (M.elems defaultValidators) c) - [ ("pos1", V3.mkFakeParameterChangeContext @Integer - [ (0, 30) -- in limits - , (1, 10_000_000) -- in limits - , (17, 6_250) -- in limits - ]) - , ("pos2", V3.mkFakeParameterChangeContext - [ (10, NonCanonicalRational $ Tx.unsafeRatio 1 1000) -- in limits - ]) - , ("pos3", V3.mkFakeParameterChangeContext - [ (19, - [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits - ]) - ]) - -- NOTE: According to constitution-script specification, this is a NOT_SPECIFIED behavior, - -- meaning a valid const.script can decide to return success or fail either way. - -- In reality, the ledger prohibits empty proposals, thus the const.script will not even run. - -- Here, we only do "regression testing" of our validators, which happen to succeed - -- for this out-of-spec behavior. - , ("pos4", V3.mkFakeParameterChangeContext @Integer - [ -- empty params - ]) - ] ++ [ - testProperty "pos5" $ forAll V3.treasuryWithdrawalsCtxGen - $ allVldtrsPassed (M.elems defaultValidators) - ] +test_pos = + const $ + testGroup "Positive" $ + fmap + (\(n, c) -> testProperty n $ allVldtrsPassed (M.elems defaultValidators) c) + [ + ( "pos1" + , V3.mkFakeParameterChangeContext @Integer + [ (0, 30) -- in limits + , (1, 10_000_000) -- in limits + , (17, 6_250) -- in limits + ] + ) + , + ( "pos2" + , V3.mkFakeParameterChangeContext + [ (10, NonCanonicalRational $ Tx.unsafeRatio 1 1000) -- in limits + ] + ) + , + ( "pos3" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits + ] + ) + ] + ) + , -- NOTE: According to constitution-script specification, this is a NOT_SPECIFIED behavior, + -- meaning a valid const.script can decide to return success or fail either way. + -- In reality, the ledger prohibits empty proposals, thus the const.script will not even run. + -- Here, we only do "regression testing" of our validators, which happen to succeed + -- for this out-of-spec behavior. + ( "pos4" + , V3.mkFakeParameterChangeContext @Integer + [] + ) + ] + -- empty params + ++ [ testProperty "pos5" $ + forAll V3.treasuryWithdrawalsCtxGen $ + allVldtrsPassed (M.elems defaultValidators) + ] test_neg :: TestTreeWithTestState -test_neg = const $ testGroup "Negative" $ - fmap (\(n, c) -> testProperty n $ allVldtrsErred (M.elems defaultValidators) c) - [ ("neg1", V3.mkFakeParameterChangeContext @Integer - [ (0, 29) -- **smaller than minbound** - , (1, 10_000_000) -- in limits - , (2, -10_000_000_000) -- unknown param - , (17, 6_250) -- in limits - ]) - , ("neg2", V3.mkFakeParameterChangeContext @Integer - [ (0, 29) -- **smaller than minbound** - , (1, 10_000_000) -- in limits - , (17, 6_251) -- ** larger than maxbound ** - ]) - , ("neg3", V3.mkFakeParameterChangeContext @Integer - [ (-1, -1_000) -- unknown param - ]) - , ("neg4", V3.mkFakeParameterChangeContext @Integer - [ (10, 1) -- type mismatch, 10 is supposed to be Rational - ]) - , ("neg5", V3.mkFakeParameterChangeContext - [ (0, NonCanonicalRational $ Tx.unsafeRatio 1 1) -- type mismatch, 0 is supposed to be integer - ]) - , ("neg6", V3.mkFakeParameterChangeContext - [ (10, NonCanonicalRational $ Tx.unsafeRatio 0 1000) -- out of limits - ]) - , ("neg7", V3.mkFakeParameterChangeContext - [ (19, - [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 0 10_000_000 -- exsteps out of limits - ]) - ]) - , ("neg8", V3.mkFakeParameterChangeContext - [ (19, [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- TOO MUCH SUBS in list SUPPLIED - ]) - ]) - , ("neg9", V3.mkFakeParameterChangeContext - [ (19, [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - -- TOO FEW SUBS in list SUPPLIED - ]) - ]) - , ("neg10", V3.mkFakeParameterChangeContext @[Integer] - [ (19, [ - -- TOO FEW SUBS in list SUPPLIED - ]) - ]) - , ("neg11", V3.mkFakeParameterChangeContext - [ (19, - -- TOO DEEPLY NESTED - [ - [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits - ] - ] - ) - ]) - -- anything other than ParameterChange or TreasuryWithdrawals is `FAIL` - , ("neg12", V3.mkFakeContextFromGovAction V3.InfoAction) - ] +test_neg = + const $ + testGroup "Negative" $ + fmap + (\(n, c) -> testProperty n $ allVldtrsErred (M.elems defaultValidators) c) + [ + ( "neg1" + , V3.mkFakeParameterChangeContext @Integer + [ (0, 29) + , -- \**smaller than minbound** + (1, 10_000_000) -- in limits + , (2, -10_000_000_000) -- unknown param + , (17, 6_250) -- in limits + ] + ) + , + ( "neg2" + , V3.mkFakeParameterChangeContext @Integer + [ (0, 29) + , -- \**smaller than minbound** + (1, 10_000_000) -- in limits + , (17, 6_251) + ] + ) + , -- \** larger than maxbound ** + + ( "neg3" + , V3.mkFakeParameterChangeContext @Integer + [ (-1, -1_000) -- unknown param + ] + ) + , + ( "neg4" + , V3.mkFakeParameterChangeContext @Integer + [ (10, 1) -- type mismatch, 10 is supposed to be Rational + ] + ) + , + ( "neg5" + , V3.mkFakeParameterChangeContext + [ (0, NonCanonicalRational $ Tx.unsafeRatio 1 1) -- type mismatch, 0 is supposed to be integer + ] + ) + , + ( "neg6" + , V3.mkFakeParameterChangeContext + [ (10, NonCanonicalRational $ Tx.unsafeRatio 0 1000) -- out of limits + ] + ) + , + ( "neg7" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 0 10_000_000 -- exsteps out of limits + ] + ) + ] + ) + , + ( "neg8" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- TOO MUCH SUBS in list SUPPLIED + ] + ) + ] + ) + , + ( "neg9" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + -- TOO FEW SUBS in list SUPPLIED + ] + ) + ] + ) + , + ( "neg10" + , V3.mkFakeParameterChangeContext @[Integer] + [ + ( 19 + , [] + ) + ] + ) + , -- TOO FEW SUBS in list SUPPLIED + + ( "neg11" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , -- TOO DEEPLY NESTED + + [ + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits + ] + ] + ) + ] + ) + , -- anything other than ParameterChange or TreasuryWithdrawals is `FAIL` + ("neg12", V3.mkFakeContextFromGovAction V3.InfoAction) + ] test_unsorted1 :: TestTreeWithTestState -test_unsorted1 = const $ testProperty "unsorted1" $ - -- unsorted fails for the right reason, sorted fails for the wrong reason - allVldtrsErred (M.elems defaultValidators) ctx +test_unsorted1 = + const $ + testProperty "unsorted1" $ + -- unsorted fails for the right reason, sorted fails for the wrong reason + allVldtrsErred (M.elems defaultValidators) ctx where - ctx = V3.mkFakeParameterChangeContext @Integer - -- deliberately kept unsorted to demonstrate the different behaviour between - -- SORTED and UNSORTED flavour. See guarantee (3) in README.md - [ (0, 30) -- in limits - , (17, 6_250) -- in limits, **but breaks sorting** - -- out of limits **should make constitution script fail** - -- unsorted flavor fails, for the right reason (out of limits) - -- sorted flavor fails, for the wrong reason (it ran past the config, and fail to find actualPid) - , (1, 10_000_001) - ] + ctx = + V3.mkFakeParameterChangeContext @Integer + -- deliberately kept unsorted to demonstrate the different behaviour between + -- SORTED and UNSORTED flavour. See guarantee (3) in README.md + [ (0, 30) -- in limits + , (17, 6_250) -- in limits, **but breaks sorting** + -- out of limits **should make constitution script fail** + -- unsorted flavor fails, for the right reason (out of limits) + -- sorted flavor fails, for the wrong reason (it ran past the config, and fail to find actualPid) + , (1, 10_000_001) + ] test_unsorted2 :: TestTreeWithTestState -test_unsorted2 = const $ testProperty "unsorted2" $ - -- The unsorted flavour does not depend on guarantee 3, - -- so it can work with unsorted input map as well - allVldtrsPassed [defaultValidators M.! "unsorted"] ctx - -- The sorted flavour depends on guarantee 3, so it breaks with unsorted maps: - -- the constitution scripts should fail, but they don't - .&&. allVldtrsErred [defaultValidators M.! "sorted"] ctx - - where - ctx = V3.mkFakeParameterChangeContext @Integer - -- deliberately kept unsorted to demonstrate the different behaviour between - -- SORTED and UNSORTED flavour. See guarantee (3) in README.md - [ (0, 30) -- in limits - , (17, 6_250) -- in limits, **but breaks sorting** - -- in limits - -- unsorted flavor passes - -- sorted flavor fails (it ran past the config, and fail to find actualPid) - , (1, 10_000_000) - ] - -{- | A safety check to make sure that a `ScriptContext` containg a large proposal -will not reach the maxTxSize currently set by the chain. -In reality, proposals will not be that big. +test_unsorted2 = + const $ + testProperty "unsorted2" $ + -- The unsorted flavour does not depend on guarantee 3, + -- so it can work with unsorted input map as well + allVldtrsPassed [defaultValidators M.! "unsorted"] ctx + -- The sorted flavour depends on guarantee 3, so it breaks with unsorted maps: + -- the constitution scripts should fail, but they don't + .&&. allVldtrsErred [defaultValidators M.! "sorted"] ctx + where + ctx = + V3.mkFakeParameterChangeContext @Integer + -- deliberately kept unsorted to demonstrate the different behaviour between + -- SORTED and UNSORTED flavour. See guarantee (3) in README.md + [ (0, 30) -- in limits + , (17, 6_250) -- in limits, **but breaks sorting** + -- in limits + -- unsorted flavor passes + -- sorted flavor fails (it ran past the config, and fail to find actualPid) + , (1, 10_000_000) + ] -If this size becomes so big that it is an issue, there is the option (*in certain cases only!*), -to split up such large proposal to smaller parts and submit them to the chain separately. --} +-- | A safety check to make sure that a `ScriptContext` containg a large proposal +-- will not reach the maxTxSize currently set by the chain. +-- In reality, proposals will not be that big. +-- +-- If this size becomes so big that it is an issue, there is the option (*in certain cases only!*), +-- to split up such large proposal to smaller parts and submit them to the chain separately. test_LargeProposalSize :: TestTreeWithTestState test_LargeProposalSize = const $ testCaseInfo "largeProposalSize" $ do - let largeSize = Tx.lengthOfByteString $ Tx.serialiseData $ toBuiltinData $ - V3.mkFakeParameterChangeContext Guards.getFakeLargeParamsChange - -- current maxTxSize is 16384 Bytes set on 07/29/2020 23:44:51 - -- , but we set this limit a bit lower (to accomodate other tx costs?) - maxTxSize = 10_000 - -- current maxTxSize - assertBool "Large Proposal does not fit transaction-size limits." (largeSize < maxTxSize) - pure $ "A large proposal has " <> show largeSize <> " below the limit set to " <> show maxTxSize + let largeSize = + Tx.lengthOfByteString $ + Tx.serialiseData $ + toBuiltinData $ + V3.mkFakeParameterChangeContext Guards.getFakeLargeParamsChange + -- current maxTxSize is 16384 Bytes set on 07/29/2020 23:44:51 + -- , but we set this limit a bit lower (to accomodate other tx costs?) + maxTxSize = 10_000 + -- current maxTxSize + assertBool "Large Proposal does not fit transaction-size limits." (largeSize < maxTxSize) + pure $ "A large proposal has " <> show largeSize <> " below the limit set to " <> show maxTxSize unitTests :: TestTreeWithTestState -unitTests = testGroup' "Unit" - [ test_pos - , test_neg - , test_unsorted1 - , test_unsorted2 - , test_LargeProposalSize - ] +unitTests = + testGroup' + "Unit" + [ test_pos + , test_neg + , test_unsorted1 + , test_unsorted2 + , test_LargeProposalSize + ] singleParamTests :: TestTreeWithTestState singleParamTests = testGroup' "Single Parameter Proposals" tests where - tests = fmap f Guards.allParams + tests = fmap f Guards.allParams - f :: Guards.GenericParam -> TestTreeWithTestState - f (Guards.MkGenericParam gr@(Guards.Param{})) = Guards.testSet gr - f (Guards.MkGenericParam gr@(Guards.WithinDomain{})) = Guards.testSet gr - f (Guards.MkGenericParam gr@(Guards.ParamList{})) = Guards.paramListTestSet gr + f :: Guards.GenericParam -> TestTreeWithTestState + f (Guards.MkGenericParam gr@(Guards.Param {})) = Guards.testSet gr + f (Guards.MkGenericParam gr@(Guards.WithinDomain {})) = Guards.testSet gr + f (Guards.MkGenericParam gr@(Guards.ParamList {})) = Guards.paramListTestSet gr diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests.hs b/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests.hs index de6f2e199a5..94579caa816 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable-file {-# LANGUAGE GADTs #-} -module Cardano.Constitution.Validator.GoldenTests - ( tests - ) where +module Cardano.Constitution.Validator.GoldenTests ( + tests, +) where import Cardano.Constitution.Config import Cardano.Constitution.Validator @@ -32,65 +32,103 @@ import Helpers.Guardrail -- The golden files may change, so use `--accept` in cabal `--test-options` to accept the changes **after reviewing them**. test_cbor, test_budget_small, test_budget_large, test_readable_pir, test_readable_uplc :: TestTree - -test_cbor = testGroup "Cbor" $ M.elems $ - (\vName (_, vCode) -> - -- The unit of measurement is in bytes - goldenVsString vName (mkPath vName ["cbor","size"]) $ - pure $ fromString $ show $ SBS.length $ V3.serialiseCompiledCode vCode - ) `M.mapWithKey` defaultValidatorsWithCodes - -test_budget_large = testGroup "BudgetLarge" $ M.elems $ - (\vName (_, vCode) -> - -- The unit of measurement is in execution steps. - -- See maxTxExSteps, maxTxExMem for limits for chain limits: - goldenVsString vName (mkPath vName ["large","budget"]) $ - pure $ fromString $ show $ runForBudget vCode $ V3.mkFakeParameterChangeContext getFakeLargeParamsChange -- mkLargeFakeProposal defaultConstitutionConfig - )`M.mapWithKey` defaultValidatorsWithCodes - -test_budget_small = testGroup "BudgetSmall" $ M.elems $ - (\vName (_, vCode) -> - -- The unit of measurement is in execution steps. - -- See maxTxExSteps, maxTxExMem for limits for chain limits: - goldenVsString vName (mkPath vName ["small","budget"]) $ - pure $ fromString $ show $ runForBudget vCode $ V3.mkSmallFakeProposal defaultConstitutionConfig - )`M.mapWithKey` defaultValidatorsWithCodes - -test_readable_pir = testGroup "ReadablePir" $ M.elems $ - (\vName (_, vCode) -> - goldenVsString vName (mkPath vName ["pir"]) $ - pure $ fromString $ show $ prettyPlcReadableSimple $ fromJust $ getPirNoAnn vCode - )`M.mapWithKey` defaultValidatorsWithCodes - -test_readable_uplc = testGroup "ReadableUplc" $ M.elems $ - (\vName (_, vCode) -> - goldenVsString vName (mkPath vName ["uplc"]) $ - pure $ fromString $ show $ prettyPlcReadableSimple $ getPlcNoAnn vCode - )`M.mapWithKey` defaultValidatorsWithCodes +test_cbor = + testGroup "Cbor" $ + M.elems $ + ( \vName (_, vCode) -> + -- The unit of measurement is in bytes + goldenVsString vName (mkPath vName ["cbor", "size"]) $ + pure $ + fromString $ + show $ + SBS.length $ + V3.serialiseCompiledCode vCode + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_budget_large = + testGroup "BudgetLarge" $ + M.elems $ + ( \vName (_, vCode) -> + -- The unit of measurement is in execution steps. + -- See maxTxExSteps, maxTxExMem for limits for chain limits: + goldenVsString vName (mkPath vName ["large", "budget"]) $ + pure $ + fromString $ + show $ + runForBudget vCode $ + V3.mkFakeParameterChangeContext getFakeLargeParamsChange -- mkLargeFakeProposal defaultConstitutionConfig + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_budget_small = + testGroup "BudgetSmall" $ + M.elems $ + ( \vName (_, vCode) -> + -- The unit of measurement is in execution steps. + -- See maxTxExSteps, maxTxExMem for limits for chain limits: + goldenVsString vName (mkPath vName ["small", "budget"]) $ + pure $ + fromString $ + show $ + runForBudget vCode $ + V3.mkSmallFakeProposal defaultConstitutionConfig + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_readable_pir = + testGroup "ReadablePir" $ + M.elems $ + ( \vName (_, vCode) -> + goldenVsString vName (mkPath vName ["pir"]) $ + pure $ + fromString $ + show $ + prettyPlcReadableSimple $ + fromJust $ + getPirNoAnn vCode + ) + `M.mapWithKey` defaultValidatorsWithCodes +test_readable_uplc = + testGroup "ReadableUplc" $ + M.elems $ + ( \vName (_, vCode) -> + goldenVsString vName (mkPath vName ["uplc"]) $ + pure $ + fromString $ + show $ + prettyPlcReadableSimple $ + getPlcNoAnn vCode + ) + `M.mapWithKey` defaultValidatorsWithCodes tests :: TestTreeWithTestState -tests = testGroup' "Golden" $ fmap const - [ test_cbor - , test_budget_large - , test_budget_small - , test_readable_pir - , test_readable_uplc - ] +tests = + testGroup' "Golden" $ + fmap + const + [ test_cbor + , test_budget_large + , test_budget_small + , test_readable_pir + , test_readable_uplc + ] -- HELPERS mkPath :: String -> [String] -> FilePath -mkPath vName exts = foldl1 () ["test","Cardano","Constitution","Validator","GoldenTests", foldl (<.>) vName ("golden" : exts)] +mkPath vName exts = foldl1 () ["test", "Cardano", "Constitution", "Validator", "GoldenTests", foldl (<.>) vName ("golden" : exts)] -runForBudget :: (ToData ctx) - => CompiledCode ConstitutionValidator - -> ctx - -> ExBudget +runForBudget :: + ToData ctx => + CompiledCode ConstitutionValidator -> + ctx -> + ExBudget runForBudget v ctx = - let vPs = UPLC._progTerm $ getPlcNoAnn $ v - `unsafeApplyCode` liftCode110 (toBuiltinData ctx) - in case UPLC.runCekDeBruijn defaultCekParametersForTesting counting noEmitter vPs of - -- Here, we guard against the case that a ConstitutionValidator **FAILS EARLY** (for some reason), - -- resulting in misleading low budget costs. - UPLC.CekReport (UPLC.CekSuccessConstant (UPLC.Some (UPLC.ValueOf UPLC.DefaultUniUnit ()))) (UPLC.CountingSt budget) _ -> budget - _ -> error "For safety, we only compare budget of succesful executions." + let vPs = + UPLC._progTerm $ + getPlcNoAnn $ + v + `unsafeApplyCode` liftCode110 (toBuiltinData ctx) + in case UPLC.runCekDeBruijn defaultCekParametersForTesting counting noEmitter vPs of + -- Here, we guard against the case that a ConstitutionValidator **FAILS EARLY** (for some reason), + -- resulting in misleading low budget costs. + UPLC.CekReport (UPLC.CekSuccessConstant (UPLC.Some (UPLC.ValueOf UPLC.DefaultUniUnit ()))) (UPLC.CountingSt budget) _ -> budget + _ -> error "For safety, we only compare budget of succesful executions." diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/PropTests.hs b/cardano-constitution/test/Cardano/Constitution/Validator/PropTests.hs index 546625f6585..fde91c32fa3 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/PropTests.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/PropTests.hs @@ -1,8 +1,9 @@ -- editorconfig-checker-disable-file {-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Constitution.Validator.PropTests - ( tests - ) where + +module Cardano.Constitution.Validator.PropTests ( + tests, +) where import Cardano.Constitution.Validator import Cardano.Constitution.Validator.TestsCommon @@ -23,19 +24,21 @@ prop_hsValidatorsAgreeAll = hsValidatorsAgree $ M.elems defaultValidators -- | Test (in Haskell) each validator in the list with the same random input, -- and make sure that all of the validators return the same result. -hsValidatorsAgree :: [ConstitutionValidator] - -> (V3.ArbitraryContext -> Property) +hsValidatorsAgree :: + [ConstitutionValidator] -> + (V3.ArbitraryContext -> Property) hsValidatorsAgree vs ctx = go vs - where - go (v1:v2:vrest) = ioProperty ((===) - <$> tryApplyOnData v1 ctx - <*> tryApplyOnData v2 ctx - ) - .&&. if null vrest - then property True -- done - else go (v2:vrest) - go _ = property False -- needs at least two validators, otherwise the property fails - + where + go (v1 : v2 : vrest) = + ioProperty + ( (===) + <$> tryApplyOnData v1 ctx + <*> tryApplyOnData v2 ctx + ) + .&&. if null vrest + then property True -- done + else go (v2 : vrest) + go _ = property False -- needs at least two validators, otherwise the property fails {- Given some random input, running each validator offline (in Haskell) and online (in Tx) yields the same result. This is different from `prop_hsValidatorsAgree`: it evals each validator individually @@ -44,28 +47,34 @@ with two different eval machines (Hs/Tx) and checks that the machines agree. prop_hsAgreesWithTxAll :: Property prop_hsAgreesWithTxAll = conjoin $ hsAgreesWithTx <$> M.elems defaultValidatorsWithCodes -hsAgreesWithTx :: (ConstitutionValidator, CompiledCode ConstitutionValidator) - -> (V3.ArbitraryContext -> Property) +hsAgreesWithTx :: + (ConstitutionValidator, CompiledCode ConstitutionValidator) -> + (V3.ArbitraryContext -> Property) hsAgreesWithTx (vHs, vCode) ctx = ioProperty $ do - resHs <- tryApplyOnData vHs ctx - let vPs = _progTerm $ getPlcNoAnn $ vCode - `unsafeApplyCode` liftCode110 (toBuiltinData ctx) - resPs = runCekRes vPs + resHs <- tryApplyOnData vHs ctx + let vPs = + _progTerm $ + getPlcNoAnn $ + vCode + `unsafeApplyCode` liftCode110 (toBuiltinData ctx) + resPs = runCekRes vPs - pure $ case (resHs, resPs) of - (Left _, Left _) -> property True - (Right okHs, Right okPs) -> liftCode110Norm okHs === okPs - _ -> property False + pure $ case (resHs, resPs) of + (Left _, Left _) -> property True + (Right okHs, Right okPs) -> liftCode110Norm okHs === okPs + _ -> property False tests :: TestTreeWithTestState -tests = testGroup' "Property" $ fmap const - [ - -- TODO This test is flaky and needs to be fixed before re-enabling - ignoreTest $ testProperty "hsValidatorsAgreeAll" prop_hsValidatorsAgreeAll - , testProperty "hsAgreesWithTxAll" prop_hsAgreesWithTxAll - ] +tests = + testGroup' "Property" $ + fmap + const + [ -- TODO This test is flaky and needs to be fixed before re-enabling + ignoreTest $ testProperty "hsValidatorsAgreeAll" prop_hsValidatorsAgreeAll + , testProperty "hsAgreesWithTxAll" prop_hsAgreesWithTxAll + ] -- for testing purposes instance Eq BI.BuiltinUnit where - -- not sure if needed to patternmatch everything here - BI.BuiltinUnit () == BI.BuiltinUnit () = True + -- not sure if needed to patternmatch everything here + BI.BuiltinUnit () == BI.BuiltinUnit () = True diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs b/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs index 6e128c4077e..cf4ae16d963 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs @@ -1,15 +1,16 @@ -- editorconfig-checker-disable-file {-# LANGUAGE TypeOperators #-} -module Cardano.Constitution.Validator.TestsCommon - ( applyOnData - , tryApplyOnData - , allVldtrsErred - , allVldtrsPassed - , runCekRes - , unsafeRunCekRes - , liftCode110 - , liftCode110Norm - ) where + +module Cardano.Constitution.Validator.TestsCommon ( + applyOnData, + tryApplyOnData, + allVldtrsErred, + allVldtrsPassed, + runCekRes, + unsafeRunCekRes, + liftCode110, + liftCode110Norm, +) where import Cardano.Constitution.Validator.Common import PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -24,45 +25,50 @@ import UntypedPlutusCore.Evaluation.Machine.Cek as UPLC import Control.Exception import Test.Tasty.QuickCheck -applyOnData :: (ToData ctx) - => ConstitutionValidator - -> ctx - -> BuiltinUnit +applyOnData :: + ToData ctx => + ConstitutionValidator -> + ctx -> + BuiltinUnit applyOnData v ctx = v (Tx.toBuiltinData ctx) -- | Here we try to catch the calls to `Tx.error`. -tryApplyOnData :: (ToData ctx) - => ConstitutionValidator - -> ctx - -> IO (Either ErrorCall BuiltinUnit) +tryApplyOnData :: + ToData ctx => + ConstitutionValidator -> + ctx -> + IO (Either ErrorCall BuiltinUnit) -- TODO: I am not sure that this is enough to test both in Haskell and Tx side, since we may throw -- other kinds of errors , e.g. `PatternMatchFail` in Haskell-side? tryApplyOnData v ctx = try $ evaluate $ applyOnData v ctx -allVldtrsErred, allVldtrsPassed - :: (ToData ctx) - => [ConstitutionValidator] - -> ctx - -> Property +allVldtrsErred + , allVldtrsPassed :: + ToData ctx => + [ConstitutionValidator] -> + ctx -> + Property -- | All given validators have to err -allVldtrsErred vs ctx = conjoin $ +allVldtrsErred vs ctx = + conjoin $ fmap (\v -> ioProperty (isLeft <$> tryApplyOnData v ctx)) vs -{- | All given validators have to not err - -Doing (ioProperty . isRight . tryApplyEval) is probably redundant here, since QC will catch any exceptions --} +-- | All given validators have to not err +-- +-- Doing (ioProperty . isRight . tryApplyEval) is probably redundant here, since QC will catch any exceptions allVldtrsPassed vs ctx = conjoin $ fmap (B.fromOpaque . (`applyOnData` ctx)) vs -unsafeRunCekRes :: (t ~ Term NamedDeBruijn DefaultUni DefaultFun ()) - => t -> t -unsafeRunCekRes = unsafeFromRight . runCekRes +unsafeRunCekRes :: + t ~ Term NamedDeBruijn DefaultUni DefaultFun () => + t -> t +unsafeRunCekRes = unsafeFromRight . runCekRes -runCekRes :: (t ~ Term NamedDeBruijn DefaultUni DefaultFun ()) - => t -> Either (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) t +runCekRes :: + t ~ Term NamedDeBruijn DefaultUni DefaultFun () => + t -> Either (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) t runCekRes t = - UPLC.cekResultToEither . UPLC._cekReportResult $ + UPLC.cekResultToEither . UPLC._cekReportResult $ UPLC.runCekDeBruijn defaultCekParametersForTesting restrictingEnormous noEmitter t liftCode110 :: Lift DefaultUni a => a -> CompiledCode a diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/UnitTests.hs b/cardano-constitution/test/Cardano/Constitution/Validator/UnitTests.hs index 3448fe292fd..87f800a078b 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/UnitTests.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/UnitTests.hs @@ -1,13 +1,14 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -module Cardano.Constitution.Validator.UnitTests - ( unitTests - , singleParamTests - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Constitution.Validator.UnitTests ( + unitTests, + singleParamTests, +) where import Cardano.Constitution.Config () import Cardano.Constitution.Validator @@ -35,7 +36,7 @@ import Test.Tasty.QuickCheck -- MC/DC coverage {- Note [Why de-duplicated ChangedParameters] -**ALL** The following ScriptContext examples *MUST* be de-duplicated Lists. +\**ALL** The following ScriptContext examples *MUST* be de-duplicated Lists. Otherwise, both the sorted and unsorted scripts will produce "wrong" results (for different reasons). See also Guarantee(2) in README.md @@ -47,169 +48,250 @@ See also Guarantee(2) in README.md -- We rely on guarantee (2) and (3) in README.md test_pos :: TestTreeWithTestState -test_pos = const $ testGroup "Positive" $ - fmap (\(n, c) -> testProperty n $ allVldtrsPassed (M.elems defaultValidators) c) - [ ("pos1", V3.mkFakeParameterChangeContext @Integer - [ (0, 30) -- in limits - , (1, 10_000_000) -- in limits - , (17, 6_250) -- in limits - ]) - , ("pos2", V3.mkFakeParameterChangeContext - [ (10, NonCanonicalRational $ Tx.unsafeRatio 1 1000) -- in limits - ]) - , ("pos3", V3.mkFakeParameterChangeContext - [ (19, - [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits - ]) - ]) - -- NOTE: According to constitution-script specification, this is a NOT_SPECIFIED behavior, - -- meaning a valid const.script can decide to return success or fail either way. - -- In reality, the ledger prohibits empty proposals, thus the const.script will not even run. - -- Here, we only do "regression testing" of our validators, which happen to succeed - -- for this out-of-spec behavior. - , ("pos4", V3.mkFakeParameterChangeContext @Integer - [ -- empty params - ]) - ] ++ [ - testProperty "pos5" $ forAll V3.treasuryWithdrawalsCtxGen - $ allVldtrsPassed (M.elems defaultValidators) - ] +test_pos = + const $ + testGroup "Positive" $ + fmap + (\(n, c) -> testProperty n $ allVldtrsPassed (M.elems defaultValidators) c) + [ + ( "pos1" + , V3.mkFakeParameterChangeContext @Integer + [ (0, 30) -- in limits + , (1, 10_000_000) -- in limits + , (17, 6_250) -- in limits + ] + ) + , + ( "pos2" + , V3.mkFakeParameterChangeContext + [ (10, NonCanonicalRational $ Tx.unsafeRatio 1 1000) -- in limits + ] + ) + , + ( "pos3" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits + ] + ) + ] + ) + , -- NOTE: According to constitution-script specification, this is a NOT_SPECIFIED behavior, + -- meaning a valid const.script can decide to return success or fail either way. + -- In reality, the ledger prohibits empty proposals, thus the const.script will not even run. + -- Here, we only do "regression testing" of our validators, which happen to succeed + -- for this out-of-spec behavior. + ( "pos4" + , V3.mkFakeParameterChangeContext @Integer + [] + ) + ] + -- empty params + ++ [ testProperty "pos5" $ + forAll V3.treasuryWithdrawalsCtxGen $ + allVldtrsPassed (M.elems defaultValidators) + ] test_neg :: TestTreeWithTestState -test_neg = const $ testGroup "Negative" $ - fmap (\(n, c) -> testProperty n $ allVldtrsErred (M.elems defaultValidators) c) - [ ("neg1", V3.mkFakeParameterChangeContext @Integer - [ (0, 29) -- **smaller than minbound** - , (1, 10_000_000) -- in limits - , (2, -10_000_000_000) -- unknown param - , (17, 6_250) -- in limits - ]) - , ("neg2", V3.mkFakeParameterChangeContext @Integer - [ (0, 29) -- **smaller than minbound** - , (1, 10_000_000) -- in limits - , (17, 6_251) -- ** larger than maxbound ** - ]) - , ("neg3", V3.mkFakeParameterChangeContext @Integer - [ (-1, -1_000) -- unknown param - ]) - , ("neg4", V3.mkFakeParameterChangeContext @Integer - [ (10, 1) -- type mismatch, 10 is supposed to be Rational - ]) - , ("neg5", V3.mkFakeParameterChangeContext - [ (0, NonCanonicalRational $ Tx.unsafeRatio 1 1) -- type mismatch, 0 is supposed to be integer - ]) - , ("neg6", V3.mkFakeParameterChangeContext - [ (10, NonCanonicalRational $ Tx.unsafeRatio 0 1000) -- out of limits - ]) - , ("neg7", V3.mkFakeParameterChangeContext - [ (19, - [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 0 10_000_000 -- exsteps out of limits - ]) - ]) - , ("neg8", V3.mkFakeParameterChangeContext - [ (19, [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- TOO MUCH SUBS in list SUPPLIED - ]) - ]) - , ("neg9", V3.mkFakeParameterChangeContext - [ (19, [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - -- TOO FEW SUBS in list SUPPLIED - ]) - ]) - , ("neg10", V3.mkFakeParameterChangeContext @[Integer] - [ (19, [ - -- TOO FEW SUBS in list SUPPLIED - ]) - ]) - , ("neg11", V3.mkFakeParameterChangeContext - [ (19, - -- TOO DEEPLY NESTED - [ - [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits - , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits - ] - ] - ) - ]) - -- anything other than ParameterChange or TreasuryWithdrawals is `FAIL` - , ("neg12", V3.mkFakeContextFromGovAction V3.InfoAction) - ] +test_neg = + const $ + testGroup "Negative" $ + fmap + (\(n, c) -> testProperty n $ allVldtrsErred (M.elems defaultValidators) c) + [ + ( "neg1" + , V3.mkFakeParameterChangeContext @Integer + [ (0, 29) + , -- \**smaller than minbound** + (1, 10_000_000) -- in limits + , (2, -10_000_000_000) -- unknown param + , (17, 6_250) -- in limits + ] + ) + , + ( "neg2" + , V3.mkFakeParameterChangeContext @Integer + [ (0, 29) + , -- \**smaller than minbound** + (1, 10_000_000) -- in limits + , (17, 6_251) + ] + ) + , -- \** larger than maxbound ** + + ( "neg3" + , V3.mkFakeParameterChangeContext @Integer + [ (-1, -1_000) -- unknown param + ] + ) + , + ( "neg4" + , V3.mkFakeParameterChangeContext @Integer + [ (10, 1) -- type mismatch, 10 is supposed to be Rational + ] + ) + , + ( "neg5" + , V3.mkFakeParameterChangeContext + [ (0, NonCanonicalRational $ Tx.unsafeRatio 1 1) -- type mismatch, 0 is supposed to be integer + ] + ) + , + ( "neg6" + , V3.mkFakeParameterChangeContext + [ (10, NonCanonicalRational $ Tx.unsafeRatio 0 1000) -- out of limits + ] + ) + , + ( "neg7" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 0 10_000_000 -- exsteps out of limits + ] + ) + ] + ) + , + ( "neg8" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- TOO MUCH SUBS in list SUPPLIED + ] + ) + ] + ) + , + ( "neg9" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + -- TOO FEW SUBS in list SUPPLIED + ] + ) + ] + ) + , + ( "neg10" + , V3.mkFakeParameterChangeContext @[Integer] + [ + ( 19 + , [] + ) + ] + ) + , -- TOO FEW SUBS in list SUPPLIED + + ( "neg11" + , V3.mkFakeParameterChangeContext + [ + ( 19 + , -- TOO DEEPLY NESTED + + [ + [ NonCanonicalRational $ Tx.unsafeRatio 2_000 10_000 -- exmem in limits + , NonCanonicalRational $ Tx.unsafeRatio 500 10_000_000 -- exsteps in limits + ] + ] + ) + ] + ) + , -- anything other than ParameterChange or TreasuryWithdrawals is `FAIL` + ("neg12", V3.mkFakeContextFromGovAction V3.InfoAction) + ] test_unsorted1 :: TestTreeWithTestState -test_unsorted1 = const $ testProperty "unsorted1" $ - -- unsorted fails for the right reason, sorted fails for the wrong reason - allVldtrsErred (M.elems defaultValidators) ctx +test_unsorted1 = + const $ + testProperty "unsorted1" $ + -- unsorted fails for the right reason, sorted fails for the wrong reason + allVldtrsErred (M.elems defaultValidators) ctx where - ctx = V3.mkFakeParameterChangeContext @Integer - -- deliberately kept unsorted to demonstrate the different behaviour between - -- SORTED and UNSORTED flavour. See guarantee (3) in README.md - [ (0, 30) -- in limits - , (17, 6_250) -- in limits, **but breaks sorting** - -- out of limits **should make constitution script fail** - -- unsorted flavor fails, for the right reason (out of limits) - -- sorted flavor fails, for the wrong reason (it ran past the config, and fail to find actualPid) - , (1, 10_000_001) - ] + ctx = + V3.mkFakeParameterChangeContext @Integer + -- deliberately kept unsorted to demonstrate the different behaviour between + -- SORTED and UNSORTED flavour. See guarantee (3) in README.md + [ (0, 30) -- in limits + , (17, 6_250) -- in limits, **but breaks sorting** + -- out of limits **should make constitution script fail** + -- unsorted flavor fails, for the right reason (out of limits) + -- sorted flavor fails, for the wrong reason (it ran past the config, and fail to find actualPid) + , (1, 10_000_001) + ] test_unsorted2 :: TestTreeWithTestState -test_unsorted2 = const $ testProperty "unsorted2" $ - -- The unsorted flavour does not depend on guarantee 3, - -- so it can work with unsorted input map as well - allVldtrsPassed [defaultValidators M.! "unsorted"] ctx - -- The sorted flavour depends on guarantee 3, so it breaks with unsorted maps: - -- the constitution scripts should fail, but they don't - .&&. allVldtrsErred [defaultValidators M.! "sorted"] ctx - - where - ctx = V3.mkFakeParameterChangeContext @Integer - -- deliberately kept unsorted to demonstrate the different behaviour between - -- SORTED and UNSORTED flavour. See guarantee (3) in README.md - [ (0, 30) -- in limits - , (17, 6_250) -- in limits, **but breaks sorting** - -- in limits - -- unsorted flavor passes - -- sorted flavor fails (it ran past the config, and fail to find actualPid) - , (1, 10_000_000) - ] - -{- | A safety check to make sure that a `ScriptContext` containg a large proposal -will not reach the maxTxSize currently set by the chain. -In reality, proposals will not be that big. +test_unsorted2 = + const $ + testProperty "unsorted2" $ + -- The unsorted flavour does not depend on guarantee 3, + -- so it can work with unsorted input map as well + allVldtrsPassed [defaultValidators M.! "unsorted"] ctx + -- The sorted flavour depends on guarantee 3, so it breaks with unsorted maps: + -- the constitution scripts should fail, but they don't + .&&. allVldtrsErred [defaultValidators M.! "sorted"] ctx + where + ctx = + V3.mkFakeParameterChangeContext @Integer + -- deliberately kept unsorted to demonstrate the different behaviour between + -- SORTED and UNSORTED flavour. See guarantee (3) in README.md + [ (0, 30) -- in limits + , (17, 6_250) -- in limits, **but breaks sorting** + -- in limits + -- unsorted flavor passes + -- sorted flavor fails (it ran past the config, and fail to find actualPid) + , (1, 10_000_000) + ] -If this size becomes so big that it is an issue, there is the option (*in certain cases only!*), -to split up such large proposal to smaller parts and submit them to the chain separately. --} +-- | A safety check to make sure that a `ScriptContext` containg a large proposal +-- will not reach the maxTxSize currently set by the chain. +-- In reality, proposals will not be that big. +-- +-- If this size becomes so big that it is an issue, there is the option (*in certain cases only!*), +-- to split up such large proposal to smaller parts and submit them to the chain separately. test_LargeProposalSize :: TestTreeWithTestState test_LargeProposalSize = const $ testCaseInfo "largeProposalSize" $ do - let largeSize = Tx.lengthOfByteString $ Tx.serialiseData $ toBuiltinData $ - V3.mkFakeParameterChangeContext Guards.getFakeLargeParamsChange - -- current maxTxSize is 16384 Bytes set on 07/29/2020 23:44:51 - -- , but we set this limit a bit lower (to accomodate other tx costs?) - maxTxSize = 10_000 - -- current maxTxSize - assertBool "Large Proposal does not fit transaction-size limits." (largeSize < maxTxSize) - pure $ "A large proposal has " <> show largeSize <> " below the limit set to " <> show maxTxSize + let largeSize = + Tx.lengthOfByteString $ + Tx.serialiseData $ + toBuiltinData $ + V3.mkFakeParameterChangeContext Guards.getFakeLargeParamsChange + -- current maxTxSize is 16384 Bytes set on 07/29/2020 23:44:51 + -- , but we set this limit a bit lower (to accomodate other tx costs?) + maxTxSize = 10_000 + -- current maxTxSize + assertBool "Large Proposal does not fit transaction-size limits." (largeSize < maxTxSize) + pure $ "A large proposal has " <> show largeSize <> " below the limit set to " <> show maxTxSize unitTests :: TestTreeWithTestState -unitTests = testGroup' "Unit" - [ test_pos - , test_neg - , test_unsorted1 - , test_unsorted2 - , test_LargeProposalSize - ] +unitTests = + testGroup' + "Unit" + [ test_pos + , test_neg + , test_unsorted1 + , test_unsorted2 + , test_LargeProposalSize + ] singleParamTests :: TestTreeWithTestState singleParamTests = testGroup' "Single Parameter Proposals" tests where - tests = fmap f Guards.allParams + tests = fmap f Guards.allParams - f :: Guards.GenericParam -> TestTreeWithTestState - f (Guards.MkGenericParam gr@(Guards.Param{})) = Guards.testSet gr - f (Guards.MkGenericParam gr@(Guards.WithinDomain{})) = Guards.testSet gr - f (Guards.MkGenericParam gr@(Guards.ParamList{})) = Guards.paramListTestSet gr + f :: Guards.GenericParam -> TestTreeWithTestState + f (Guards.MkGenericParam gr@(Guards.Param {})) = Guards.testSet gr + f (Guards.MkGenericParam gr@(Guards.WithinDomain {})) = Guards.testSet gr + f (Guards.MkGenericParam gr@(Guards.ParamList {})) = Guards.paramListTestSet gr diff --git a/cardano-constitution/test/Driver.hs b/cardano-constitution/test/Driver.hs index c863fe50dd7..8cc41227f28 100644 --- a/cardano-constitution/test/Driver.hs +++ b/cardano-constitution/test/Driver.hs @@ -26,7 +26,6 @@ import Test.Tasty.Ingredients.Basic import Test.Tasty.JsonReporter import Test.Tasty.QuickCheck qualified as TQC - expectTrue :: (a, b) -> a expectTrue = fst @@ -39,61 +38,65 @@ main = do ref <- newIORef (TestState mempty mempty) -- tests to be run - let mainTest = testGroup' "Testing Campaign" [ - UnitTests.unitTests, - PropTests.tests, - ConfigTests.tests, - GoldenTests.tests, - UnitTests.singleParamTests, - Data.UnitTests.unitTests, - Data.PropTests.tests, - Data.GoldenTests.tests, - Data.UnitTests.singleParamTests, - testGroup' "Multiple Parameter Changes" - [ - testProperty' "Proposal with all parameters at their current (or default value if new)" $ - multiParamProp 1 (allValid allParams) expectTrue, - testProperty' "Proposals with one parameter missing, and all the other ones within their ranges" $ - multiParamProp 2 (allValidAndOneMissing allParams) expectTrue, - testProperty' "Proposals with one parameter lower than its lower bound, and all the other ones within their ranges" $ - multiParamProp 3 (allValidAndOneLessThanLower allParams) expectFalse, - testProperty' "Proposals with one parameter greater than its upper bound, and all the other ones within their ranges" $ - multiParamProp 4 (allValidAndOneGreaterThanUpper allParams) expectFalse, - testProperty' "Proposals with one parameter unknown and all the other ones within their ranges" $ - multiParamProp 5 (allValidAndOneUnknown allParams) expectFalse, - testProperty' "Proposals with all parameters but one, all within their ranges, plus one unknown" $ -- To see if they don't do a trick on proposal length - multiParamProp 6 (allValidButOnePlusOneUnknown allParams) expectFalse, - testProperty' "Proposals with all parameters within their ranges" $ - multiParamProp 7 (allValid allParams) expectTrue, - testProperty' "Proposals with all parameters outside their ranges " $ - multiParamProp 8 (allInvalid allParams) expectFalse, - testProperty' "Proposals with a selection of parameters within their ranges" $ - multiParamProp 9 (someValidParams allParams) expectTrue, - testProperty' "Proposals with a selection of parameters, some within their ranges, some outside" $ - multiParamProp 10 (someInvalidAndSomeValidParams allParams) expectFalse, - testProperty' "Proposals with a selection of parameters within their ranges + costModels" $ - multiParamProp' 11 (someValidParams allParams) ((:[]) <$> costModelsParamGen) expectTrue, - testProperty' "Proposals with a selection of parameters, some within their ranges, some outside + costModels" $ - multiParamProp' 12 (someInvalidAndSomeValidParams allParams) ((:[]) <$> costModelsParamGen) expectFalse - ], - testGroup' "Internal Tests" [ - const IntervalSpec.internalTests, - const FareySpec.internalTests - ] - ] + let mainTest = + testGroup' + "Testing Campaign" + [ UnitTests.unitTests + , PropTests.tests + , ConfigTests.tests + , GoldenTests.tests + , UnitTests.singleParamTests + , Data.UnitTests.unitTests + , Data.PropTests.tests + , Data.GoldenTests.tests + , Data.UnitTests.singleParamTests + , testGroup' + "Multiple Parameter Changes" + [ testProperty' "Proposal with all parameters at their current (or default value if new)" $ + multiParamProp 1 (allValid allParams) expectTrue + , testProperty' "Proposals with one parameter missing, and all the other ones within their ranges" $ + multiParamProp 2 (allValidAndOneMissing allParams) expectTrue + , testProperty' "Proposals with one parameter lower than its lower bound, and all the other ones within their ranges" $ + multiParamProp 3 (allValidAndOneLessThanLower allParams) expectFalse + , testProperty' "Proposals with one parameter greater than its upper bound, and all the other ones within their ranges" $ + multiParamProp 4 (allValidAndOneGreaterThanUpper allParams) expectFalse + , testProperty' "Proposals with one parameter unknown and all the other ones within their ranges" $ + multiParamProp 5 (allValidAndOneUnknown allParams) expectFalse + , testProperty' "Proposals with all parameters but one, all within their ranges, plus one unknown" $ -- To see if they don't do a trick on proposal length + multiParamProp 6 (allValidButOnePlusOneUnknown allParams) expectFalse + , testProperty' "Proposals with all parameters within their ranges" $ + multiParamProp 7 (allValid allParams) expectTrue + , testProperty' "Proposals with all parameters outside their ranges " $ + multiParamProp 8 (allInvalid allParams) expectFalse + , testProperty' "Proposals with a selection of parameters within their ranges" $ + multiParamProp 9 (someValidParams allParams) expectTrue + , testProperty' "Proposals with a selection of parameters, some within their ranges, some outside" $ + multiParamProp 10 (someInvalidAndSomeValidParams allParams) expectFalse + , testProperty' "Proposals with a selection of parameters within their ranges + costModels" $ + multiParamProp' 11 (someValidParams allParams) ((: []) <$> costModelsParamGen) expectTrue + , testProperty' "Proposals with a selection of parameters, some within their ranges, some outside + costModels" $ + multiParamProp' 12 (someInvalidAndSomeValidParams allParams) ((: []) <$> costModelsParamGen) expectFalse + ] + , testGroup' + "Internal Tests" + [ const IntervalSpec.internalTests + , const FareySpec.internalTests + ] + ] - let testTree - = localOption (TQC.QuickCheckTests 30) - $ mainTest ref + let testTree = + localOption (TQC.QuickCheckTests 30) $ + mainTest ref -- run the tests defaultMainWithIngredients [listingTests, consoleAndJsonReporter] testTree - `catch` (\(e :: ExitCode) -> do - -- write the results to a file - (TestState oneParamS multiParamS) <- readIORef ref - let directory = "certification" "data" - createDirectoryIfMissing True directory - BS.writeFile (directory "single-param.json") $ BS.toStrict $ encode oneParamS - BS.writeFile (directory "multi-param.json") $ BS.toStrict $ encode multiParamS - putStrLn $ "JSON files written to " <> directory - throwIO e) + `catch` ( \(e :: ExitCode) -> do + -- write the results to a file + (TestState oneParamS multiParamS) <- readIORef ref + let directory = "certification" "data" + createDirectoryIfMissing True directory + BS.writeFile (directory "single-param.json") $ BS.toStrict $ encode oneParamS + BS.writeFile (directory "multi-param.json") $ BS.toStrict $ encode multiParamS + putStrLn $ "JSON files written to " <> directory + throwIO e + ) diff --git a/cardano-constitution/test/Helpers/CekTests.hs b/cardano-constitution/test/Helpers/CekTests.hs index fe262f35da4..f85d4672114 100644 --- a/cardano-constitution/test/Helpers/CekTests.hs +++ b/cardano-constitution/test/Helpers/CekTests.hs @@ -1,8 +1,8 @@ -module Helpers.CekTests - ( hsValidatorsAgreesAndPassAll - , hsValidatorsAgreesAndErrAll - , hsAgreesWithTxBool - ) where +module Helpers.CekTests ( + hsValidatorsAgreesAndPassAll, + hsValidatorsAgreesAndErrAll, + hsAgreesWithTxBool, +) where import Cardano.Constitution.Validator import Cardano.Constitution.Validator.TestsCommon @@ -11,47 +11,66 @@ import PlutusTx as Tx import Test.Tasty.QuickCheck import UntypedPlutusCore as UPLC -hsValidatorsAgreesAndPassAll :: [(ConstitutionValidator, CompiledCode ConstitutionValidator)] - -> V3.FakeProposedContext -> Property +hsValidatorsAgreesAndPassAll :: + [(ConstitutionValidator, CompiledCode ConstitutionValidator)] -> + V3.FakeProposedContext -> + Property hsValidatorsAgreesAndPassAll vs ctx = conjoin $ fmap (`hsValidatorsAgreesAndPass` ctx) vs -hsValidatorsAgreesAndErrAll :: [(ConstitutionValidator, CompiledCode ConstitutionValidator)] - -> V3.FakeProposedContext -> Property +hsValidatorsAgreesAndErrAll :: + [(ConstitutionValidator, CompiledCode ConstitutionValidator)] -> + V3.FakeProposedContext -> + Property hsValidatorsAgreesAndErrAll vs ctx = conjoin $ fmap (`hsValidatorsAgreesAndErr` ctx) vs -hsAgreesWithTxBool :: (ConstitutionValidator, CompiledCode ConstitutionValidator) - -> V3.FakeProposedContext -> IO Bool +hsAgreesWithTxBool :: + (ConstitutionValidator, CompiledCode ConstitutionValidator) -> + V3.FakeProposedContext -> + IO Bool hsAgreesWithTxBool (vHs, vCode) ctx = do - resHs <- tryApplyOnData vHs ctx - let vPs = _progTerm $ getPlcNoAnn $ vCode - `unsafeApplyCode` liftCode110 (toBuiltinData ctx) - resPs = runCekRes vPs - - pure $ case (resHs, resPs) of - (Left _, Left _) -> True - (Right okHs, Right okPs) -> liftCode110Norm okHs == okPs - _ -> False - -hsValidatorsAgreesAndErr :: (ConstitutionValidator, CompiledCode ConstitutionValidator) - -> V3.FakeProposedContext -> Property + resHs <- tryApplyOnData vHs ctx + let vPs = + _progTerm $ + getPlcNoAnn $ + vCode + `unsafeApplyCode` liftCode110 (toBuiltinData ctx) + resPs = runCekRes vPs + + pure $ case (resHs, resPs) of + (Left _, Left _) -> True + (Right okHs, Right okPs) -> liftCode110Norm okHs == okPs + _ -> False + +hsValidatorsAgreesAndErr :: + (ConstitutionValidator, CompiledCode ConstitutionValidator) -> + V3.FakeProposedContext -> + Property hsValidatorsAgreesAndErr (vHs, vCode) ctx = ioProperty $ do - resHs <- tryApplyOnData vHs ctx - let vPs = _progTerm $ getPlcNoAnn $ vCode - `unsafeApplyCode` liftCode110 (toBuiltinData ctx) - resPs = runCekRes vPs + resHs <- tryApplyOnData vHs ctx + let vPs = + _progTerm $ + getPlcNoAnn $ + vCode + `unsafeApplyCode` liftCode110 (toBuiltinData ctx) + resPs = runCekRes vPs - pure $ case (resHs, resPs) of - (Left _, Left _) -> property True - _ -> property False + pure $ case (resHs, resPs) of + (Left _, Left _) -> property True + _ -> property False -hsValidatorsAgreesAndPass :: (ConstitutionValidator, CompiledCode ConstitutionValidator) - -> V3.FakeProposedContext -> Property +hsValidatorsAgreesAndPass :: + (ConstitutionValidator, CompiledCode ConstitutionValidator) -> + V3.FakeProposedContext -> + Property hsValidatorsAgreesAndPass (vHs, vCode) ctx = ioProperty $ do - resHs <- tryApplyOnData vHs ctx - let vPs = _progTerm $ getPlcNoAnn $ vCode - `unsafeApplyCode` liftCode110 (toBuiltinData ctx) - resPs = runCekRes vPs - - pure $ case (resHs, resPs) of - (Right okHs, Right okPs) -> liftCode110Norm okHs === okPs - _ -> property False + resHs <- tryApplyOnData vHs ctx + let vPs = + _progTerm $ + getPlcNoAnn $ + vCode + `unsafeApplyCode` liftCode110 (toBuiltinData ctx) + resPs = runCekRes vPs + + pure $ case (resHs, resPs) of + (Right okHs, Right okPs) -> liftCode110Norm okHs === okPs + _ -> property False diff --git a/cardano-constitution/test/Helpers/Farey.hs b/cardano-constitution/test/Helpers/Farey.hs index e3b028738ff..f51058ff6d7 100644 --- a/cardano-constitution/test/Helpers/Farey.hs +++ b/cardano-constitution/test/Helpers/Farey.hs @@ -34,15 +34,15 @@ findFsbSubtree :: findFsbSubtree target limNumb = let (a, b, c, d, e, f) = (0, 1, 1, 1, 1, 0) in loop a b c d e f - where - loop a b c d e f - | c % d == target || any (>= limNumb) [a, b, c, d, e, f] = (a, b, c, d, e, f) - | a % b < target && target < c % d = - let (c', d', e', f') = goLeftInFsbTree a b c d - in loop a b c' d' e' f' - | otherwise = - let (a', b', c', d') = goRightInFsbTree c d e f - in loop a' b' c' d' e f + where + loop a b c d e f + | c % d == target || any (>= limNumb) [a, b, c, d, e, f] = (a, b, c, d, e, f) + | a % b < target && target < c % d = + let (c', d', e', f') = goLeftInFsbTree a b c d + in loop a b c' d' e' f' + | otherwise = + let (a', b', c', d') = goRightInFsbTree c d e f + in loop a' b' c' d' e f findSuccInFsbTree :: (Integer, Integer, Integer, Integer) -> diff --git a/cardano-constitution/test/Helpers/Guardrail.hs b/cardano-constitution/test/Helpers/Guardrail.hs index 99462c76e05..4110950d362 100644 --- a/cardano-constitution/test/Helpers/Guardrail.hs +++ b/cardano-constitution/test/Helpers/Guardrail.hs @@ -1,65 +1,64 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Helpers.Guardrail - ( txFeePerByte - , txFeeFixed - , utxoCostPerByte - , stakeAddressDeposit - , stakePoolDeposit - , minPoolCost - , treasuryCut - , monetaryExpansion - , executionUnitPrices - , minFeeRefScriptCoinsPerByte - , maxBlockBodySize - , maxTxSize - , maxBlockExecutionUnits - , maxTxExecutionUnits - , maxBlockHeaderSize - , stakePoolTargetNum - , poolPledgeInfluence - , poolRetireMaxEpoch - , collateralPercentage - , maxCollateralInputs - , maxValueSize - , guardrailsNotChecked - , govDeposit - , dRepDeposit - , dRepActivity - , dRepVotingThresholds - , poolVotingThresholds - , govActionLifetime - , committeeMaxTermLimit - , committeeMinSize - - , ignoreTestBecauseIf - , getGuardrailTestGroup - , getCombinedConstraintTest - , boundaries - , paramRange - , getParamIx - , getParamName - - , IntervalEnum(..) - , Guardrail(..) - , Scalar - , Boundary(..) - , Param - , Collection - , GenericParam(..) - , getDomain - , getDefaultValue - , testSet - , paramListTestSet - , allParams - , getFakeLargeParamsChange - )where +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Helpers.Guardrail ( + txFeePerByte, + txFeeFixed, + utxoCostPerByte, + stakeAddressDeposit, + stakePoolDeposit, + minPoolCost, + treasuryCut, + monetaryExpansion, + executionUnitPrices, + minFeeRefScriptCoinsPerByte, + maxBlockBodySize, + maxTxSize, + maxBlockExecutionUnits, + maxTxExecutionUnits, + maxBlockHeaderSize, + stakePoolTargetNum, + poolPledgeInfluence, + poolRetireMaxEpoch, + collateralPercentage, + maxCollateralInputs, + maxValueSize, + guardrailsNotChecked, + govDeposit, + dRepDeposit, + dRepActivity, + dRepVotingThresholds, + poolVotingThresholds, + govActionLifetime, + committeeMaxTermLimit, + committeeMinSize, + ignoreTestBecauseIf, + getGuardrailTestGroup, + getCombinedConstraintTest, + boundaries, + paramRange, + getParamIx, + getParamName, + IntervalEnum (..), + Guardrail (..), + Scalar, + Boundary (..), + Param, + Collection, + GenericParam (..), + getDomain, + getDefaultValue, + testSet, + paramListTestSet, + allParams, + getFakeLargeParamsChange, +) where + import Helpers.TestBuilders hiding (Range (..)) import Data.Aeson @@ -79,454 +78,647 @@ import PlutusLedgerApi.V3 (BuiltinData) data Scalar a data Collection a data Param a ---data FixedList a + +-- data FixedList a data Assertion a data Guardrail a where MustNotBe :: (String, String) -> RangeConstraint a -> Guardrail (Assertion a) - Once :: Guardrail (Assertion a) -> Guardrail (Assertion a) - - Param :: (IntervalEnum a,ToData a,ToJSON a, Show a,HasRange a, HasDomain a,Num a,Ord a) - => Integer -> String -> a -> [Guardrail (Assertion a)] -> Guardrail (Param (Scalar a)) - - WithinDomain :: (IntervalEnum a, ToData a, ToJSON a, Show a, HasRange a, HasDomain a, Num a, Ord a) - => Guardrail (Param (Scalar a)) -> (a,a) -> Guardrail (Param (Scalar a)) - - ParamList :: (IntervalEnum a, ToData a, ToJSON a, Show a, Num a, HasRange a, Ord a, HasDomain a) - => Integer -> String -> [Guardrail (Param (Scalar a))] -> Guardrail (Param (Collection a)) + Param :: + (IntervalEnum a, ToData a, ToJSON a, Show a, HasRange a, HasDomain a, Num a, Ord a) => + Integer -> String -> a -> [Guardrail (Assertion a)] -> Guardrail (Param (Scalar a)) + WithinDomain :: + (IntervalEnum a, ToData a, ToJSON a, Show a, HasRange a, HasDomain a, Num a, Ord a) => + Guardrail (Param (Scalar a)) -> (a, a) -> Guardrail (Param (Scalar a)) + ParamList :: + (IntervalEnum a, ToData a, ToJSON a, Show a, Num a, HasRange a, Ord a, HasDomain a) => + Integer -> String -> [Guardrail (Param (Scalar a))] -> Guardrail (Param (Collection a)) guardrailsNotChecked :: Guardrail (Param (Scalar Integer)) -guardrailsNotChecked = Param @Integer 999 "guardrailsNotChecked" 0 - [ ("PARAM-01", "Any protocol parameter that is not explicitly named in this document must not be changed by a parameter update governance action") `MustNotBe` NL 0 - , ("PARAM-02", "Where a parameter is explicitly listed in this document but no guardrails are specified, the script must not impose any constraints on changes to the parameter") `MustNotBe` NL 0 - , ("PARAM-03", "Critical protocol parameters require an SPO vote in addition to a DRep vote: SPOs must say \"yes\" with a collective support of more than 60% of all active block production stake. This is enforced by the guardrails on the `ppSecurityParam` voting threshold") `MustNotBe` NL 0 - , ("PARAM-05", "DReps must vote \"yes\" with a collective support of more than 50% of all active voting stake. This is enforced by the guardrails on the DRep voting thresholds") `MustNotBe` NL 0 - ] +guardrailsNotChecked = + Param @Integer + 999 + "guardrailsNotChecked" + 0 + [ ("PARAM-01", "Any protocol parameter that is not explicitly named in this document must not be changed by a parameter update governance action") `MustNotBe` NL 0 + , ("PARAM-02", "Where a parameter is explicitly listed in this document but no guardrails are specified, the script must not impose any constraints on changes to the parameter") `MustNotBe` NL 0 + , ("PARAM-03", "Critical protocol parameters require an SPO vote in addition to a DRep vote: SPOs must say \"yes\" with a collective support of more than 60% of all active block production stake. This is enforced by the guardrails on the `ppSecurityParam` voting threshold") `MustNotBe` NL 0 + , ("PARAM-05", "DReps must vote \"yes\" with a collective support of more than 50% of all active voting stake. This is enforced by the guardrails on the DRep voting thresholds") `MustNotBe` NL 0 + ] txFeePerByte :: Guardrail (Param (Scalar Integer)) -txFeePerByte = Param @Integer 0 "txFeePerByte" 44 - [ ("TFPB-01", "txFeePerByte must not be lower than 30 (0.000030 ada)") `MustNotBe` NL 30 - , ("TFPB-02", "txFeePerByte must not exceed 1,000 (0.001 ada)") `MustNotBe` NG 1_000 - , ("TFPB-03", "txFeePerByte must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,5_000) +txFeePerByte = + Param @Integer + 0 + "txFeePerByte" + 44 + [ ("TFPB-01", "txFeePerByte must not be lower than 30 (0.000030 ada)") `MustNotBe` NL 30 + , ("TFPB-02", "txFeePerByte must not exceed 1,000 (0.001 ada)") `MustNotBe` NG 1_000 + , ("TFPB-03", "txFeePerByte must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 5_000) txFeeFixed :: Guardrail (Param (Scalar Integer)) -txFeeFixed = Param @Integer 1 "txFeeFixed" 155_381 - [ ("TFF-01","txFeeFixed must not be lower than 100,000 (0.1 ada)") `MustNotBe` NL 100_000 - , ("TFF-02","txFeeFixed must not exceed 10,000,000 (10 ada)") `MustNotBe` NG 10_000_000 - , ("TFF-03","txFeeFixed must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-100_000,12_000_000) +txFeeFixed = + Param @Integer + 1 + "txFeeFixed" + 155_381 + [ ("TFF-01", "txFeeFixed must not be lower than 100,000 (0.1 ada)") `MustNotBe` NL 100_000 + , ("TFF-02", "txFeeFixed must not exceed 10,000,000 (10 ada)") `MustNotBe` NG 10_000_000 + , ("TFF-03", "txFeeFixed must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-100_000, 12_000_000) utxoCostPerByte :: Guardrail (Param (Scalar Integer)) -utxoCostPerByte = Param @Integer 17 "utxoCostPerByte" 4_310 - [ ("UCPB-01","utxoCostPerByte must not be lower than 3,000 (0.003 ada)") `MustNotBe` NL 3_000 - , ("UCPB-02","utxoCostPerByte must not exceed 6,500 (0.0065 ada)") `MustNotBe` NG 6_500 - , Once (("UCPB-03","utxoCostPerByte must not be set to 0") `MustNotBe` NEQ 0) - , ("UCPB-04","utxoCostPerByte must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,10_000) +utxoCostPerByte = + Param @Integer + 17 + "utxoCostPerByte" + 4_310 + [ ("UCPB-01", "utxoCostPerByte must not be lower than 3,000 (0.003 ada)") `MustNotBe` NL 3_000 + , ("UCPB-02", "utxoCostPerByte must not exceed 6,500 (0.0065 ada)") `MustNotBe` NG 6_500 + , Once (("UCPB-03", "utxoCostPerByte must not be set to 0") `MustNotBe` NEQ 0) + , ("UCPB-04", "utxoCostPerByte must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 10_000) stakeAddressDeposit :: Guardrail (Param (Scalar Integer)) -stakeAddressDeposit = Param @Integer 5 "stakeAddressDeposit" 2_000_000 - [ ("SAD-01","stakeAddressDeposit must not be lower than 1,000,000 (1 ada)") `MustNotBe` NL 1_000_000 - , ("SAD-02","stakeAddressDeposit must not exceed 5,000,000 (5 ada)") `MustNotBe` NG 5_000_000 - , ("SAD-03","stakeAddressDeposit must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,10_000_000) +stakeAddressDeposit = + Param @Integer + 5 + "stakeAddressDeposit" + 2_000_000 + [ ("SAD-01", "stakeAddressDeposit must not be lower than 1,000,000 (1 ada)") `MustNotBe` NL 1_000_000 + , ("SAD-02", "stakeAddressDeposit must not exceed 5,000,000 (5 ada)") `MustNotBe` NG 5_000_000 + , ("SAD-03", "stakeAddressDeposit must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 10_000_000) stakePoolDeposit :: Guardrail (Param (Scalar Integer)) -stakePoolDeposit = Param @Integer 6 "stakePoolDeposit" 500_000_000 - [ ("SPD-01","stakePoolDeposit must not be lower than 250,000,000 (250 ada)") `MustNotBe` NL 250_000_000 - , ("SPD-02","stakePoolDeposit must not exceed 500,000,000 (500 ada)") `MustNotBe` NG 500_000_000 - , ("SDP-03","stakePoolDeposit must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,700_000_000) - +stakePoolDeposit = + Param @Integer + 6 + "stakePoolDeposit" + 500_000_000 + [ ("SPD-01", "stakePoolDeposit must not be lower than 250,000,000 (250 ada)") `MustNotBe` NL 250_000_000 + , ("SPD-02", "stakePoolDeposit must not exceed 500,000,000 (500 ada)") `MustNotBe` NG 500_000_000 + , ("SDP-03", "stakePoolDeposit must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 700_000_000) minPoolCost :: Guardrail (Param (Scalar Integer)) -minPoolCost = Param @Integer 16 "minPoolCost" 170_000_000 - [ ("MPC-01","minPoolCost must not be negative") `MustNotBe` NL 0 - , ("MPC-02","minPoolCost must not exceed 500,000,000 (500 ada)") `MustNotBe` NG 500_000_000 - ] - `WithinDomain` (-5_000,600_000_000) +minPoolCost = + Param @Integer + 16 + "minPoolCost" + 170_000_000 + [ ("MPC-01", "minPoolCost must not be negative") `MustNotBe` NL 0 + , ("MPC-02", "minPoolCost must not exceed 500,000,000 (500 ada)") `MustNotBe` NG 500_000_000 + ] + `WithinDomain` (-5_000, 600_000_000) treasuryCut :: Guardrail (Param (Scalar Rational)) -treasuryCut = Param @Rational 11 "treasuryCut" 0.3 - [ ("TC-01","treasuryCut must not be lower than 0.1 (10%)") `MustNotBe` NL 0.1 - , ("TC-02", "treasuryCut must not exceed 0.3 (30%)") `MustNotBe` NG 0.3 - , ("TC-03","treasuryCut must not be negative") `MustNotBe` NL 0 - , ("TC-04", "treasuryCut must not exceed 1.0 (100%)") `MustNotBe` NG 1.0 - ] - `WithinDomain` (-1.0,1.0) +treasuryCut = + Param @Rational + 11 + "treasuryCut" + 0.3 + [ ("TC-01", "treasuryCut must not be lower than 0.1 (10%)") `MustNotBe` NL 0.1 + , ("TC-02", "treasuryCut must not exceed 0.3 (30%)") `MustNotBe` NG 0.3 + , ("TC-03", "treasuryCut must not be negative") `MustNotBe` NL 0 + , ("TC-04", "treasuryCut must not exceed 1.0 (100%)") `MustNotBe` NG 1.0 + ] + `WithinDomain` (-1.0, 1.0) monetaryExpansion :: Guardrail (Param (Scalar Rational)) -monetaryExpansion = Param @Rational 10 "monetaryExpansion" 0.003 - [ ("ME-01","monetaryExpansion must not exceed 0.005") `MustNotBe` NG 0.005 - , ("ME-02","monetaryExpansion must not be lower than 0.001") `MustNotBe` NL 0.001 - , ("ME-03","monetaryExpansion must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-1.0,1.0) +monetaryExpansion = + Param @Rational + 10 + "monetaryExpansion" + 0.003 + [ ("ME-01", "monetaryExpansion must not exceed 0.005") `MustNotBe` NG 0.005 + , ("ME-02", "monetaryExpansion must not be lower than 0.001") `MustNotBe` NL 0.001 + , ("ME-03", "monetaryExpansion must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-1.0, 1.0) executionUnitPrices :: Guardrail (Param (Collection Rational)) -executionUnitPrices = ParamList @Rational 19 "executionUnitPrices" - [ Param 0 "priceMemory" (577 % 10_000) - [ ("EIUP-PM-01","executionUnitPrices[priceMemory] must not exceed 2_000 / 10_000") `MustNotBe` NG (2_000 % 10_000) - , ("EIUP-PM-02","executionUnitPrices[priceMemory] must not be lower than 400 / 10_000") `MustNotBe` NL (400 % 10_000) - ] `WithinDomain` (0.0, 1.0) - , Param 1 "priceSteps" (721 % 10_000_000) - [ ("EIUP-PS-01","executionUnitPrices[priceSteps] must not exceed 2,000 / 10,000,000") `MustNotBe` NG (2_000 % 10_000_000) - , ("EIUP-PS-02","executionUnitPrices[priceSteps] must not be lower than 500 / 10,000,000") `MustNotBe` NL (500 % 10_000_000) - ] `WithinDomain` (0.0, 1.0) - ] +executionUnitPrices = + ParamList @Rational + 19 + "executionUnitPrices" + [ Param + 0 + "priceMemory" + (577 % 10_000) + [ ("EIUP-PM-01", "executionUnitPrices[priceMemory] must not exceed 2_000 / 10_000") `MustNotBe` NG (2_000 % 10_000) + , ("EIUP-PM-02", "executionUnitPrices[priceMemory] must not be lower than 400 / 10_000") `MustNotBe` NL (400 % 10_000) + ] + `WithinDomain` (0.0, 1.0) + , Param + 1 + "priceSteps" + (721 % 10_000_000) + [ ("EIUP-PS-01", "executionUnitPrices[priceSteps] must not exceed 2,000 / 10,000,000") `MustNotBe` NG (2_000 % 10_000_000) + , ("EIUP-PS-02", "executionUnitPrices[priceSteps] must not be lower than 500 / 10,000,000") `MustNotBe` NL (500 % 10_000_000) + ] + `WithinDomain` (0.0, 1.0) + ] minFeeRefScriptCoinsPerByte :: Guardrail (Param (Scalar Rational)) -minFeeRefScriptCoinsPerByte = Param @Rational 33 "minFeeRefScriptCoinsPerByte" 1 - [ ("MFRS-01", "minFeeRefScriptCoinsPerByte must not exceed 1,000 (0.001 ada)") `MustNotBe` NG (1_000 % 1) - , ("MFRS-02", "minFeeRefScriptCoinsPerByte must not be negative") `MustNotBe` NL (0 % 1) - ] - `WithinDomain` (-5_000,10_000) +minFeeRefScriptCoinsPerByte = + Param @Rational + 33 + "minFeeRefScriptCoinsPerByte" + 1 + [ ("MFRS-01", "minFeeRefScriptCoinsPerByte must not exceed 1,000 (0.001 ada)") `MustNotBe` NG (1_000 % 1) + , ("MFRS-02", "minFeeRefScriptCoinsPerByte must not be negative") `MustNotBe` NL (0 % 1) + ] + `WithinDomain` (-5_000, 10_000) maxBlockBodySize :: Guardrail (Param (Scalar Integer)) -maxBlockBodySize = Param @Integer 2 "maxBlockBodySize" 90_112 - [ ("MBBS-01","maxBlockBodySize must not exceed 122,880 Bytes (120KB)") `MustNotBe` NG 122_880 - , ("MBBS-02","maxBlockBodySize must not be lower than 24,576 Bytes (24KB)") `MustNotBe` NL 24_576 - ] - `WithinDomain` (-5_000,200_000) +maxBlockBodySize = + Param @Integer + 2 + "maxBlockBodySize" + 90_112 + [ ("MBBS-01", "maxBlockBodySize must not exceed 122,880 Bytes (120KB)") `MustNotBe` NG 122_880 + , ("MBBS-02", "maxBlockBodySize must not be lower than 24,576 Bytes (24KB)") `MustNotBe` NL 24_576 + ] + `WithinDomain` (-5_000, 200_000) maxTxSize :: Guardrail (Param (Scalar Integer)) -maxTxSize = Param @Integer 3 "maxTxSize" 16_384 - [ ("MTS-01","maxTxSize must not exceed 32,768 Bytes (32KB)") `MustNotBe` NG 32_768 - , ("MTS-02","maxTxSize must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,50_000) +maxTxSize = + Param @Integer + 3 + "maxTxSize" + 16_384 + [ ("MTS-01", "maxTxSize must not exceed 32,768 Bytes (32KB)") `MustNotBe` NG 32_768 + , ("MTS-02", "maxTxSize must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 50_000) maxBlockExecutionUnits :: Guardrail (Param (Collection Integer)) -maxBlockExecutionUnits = ParamList @Integer 21 "maxBlockExecutionUnits" - [ Param 0 "memory" 62_000_000 - [ ("MBEU-M-01","maxBlockExecutionUnits[memory] must not exceed 120,000,000 units") `MustNotBe` NG 120_000_000 - , ("MBEU-M-02","maxBlockExecutionUnits[memory] must not be negative") `MustNotBe` NL 0 - ] `WithinDomain` (-100,200_000_000) - , Param 1 "steps" 20_000_000_000 - [ ("MBEU-S-01","maxBlockExecutionUnits[steps] must not exceed 40,000,000,000 (40Bn) units") `MustNotBe` NG 40_000_000_000 - , ("MBEU-S-02","maxBlockExecutionUnits[steps] must not be negative") `MustNotBe` NL 0 - ] `WithinDomain` (-100,50_000_000_000) - ] +maxBlockExecutionUnits = + ParamList @Integer + 21 + "maxBlockExecutionUnits" + [ Param + 0 + "memory" + 62_000_000 + [ ("MBEU-M-01", "maxBlockExecutionUnits[memory] must not exceed 120,000,000 units") `MustNotBe` NG 120_000_000 + , ("MBEU-M-02", "maxBlockExecutionUnits[memory] must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-100, 200_000_000) + , Param + 1 + "steps" + 20_000_000_000 + [ ("MBEU-S-01", "maxBlockExecutionUnits[steps] must not exceed 40,000,000,000 (40Bn) units") `MustNotBe` NG 40_000_000_000 + , ("MBEU-S-02", "maxBlockExecutionUnits[steps] must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-100, 50_000_000_000) + ] maxTxExecutionUnits :: Guardrail (Param (Collection Integer)) -maxTxExecutionUnits = ParamList 20 "maxTxExecutionUnits" - [ Param 0 "mem" 20_000_000 - [ ("MTEU-M-01","maxTxExecutionUnits[memory] must not exceed 40,000,000 units") `MustNotBe` NG 40_000_000 - , ("MTEU-M-02","maxTxExecutionUnits[memory] must not be negative") `MustNotBe` NL 0 - ] `WithinDomain` (-100,50_000_000) - , Param 1 "steps" 10_000_000_000 - [ ("MTEU-S-01","maxTxExecutionUnits[steps] must not exceed 15,000,000,000 (15Bn) units") `MustNotBe` NG 15_000_000_000 - , ("MTEU-S-02","maxTxExecutionUnits[steps] must not be negative") `MustNotBe` NL 0 - ] `WithinDomain` (-100,16_000_000_000) - ] +maxTxExecutionUnits = + ParamList + 20 + "maxTxExecutionUnits" + [ Param + 0 + "mem" + 20_000_000 + [ ("MTEU-M-01", "maxTxExecutionUnits[memory] must not exceed 40,000,000 units") `MustNotBe` NG 40_000_000 + , ("MTEU-M-02", "maxTxExecutionUnits[memory] must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-100, 50_000_000) + , Param + 1 + "steps" + 10_000_000_000 + [ ("MTEU-S-01", "maxTxExecutionUnits[steps] must not exceed 15,000,000,000 (15Bn) units") `MustNotBe` NG 15_000_000_000 + , ("MTEU-S-02", "maxTxExecutionUnits[steps] must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-100, 16_000_000_000) + ] maxBlockHeaderSize :: Guardrail (Param (Scalar Integer)) -maxBlockHeaderSize = Param @Integer 4 "maxBlockHeaderSize" 1_100 - [ ("MBHS-01","maxBlockHeaderSize must not exceed 5,000 Bytes") `MustNotBe` NG 5_000 - , ("MBHS-02","maxBlockHeaderSize must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,10_000) +maxBlockHeaderSize = + Param @Integer + 4 + "maxBlockHeaderSize" + 1_100 + [ ("MBHS-01", "maxBlockHeaderSize must not exceed 5,000 Bytes") `MustNotBe` NG 5_000 + , ("MBHS-02", "maxBlockHeaderSize must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 10_000) stakePoolTargetNum :: Guardrail (Param (Scalar Integer)) -stakePoolTargetNum = Param @Integer 8 "stakePoolTargetNum" 500 - [ ("SPTN-01","stakePoolTargetNum must not be lower than 250") `MustNotBe` NL 250 - , ("SPTN-02","stakePoolTargetNum must not exceed 2,000") `MustNotBe` NG 2_000 - , ("SPTN-03","stakePoolTargetNum must not be negative") `MustNotBe` NL 0 - , ("SPTN-04", "stakePoolTargetNum must not be zero") `MustNotBe` NEQ 0 - ] - `WithinDomain` (-5_000,10_000) +stakePoolTargetNum = + Param @Integer + 8 + "stakePoolTargetNum" + 500 + [ ("SPTN-01", "stakePoolTargetNum must not be lower than 250") `MustNotBe` NL 250 + , ("SPTN-02", "stakePoolTargetNum must not exceed 2,000") `MustNotBe` NG 2_000 + , ("SPTN-03", "stakePoolTargetNum must not be negative") `MustNotBe` NL 0 + , ("SPTN-04", "stakePoolTargetNum must not be zero") `MustNotBe` NEQ 0 + ] + `WithinDomain` (-5_000, 10_000) poolPledgeInfluence :: Guardrail (Param (Scalar Rational)) -poolPledgeInfluence = Param @Rational 9 "poolPledgeInfluence" 0.3 - [ ("PPI-01","poolPledgeInfluence must not be lower than 0.1") `MustNotBe` NL (1 % 10) - , ("PPI-02","poolPledgeInfluence must not exceed 1.0") `MustNotBe` NG (10 % 10) - , ("PPI-03","poolPledgeInfluence must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-1.0,2.0) +poolPledgeInfluence = + Param @Rational + 9 + "poolPledgeInfluence" + 0.3 + [ ("PPI-01", "poolPledgeInfluence must not be lower than 0.1") `MustNotBe` NL (1 % 10) + , ("PPI-02", "poolPledgeInfluence must not exceed 1.0") `MustNotBe` NG (10 % 10) + , ("PPI-03", "poolPledgeInfluence must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-1.0, 2.0) poolRetireMaxEpoch :: Guardrail (Param (Scalar Integer)) -poolRetireMaxEpoch = Param @Integer 7 "poolRetireMaxEpoch" 18 - [ ("PRME-01","poolRetireMaxEpoch must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,10_000) - +poolRetireMaxEpoch = + Param @Integer + 7 + "poolRetireMaxEpoch" + 18 + [ ("PRME-01", "poolRetireMaxEpoch must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 10_000) collateralPercentage :: Guardrail (Param (Scalar Integer)) -collateralPercentage = Param @Integer 23 "collateralPercentage" 150 - [ ("CP-01","collateralPercentage must not be lower than 100") `MustNotBe` NL 100 - , ("CP-02","collateralPercentage must not exceed 200") `MustNotBe` NG 200 - , ("CP-03","collateralPercentage must not be negative") `MustNotBe` NL 0 - , ("CP-04","collateralPercentage must not be set to 0") `MustNotBe` NEQ 0 - ] - `WithinDomain` (-100,300) +collateralPercentage = + Param @Integer + 23 + "collateralPercentage" + 150 + [ ("CP-01", "collateralPercentage must not be lower than 100") `MustNotBe` NL 100 + , ("CP-02", "collateralPercentage must not exceed 200") `MustNotBe` NG 200 + , ("CP-03", "collateralPercentage must not be negative") `MustNotBe` NL 0 + , ("CP-04", "collateralPercentage must not be set to 0") `MustNotBe` NEQ 0 + ] + `WithinDomain` (-100, 300) maxCollateralInputs :: Guardrail (Param (Scalar Integer)) -maxCollateralInputs = Param @Integer 24 "maxCollateralInputs" 3 - [ ("MCI-01","maxCollateralInputs must not be lower than 1") `MustNotBe` NL 1 - ] - `WithinDomain` (-10,100) +maxCollateralInputs = + Param @Integer + 24 + "maxCollateralInputs" + 3 + [ ("MCI-01", "maxCollateralInputs must not be lower than 1") `MustNotBe` NL 1 + ] + `WithinDomain` (-10, 100) maxValueSize :: Guardrail (Param (Scalar Integer)) -maxValueSize = Param @Integer 22 "maxValueSize" 5_000 - [ ("MVS-01","maxValueSize must not exceed 12,288 Bytes (12KB)") `MustNotBe` NG 12_288 - , ("MVS-02","maxValueSize must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-5_000,20_000) +maxValueSize = + Param @Integer + 22 + "maxValueSize" + 5_000 + [ ("MVS-01", "maxValueSize must not exceed 12,288 Bytes (12KB)") `MustNotBe` NG 12_288 + , ("MVS-02", "maxValueSize must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-5_000, 20_000) govDeposit :: Guardrail (Param (Scalar Integer)) -govDeposit = Param @Integer 30 "govDeposit" 1_000_000 - [ ("GD-01", "govDeposit must not be negative" ) `MustNotBe` NL 0 - , ("GD-02", "govDeposit must not be lower than 1,000,000 (1 ada)") `MustNotBe` NL 1_000_000 - , ("GD-03", "govDeposit must not exceed 10,000,000,000,000 (10 Million ada)") `MustNotBe` NG 10_000_000_000_000 - ] - `WithinDomain` (-5_000,11_000_000_000_000) - +govDeposit = + Param @Integer + 30 + "govDeposit" + 1_000_000 + [ ("GD-01", "govDeposit must not be negative") `MustNotBe` NL 0 + , ("GD-02", "govDeposit must not be lower than 1,000,000 (1 ada)") `MustNotBe` NL 1_000_000 + , ("GD-03", "govDeposit must not exceed 10,000,000,000,000 (10 Million ada)") `MustNotBe` NG 10_000_000_000_000 + ] + `WithinDomain` (-5_000, 11_000_000_000_000) dRepDeposit :: Guardrail (Param (Scalar Integer)) -dRepDeposit = Param @Integer 31 "dRepDeposit" 1_000_000 - [ ("DRD-01", "dRepDeposit must not be negative" ) `MustNotBe` NL 0 - , ("DRD-02", "dRepDeposit must not be lower than 1,000,000 (1 ada)") `MustNotBe` NL 1_000_000 - , ("DRD-03", "dRepDeposit must be no more than 100,000,000,000 (100,000 ada)") `MustNotBe` NG 100_000_000_000 - ] - `WithinDomain` (-5_000,110_000_000_000) +dRepDeposit = + Param @Integer + 31 + "dRepDeposit" + 1_000_000 + [ ("DRD-01", "dRepDeposit must not be negative") `MustNotBe` NL 0 + , ("DRD-02", "dRepDeposit must not be lower than 1,000,000 (1 ada)") `MustNotBe` NL 1_000_000 + , ("DRD-03", "dRepDeposit must be no more than 100,000,000,000 (100,000 ada)") `MustNotBe` NG 100_000_000_000 + ] + `WithinDomain` (-5_000, 110_000_000_000) dRepActivity :: Guardrail (Param (Scalar Integer)) -dRepActivity = Param @Integer 32 "dRepActivity" 25 - [ ("DRA-01", "dRepActivity must not be lower than 13 epochs (2 months)") `MustNotBe` NL 13 - , ("DRA-02", "dRepActivity must not exceed 37 epochs (6 months)") `MustNotBe` NG 37 - , ("DRA-03", "dRepActivity must not be negative") `MustNotBe` NL 0 - ] - `WithinDomain` (-10, 100) +dRepActivity = + Param @Integer + 32 + "dRepActivity" + 25 + [ ("DRA-01", "dRepActivity must not be lower than 13 epochs (2 months)") `MustNotBe` NL 13 + , ("DRA-02", "dRepActivity must not exceed 37 epochs (6 months)") `MustNotBe` NG 37 + , ("DRA-03", "dRepActivity must not be negative") `MustNotBe` NL 0 + ] + `WithinDomain` (-10, 100) poolVotingThresholds :: Guardrail (Param (Collection Rational)) -poolVotingThresholds = ParamList @Rational 25 "poolVotingThresholds" - [ Param 0 "motionNoConfidence" (2 % 3) - [ ("VT-GEN-01" ,"All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-NC-01", "No confidence action thresholds must be in the range 51%-75%") - `MustNotBe` NL (51 % 100) - , ("VT-NC-01b", "No confidence action thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) - ] `WithinDomain` (0,1.5) - - , Param 1 "committeeNormal" (2 % 3) - [ ("VT-GEN-01" ,"All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-CC-01","Update Constitutional Committee action thresholds must be in the range 51%-90%") - `MustNotBe` NL (51 % 100) - , ("VT-CC-01b","Update Constitutional Committee action thresholds must be in the range 51%-90%") - `MustNotBe` NG (90 % 100) - ] `WithinDomain` (0,1.5) - - , Param 2 "committeeNoConfidence" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-CC-01","Update Constitutional Committee action thresholds must be in the range 51%-90%") - `MustNotBe` NL (51 % 100) - , ("VT-CC-01b","Update Constitutional Committee action thresholds must be in the range 51%-90%") - `MustNotBe` NG (90 % 100) - ] `WithinDomain` (0,1.5) - - , Param 3 "hardForkInitiation" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-HF-01", "Hard fork action thresholds must be in the range 51%-80%") - `MustNotBe` NL (51 % 100) - , ("VT-HF-01b", "Hard fork action thresholds must be in the range 51%-80%") - `MustNotBe` NG (80 % 100) - ] `WithinDomain` (0,1.5) - - , Param 4 "ppSecurityGroup" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - ] `WithinDomain` (0,1.5) - ] +poolVotingThresholds = + ParamList @Rational + 25 + "poolVotingThresholds" + [ Param + 0 + "motionNoConfidence" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-NC-01", "No confidence action thresholds must be in the range 51%-75%") + `MustNotBe` NL (51 % 100) + , ("VT-NC-01b", "No confidence action thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 1 + "committeeNormal" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-CC-01", "Update Constitutional Committee action thresholds must be in the range 51%-90%") + `MustNotBe` NL (51 % 100) + , ("VT-CC-01b", "Update Constitutional Committee action thresholds must be in the range 51%-90%") + `MustNotBe` NG (90 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 2 + "committeeNoConfidence" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-CC-01", "Update Constitutional Committee action thresholds must be in the range 51%-90%") + `MustNotBe` NL (51 % 100) + , ("VT-CC-01b", "Update Constitutional Committee action thresholds must be in the range 51%-90%") + `MustNotBe` NG (90 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 3 + "hardForkInitiation" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-HF-01", "Hard fork action thresholds must be in the range 51%-80%") + `MustNotBe` NL (51 % 100) + , ("VT-HF-01b", "Hard fork action thresholds must be in the range 51%-80%") + `MustNotBe` NG (80 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 4 + "ppSecurityGroup" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + ] + `WithinDomain` (0, 1.5) + ] dRepVotingThresholds :: Guardrail (Param (Collection Rational)) -dRepVotingThresholds = ParamList @Rational 26 "dRepVotingThresholds" - [ Param 0 "motionNoConfidence" (2 % 3) - [ ("VT-GEN-01" ,"All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-NC-01", "No confidence action thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) - , ("VT-NC-01b", "No confidence action thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) - ] `WithinDomain` (0,1.5) - - , Param 1 "committeeNormal" (2 % 3) - [ ("VT-GEN-01" ,"All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-CC-01","Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NL (51 % 100) - , ("VT-CC-01b","Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NG (90 % 100) - ] `WithinDomain` (0,1.5) - - , Param 2 "committeeNoConfidence" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-CC-01","Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NL (51 % 100) - , ("VT-CC-01b","Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NG (90 % 100) - ] `WithinDomain` (0,1.5) - - , Param 3 "updateConstitution" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-CON-01", "New Constitution or guardrails script action thresholds must be in the range 65%-90%") `MustNotBe` NL (65 % 100) - , ("VT-CON-01b", "New Constitution or guardrails script action thresholds must be in the range 65%-90%") `MustNotBe` NG (90 % 100) - ] `WithinDomain` (0,1.5) - - , Param 4 "hardForkInitiation" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-HF-01", "Hard fork action thresholds must be in the range 51%-80%") `MustNotBe` NL (51 % 100) - , ("VT-HF-01b", "Hard fork action thresholds must be in the range 51%-80%") `MustNotBe` NG (80 % 100) - ] `WithinDomain` (0,1.5) - - , Param 5 "ppNetworkGroup" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-GEN-02", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) - , ("VT-GEN-02b", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) - ] `WithinDomain` (0,1.5) - - , Param 6 "ppEconomicGroup" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-GEN-02", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) - , ("VT-GEN-02b", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) - ] `WithinDomain` (0,1.5) - - , Param 7 "ppTechnicalGroup" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-GEN-02", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) - , ("VT-GEN-02b", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) - ] `WithinDomain` (0,1.5) - - , Param 8 "ppGovernanceGroup" (4 % 5) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - , ("VT-GOV-01", "Governance parameter thresholds must be in the range 75%-90%") `MustNotBe` NL (75 % 100) - , ("VT-GOV-01b", "Governance parameter thresholds must be in the range 75%-90%") `MustNotBe` NG (90 % 100) - ] `WithinDomain` (0,1.5) - - , Param 9 "treasuryWithdrawal" (2 % 3) - [ ("VT-GEN-01","All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) - , ("VT-GEN-01b","All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) - ] `WithinDomain` (0,1.5) - ] +dRepVotingThresholds = + ParamList @Rational + 26 + "dRepVotingThresholds" + [ Param + 0 + "motionNoConfidence" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-NC-01", "No confidence action thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) + , ("VT-NC-01b", "No confidence action thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 1 + "committeeNormal" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-CC-01", "Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NL (51 % 100) + , ("VT-CC-01b", "Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NG (90 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 2 + "committeeNoConfidence" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-CC-01", "Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NL (51 % 100) + , ("VT-CC-01b", "Update Constitutional Committee action thresholds must be in the range 51%-90%") `MustNotBe` NG (90 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 3 + "updateConstitution" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-CON-01", "New Constitution or guardrails script action thresholds must be in the range 65%-90%") `MustNotBe` NL (65 % 100) + , ("VT-CON-01b", "New Constitution or guardrails script action thresholds must be in the range 65%-90%") `MustNotBe` NG (90 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 4 + "hardForkInitiation" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-HF-01", "Hard fork action thresholds must be in the range 51%-80%") `MustNotBe` NL (51 % 100) + , ("VT-HF-01b", "Hard fork action thresholds must be in the range 51%-80%") `MustNotBe` NG (80 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 5 + "ppNetworkGroup" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-GEN-02", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) + , ("VT-GEN-02b", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 6 + "ppEconomicGroup" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-GEN-02", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) + , ("VT-GEN-02b", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 7 + "ppTechnicalGroup" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-GEN-02", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NL (51 % 100) + , ("VT-GEN-02b", "Economic, network, and technical parameters thresholds must be in the range 51%-75%") `MustNotBe` NG (75 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 8 + "ppGovernanceGroup" + (4 % 5) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + , ("VT-GOV-01", "Governance parameter thresholds must be in the range 75%-90%") `MustNotBe` NL (75 % 100) + , ("VT-GOV-01b", "Governance parameter thresholds must be in the range 75%-90%") `MustNotBe` NG (90 % 100) + ] + `WithinDomain` (0, 1.5) + , Param + 9 + "treasuryWithdrawal" + (2 % 3) + [ ("VT-GEN-01", "All thresholds must be in the range 50%-100%") `MustNotBe` NL (1 % 2) + , ("VT-GEN-01b", "All thresholds must be in the range 50%-100%") `MustNotBe` NG (1 % 1) + ] + `WithinDomain` (0, 1.5) + ] govActionLifetime :: Guardrail (Param (Scalar Integer)) -govActionLifetime = Param @Integer 29 "govActionLifetime" 5 - [ ("GAL-01", "govActionLifetime must not be lower than 1 epoch (5 days)") `MustNotBe` NL 1 - , ("GAL-02", "govActionLifetime must not be greater than 15 epochs (75 days)") `MustNotBe` NG 15 - ] - `WithinDomain` (-10, 100) - +govActionLifetime = + Param @Integer + 29 + "govActionLifetime" + 5 + [ ("GAL-01", "govActionLifetime must not be lower than 1 epoch (5 days)") `MustNotBe` NL 1 + , ("GAL-02", "govActionLifetime must not be greater than 15 epochs (75 days)") `MustNotBe` NG 15 + ] + `WithinDomain` (-10, 100) committeeMaxTermLimit :: Guardrail (Param (Scalar Integer)) -committeeMaxTermLimit = Param @Integer 28 "committeeMaxTermLimit" 50 - [ ("CMTL-01", "committeeMaxTermLimit must not be zero") `MustNotBe` NEQ 0 - , ("CMTL-02", "committeeMaxTermLimit must not be negative") `MustNotBe` NL 0 - , ("CMTL-03", "committeeMaxTermLimit must not be lower than 18 epochs (90 days, or approximately 3 months)") `MustNotBe` NL 18 - , ("CMTL-04", "committeeMaxTermLimit must not exceed 293 epochs (approximately 4 years)") `MustNotBe` NG 293 - ] - `WithinDomain` (-10, 400) +committeeMaxTermLimit = + Param @Integer + 28 + "committeeMaxTermLimit" + 50 + [ ("CMTL-01", "committeeMaxTermLimit must not be zero") `MustNotBe` NEQ 0 + , ("CMTL-02", "committeeMaxTermLimit must not be negative") `MustNotBe` NL 0 + , ("CMTL-03", "committeeMaxTermLimit must not be lower than 18 epochs (90 days, or approximately 3 months)") `MustNotBe` NL 18 + , ("CMTL-04", "committeeMaxTermLimit must not exceed 293 epochs (approximately 4 years)") `MustNotBe` NG 293 + ] + `WithinDomain` (-10, 400) committeeMinSize :: Guardrail (Param (Scalar Integer)) -committeeMinSize = Param @Integer 27 "committeeMinSize" 3 - [ ("CMS-01", "committeeMinSize must not be negative") `MustNotBe` NL 0 - , ("CMS-02", "committeeMinSize must not be lower than 3") `MustNotBe` NL 3 - , ("CMS-03", "committeeMinSize must not exceed 10") `MustNotBe` NG 10 - ] - `WithinDomain` (-10, 50) +committeeMinSize = + Param @Integer + 27 + "committeeMinSize" + 3 + [ ("CMS-01", "committeeMinSize must not be negative") `MustNotBe` NL 0 + , ("CMS-02", "committeeMinSize must not be lower than 3") `MustNotBe` NL 3 + , ("CMS-03", "committeeMinSize must not exceed 10") `MustNotBe` NG 10 + ] + `WithinDomain` (-10, 50) gStr :: [Char] -> [Char] -> [Char] gStr g str = g ++ ": " ++ str -------------------------------------------------------------------------------- + -- | property test for each guardrail -getGuardrailTestTree' :: (Num a,HasRange a,Ord a, ToJSON a , Show a, ToData a ) - => (a,a) - -> ParamId - -> (a -> ParamValues) - -> Guardrail (Assertion a) - -> TestTreeWithTestState -getGuardrailTestTree' domain' paramIx toData' assertion@(MustNotBe (g,str) _) = +getGuardrailTestTree' :: + (Num a, HasRange a, Ord a, ToJSON a, Show a, ToData a) => + (a, a) -> + ParamId -> + (a -> ParamValues) -> + Guardrail (Assertion a) -> + TestTreeWithTestState +getGuardrailTestTree' domain' paramIx toData' assertion@(MustNotBe (g, str) _) = testProperty' (gStr g str) $ getGuardrailProperty domain' toData' paramIx assertion getGuardrailTestTree' domain' paramIx toData' g@(Once guardrail) = testProperty' (getStr guardrail) $ getGuardrailProperty domain' toData' paramIx g where - getStr :: Guardrail (Assertion a) -> String - getStr (MustNotBe (g',str) _) = g' ++ ": " ++ str - getStr (Once guardrail') = getStr guardrail' - -getGuardrailProperty :: (Num a,HasRange a,Ord a, ToJSON a , Show a, ToData a ) - => (a,a) - -> (a -> ParamValues) - -> ParamId - -> Guardrail (Assertion a) - -> PropertyWithTestState -getGuardrailProperty domain' toData' paramIx (MustNotBe _ range) = + getStr :: Guardrail (Assertion a) -> String + getStr (MustNotBe (g', str) _) = g' ++ ": " ++ str + getStr (Once guardrail') = getStr guardrail' + +getGuardrailProperty :: + (Num a, HasRange a, Ord a, ToJSON a, Show a, ToData a) => + (a, a) -> + (a -> ParamValues) -> + ParamId -> + Guardrail (Assertion a) -> + PropertyWithTestState +getGuardrailProperty domain' toData' paramIx (MustNotBe _ range) = oneParamProp' paramIx toData' (I.rangeGen' domain' range) (not . fst) - getGuardrailProperty domain' toData' paramIx (Once guardrail) = once . getGuardrailProperty domain' toData' paramIx guardrail -getGuardrailTestGroup :: forall a. ( Num a,HasRange a,Ord a, ToJSON a , Show a, ToData a , HasDomain a ) - => Guardrail (Param (Scalar a)) - -> TestTreeWithTestState +getGuardrailTestGroup :: + forall a. + (Num a, HasRange a, Ord a, ToJSON a, Show a, ToData a, HasDomain a) => + Guardrail (Param (Scalar a)) -> + TestTreeWithTestState getGuardrailTestGroup gr = getGuardrailTestGroup' (oneParamChange $ getParamIx gr) (\ix _ -> show ix) gr -getGuardrailTestGroup' :: forall a. ( Num a,HasRange a,Ord a, ToJSON a , Show a, ToData a , HasDomain a ) - => (a -> ParamValues) - -> (Integer -> String -> String) - -> Guardrail (Param (Scalar a)) - -> TestTreeWithTestState +getGuardrailTestGroup' :: + forall a. + (Num a, HasRange a, Ord a, ToJSON a, Show a, ToData a, HasDomain a) => + (a -> ParamValues) -> + (Integer -> String -> String) -> + Guardrail (Param (Scalar a)) -> + TestTreeWithTestState getGuardrailTestGroup' toData' getParamId (Param paramIx paramName _ assertions) = testGroup' ("Guardrails for " ++ show paramIx) $ map (getGuardrailTestTree' domain (getParamId paramIx paramName) toData') assertions getGuardrailTestGroup' toData' getParamId (WithinDomain group domain') = propWithDomain domain' group where - propWithDomain :: (a,a) - -> Guardrail (Param (Scalar a)) - -> TestTreeWithTestState - propWithDomain _ (WithinDomain group' domain'') = propWithDomain domain'' group' - propWithDomain domain'' (Param paramIx paramName _ assertions) = - testGroup' ("Guardrails for " ++ show paramIx) $ - map (getGuardrailTestTree' domain'' (getParamId paramIx paramName) toData') assertions + propWithDomain :: + (a, a) -> + Guardrail (Param (Scalar a)) -> + TestTreeWithTestState + propWithDomain _ (WithinDomain group' domain'') = propWithDomain domain'' group' + propWithDomain domain'' (Param paramIx paramName _ assertions) = + testGroup' ("Guardrails for " ++ show paramIx) $ + map (getGuardrailTestTree' domain'' (getParamId paramIx paramName) toData') assertions -------------------------------------------------------------------------------- --- | Combine constraints and negate one of each - -getAssertionRangeAndStr :: Guardrail (Assertion a) -> (String,RangeConstraint a) -getAssertionRangeAndStr (MustNotBe (g,_) range) = (g,range) -getAssertionRangeAndStr (Once guardrail) = getAssertionRangeAndStr guardrail - -negateOneConstraint :: [(String,RangeConstraint a)] - -> Integer - -> (String,[RangeConstraint a]) -negateOneConstraint xs ix = foldl' f ("",[]) $ zip xs [0..] +-- | Combine constraints and negate one of each +getAssertionRangeAndStr :: Guardrail (Assertion a) -> (String, RangeConstraint a) +getAssertionRangeAndStr (MustNotBe (g, _) range) = (g, range) +getAssertionRangeAndStr (Once guardrail) = getAssertionRangeAndStr guardrail + +negateOneConstraint :: + [(String, RangeConstraint a)] -> + Integer -> + (String, [RangeConstraint a]) +negateOneConstraint xs ix = foldl' f ("", []) $ zip xs [0 ..] where - f :: (String, [RangeConstraint a]) - -> ((String, RangeConstraint a), Integer) - -> (String, [RangeConstraint a]) - f (g,constraints) ((g',constraint),i) + f :: + (String, [RangeConstraint a]) -> + ((String, RangeConstraint a), Integer) -> + (String, [RangeConstraint a]) + f (g, constraints) ((g', constraint), i) | ix == i = (prefix ++ "!" ++ g', negateRange constraint ++ constraints) - | otherwise = (prefix ++ g',constraint:constraints) - where prefix = if null g then "" else g ++ " & " + | otherwise = (prefix ++ g', constraint : constraints) + where + prefix = if null g then "" else g ++ " & " -allNegationCases :: [(String,RangeConstraint a)] -> [(String,[RangeConstraint a])] -allNegationCases xs = map (negateOneConstraint xs) - [0..(toInteger $ length xs - 1)] +allNegationCases :: [(String, RangeConstraint a)] -> [(String, [RangeConstraint a])] +allNegationCases xs = + map + (negateOneConstraint xs) + [0 .. (toInteger $ length xs - 1)] allPositive :: [(String, RangeConstraint a)] -> (String, [RangeConstraint a]) allPositive xs = negateOneConstraint xs (-1) @@ -535,221 +727,255 @@ ignoreTestBecauseIf :: Bool -> String -> TestTreeWithTestState -> TestTreeWithTe ignoreTestBecauseIf cond' str tst = if cond' then ignoreTestBecause str . tst else tst -expectTo :: (Num a,HasRange a,Ord a, ToJSON a , Show a, ToData a) - => Bool - -> (a,a) - -> (a -> ParamValues) - -> ParamId - -> (String, [RangeConstraint a]) - -> TestTreeWithTestState -expectTo expectToSucceed domain' toData' paramId (g,constraints) ref = +expectTo :: + (Num a, HasRange a, Ord a, ToJSON a, Show a, ToData a) => + Bool -> + (a, a) -> + (a -> ParamValues) -> + ParamId -> + (String, [RangeConstraint a]) -> + TestTreeWithTestState +expectTo expectToSucceed domain' toData' paramId (g, constraints) ref = case gapsWithinRange domain' constraints of [] -> ignoreTestBecause "No domain to choose values from" $ testProperty g True xs -> let gen = generateFromIntervals xs - testName = g ++ " should " - ++ (if expectToSucceed then "succeed" else "fail") - ++ " in range " ++ showIntervals xs - in testProperty testName $ oneParamProp' paramId toData' gen ((== expectToSucceed) . fst) ref - -getCombinedConstraintTest :: forall a. - ( Num a, HasRange a, Ord a, ToJSON a , Show a, ToData a , HasDomain a ) - => Guardrail (Param (Scalar a)) - -> TestTreeWithTestState + testName = + g + ++ " should " + ++ (if expectToSucceed then "succeed" else "fail") + ++ " in range " + ++ showIntervals xs + in testProperty testName $ oneParamProp' paramId toData' gen ((== expectToSucceed) . fst) ref + +getCombinedConstraintTest :: + forall a. + (Num a, HasRange a, Ord a, ToJSON a, Show a, ToData a, HasDomain a) => + Guardrail (Param (Scalar a)) -> + TestTreeWithTestState getCombinedConstraintTest group = getCombinedConstraintTest' toData' (\ix _ -> show ix) group where - toData' = oneParamChange (getParamIx group) - -getCombinedConstraintTest' :: forall a. - ( Num a, HasRange a, Ord a, ToJSON a , Show a, ToData a , HasDomain a ) - => (a -> ParamValues) - -> (Integer -> String -> String) - -> Guardrail (Param (Scalar a)) - -> TestTreeWithTestState + toData' = oneParamChange (getParamIx group) + +getCombinedConstraintTest' :: + forall a. + (Num a, HasRange a, Ord a, ToJSON a, Show a, ToData a, HasDomain a) => + (a -> ParamValues) -> + (Integer -> String -> String) -> + Guardrail (Param (Scalar a)) -> + TestTreeWithTestState getCombinedConstraintTest' toData' getParamId (WithinDomain group domain') = propWithDomain domain' group where - propWithDomain :: (a,a) - -> Guardrail (Param (Scalar a)) - -> TestTreeWithTestState - propWithDomain _ (WithinDomain group' domain'') = propWithDomain domain'' group' - propWithDomain domain'' (Param paramIx paramName _ assertions) = - let paramId = getParamId paramIx paramName - in testGroup' ("Combined Guardrails for " ++ show paramIx) $ - -- first all positive cases - expectTo succeed' domain'' toData' paramId (allPositive ranges) - -- then all negation cases - : map (expectTo fail' domain'' toData' paramId) allNegationCases' - where - ranges = map getAssertionRangeAndStr assertions - allNegationCases' = allNegationCases ranges - + propWithDomain :: + (a, a) -> + Guardrail (Param (Scalar a)) -> + TestTreeWithTestState + propWithDomain _ (WithinDomain group' domain'') = propWithDomain domain'' group' + propWithDomain domain'' (Param paramIx paramName _ assertions) = + let paramId = getParamId paramIx paramName + in testGroup' ("Combined Guardrails for " ++ show paramIx) $ + -- first all positive cases + expectTo succeed' domain'' toData' paramId (allPositive ranges) + -- then all negation cases + : map (expectTo fail' domain'' toData' paramId) allNegationCases' + where + ranges = map getAssertionRangeAndStr assertions + allNegationCases' = allNegationCases ranges getCombinedConstraintTest' toData' getParamId (Param paramIx name defaultValue assertions) = getCombinedConstraintTest' toData' getParamId (WithinDomain (Param paramIx name defaultValue assertions) domain) - fail', succeed' :: Bool fail' = False succeed' = True -getAllRangeConstraints :: Guardrail (Param (Scalar a)) -> [(String,RangeConstraint a)] -getAllRangeConstraints (WithinDomain group _) = getAllRangeConstraints group +getAllRangeConstraints :: Guardrail (Param (Scalar a)) -> [(String, RangeConstraint a)] +getAllRangeConstraints (WithinDomain group _) = getAllRangeConstraints group getAllRangeConstraints (Param _ _ _ assertions) = map getAssertionRangeAndStr assertions -getDomain :: HasDomain a => Guardrail (Param (Scalar a)) -> (a,a) +getDomain :: HasDomain a => Guardrail (Param (Scalar a)) -> (a, a) getDomain (WithinDomain _ domain') = domain' -getDomain (Param{}) = domain +getDomain (Param {}) = domain class IntervalEnum a where boundaryPred :: Boundary a -> a boundarySucc :: Boundary a -> a - instance IntervalEnum Integer where boundaryPred (Closed a) = a - 1 - boundaryPred (Open a) = a + boundaryPred (Open a) = a boundarySucc (Closed a) = a + 1 - boundarySucc (Open a) = a + boundarySucc (Open a) = a instance a ~ Integer => IntervalEnum (Ratio a) where boundaryPred (Closed a) = fst $ findTightestRationalBounds a 64 - boundaryPred (Open a) = a + boundaryPred (Open a) = a boundarySucc (Closed a) = snd $ findTightestRationalBounds a 64 - boundarySucc (Open a) = a + boundarySucc (Open a) = a -boundaries :: (IntervalEnum a,HasDomain a,Num a,Ord a) - => Guardrail (Param (Scalar a)) - -> (a, a) +boundaries :: + (IntervalEnum a, HasDomain a, Num a, Ord a) => + Guardrail (Param (Scalar a)) -> + (a, a) boundaries x = let - domain' = getDomain x - in boundaries' domain' x - -boundaries' :: (IntervalEnum a,Num a,Ord a) - => (a,a) - -> Guardrail (Param (Scalar a)) - -> (a, a) + domain' = getDomain x + in + boundaries' domain' x + +boundaries' :: + (IntervalEnum a, Num a, Ord a) => + (a, a) -> + Guardrail (Param (Scalar a)) -> + (a, a) boundaries' domain' x = let constraints = map snd $ getAllRangeConstraints x xs = gapsWithinRange domain' constraints - (start,end) = case xs of - [] -> error "No domain to choose values from" + (start, end) = case xs of + [] -> error "No domain to choose values from" xs' -> (fst $ head xs', snd $ last xs') - in case (start,end) of - (Open a,Open b) -> (boundaryPred $ Open a,boundarySucc $ Open b) - (Closed a,Open b) -> (a,boundarySucc $ Open b) - (Open a,Closed b) -> (boundaryPred $ Open a,b) - (Closed a,Closed b) -> (a,b) - - + in case (start, end) of + (Open a, Open b) -> (boundaryPred $ Open a, boundarySucc $ Open b) + (Closed a, Open b) -> (a, boundarySucc $ Open b) + (Open a, Closed b) -> (boundaryPred $ Open a, b) + (Closed a, Closed b) -> (a, b) getDefaultValue :: Guardrail (Param (Scalar a)) -> a -getDefaultValue (WithinDomain group _) = getDefaultValue group +getDefaultValue (WithinDomain group _) = getDefaultValue group getDefaultValue (Param _ _ defaultValue _) = defaultValue getParamIx :: Guardrail (Param a) -> ParamIx -getParamIx (WithinDomain group _) = getParamIx group -getParamIx (Param paramIx' _ _ _) = paramIx' +getParamIx (WithinDomain group _) = getParamIx group +getParamIx (Param paramIx' _ _ _) = paramIx' getParamIx (ParamList paramIx' _ _) = paramIx' ---getParamIx (ParamStructure paramIx' _ _) = paramIx' + +-- getParamIx (ParamStructure paramIx' _ _) = paramIx' getParamName :: Guardrail (Param (Scalar a)) -> String getParamName (WithinDomain group _) = getParamName group -getParamName (Param _ name _ _) = name +getParamName (Param _ name _ _) = name -paramRange :: (IntervalEnum a,ToData a,ToJSON a, Show a,HasRange a, HasDomain a,Num a,Ord a) - => Guardrail (Param (Scalar a)) - -> (ParamIx,ParamRange) +paramRange :: + (IntervalEnum a, ToData a, ToJSON a, Show a, HasRange a, HasDomain a, Num a, Ord a) => + Guardrail (Param (Scalar a)) -> + (ParamIx, ParamRange) paramRange a = - let (low,high) = boundaries a + let (low, high) = boundaries a domain' = getDomain a - range = MkParamRangeWithinDomain (low,high) domain' - in (getParamIx a,range) - + range = MkParamRangeWithinDomain (low, high) domain' + in (getParamIx a, range) -------------------------------------------------------------------------------- --- | test set -testSet :: forall a. - ( IntervalEnum a, ToJSON a, ToData a, Show a - , Num a, HasRange a, Ord a, HasDomain a - ) - => Guardrail (Param (Scalar a)) -> TestTreeWithTestState +-- | test set +testSet :: + forall a. + ( IntervalEnum a + , ToJSON a + , ToData a + , Show a + , Num a + , HasRange a + , Ord a + , HasDomain a + ) => + Guardrail (Param (Scalar a)) -> TestTreeWithTestState testSet guardRail = testSet' toData' (\ix _ -> show ix) guardRail where - toData' = oneParamChange $ getParamIx guardRail - -paramListTestSet :: forall a. - ( IntervalEnum a, ToJSON a, ToData a, Show a - , Num a, HasRange a, Ord a, HasDomain a - ) - => Guardrail (Param (Collection a)) -> TestTreeWithTestState + toData' = oneParamChange $ getParamIx guardRail + +paramListTestSet :: + forall a. + ( IntervalEnum a + , ToJSON a + , ToData a + , Show a + , Num a + , HasRange a + , Ord a + , HasDomain a + ) => + Guardrail (Param (Collection a)) -> TestTreeWithTestState paramListTestSet (ParamList paramIx name xs) = testGroup' name $ map testParam xs where - testParam :: Guardrail (Param (Scalar a)) -> TestTreeWithTestState - testParam gr = testSet' (toData' gr) getParamId gr + testParam :: Guardrail (Param (Scalar a)) -> TestTreeWithTestState + testParam gr = testSet' (toData' gr) getParamId gr - toData' :: Guardrail (Param (Scalar a)) -> a -> ParamValues - toData' gr value = [(paramIx,toValues' gr value)] + toData' :: Guardrail (Param (Scalar a)) -> a -> ParamValues + toData' gr value = [(paramIx, toValues' gr value)] - getParamId :: Integer -> String -> String - getParamId = getSubParamId paramIx + getParamId :: Integer -> String -> String + getParamId = getSubParamId paramIx - toValues' :: Guardrail (Param (Scalar a)) -> a -> Printable - toValues' selectedGr val = - let selectedParamName = getParamName selectedGr - xs' = flip map xs $ \x -> - let paramName = getParamName x - in if selectedParamName == paramName - then val - else getDefaultValue x - in pack xs' + toValues' :: Guardrail (Param (Scalar a)) -> a -> Printable + toValues' selectedGr val = + let selectedParamName = getParamName selectedGr + xs' = flip map xs $ \x -> + let paramName = getParamName x + in if selectedParamName == paramName + then val + else getDefaultValue x + in pack xs' getSubParamId :: Integer -> Integer -> String -> String getSubParamId paramIx subParamIx _ = show paramIx ++ "[" ++ show subParamIx ++ "]" -testSet' :: forall a. - ( IntervalEnum a, ToJSON a - , ToData a, Show a - , Num a, Ord a, HasDomain a - , HasRange a - ) - => (a -> ParamValues) - -> (Integer -> String -> String) - -> Guardrail (Param (Scalar a)) -> TestTreeWithTestState -testSet' toData' getParamId guardRail = testGroup' paramName - [ testGroup' "In range tests" - [ testCase' ("At upper bound (" ++ show upper ++ ")") $ unitTestTemplatePositive' paramId toData' upper - , testCase' ("At lower bound (" ++ show lower ++ ")") $ unitTestTemplatePositive' paramId toData' lower - , testCase' ("Current (" ++ show defaultValue ++ ")") $ unitTestTemplatePositive' paramId toData' defaultValue - ] - , testGroup' "Outside bounds" - [ ignoreTestBecauseIf (succUpper > ed) "No upper limit" $ - testCase' ("Upper Bound (" ++ show succUpper ++ ")") $ unitTestTemplateNegative' paramId toData' succUpper - , ignoreTestBecauseIf (predLower < sd) "No lower limit" $ - testCase' ("Lower Bound (" ++ show predLower ++ ")") $ unitTestTemplateNegative' paramId toData' predLower - ] - , getCombinedConstraintTest' toData' getParamId guardRail - , getGuardrailTestGroup' toData' getParamId guardRail - , testGroup' "Property Based Tests" - [ testProperty' ("In range [" ++ show lower ++", " ++ show upper ++ "]") $ - pbtParamValidRange' paramId toData' (lower, upper) ] - ] +testSet' :: + forall a. + ( IntervalEnum a + , ToJSON a + , ToData a + , Show a + , Num a + , Ord a + , HasDomain a + , HasRange a + ) => + (a -> ParamValues) -> + (Integer -> String -> String) -> + Guardrail (Param (Scalar a)) -> + TestTreeWithTestState +testSet' toData' getParamId guardRail = + testGroup' + paramName + [ testGroup' + "In range tests" + [ testCase' ("At upper bound (" ++ show upper ++ ")") $ unitTestTemplatePositive' paramId toData' upper + , testCase' ("At lower bound (" ++ show lower ++ ")") $ unitTestTemplatePositive' paramId toData' lower + , testCase' ("Current (" ++ show defaultValue ++ ")") $ unitTestTemplatePositive' paramId toData' defaultValue + ] + , testGroup' + "Outside bounds" + [ ignoreTestBecauseIf (succUpper > ed) "No upper limit" $ + testCase' ("Upper Bound (" ++ show succUpper ++ ")") $ + unitTestTemplateNegative' paramId toData' succUpper + , ignoreTestBecauseIf (predLower < sd) "No lower limit" $ + testCase' ("Lower Bound (" ++ show predLower ++ ")") $ + unitTestTemplateNegative' paramId toData' predLower + ] + , getCombinedConstraintTest' toData' getParamId guardRail + , getGuardrailTestGroup' toData' getParamId guardRail + , testGroup' + "Property Based Tests" + [ testProperty' ("In range [" ++ show lower ++ ", " ++ show upper ++ "]") $ + pbtParamValidRange' paramId toData' (lower, upper) + ] + ] where - defaultValue = getDefaultValue guardRail - paramNo = getParamIx guardRail - paramName = getParamName guardRail - paramId = getParamId paramNo paramName - (lower, upper) = boundaries guardRail - (sd, ed) = getDomain guardRail - predLower = boundaryPred $ Closed lower - succUpper = boundarySucc $ Closed upper + defaultValue = getDefaultValue guardRail + paramNo = getParamIx guardRail + paramName = getParamName guardRail + paramId = getParamId paramNo paramName + (lower, upper) = boundaries guardRail + (sd, ed) = getDomain guardRail + predLower = boundaryPred $ Closed lower + succUpper = boundarySucc $ Closed upper data GenericParam = forall a. MkGenericParam (Guardrail (Param a)) @@ -786,18 +1012,19 @@ allParams = , MkGenericParam maxTxExecutionUnits ] -makeChangedParams :: (forall a. Guardrail (Param a) -> BuiltinData) - -> [GenericParam] - -> [(ParamKey, BuiltinData)] +makeChangedParams :: + (forall a. Guardrail (Param a) -> BuiltinData) -> + [GenericParam] -> + [(ParamKey, BuiltinData)] makeChangedParams getValue params = let changedParams = map (\(MkGenericParam gr) -> (getParamIx gr, getValue gr)) params - allCostModels':: (ParamKey, BuiltinData) = (18, toBuiltinData allCostModels) - in sortOn fst (allCostModels' : changedParams) + allCostModels' :: (ParamKey, BuiltinData) = (18, toBuiltinData allCostModels) + in sortOn fst (allCostModels' : changedParams) getMaxValue' :: Guardrail (Param a) -> BuiltinData -getMaxValue' gr@(Param{}) = +getMaxValue' gr@(Param {}) = let max' = 2 ^ (64 :: Int) - 1 - in toBuiltinData $ boundaryPred $ (Closed $ snd $ boundaries' (-max' ,max') gr) + in toBuiltinData $ boundaryPred $ (Closed $ snd $ boundaries' (-max', max') gr) getMaxValue' (WithinDomain gr _) = getMaxValue' gr getMaxValue' (ParamList _ _ xs) = toBuiltinData $ map getMaxValue' xs diff --git a/cardano-constitution/test/Helpers/Intervals.hs b/cardano-constitution/test/Helpers/Intervals.hs index cfee4364a74..181623a8493 100644 --- a/cardano-constitution/test/Helpers/Intervals.hs +++ b/cardano-constitution/test/Helpers/Intervals.hs @@ -1,24 +1,24 @@ - -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ViewPatterns #-} module Helpers.Intervals where + import Control.Monad (guard) import Data.List import Helpers.TestBuilders hiding (rangeGen) import Test.QuickCheck (Gen, oneof, suchThat) -------------------------------------------------------------------------------- + -- | Boundaries data Boundary a = Closed !a | Open !a - deriving stock (Show, Eq) + deriving stock (Show, Eq) boundaryValue :: Boundary a -> a boundaryValue (Closed a) = a -boundaryValue (Open a) = a - +boundaryValue (Open a) = a -instance (Num a,Ord a) => Ord (Boundary a) where +instance (Num a, Ord a) => Ord (Boundary a) where compare (boundaryValue -> a) (boundaryValue -> b) | a /= b = compare a b compare (Open a) (Closed _) = 0 `compare` a @@ -27,129 +27,125 @@ instance (Num a,Ord a) => Ord (Boundary a) where compare (Closed _) (Closed _) = EQ -------------------------------------------------------------------------------- --- | Ranges +-- | Ranges data RangeConstraint a = NL !a | NG !a | NLEQ !a | NGEQ !a | NEQ !a - deriving stock (Show, Eq) + deriving stock (Show, Eq) rangeValue :: RangeConstraint a -> a -rangeValue (NL a) = a -rangeValue (NG a) = a +rangeValue (NL a) = a +rangeValue (NG a) = a rangeValue (NLEQ a) = a rangeValue (NGEQ a) = a -rangeValue (NEQ a) = a - -type Interval a = (Boundary a ,Boundary a) +rangeValue (NEQ a) = a +type Interval a = (Boundary a, Boundary a) showInterval :: Show a => Interval a -> String -showInterval (Closed a,Closed b) = "[" <> show a <> ", " <> show b <> "]" -showInterval (Open a,Open b) = "(" <> show a <> ", " <> show b <> ")" -showInterval (Open a,Closed b) = "(" <> show a <> ", " <> show b <> "]" -showInterval (Closed a,Open b) = "[" <> show a <> ", " <> show b <> ")" +showInterval (Closed a, Closed b) = "[" <> show a <> ", " <> show b <> "]" +showInterval (Open a, Open b) = "(" <> show a <> ", " <> show b <> ")" +showInterval (Open a, Closed b) = "(" <> show a <> ", " <> show b <> "]" +showInterval (Closed a, Open b) = "[" <> show a <> ", " <> show b <> ")" -- | Show a list of intervals -- (a,b) | (c,d) | (e,f) | ... showIntervals :: Show a => [Interval a] -> String showIntervals = foldl' f "" where - f [] x = showInterval x - f acc x = acc <> " | " <> showInterval x + f [] x = showInterval x + f acc x = acc <> " | " <> showInterval x -rangeToInterval :: forall a. Ord a => (a,a) -> RangeConstraint a -> Interval a -rangeToInterval (min',max') a = +rangeToInterval :: forall a. Ord a => (a, a) -> RangeConstraint a -> Interval a +rangeToInterval (min', max') a = let value = rangeValue a - in if min' > value || max' < value - then error "rangeToInterval: value not in range" - else toInterval a + in if min' > value || max' < value + then error "rangeToInterval: value not in range" + else toInterval a where - toInterval :: RangeConstraint a -> Interval a - toInterval (NL v) = (Closed min', Open v) - toInterval (NG v) = (Open v, Closed max') - toInterval (NLEQ v) = (Closed min', Closed v) - toInterval (NGEQ v) = (Closed v, Closed max') - toInterval (NEQ v) = (Closed v, Closed v) + toInterval :: RangeConstraint a -> Interval a + toInterval (NL v) = (Closed min', Open v) + toInterval (NG v) = (Open v, Closed max') + toInterval (NLEQ v) = (Closed min', Closed v) + toInterval (NGEQ v) = (Closed v, Closed max') + toInterval (NEQ v) = (Closed v, Closed v) negateRange :: RangeConstraint a -> [RangeConstraint a] -negateRange (NL a) = [NGEQ a] -negateRange (NG a) = [NLEQ a] +negateRange (NL a) = [NGEQ a] +negateRange (NG a) = [NLEQ a] negateRange (NLEQ a) = [NG a] negateRange (NGEQ a) = [NL a] -negateRange (NEQ a) = [NL a, NG a] +negateRange (NEQ a) = [NL a, NG a] - -mergeIntervals :: (Num a,Ord a) => Interval a -> Interval a -> [Interval a] +mergeIntervals :: (Num a, Ord a) => Interval a -> Interval a -> [Interval a] -- if the b value is less than the c value, then the intervals -- do not overlap -mergeIntervals (a,b) (c,d) - | boundaryValue b < boundaryValue c = [(a,b),(c,d)] - +mergeIntervals (a, b) (c, d) + | boundaryValue b < boundaryValue c = [(a, b), (c, d)] -- if the b value is equal to the c value -- but both are open, then the intervals do not overlap -mergeIntervals (a,Open b) (Open c,d) - | b == c = [(a,Open b),(Open c,d)] - -mergeIntervals (a,b) (c,d) = [(min a c,max b d)] +mergeIntervals (a, Open b) (Open c, d) + | b == c = [(a, Open b), (Open c, d)] +mergeIntervals (a, b) (c, d) = [(min a c, max b d)] -mergeIntervalList :: forall a. (Num a,Ord a) => [Interval a] -> [Interval a] +mergeIntervalList :: forall a. (Num a, Ord a) => [Interval a] -> [Interval a] mergeIntervalList list = merge sorted where - sorted = sortOn fst list + sorted = sortOn fst list - merge :: [Interval a] -> [Interval a] - merge [] = [] - merge [x] = [x] - merge (x:y:xs) = case mergeIntervals x y of - [] -> merge xs - [x1] -> merge (x1:xs) - x1:x2:_ -> x1 : merge (x2:xs) + merge :: [Interval a] -> [Interval a] + merge [] = [] + merge [x] = [x] + merge (x : y : xs) = case mergeIntervals x y of + [] -> merge xs + [x1] -> merge (x1 : xs) + x1 : x2 : _ -> x1 : merge (x2 : xs) reverseBoundary :: Boundary a -> Boundary a reverseBoundary (Closed a) = Open a -reverseBoundary (Open a) = Closed a +reverseBoundary (Open a) = Closed a type Domain a = Interval a -diff :: (Num a,Ord a) => Domain a -> Interval a -> (Maybe (Interval a),Maybe (Interval a)) -diff (a,b) (c,d) = (first, second) +diff :: (Num a, Ord a) => Domain a -> Interval a -> (Maybe (Interval a), Maybe (Interval a)) +diff (a, b) (c, d) = (first, second) where - first = guard (a < c) >> Just (a,reverseBoundary c) - second = guard (d < b) >> Just (reverseBoundary d,b) + first = guard (a < c) >> Just (a, reverseBoundary c) + second = guard (d < b) >> Just (reverseBoundary d, b) intervalPoints :: Interval a -> [Boundary a] -intervalPoints (a,b) = [a,b] +intervalPoints (a, b) = [a, b] intervalsToPoints :: [Interval a] -> [Boundary a] intervalsToPoints = concatMap intervalPoints -addDomainPoints :: (Num a,Ord a) => Domain a -> [Boundary a] -> [Boundary a] +addDomainPoints :: (Num a, Ord a) => Domain a -> [Boundary a] -> [Boundary a] addDomainPoints d [] = intervalPoints d addDomainPoints _ [_] = error "addDomainPoints: invalid input" -addDomainPoints (a,b) (head':xs) = +addDomainPoints (a, b) (head' : xs) = let - lst = last xs - middle = take (length xs - 1) xs - begin = if a < head' then [a,reverseBoundary head'] else [] - end = if lst < b then [reverseBoundary lst,b] else [] - in begin ++ map reverseBoundary middle ++ end + lst = last xs + middle = take (length xs - 1) xs + begin = if a < head' then [a, reverseBoundary head'] else [] + end = if lst < b then [reverseBoundary lst, b] else [] + in + begin ++ map reverseBoundary middle ++ end boundaryListToIntervalList :: [Boundary a] -> [Interval a] -boundaryListToIntervalList [] = [] -boundaryListToIntervalList (x:y:xs) = (x,y) : boundaryListToIntervalList xs -boundaryListToIntervalList [_] = error "boundaryListToIntervalList: invalid input" +boundaryListToIntervalList [] = [] +boundaryListToIntervalList (x : y : xs) = (x, y) : boundaryListToIntervalList xs +boundaryListToIntervalList [_] = error "boundaryListToIntervalList: invalid input" -gaps :: (Num a,Ord a) => Domain a -> [Interval a] -> [Interval a] +gaps :: (Num a, Ord a) => Domain a -> [Interval a] -> [Interval a] gaps d intervals = let merged = mergeIntervalList intervals points = addDomainPoints d $ intervalsToPoints merged - in boundaryListToIntervalList points + in boundaryListToIntervalList points - -gapsWithinRange :: (Num a,Ord a) => (a,a) -> [RangeConstraint a] -> [Interval a] -gapsWithinRange d@(d1,d2) ranges = +gapsWithinRange :: (Num a, Ord a) => (a, a) -> [RangeConstraint a] -> [Interval a] +gapsWithinRange d@(d1, d2) ranges = let intervals = map (rangeToInterval d) ranges d' = (Closed d1, Closed d2) - in gaps d' intervals + in gaps d' intervals {- >>> gapsWithinRange (0,10) [NL 1, NG 5] @@ -183,38 +179,43 @@ gapsWithinRange d@(d1,d2) ranges = -} -------------------------------------------------------------------------------- --- | Generators -generateFromInterval :: (HasRange a,Ord a) => Interval a -> Gen a +-- | Generators +generateFromInterval :: (HasRange a, Ord a) => Interval a -> Gen a generateFromInterval (a, b) = - let range = choose' (boundaryValue a,boundaryValue b) - in case (a,b) of - (Closed _,Closed _) -> range - (Open _,Open _) -> range `suchThat` (\x -> x > boundaryValue a && x < boundaryValue b) - (Closed _,Open _) -> range `suchThat` (\x -> x < boundaryValue b) - (Open _,Closed _) -> range `suchThat` (\x -> x > boundaryValue a) - -generateFromIntervals :: (HasRange a,Ord a) => [Interval a] -> Gen a + let range = choose' (boundaryValue a, boundaryValue b) + in case (a, b) of + (Closed _, Closed _) -> range + (Open _, Open _) -> range `suchThat` (\x -> x > boundaryValue a && x < boundaryValue b) + (Closed _, Open _) -> range `suchThat` (\x -> x < boundaryValue b) + (Open _, Closed _) -> range `suchThat` (\x -> x > boundaryValue a) + +generateFromIntervals :: (HasRange a, Ord a) => [Interval a] -> Gen a generateFromIntervals = oneof . map generateFromInterval -generateFromConstraints :: (HasRange a,Ord a,Num a) - => (a,a) - -> [RangeConstraint a] - -> Gen a +generateFromConstraints :: + (HasRange a, Ord a, Num a) => + (a, a) -> + [RangeConstraint a] -> + Gen a generateFromConstraints d ranges = generateFromIntervals $ gapsWithinRange d ranges -rangeGen :: forall a. (Num a,HasDomain a,HasRange a,Ord a) - => RangeConstraint a - -> Gen a +rangeGen :: + forall a. + (Num a, HasDomain a, HasRange a, Ord a) => + RangeConstraint a -> + Gen a rangeGen = rangeGen' domain -rangeGen' :: forall a. (Num a,HasRange a,Ord a) - => (a,a) - -> RangeConstraint a - -> Gen a -rangeGen' (lower,upper) range = case range of - NL x -> choose' (lower,x) `suchThat` (< x) - NG x -> choose' (x,max upper (upper + x)) `suchThat` (> x) - NEQ x -> pure x - NLEQ x -> choose' (lower,x) - NGEQ x -> choose' (x,upper) +rangeGen' :: + forall a. + (Num a, HasRange a, Ord a) => + (a, a) -> + RangeConstraint a -> + Gen a +rangeGen' (lower, upper) range = case range of + NL x -> choose' (lower, x) `suchThat` (< x) + NG x -> choose' (x, max upper (upper + x)) `suchThat` (> x) + NEQ x -> pure x + NLEQ x -> choose' (lower, x) + NGEQ x -> choose' (x, upper) diff --git a/cardano-constitution/test/Helpers/MultiParam.hs b/cardano-constitution/test/Helpers/MultiParam.hs index ec970b35d98..acd8ada4eb4 100644 --- a/cardano-constitution/test/Helpers/MultiParam.hs +++ b/cardano-constitution/test/Helpers/MultiParam.hs @@ -1,25 +1,25 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE TupleSections #-} - -module Helpers.MultiParam - ( allValidAndOneMissing - , allValid - , allValidAndOneGreaterThanUpper - , allValidAndOneLessThanLower - , allInvalid - , someInvalidAndSomeValidParams - , someValidParams - , allValidButOnePlusOneUnknown - , allValidAndOneUnknown - , onlyUnknownParams - , GenericParam(..) - , multiParamProp - , multiParamProp' - ) - where +{-# LANGUAGE TupleSections #-} + +module Helpers.MultiParam ( + allValidAndOneMissing, + allValid, + allValidAndOneGreaterThanUpper, + allValidAndOneLessThanLower, + allInvalid, + someInvalidAndSomeValidParams, + someValidParams, + allValidButOnePlusOneUnknown, + allValidAndOneUnknown, + onlyUnknownParams, + GenericParam (..), + multiParamProp, + multiParamProp', +) +where import Cardano.Constitution.Validator import Cardano.Constitution.Validator.TestsCommon @@ -38,69 +38,72 @@ import Helpers.CekTests import Helpers.Guardrail as G import Helpers.TestBuilders - getGenericParamIx :: GenericParam -> ParamIx -getGenericParamIx (MkGenericParam gr) = getParamIx gr +getGenericParamIx (MkGenericParam gr) = getParamIx gr -------------------------------------------------------------------------------- + -- | Multi param property based test builders ---TODO: think about other name -multiParamProp :: (Testable prop) - => TestNumber - -> Gen ParamValues - -> ((Bool, ParamValues) -> prop) - -> PropertyWithTestState +-- TODO: think about other name +multiParamProp :: + Testable prop => + TestNumber -> + Gen ParamValues -> + ((Bool, ParamValues) -> prop) -> + PropertyWithTestState multiParamProp testNo gen = multiParamProp' testNo gen (pure []) -combine2Gen :: Gen a -> Gen b -> Gen (a,b) +combine2Gen :: Gen a -> Gen b -> Gen (a, b) combine2Gen genA genB = (,) <$> genA <*> genB ---TODO: think about other name -multiParamProp' :: (Testable prop) - => TestNumber - -> Gen ParamValues - -> Gen ParamValues - -> ((Bool, ParamValues) -> prop) - -> PropertyWithTestState +-- TODO: think about other name +multiParamProp' :: + Testable prop => + TestNumber -> + Gen ParamValues -> + Gen ParamValues -> + ((Bool, ParamValues) -> prop) -> + PropertyWithTestState multiParamProp' testNo gen extraGen finalProp ref = TSQ.forAll (combine2Gen gen extraGen) $ - \(params',extraParams) -> monadicIO $ do - - let params = case extraParams of - [] -> params' - -- if there are extra params, sort them by index - _nonEmpty -> sortOn fst $ params' ++ extraParams - let (V3.ArbitraryContext ctx) = V3.simpleContextWithParam params - -- validate all the validators - results' <- liftIO $ for defaultValidators $ \ v -> tryApplyOnData v ctx - complyResults <- liftIO $ for defaultValidatorsWithCodes $ \v -> hsAgreesWithTxBool v (V3.FakeProposedContext ctx) - let results = map isRight $ elems results' - -- remove duplicates. - -- in the happy path, there should be only one result - joinedResults = nub results - - -- Fail if v1 or v2 or v3 or v4 are wrong - when (length joinedResults /= 1) $ - fail $ "Validator results are not the same: " ++ show results' - - let headResult = head results - headComplyResult = head $ elems complyResults - complyResult = and complyResults - - unless complyResult $ - fail "Validator results do not comply" - - -- update the test state with the result and the generated params - -- (skip the extra params) - liftIO $ updateMultiParamStateRef testNo params' (headResult && headComplyResult) ref - - -- pass the evaluation to the root property caller - pure $ finalProp (headResult && headComplyResult,params') + \(params', extraParams) -> monadicIO $ do + let params = case extraParams of + [] -> params' + -- if there are extra params, sort them by index + _nonEmpty -> sortOn fst $ params' ++ extraParams + let (V3.ArbitraryContext ctx) = V3.simpleContextWithParam params + -- validate all the validators + results' <- liftIO $ for defaultValidators $ \v -> tryApplyOnData v ctx + complyResults <- liftIO $ for defaultValidatorsWithCodes $ \v -> hsAgreesWithTxBool v (V3.FakeProposedContext ctx) + let results = map isRight $ elems results' + -- remove duplicates. + -- in the happy path, there should be only one result + joinedResults = nub results + + -- Fail if v1 or v2 or v3 or v4 are wrong + when (length joinedResults /= 1) $ + fail $ + "Validator results are not the same: " ++ show results' + + let headResult = head results + headComplyResult = head $ elems complyResults + complyResult = and complyResults + + unless complyResult $ + fail "Validator results do not comply" + + -- update the test state with the result and the generated params + -- (skip the extra params) + liftIO $ updateMultiParamStateRef testNo params' (headResult && headComplyResult) ref + + -- pass the evaluation to the root property caller + pure $ finalProp (headResult && headComplyResult, params') + -------------------------------------------------------------------------------- --- | Multi param by guard-rails -allValidAndOneMissing :: [GenericParam] -> Gen [(ParamIx,Printable)] +-- | Multi param by guard-rails +allValidAndOneMissing :: [GenericParam] -> Gen [(ParamIx, Printable)] allValidAndOneMissing [] = pure [] allValidAndOneMissing [_] = pure [] allValidAndOneMissing validRanges = do @@ -109,19 +112,20 @@ allValidAndOneMissing validRanges = do let generators = fmap (\(MkGenericParam gr) -> inRangeSingleParamValues gr) shuffled validValues <- sequence generators case validValues of - [] -> pure [] - _:xs' -> pure $ sortOn fst xs' + [] -> pure [] + _ : xs' -> pure $ sortOn fst xs' -allValid :: [GenericParam] -> Gen [(ParamIx,Printable)] +allValid :: [GenericParam] -> Gen [(ParamIx, Printable)] allValid [] = pure [] allValid params = do let generators = fmap (\(MkGenericParam gr) -> inRangeSingleParamValues gr) params validValues <- sequence generators pure $ sortOn fst validValues -allValidAndOneCustom :: (GenericParam -> Maybe (Gen Printable)) - -> [GenericParam] - -> Gen [(ParamIx,Printable)] +allValidAndOneCustom :: + (GenericParam -> Maybe (Gen Printable)) -> + [GenericParam] -> + Gen [(ParamIx, Printable)] allValidAndOneCustom _ [] = pure [] allValidAndOneCustom customGen [gr@(MkGenericParam param)] = case customGen gr of @@ -132,31 +136,34 @@ allValidAndOneCustom customGen [gr@(MkGenericParam param)] = allValidAndOneCustom customGen params = do tryGenerate where - tryGenerate = do - xs <- shuffle params - - tailValues <- mapM (\(MkGenericParam gr) -> inRangeSingleParamValues gr) - $ tail xs - case customGen $ head xs of - Nothing -> tryGenerate - Just customOne -> do - value <- customOne - pure $ sortOn fst ((getGenericParamIx $ head xs,value):tailValues) - -allValidAndOneGreaterThanUpper :: [GenericParam] -> Gen [(ParamIx,Printable)] -allValidAndOneGreaterThanUpper = allValidAndOneCustom - (\(MkGenericParam x) -> greaterThanUpperParamValue One x ) - -allValidAndOneLessThanLower :: [GenericParam] -> Gen [(ParamIx,Printable)] -allValidAndOneLessThanLower = allValidAndOneCustom - (\(MkGenericParam x) -> lessThanLowerParamValue One x ) - -allInvalid :: [GenericParam] -> Gen [(ParamIx,Printable)] + tryGenerate = do + xs <- shuffle params + + tailValues <- + mapM (\(MkGenericParam gr) -> inRangeSingleParamValues gr) $ + tail xs + case customGen $ head xs of + Nothing -> tryGenerate + Just customOne -> do + value <- customOne + pure $ sortOn fst ((getGenericParamIx $ head xs, value) : tailValues) + +allValidAndOneGreaterThanUpper :: [GenericParam] -> Gen [(ParamIx, Printable)] +allValidAndOneGreaterThanUpper = + allValidAndOneCustom + (\(MkGenericParam x) -> greaterThanUpperParamValue One x) + +allValidAndOneLessThanLower :: [GenericParam] -> Gen [(ParamIx, Printable)] +allValidAndOneLessThanLower = + allValidAndOneCustom + (\(MkGenericParam x) -> lessThanLowerParamValue One x) + +allInvalid :: [GenericParam] -> Gen [(ParamIx, Printable)] allInvalid xs = do values <- outOfRangeParamValues All xs pure $ sortOn fst values -allValidAndOneUnknown :: [GenericParam] -> Gen [(ParamIx,Printable)] +allValidAndOneUnknown :: [GenericParam] -> Gen [(ParamIx, Printable)] allValidAndOneUnknown xs = do allValidValues <- allValid xs unknownValue <- unknownParamValue () @@ -168,98 +175,106 @@ unknownParamValue _ = do value <- chooseInteger domain pure (paramIx, MkPrintable value) -allValidButOnePlusOneUnknown :: [GenericParam] -> Gen [(ParamIx,Printable)] +allValidButOnePlusOneUnknown :: [GenericParam] -> Gen [(ParamIx, Printable)] allValidButOnePlusOneUnknown xs = do -- shuffle params and get all the values - values <- oneof [allValidAndOneLessThanLower xs - ,allValidAndOneGreaterThanUpper xs] + values <- + oneof + [ allValidAndOneLessThanLower xs + , allValidAndOneGreaterThanUpper xs + ] -- remove one value and sort the list unknownValue <- unknownParamValue () pure $ sortOn fst (unknownValue : values) -someValidParams :: [GenericParam] -> Gen [(ParamIx,Printable)] +someValidParams :: [GenericParam] -> Gen [(ParamIx, Printable)] someValidParams xs = do -- shuffle params and take a sublist of them shuffle xs >>= sublistOf1 >>= allValid -someInvalidAndSomeValidParams :: [GenericParam] -> Gen [(ParamIx,Printable)] +someInvalidAndSomeValidParams :: [GenericParam] -> Gen [(ParamIx, Printable)] someInvalidAndSomeValidParams params = do tryGenerate where - tryGenerate = do - -- shuffle the params and choose a sublist of them - -- the sublist must not be empty - xs <- shuffle params >>= sublistOf1 - -- at least one param must be out of range - splitAt' <- choose (1, length xs) - let forOutOfRange = Prelude.take splitAt' xs - forInRange = Prelude.drop splitAt' xs - invalidValues <- outOfRangeParamValues One forOutOfRange - case invalidValues of - [] -> tryGenerate - _xs -> do - validValues <- forM forInRange \(MkGenericParam gr) -> inRangeSingleParamValues gr - - -- return the values sorted by the param index - pure $ sortOn fst (invalidValues ++ validValues) - -onlyUnknownParams :: Gen [(ParamIx,Printable)] + tryGenerate = do + -- shuffle the params and choose a sublist of them + -- the sublist must not be empty + xs <- shuffle params >>= sublistOf1 + -- at least one param must be out of range + splitAt' <- choose (1, length xs) + let forOutOfRange = Prelude.take splitAt' xs + forInRange = Prelude.drop splitAt' xs + invalidValues <- outOfRangeParamValues One forOutOfRange + case invalidValues of + [] -> tryGenerate + _xs -> do + validValues <- forM forInRange \(MkGenericParam gr) -> inRangeSingleParamValues gr + + -- return the values sorted by the param index + pure $ sortOn fst (invalidValues ++ validValues) + +onlyUnknownParams :: Gen [(ParamIx, Printable)] onlyUnknownParams = listOf1 (unknownParamValue ()) -------------------------------------------------------------------------------- --- | Primitives +-- | Primitives sublistOf1 :: [a] -> Gen [a] sublistOf1 = flip suchThat (not . Prelude.null) . sublistOf -- all invalid , unsorted -outOfRangeParamValues :: GeneratorSpectrum -> [GenericParam] -> Gen [(ParamIx,Printable)] +outOfRangeParamValues :: GeneratorSpectrum -> [GenericParam] -> Gen [(ParamIx, Printable)] outOfRangeParamValues spectrum xs = do - foldM (\acc (MkGenericParam gr) -> - case outOfRangeParamValue spectrum gr of - -- if it can't generate a value, return the accumulator - Nothing -> pure acc - -- if it can generate a value, add it to the accumulator - Just gen -> do - value <- gen - pure $ (getParamIx gr,value) : acc - ) - [] xs - -inRangeParamValues :: [Guardrail (Param a)] -> Gen [(ParamIx,Printable)] + foldM + ( \acc (MkGenericParam gr) -> + case outOfRangeParamValue spectrum gr of + -- if it can't generate a value, return the accumulator + Nothing -> pure acc + -- if it can generate a value, add it to the accumulator + Just gen -> do + value <- gen + pure $ (getParamIx gr, value) : acc + ) + [] + xs + +inRangeParamValues :: [Guardrail (Param a)] -> Gen [(ParamIx, Printable)] inRangeParamValues paramRanges = forM paramRanges inRangeSingleParamValues -inRangeSingleParamValues :: forall a. Guardrail (Param a) - -> Gen (ParamIx,Printable) +inRangeSingleParamValues :: + forall a. + Guardrail (Param a) -> + Gen (ParamIx, Printable) inRangeSingleParamValues gr@(G.WithinDomain _ _) = - let (paramIx,range) = paramRange gr - in case range of - MkParamRangeWithinDomain (a,b) domain' -> + let (paramIx, range) = paramRange gr + in case range of + MkParamRangeWithinDomain (a, b) domain' -> (paramIx,) . pack <$> rangeGen domain' (IN' a b) -inRangeSingleParamValues gr@(Param{} ) = - inRangeSingleParamValues $ G.WithinDomain gr $ getDomain gr - -inRangeSingleParamValues (ParamList paramIx _ subparams ) = do - xs <- fmap snd <$> forM subparams inRangeSingleParamValues - return (paramIx, pack xs) +inRangeSingleParamValues gr@(Param {}) = + inRangeSingleParamValues $ G.WithinDomain gr $ getDomain gr +inRangeSingleParamValues (ParamList paramIx _ subparams) = do + xs <- fmap snd <$> forM subparams inRangeSingleParamValues + return (paramIx, pack xs) data GeneratorSpectrum = All | One -- | choose a random value lower than the lower bound of the range -- NOTE: if the range is unbounded Nothing is returned -lessThanLowerParamValue :: forall a. GeneratorSpectrum - -> Guardrail (Param a) - -> Maybe (Gen Printable) +lessThanLowerParamValue :: + forall a. + GeneratorSpectrum -> + Guardrail (Param a) -> + Maybe (Gen Printable) lessThanLowerParamValue _ gr@(Param {}) = lessThanLowerParamValue All $ G.WithinDomain gr $ getDomain gr lessThanLowerParamValue _ gr@(G.WithinDomain _ _) = lessThanLowerParamValue' range where - (_,range) = paramRange gr - lessThanLowerParamValue' (MkParamRangeWithinDomain (a,_) (start,_)) | a <= start = Nothing - lessThanLowerParamValue' (MkParamRangeWithinDomain (a,_) domain') = Just $ - pack <$> rangeGen domain' (LT' a) - + (_, range) = paramRange gr + lessThanLowerParamValue' (MkParamRangeWithinDomain (a, _) (start, _)) | a <= start = Nothing + lessThanLowerParamValue' (MkParamRangeWithinDomain (a, _) domain') = + Just $ + pack <$> rangeGen domain' (LT' a) lessThanLowerParamValue spectrum (ParamList _ _ xs) = withInvalidator (lessThanLowerParamValue spectrum) All xs @@ -269,53 +284,55 @@ greaterThanUpperParamValue :: forall a. GeneratorSpectrum -> Guardrail (Param a) greaterThanUpperParamValue _ gr@(Param {}) = greaterThanUpperParamValue All $ G.WithinDomain gr $ getDomain gr greaterThanUpperParamValue _ gr@(G.WithinDomain _ _) = greaterThanUpperParamValue' range where - (_,range) = paramRange gr - greaterThanUpperParamValue' (MkParamRangeWithinDomain (_,b) (_,end)) | b >= end = Nothing - greaterThanUpperParamValue' (MkParamRangeWithinDomain (_,b) domain') = Just $ - pack <$> rangeGen domain' (GT' b) + (_, range) = paramRange gr + greaterThanUpperParamValue' (MkParamRangeWithinDomain (_, b) (_, end)) | b >= end = Nothing + greaterThanUpperParamValue' (MkParamRangeWithinDomain (_, b) domain') = + Just $ + pack <$> rangeGen domain' (GT' b) greaterThanUpperParamValue spectrum (ParamList _ _ xs) = withInvalidator (greaterThanUpperParamValue spectrum) All xs - -- | choose a random value out of the range -- NOTE: if the range is unbounded Nothing is returned -outOfRangeParamValue :: forall a.GeneratorSpectrum -> Guardrail (Param a) -> Maybe (Gen Printable) +outOfRangeParamValue :: forall a. GeneratorSpectrum -> Guardrail (Param a) -> Maybe (Gen Printable) outOfRangeParamValue _ gr@(Param {}) = outOfRangeParamValue All $ G.WithinDomain gr $ getDomain gr outOfRangeParamValue _ gr@(G.WithinDomain _ _) = outOfRangeParamValue' range where - (_,range) = paramRange gr - outOfRangeParamValue' (MkParamRangeWithinDomain (a,b) (start,end)) | a > start && b < end = Just $ - pack <$> rangeGen (start,end) (OUT' a b) - outOfRangeParamValue' (MkParamRangeWithinDomain (a,_) (start,_)) | a > start = lessThanLowerParamValue All gr - outOfRangeParamValue' (MkParamRangeWithinDomain (_,b) (_,end)) | b < end = greaterThanUpperParamValue All gr - outOfRangeParamValue' _ = Nothing + (_, range) = paramRange gr + outOfRangeParamValue' (MkParamRangeWithinDomain (a, b) (start, end)) + | a > start && b < end = + Just $ + pack <$> rangeGen (start, end) (OUT' a b) + outOfRangeParamValue' (MkParamRangeWithinDomain (a, _) (start, _)) | a > start = lessThanLowerParamValue All gr + outOfRangeParamValue' (MkParamRangeWithinDomain (_, b) (_, end)) | b < end = greaterThanUpperParamValue All gr + outOfRangeParamValue' _ = Nothing outOfRangeParamValue spectrum (ParamList _ _ xs) = withInvalidator (outOfRangeParamValue spectrum) All xs - -- | custom invalid value generator for single param -withInvalidator :: forall a. - (Guardrail (Param (Scalar a)) -> Maybe (Gen Printable)) - -> GeneratorSpectrum - -> [Guardrail (Param (Scalar a))] - -> Maybe (Gen Printable) +withInvalidator :: + forall a. + (Guardrail (Param (Scalar a)) -> Maybe (Gen Printable)) -> + GeneratorSpectrum -> + [Guardrail (Param (Scalar a))] -> + Maybe (Gen Printable) withInvalidator f All xs = -- we generate a random value for each subparam let subparamsGen = mapM f xs - in case subparamsGen of - Just gens -> Just $ do - subparams <- sequence gens - return $ pack subparams - Nothing -> Nothing + in case subparamsGen of + Just gens -> Just $ do + subparams <- sequence gens + return $ pack subparams + Nothing -> Nothing withInvalidator _ One [] = Nothing -withInvalidator f One (first:xs) = +withInvalidator f One (first : xs) = let - validGenerators = inRangeParamValues xs - invalidGenerator = f first - in case invalidGenerator of - Nothing -> Nothing - Just gen -> Just $ do - subparams <- fmap snd <$> validGenerators - invalid <- gen - return $ pack $ invalid : subparams - + validGenerators = inRangeParamValues xs + invalidGenerator = f first + in + case invalidGenerator of + Nothing -> Nothing + Just gen -> Just $ do + subparams <- fmap snd <$> validGenerators + invalid <- gen + return $ pack $ invalid : subparams diff --git a/cardano-constitution/test/Helpers/Spec/IntervalSpec.hs b/cardano-constitution/test/Helpers/Spec/IntervalSpec.hs index 8021ea32557..f104e002f8b 100644 --- a/cardano-constitution/test/Helpers/Spec/IntervalSpec.hs +++ b/cardano-constitution/test/Helpers/Spec/IntervalSpec.hs @@ -1,103 +1,92 @@ -- editorconfig-checker-disable-file {-# LANGUAGE TypeApplications #-} + module Helpers.Spec.IntervalSpec where import Helpers.Intervals import Test.Tasty ---import Test.QuickCheck.Property (Result(testCase)) + +-- import Test.QuickCheck.Property (Result(testCase)) import Data.List (foldl') import Data.Ratio import Helpers.TestBuilders import Test.Tasty.HUnit import Test.Tasty.QuickCheck as TSQ - -- NOTE: if you want to use rationals the test name won't -- be guaranteed to be the same, since the show instance of -- rationals is simplified -intervalTest :: (Num a,Ord a,Show a) => (a,a) -> [RangeConstraint a] -> [(Boundary a,Boundary a)] -> TestTree -intervalTest domain' constraints expected = testCase testStr $ - gapsWithinRange domain' constraints @?= - expected - +intervalTest :: (Num a, Ord a, Show a) => (a, a) -> [RangeConstraint a] -> [(Boundary a, Boundary a)] -> TestTree +intervalTest domain' constraints expected = + testCase testStr $ + gapsWithinRange domain' constraints + @?= expected where - testStr = inputStr ++ " => " ++ expectedStr - inputStr = removeLastAnd $ foldl' f "not: " constraints - f acc (NL a)= acc ++ "(< " ++ show a ++ ") && " - f acc (NG a)= acc ++ "( > " ++ show a ++ ") && " - f acc (NEQ a)= acc ++ "(!= " ++ show a ++ ") && " - f acc (NLEQ a)=acc ++ "(<= " ++ show a ++ ") && " - f acc (NGEQ a)=acc ++ "(>= " ++ show a ++ ") && " - removeLastAnd = reverse . drop 4 . reverse - - expectedStr = removeLastOr $ foldl g "" expected - g acc (Open a, Open b) = acc ++ "(" ++ show a ++ "," ++ show b ++ ") | " - g acc (Open a, Closed b) = acc ++ "(" ++ show a ++ "," ++ show b ++ "] | " - g acc (Closed a, Open b) = acc ++ "[" ++ show a ++ "," ++ show b ++ ") | " - g acc (Closed a, Closed b) = acc ++ "[" ++ show a ++ "," ++ show b ++ "] | " - removeLastOr = reverse . drop 3 . reverse + testStr = inputStr ++ " => " ++ expectedStr + inputStr = removeLastAnd $ foldl' f "not: " constraints + f acc (NL a) = acc ++ "(< " ++ show a ++ ") && " + f acc (NG a) = acc ++ "( > " ++ show a ++ ") && " + f acc (NEQ a) = acc ++ "(!= " ++ show a ++ ") && " + f acc (NLEQ a) = acc ++ "(<= " ++ show a ++ ") && " + f acc (NGEQ a) = acc ++ "(>= " ++ show a ++ ") && " + removeLastAnd = reverse . drop 4 . reverse + + expectedStr = removeLastOr $ foldl g "" expected + g acc (Open a, Open b) = acc ++ "(" ++ show a ++ "," ++ show b ++ ") | " + g acc (Open a, Closed b) = acc ++ "(" ++ show a ++ "," ++ show b ++ "] | " + g acc (Closed a, Open b) = acc ++ "[" ++ show a ++ "," ++ show b ++ ") | " + g acc (Closed a, Closed b) = acc ++ "[" ++ show a ++ "," ++ show b ++ "] | " + removeLastOr = reverse . drop 3 . reverse internalTests :: TestTree -internalTests = testGroup "Tools: Intervals" [ - testGroup "gapsWithinRange" - [ testCase "no constraint gives back the full domain " $ - gapsWithinRange' [] @?= [(Closed negInf,Closed 10)] - - , testCase "no less than 1 => [1,inf] " $ - gapsWithinRange' [NL 1] @?= [(Closed 1,Closed 10)] - - , testCase "not less than 1 and not greater than 5 => [1,5]" $ - gapsWithinRange' [NL 1, NG 5] @?= [(Closed 1,Closed 5)] - - , testCase "not less than 1, not greater than 5 and not equal to 0 => [1,5]" $ - gapsWithinRange' [NL 1, NG 5, NEQ 0] @?= [(Closed 1,Closed 5)] - - , testCase "not less than 3, not greater than 6 and not less than 0 => [3,6]" $ - gapsWithinRange' [NL 3, NG 6, NL 0] @?= [(Closed 3,Closed 6)] - - , testCase "not less then 1 and not greater than 5 and equal to 0 => []" $ - gapsWithinRange' ([NL 1, NG 5 ] ++ negateRange (NEQ 0)) @?= [] - - , testCase "not less then 1 and not greater than 5 and equal to 3 => [3,3]" $ - gapsWithinRange' ([NL 1, NG 5 ] ++ negateRange (NEQ 3)) @?= [(Closed 3,Closed 3)] - - , testCase "not equal to 0 => [-inf,0) | (0,+inf]" $ - gapsWithinRange' ([NL 1, NG 5 ] ++ negateRange (NEQ 3)) @?= [(Closed 3,Closed 3)] - - , intervalTest @Integer (-10000,10000) [NL 3125, NG 6250, NEQ 0, NL 0] [(Closed 3125,Closed 6250)] - - , intervalTest @Integer (-10000,10000) [NG 6250, NEQ 0, NL 0] [(Open 0,Closed 6250)] - - , intervalTest @Integer (-10000,10000) [NL 1 , NG 3, NEQ 2] [(Closed 1,Open 2),(Open 2,Closed 3)] - - , intervalTest @Integer (-10000,10000) [NL 1 , NG 10, NEQ 2,NEQ 4,NEQ 8] - [(Closed 1,Open 2),(Open 2,Open 4),(Open 4,Open 8),(Open 8,Closed 10)] - - , intervalTest @Integer (-10000,10000) [NL 10 , NG 9] [] - - , testCase "not: (< 1 % 10) && (> 10 % 10) => [1 % 10, 1 % 1]" $ - gapsWithinRange @Rational (-1,3) [NL (1 % 10), NG (10 % 10) ] @?= [(Closed (1 % 10),Closed (1 % 1))] - - , TSQ.testProperty "[NL (1 % 10), NG (10 % 10) ] should generate within the boundaries" $ - TSQ.forAll (rationalGenerator [NL (1 % 10), NG (10 % 10) ]) $ - \x -> x >= 1 % 10 && x <= 1 - - , testCase "[NL (50 % 100), NG (100 % 100), NL (65 % 100) , NG (90 % 100) ] => [65 % 100, 90 % 100]" $ - gapsWithinRange @Rational (-1,1) [NL (50 % 100), NG (100 % 100), NL (65 % 100) , NG (90 % 100)] @?= - [(Closed (65%100),Closed (90%100))] - - , TSQ.testProperty "[NL (50 % 100), NG (100 % 100), NL (65 % 100) , NG (90 % 100) ] should generate within the boundaries" $ - TSQ.forAll (rationalGenerator [NL (50 % 100), NG (100 % 100), NL (65 % 100) , NG (90 % 100)]) $ - \x -> x >= 65 % 100 && x <= 90 % 100 - - , TSQ.testProperty "rationals should be generated within the boundaries" $ - TSQ.forAll (choose' @Rational (0,1)) $ - \x -> x >= 0 && x <= 100 +internalTests = + testGroup + "Tools: Intervals" + [ testGroup + "gapsWithinRange" + [ testCase "no constraint gives back the full domain " $ + gapsWithinRange' [] @?= [(Closed negInf, Closed 10)] + , testCase "no less than 1 => [1,inf] " $ + gapsWithinRange' [NL 1] @?= [(Closed 1, Closed 10)] + , testCase "not less than 1 and not greater than 5 => [1,5]" $ + gapsWithinRange' [NL 1, NG 5] @?= [(Closed 1, Closed 5)] + , testCase "not less than 1, not greater than 5 and not equal to 0 => [1,5]" $ + gapsWithinRange' [NL 1, NG 5, NEQ 0] @?= [(Closed 1, Closed 5)] + , testCase "not less than 3, not greater than 6 and not less than 0 => [3,6]" $ + gapsWithinRange' [NL 3, NG 6, NL 0] @?= [(Closed 3, Closed 6)] + , testCase "not less then 1 and not greater than 5 and equal to 0 => []" $ + gapsWithinRange' ([NL 1, NG 5] ++ negateRange (NEQ 0)) @?= [] + , testCase "not less then 1 and not greater than 5 and equal to 3 => [3,3]" $ + gapsWithinRange' ([NL 1, NG 5] ++ negateRange (NEQ 3)) @?= [(Closed 3, Closed 3)] + , testCase "not equal to 0 => [-inf,0) | (0,+inf]" $ + gapsWithinRange' ([NL 1, NG 5] ++ negateRange (NEQ 3)) @?= [(Closed 3, Closed 3)] + , intervalTest @Integer (-10000, 10000) [NL 3125, NG 6250, NEQ 0, NL 0] [(Closed 3125, Closed 6250)] + , intervalTest @Integer (-10000, 10000) [NG 6250, NEQ 0, NL 0] [(Open 0, Closed 6250)] + , intervalTest @Integer (-10000, 10000) [NL 1, NG 3, NEQ 2] [(Closed 1, Open 2), (Open 2, Closed 3)] + , intervalTest @Integer + (-10000, 10000) + [NL 1, NG 10, NEQ 2, NEQ 4, NEQ 8] + [(Closed 1, Open 2), (Open 2, Open 4), (Open 4, Open 8), (Open 8, Closed 10)] + , intervalTest @Integer (-10000, 10000) [NL 10, NG 9] [] + , testCase "not: (< 1 % 10) && (> 10 % 10) => [1 % 10, 1 % 1]" $ + gapsWithinRange @Rational (-1, 3) [NL (1 % 10), NG (10 % 10)] @?= [(Closed (1 % 10), Closed (1 % 1))] + , TSQ.testProperty "[NL (1 % 10), NG (10 % 10) ] should generate within the boundaries" $ + TSQ.forAll (rationalGenerator [NL (1 % 10), NG (10 % 10)]) $ + \x -> x >= 1 % 10 && x <= 1 + , testCase "[NL (50 % 100), NG (100 % 100), NL (65 % 100) , NG (90 % 100) ] => [65 % 100, 90 % 100]" $ + gapsWithinRange @Rational (-1, 1) [NL (50 % 100), NG (100 % 100), NL (65 % 100), NG (90 % 100)] + @?= [(Closed (65 % 100), Closed (90 % 100))] + , TSQ.testProperty "[NL (50 % 100), NG (100 % 100), NL (65 % 100) , NG (90 % 100) ] should generate within the boundaries" $ + TSQ.forAll (rationalGenerator [NL (50 % 100), NG (100 % 100), NL (65 % 100), NG (90 % 100)]) $ + \x -> x >= 65 % 100 && x <= 90 % 100 + , TSQ.testProperty "rationals should be generated within the boundaries" $ + TSQ.forAll (choose' @Rational (0, 1)) $ + \x -> x >= 0 && x <= 100 + ] ] - ] where - rationalGenerator = generateFromIntervals . gapsWithinRange @Rational (-1,3) - gapsWithinRange' = gapsWithinRange @Integer domain' - domain' = (negInf,posInf) - negInf = -10 - posInf = 10 + rationalGenerator = generateFromIntervals . gapsWithinRange @Rational (-1, 3) + gapsWithinRange' = gapsWithinRange @Integer domain' + domain' = (negInf, posInf) + negInf = -10 + posInf = 10 diff --git a/cardano-constitution/test/Helpers/TestBuilders.hs b/cardano-constitution/test/Helpers/TestBuilders.hs index f869c13593e..82dd9bc6933 100644 --- a/cardano-constitution/test/Helpers/TestBuilders.hs +++ b/cardano-constitution/test/Helpers/TestBuilders.hs @@ -1,11 +1,10 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wno-orphans #-} module Helpers.TestBuilders where @@ -41,10 +40,11 @@ none :: Foldable t => (a -> Bool) -> t a -> Bool none f = not . any f -- | Wrapper for a test case that includes a reference to the test state + -------------------------------------------------------------------------------- -- | Heterogeneous values that can be printed and serialized -data Printable = forall a . (Show a,ToJSON a,ToData a) => MkPrintable a +data Printable = forall a. (Show a, ToJSON a, ToData a) => MkPrintable a deriving stock instance Show Printable instance ToJSON Printable where @@ -53,68 +53,72 @@ instance ToJSON Printable where instance ToData Printable where toBuiltinData (MkPrintable a) = toBuiltinData a - -- | Pack a value into a Printable -pack :: (ToJSON a,Show a,ToData a) => a -> Printable +pack :: (ToJSON a, Show a, ToData a) => a -> Printable pack = MkPrintable - type TestNumber = Int -type ParamValues =[(ParamKey,Printable)] -type MultiParamState = Map TestNumber [(ParamValues,Bool)] -type SingleParamState = Map ParamId [(Printable,Bool)] +type ParamValues = [(ParamKey, Printable)] +type MultiParamState = Map TestNumber [(ParamValues, Bool)] +type SingleParamState = Map ParamId [(Printable, Bool)] type ParamId = String -- testProperty "#1" # template [(ParamKey,Printable)] + -- | Test state data TestState = TestState - { oneParamState :: !SingleParamState - , multiParamState :: !MultiParamState - } deriving stock (Show) + { oneParamState :: !SingleParamState + , multiParamState :: !MultiParamState + } + deriving stock (Show) -- | Update the test state with a new test result of a single parameter test -updateSingleParamState :: (ToJSON n,Show n,ToData n) - => ParamId - -> n - -> Bool - -> TestState - -> TestState +updateSingleParamState :: + (ToJSON n, Show n, ToData n) => + ParamId -> + n -> + Bool -> + TestState -> + TestState updateSingleParamState paramIx value result (TestState oneS multiS) = TestState newMap multiS where - newMap = alter (Just . f) paramIx oneS - f (Just xs) = (pack value, result) : xs - f Nothing = [(pack value, result)] + newMap = alter (Just . f) paramIx oneS + f (Just xs) = (pack value, result) : xs + f Nothing = [(pack value, result)] -- | Update the test state ioRef with a new test result of a single parameter test -updateSingleParamStateRef :: (ToJSON n,Show n,ToData n) - => ParamId - -> n - -> Bool - -> IORef TestState - -> IO () +updateSingleParamStateRef :: + (ToJSON n, Show n, ToData n) => + ParamId -> + n -> + Bool -> + IORef TestState -> + IO () updateSingleParamStateRef paramId value result ref = atomicModifyIORef' ref (\ts -> (updateSingleParamState paramId value result ts, ())) -- | Update the test state with a new test result of a multi parameter test -updateMultiParamState :: TestNumber - -> ParamValues - -> Bool - -> TestState - -> TestState +updateMultiParamState :: + TestNumber -> + ParamValues -> + Bool -> + TestState -> + TestState updateMultiParamState testNo params result (TestState oneS multiS) = TestState oneS newMap where - newMap = alter (Just . f) testNo multiS - f (Just xs) = (params,result) : xs - f Nothing = [(params,result)] + newMap = alter (Just . f) testNo multiS + f (Just xs) = (params, result) : xs + f Nothing = [(params, result)] -- | Update the test state ioRef with a new test result of a multi parameter test -updateMultiParamStateRef :: TestNumber - -> ParamValues - -> Bool - -> IORef TestState - -> IO () +updateMultiParamStateRef :: + TestNumber -> + ParamValues -> + Bool -> + IORef TestState -> + IO () updateMultiParamStateRef testNo params result ref = atomicModifyIORef' ref (\ts -> (updateMultiParamState testNo params result ts, ())) @@ -131,19 +135,19 @@ type AssertionWithTestState = IORef TestState -> Assertion class TestableWithState a where testProperty' :: TestName -> a -> TestTreeWithTestState -instance Testable a => TestableWithState (IORef TestState -> a) where +instance Testable a => TestableWithState (IORef TestState -> a) where testProperty' name f = testProperty name . f -instance TestableWithState Property where +instance TestableWithState Property where testProperty' name val _ = testProperty name val class AssertableWithState a where testCase' :: TestName -> a -> TestTreeWithTestState -instance AssertableWithState (IORef TestState -> Assertion) where +instance AssertableWithState (IORef TestState -> Assertion) where testCase' name f = testCase name . f -instance AssertableWithState Assertion where +instance AssertableWithState Assertion where testCase' name a _ = testCase name a -- | Test tree with a reference to the test state @@ -153,21 +157,23 @@ testGroup' name tests ref = testGroup name $ map ($ ref) tests -------------------------------------------------------------------------------- -- Unit test builders -unitTestTemplatePositive :: (ToJSON b,Show b, ToData b) - => ParamKey - -> b - -> AssertionWithTestState +unitTestTemplatePositive :: + (ToJSON b, Show b, ToData b) => + ParamKey -> + b -> + AssertionWithTestState unitTestTemplatePositive paramIx = - unitTestTemplatePositive' (show paramIx) (oneParamChange paramIx ) - -unitTestTemplatePositive' :: (ToJSON b,Show b, ToData b) - => ParamId - -> (b -> ParamValues) - -> b - -> AssertionWithTestState + unitTestTemplatePositive' (show paramIx) (oneParamChange paramIx) + +unitTestTemplatePositive' :: + (ToJSON b, Show b, ToData b) => + ParamId -> + (b -> ParamValues) -> + b -> + AssertionWithTestState unitTestTemplatePositive' paramIx toData' val ref = do let ctx = V3.mkFakeParameterChangeContext $ toData' val - results <- for defaultValidators $ \ v -> tryApplyOnData v ctx + results <- for defaultValidators $ \v -> tryApplyOnData v ctx complyResults <- for defaultValidatorsWithCodes $ \v -> hsAgreesWithTxBool v ctx let result = all isRight results complyResult = and complyResults @@ -179,21 +185,23 @@ unitTestTemplatePositive' paramIx toData' val ref = do liftIO $ updateSingleParamStateRef paramIx val (headResult && headComplyResult) ref -unitTestTemplateNegative :: (ToJSON b,Show b, ToData b) - => ParamKey - -> b - -> AssertionWithTestState +unitTestTemplateNegative :: + (ToJSON b, Show b, ToData b) => + ParamKey -> + b -> + AssertionWithTestState unitTestTemplateNegative paramIx = unitTestTemplateNegative' (show paramIx) (oneParamChange paramIx) -unitTestTemplateNegative' :: (ToJSON b,Show b, ToData b) - => ParamId - -> (b -> ParamValues) - -> b - -> AssertionWithTestState +unitTestTemplateNegative' :: + (ToJSON b, Show b, ToData b) => + ParamId -> + (b -> ParamValues) -> + b -> + AssertionWithTestState unitTestTemplateNegative' paramIx toData' val ref = do let ctx = V3.mkFakeParameterChangeContext $ toData' val - results <- for defaultValidators $ \ v -> tryApplyOnData v ctx + results <- for defaultValidators $ \v -> tryApplyOnData v ctx complyResults <- for defaultValidatorsWithCodes $ \v -> hsAgreesWithTxBool v ctx let result = none isRight results complyResult = and complyResults @@ -208,32 +216,34 @@ unitTestTemplateNegative' paramIx toData' val ref = do -------------------------------------------------------------------------------- -- Property based test builders -oneParamProp :: (ToJSON b,Show b, Testable prop, ToData b) - => ParamKey - -> Gen b - -> ((Bool, b) -> prop) - -> PropertyWithTestState +oneParamProp :: + (ToJSON b, Show b, Testable prop, ToData b) => + ParamKey -> + Gen b -> + ((Bool, b) -> prop) -> + PropertyWithTestState oneParamProp paramIx = oneParamProp' (show paramIx) (oneParamChange paramIx) -oneParamChange :: (ToJSON a, Show a, ToData a) - => ParamIx - -> a - -> [(ParamIx, Printable)] +oneParamChange :: + (ToJSON a, Show a, ToData a) => + ParamIx -> + a -> + [(ParamIx, Printable)] oneParamChange paramIx value = [(paramIx, pack value)] -oneParamProp' :: (ToJSON a,Show a, Testable prop, ToData a) - => ParamId - -> (a -> ParamValues) - -> Gen a - -> ((Bool, a) -> prop) - -> PropertyWithTestState +oneParamProp' :: + (ToJSON a, Show a, Testable prop, ToData a) => + ParamId -> + (a -> ParamValues) -> + Gen a -> + ((Bool, a) -> prop) -> + PropertyWithTestState oneParamProp' paramIx toData' gen finalProp ref = TSQ.forAll gen $ - \value -> monadicIO $ do - + \value -> monadicIO $ do let (V3.ArbitraryContext ctx) = V3.simpleContextWithParam (toData' value) -- validate all the validators - results' <- liftIO $ for defaultValidators $ \ v -> tryApplyOnData v ctx + results' <- liftIO $ for defaultValidators $ \v -> tryApplyOnData v ctx complyResults <- liftIO $ for defaultValidatorsWithCodes $ \v -> hsAgreesWithTxBool v (V3.FakeProposedContext ctx) -- remove duplicates. @@ -243,7 +253,8 @@ oneParamProp' paramIx toData' gen finalProp ref = TSQ.forAll gen $ -- Fail if v1 or v2 or v3 or v4 are wrong when (length joinedResults /= 1) $ - fail $ "Validator results are not the same: " ++ show results + fail $ + "Validator results are not the same: " ++ show results let headResult = isRight $ head $ elems results' headComplyResult = head $ elems complyResults @@ -256,46 +267,49 @@ oneParamProp' paramIx toData' gen finalProp ref = TSQ.forAll gen $ liftIO $ updateSingleParamStateRef paramIx value (headResult && headComplyResult) ref -- pass the evaluation to the root property caller - pure $ finalProp (headResult && headComplyResult,value) + pure $ finalProp (headResult && headComplyResult, value) -pbtParamValidRange :: (ToJSON a,Show a,ToData a,HasRange a) - => ParamKey - -> (a, a) - -> PropertyWithTestState +pbtParamValidRange :: + (ToJSON a, Show a, ToData a, HasRange a) => + ParamKey -> + (a, a) -> + PropertyWithTestState pbtParamValidRange paramIx (lower, upper) = pbtParamValidRange' (show paramIx) (oneParamChange paramIx) (lower, upper) -pbtParamValidRange' :: (ToJSON a,Show a,ToData a,HasRange a) - => ParamId - -> (a -> ParamValues) - -> (a, a) - -> PropertyWithTestState +pbtParamValidRange' :: + (ToJSON a, Show a, ToData a, HasRange a) => + ParamId -> + (a -> ParamValues) -> + (a, a) -> + PropertyWithTestState pbtParamValidRange' param toData' (lower, upper) = - oneParamProp' param toData' (choose' (lower,upper)) fst + oneParamProp' param toData' (choose' (lower, upper)) fst pbtParamInvalidRange :: ParamKey -> (Integer, Integer) -> PropertyWithTestState pbtParamInvalidRange param (lower, upper) = oneParamProp param gen (not . fst) where - gen = oneof [ - chooseInteger ( lower - 5_000 , lower - 1 ), - chooseInteger ( upper + 1 , upper + 5_000) - ] + gen = + oneof + [ chooseInteger (lower - 5_000, lower - 1) + , chooseInteger (upper + 1, upper + 5_000) + ] class HasRange a where choose' :: (a, a) -> Gen a class HasDomain a where - domain :: (a,a) + domain :: (a, a) instance HasDomain Integer where - domain = (-upperBound,upperBound) + domain = (-upperBound, upperBound) where - upperBound = 10_000 + upperBound = 10_000 instance HasDomain Rational where - domain = (-upperBound,upperBound) + domain = (-upperBound, upperBound) where - upperBound = 10_000 + upperBound = 10_000 instance HasRange Integer where choose' = chooseInteger @@ -304,60 +318,63 @@ instance ToData Rational where toBuiltinData ratio = let num = numerator ratio den = denominator ratio - in toBuiltinData [num,den] + in toBuiltinData [num, den] instance HasRange Rational where - choose' (min_ratio,max_ratio) = do - let (a,b) = (numerator &&& denominator) min_ratio - (c,d) = (numerator &&& denominator) max_ratio - den <- chooseInteger - ( if a == 0 then 1 else max 1 (ceiling (b % a)) - , maxDenominator - ) + choose' (min_ratio, max_ratio) = do + let (a, b) = (numerator &&& denominator) min_ratio + (c, d) = (numerator &&& denominator) max_ratio + den <- + chooseInteger + ( if a == 0 then 1 else max 1 (ceiling (b % a)) + , maxDenominator + ) num <- chooseInteger (ceiling (den * a % b), floor (den * c % d)) pure (num % den) where - - {-# INLINEABLE maxDenominator #-} - maxDenominator = 2^(64 :: Integer)-1 + {-# INLINEABLE maxDenominator #-} + maxDenominator = 2 ^ (64 :: Integer) - 1 data Range a = LT' a | GT' a | EQ' a | NEQ' a | LEQT' a | GEQT' a | IN' a a | OUT' a a deriving stock (Show) -rangeGen :: forall a. (Num a,HasRange a,Ord a) - => (a,a) - -> Range a - -> Gen a -rangeGen (lower,upper) range = case range of - LT' x -> choose' (lower,x) `suchThat` (< x) - GT' x -> choose' (x,max upper (upper + x)) `suchThat` (> x) - EQ' x -> pure x - NEQ' x -> choose' (lower,upper) `suchThat` (/= x) - LEQT' x -> choose' (lower,x) - GEQT' x -> choose' (x,upper) - IN' x y -> choose' (x,y) - OUT' x y -> oneof [choose' (lower,x) `suchThat` (/= x), choose' (y,upper) `suchThat` (/= y)] - -mergeDomains :: (Ord a) => (a,a) -> (a,a) -> [(a,a)] -mergeDomains (a,b) (c,d) | b < c = [(a,b),(c,d)] - | otherwise = [(min a c,max b d)] - -mergeDomainList :: forall a. (Ord a) => [(a,a)] -> [(a,a)] +rangeGen :: + forall a. + (Num a, HasRange a, Ord a) => + (a, a) -> + Range a -> + Gen a +rangeGen (lower, upper) range = case range of + LT' x -> choose' (lower, x) `suchThat` (< x) + GT' x -> choose' (x, max upper (upper + x)) `suchThat` (> x) + EQ' x -> pure x + NEQ' x -> choose' (lower, upper) `suchThat` (/= x) + LEQT' x -> choose' (lower, x) + GEQT' x -> choose' (x, upper) + IN' x y -> choose' (x, y) + OUT' x y -> oneof [choose' (lower, x) `suchThat` (/= x), choose' (y, upper) `suchThat` (/= y)] + +mergeDomains :: Ord a => (a, a) -> (a, a) -> [(a, a)] +mergeDomains (a, b) (c, d) + | b < c = [(a, b), (c, d)] + | otherwise = [(min a c, max b d)] + +mergeDomainList :: forall a. Ord a => [(a, a)] -> [(a, a)] mergeDomainList = Prelude.foldr f [] . sort' where - sort' = sortOn fst - f :: (a,a) -> [(a,a)] -> [(a,a)] - f d []= [d] - f d (x:xs) = case mergeDomains d x of - [] -> xs - [d1] -> d1 : xs - d1:d2:_ -> d1 : d2 : xs + sort' = sortOn fst + f :: (a, a) -> [(a, a)] -> [(a, a)] + f d [] = [d] + f d (x : xs) = case mergeDomains d x of + [] -> xs + [d1] -> d1 : xs + d1 : d2 : _ -> d1 : d2 : xs type ParamIx = Integer -mkCtxFromChangedParams :: ToData b => [(ParamIx,b)] -> V3.ScriptContext +mkCtxFromChangedParams :: ToData b => [(ParamIx, b)] -> V3.ScriptContext mkCtxFromChangedParams = - V3.ScriptContext V3.memptyTxInfo V3.emptyRedeemer + V3.ScriptContext V3.memptyTxInfo V3.emptyRedeemer . V3.ProposingScript 0 . V3.ProposalProcedure 0 (V3.PubKeyCredential "") . flip (V3.ParameterChange Nothing) Nothing @@ -367,16 +384,17 @@ mkCtxFromChangedParams = -- a heterogeneous data type to store the valid ranges data ParamRange - = forall a . (Num a, Show a, ToJSON a, HasRange a, ToData a, Ord a) - => MkParamRangeWithinDomain !(a,a) !(a,a) + = forall a. + (Num a, Show a, ToJSON a, HasRange a, ToData a, Ord a) => + MkParamRangeWithinDomain !(a, a) !(a, a) instance Show ParamRange where - show (MkParamRangeWithinDomain (a,b) (c,d)) = "MkParamRangeWithinDomain " ++ show (a,b) <> " within " <> show (c,d) + show (MkParamRangeWithinDomain (a, b) (c, d)) = "MkParamRangeWithinDomain " ++ show (a, b) <> " within " <> show (c, d) -- for testing purposes instance Show BI.BuiltinUnit where - -- not sure if needed to patternmatch everything here - show (BI.BuiltinUnit ()) = "BuiltinUnit" + -- not sure if needed to patternmatch everything here + show (BI.BuiltinUnit ()) = "BuiltinUnit" instance ToJSON (Tx.Map Integer [Integer]) where toJSON = toJSON . Tx.toList @@ -391,13 +409,13 @@ costModelsParamGen = do allCostModelsFlat :: [(Integer, [Integer])] allCostModelsFlat = - [ (0, [ val | _ <- [1 :: Int ..166]]) - , (1, [ val | _ <- [1 :: Int ..175]]) - , (2, [ val | _ <- [1 :: Int ..233]]) - , (3, [ val | _ <- [1 :: Int ..300]]) + [ (0, [val | _ <- [1 :: Int .. 166]]) + , (1, [val | _ <- [1 :: Int .. 175]]) + , (2, [val | _ <- [1 :: Int .. 233]]) + , (3, [val | _ <- [1 :: Int .. 300]]) ] where - val = 9_223_372_036_854_775_807 :: Integer + val = 9_223_372_036_854_775_807 :: Integer allCostModels :: Tx.Map Integer [Integer] allCostModels = Tx.unsafeFromList allCostModelsFlat diff --git a/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs b/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs index 863597bf65c..7ac221b592a 100644 --- a/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs +++ b/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs @@ -1,22 +1,23 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -module PlutusLedgerApi.V3.ArbitraryContexts - ( ArbitraryContext (..) - , GovernanceAction (..) - , FakeProposedContext (..) - , mkFakeParameterChangeContext - , mkFakeContextFromGovAction - , mkLargeFakeProposal - , mkSmallFakeProposal - , memptyTxInfo - , emptyRedeemer - , simpleContextWithParam - , withOneParamGen - , treasuryWithdrawalsCtxGen - ) where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module PlutusLedgerApi.V3.ArbitraryContexts ( + ArbitraryContext (..), + GovernanceAction (..), + FakeProposedContext (..), + mkFakeParameterChangeContext, + mkFakeContextFromGovAction, + mkLargeFakeProposal, + mkSmallFakeProposal, + memptyTxInfo, + emptyRedeemer, + simpleContextWithParam, + withOneParamGen, + treasuryWithdrawalsCtxGen, +) where import Cardano.Constitution.Config import PlutusCore.Generators.QuickCheck () @@ -40,21 +41,23 @@ import Data.Function (on) import Data.Int import Data.List as List import Data.String qualified as Haskell -import Prelude qualified as Haskell import Test.Tasty.QuickCheck +import Prelude qualified as Haskell -- | An arbitrary context, focusing mostly on generating proposals for changing parameters newtype ArbitraryContext = ArbitraryContext - { unArbitraryContext :: V3.ScriptContext - } - deriving newtype (Haskell.Show, Tx.ToData) + { unArbitraryContext :: V3.ScriptContext + } + deriving newtype (Haskell.Show, Tx.ToData) instance Arbitrary ArbitraryContext where - arbitrary = ArbitraryContext Haskell.<$> (V3.ScriptContext - Haskell.<$> arbitraryTxInfo - Haskell.<*> arbitraryRedeemer - Haskell.<*> arbitraryScriptInfo - ) + arbitrary = + ArbitraryContext + Haskell.<$> ( V3.ScriptContext + Haskell.<$> arbitraryTxInfo + Haskell.<*> arbitraryRedeemer + Haskell.<*> arbitraryScriptInfo + ) arbitraryTxInfo :: Gen TxInfo arbitraryTxInfo = Haskell.pure memptyTxInfo @@ -63,139 +66,154 @@ arbitraryRedeemer :: Gen Redeemer arbitraryRedeemer = Redeemer . BuiltinData Haskell.<$> arbitrary -- BuiltinData memptyTxInfo :: TxInfo -memptyTxInfo = TxInfo - { txInfoInputs = mempty - , txInfoReferenceInputs = mempty - , txInfoOutputs = mempty - , txInfoFee = zero - , txInfoMint = emptyMintValue - , txInfoTxCerts = mempty - , txInfoWdrl = AssocMap.unsafeFromList mempty - , txInfoValidRange = always - , txInfoSignatories = mempty - , txInfoRedeemers = AssocMap.unsafeFromList mempty - , txInfoData = AssocMap.unsafeFromList mempty - , txInfoId = V3.TxId mempty - , txInfoVotes = AssocMap.unsafeFromList mempty - , txInfoProposalProcedures = mempty - -- cant'use mempty, Lovelace is not Semigroup - , txInfoCurrentTreasuryAmount = Nothing - -- cant'use mempty, Lovelace is not Semigroup - , txInfoTreasuryDonation = Nothing - } +memptyTxInfo = + TxInfo + { txInfoInputs = mempty + , txInfoReferenceInputs = mempty + , txInfoOutputs = mempty + , txInfoFee = zero + , txInfoMint = emptyMintValue + , txInfoTxCerts = mempty + , txInfoWdrl = AssocMap.unsafeFromList mempty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoRedeemers = AssocMap.unsafeFromList mempty + , txInfoData = AssocMap.unsafeFromList mempty + , txInfoId = V3.TxId mempty + , txInfoVotes = AssocMap.unsafeFromList mempty + , txInfoProposalProcedures = mempty + , -- cant'use mempty, Lovelace is not Semigroup + txInfoCurrentTreasuryAmount = Nothing + , -- cant'use mempty, Lovelace is not Semigroup + txInfoTreasuryDonation = Nothing + } emptyRedeemer :: Redeemer emptyRedeemer = Redeemer (toBuiltinData ()) arbitraryScriptInfo :: Gen ScriptInfo -arbitraryScriptInfo = frequency - [(1, Haskell.pure (MintingScript (V3.CurrencySymbol ""))) -- negative testing - ,(5, ProposingScript zero Haskell.<$> arbitraryProposalProcedure ) - ] +arbitraryScriptInfo = + frequency + [ (1, Haskell.pure (MintingScript (V3.CurrencySymbol ""))) -- negative testing + , (5, ProposingScript zero Haskell.<$> arbitraryProposalProcedure) + ] arbitraryProposalProcedure :: Gen ProposalProcedure -arbitraryProposalProcedure = ProposalProcedure zero - Haskell.<$> arbitraryCredential - Haskell.<*> arbitraryGovernanceAction +arbitraryProposalProcedure = + ProposalProcedure zero + Haskell.<$> arbitraryCredential + Haskell.<*> arbitraryGovernanceAction arbitraryCredential :: Gen Credential arbitraryCredential = Haskell.pure (PubKeyCredential "") arbitraryGovernanceAction :: Gen GovernanceAction -arbitraryGovernanceAction = ParameterChange Nothing - Haskell.<$> arbitraryChangedParameters - Haskell.<*> Haskell.pure Nothing +arbitraryGovernanceAction = + ParameterChange Nothing + Haskell.<$> arbitraryChangedParameters + Haskell.<*> Haskell.pure Nothing twAction :: Gen GovernanceAction -twAction = TreasuryWithdrawals - Haskell.<$> treasuryWithdrawalsCredentials - Haskell.<*> Haskell.pure Nothing +twAction = + TreasuryWithdrawals + Haskell.<$> treasuryWithdrawalsCredentials + Haskell.<*> Haskell.pure Nothing -- Define a generator for a single hexadecimal character hexChar :: Gen Haskell.Char -hexChar = elements $ ['0'..'9'] ++ ['a'..'f'] +hexChar = elements $ ['0' .. '9'] ++ ['a' .. 'f'] -- Define a generator for a hexadecimal string of a given length hexString :: Int -> Gen Haskell.String hexString len = Haskell.replicateM len hexChar -- Generate a list of arbitrary length hexadecimal strings -arbitraryHexStrings :: Gen [(Credential,Lovelace)] +arbitraryHexStrings :: Gen [(Credential, Lovelace)] arbitraryHexStrings = sized $ \n -> do k <- choose (0, n) -- Generate a length for the list let toCredential = Haskell.map (PubKeyCredential . Haskell.fromString) - str <- toCredential Haskell.<$> vectorOf k (hexString 16) -- Generate a list of hex strings + str <- toCredential Haskell.<$> vectorOf k (hexString 16) -- Generate a list of hex strings int <- Haskell.map Lovelace Haskell.<$> vectorOf k (chooseInteger (1, 100000000)) -- Generate a list of integers Haskell.pure $ zip str int treasuryWithdrawalsCredentials :: Gen (Map Credential Lovelace) treasuryWithdrawalsCredentials = do - unsafeFromList Haskell.<$> arbitraryHexStrings + unsafeFromList Haskell.<$> arbitraryHexStrings treasuryWithdrawalsCtxGen :: Gen ScriptContext -treasuryWithdrawalsCtxGen = V3.ScriptContext - Haskell.<$> arbitraryTxInfo - Haskell.<*> arbitraryRedeemer - Haskell.<*> twInfo +treasuryWithdrawalsCtxGen = + V3.ScriptContext + Haskell.<$> arbitraryTxInfo + Haskell.<*> arbitraryRedeemer + Haskell.<*> twInfo twInfo :: Gen ScriptInfo twInfo = ProposingScript zero Haskell.<$> twProposalProcedure twProposalProcedure :: Gen ProposalProcedure -twProposalProcedure = ProposalProcedure zero - Haskell.<$> arbitraryCredential - Haskell.<*> twAction +twProposalProcedure = + ProposalProcedure zero + Haskell.<$> arbitraryCredential + Haskell.<*> twAction arbitraryChangedParameters :: Gen ChangedParameters -arbitraryChangedParameters = ChangedParameters Haskell.<$> frequency - [ (1, Haskell.pure (Tx.toBuiltinData (Tx.mkList []))) -- negative testing - , (1, Haskell.pure (Tx.toBuiltinData (Tx.mkI zero))) -- negative testing +arbitraryChangedParameters = + ChangedParameters + Haskell.<$> frequency + [ (1, Haskell.pure (Tx.toBuiltinData (Tx.mkList []))) -- negative testing + , (1, Haskell.pure (Tx.toBuiltinData (Tx.mkI zero))) -- negative testing -- See guarantees (2) and (3) in README.md - , (10, Tx.toBuiltinData - -- sort the random Map, see guarantee (3) in README.md - -- Ugly code, but we want to use an external sorting function here (GHC stdlib) - -- because we do not want to rely for our tests on - -- our experimental `PlutusTx.SortedMap` sorting functions. - -- NOTE: do not use safeFromList; it destroys sortedness. - . AssocMap.unsafeFromList . List.sortOn fst . AssocMap.toList - -- using safeFromList here de-deduplicates the Map, - -- See guarantee (2) in README.md - -- See Note [Why de-duplicated ChangedParameters] - . AssocMap.safeFromList - Haskell.<$> listOf arbitraryChangedParameter) - ] + , + ( 10 + , Tx.toBuiltinData + -- sort the random Map, see guarantee (3) in README.md + -- Ugly code, but we want to use an external sorting function here (GHC stdlib) + -- because we do not want to rely for our tests on + -- our experimental `PlutusTx.SortedMap` sorting functions. + -- NOTE: do not use safeFromList; it destroys sortedness. + . AssocMap.unsafeFromList + . List.sortOn fst + . AssocMap.toList + -- using safeFromList here de-deduplicates the Map, + -- See guarantee (2) in README.md + -- See Note [Why de-duplicated ChangedParameters] + . AssocMap.safeFromList + Haskell.<$> listOf arbitraryChangedParameter + ) + ] arbitraryChangedParameter :: Gen (ParamKey, BuiltinData) -arbitraryChangedParameter = (,) - -- TODO: this is too arbitrary, create more plausible keys - Haskell.<$> arbitrary - Haskell.<*> arbitraryParamValue - where - - arbitraryParamValue :: Gen BuiltinData - arbitraryParamValue = - frequency [ - (2, arbitraryLeaf) - , (1, arbitraryNode) -- testing subs - ] - where - arbitraryLeaf = oneof [ - -- TODO: this is too arbitrary, create more plausible values - Tx.toBuiltinData Haskell.<$> arbitrary @Integer - -- TODO: this is too arbitrary, create more plausible values - , Haskell.fmap (Tx.toBuiltinData . NonCanonicalRational) . Tx.unsafeRatio - Haskell.<$> arbitrary - -- unsafeRatio err's on zero denominator - Haskell.<*> arbitrary `suchThat` (Haskell./= 0) - ] - -- 1-level nested, arbitrary-level can become too expensive - arbitraryNode = Tx.toBuiltinData Haskell.<$> listOf arbitraryLeaf +arbitraryChangedParameter = + (,) + -- TODO: this is too arbitrary, create more plausible keys + Haskell.<$> arbitrary + Haskell.<*> arbitraryParamValue + where + arbitraryParamValue :: Gen BuiltinData + arbitraryParamValue = + frequency + [ (2, arbitraryLeaf) + , (1, arbitraryNode) -- testing subs + ] + where + arbitraryLeaf = + oneof + [ -- TODO: this is too arbitrary, create more plausible values + Tx.toBuiltinData Haskell.<$> arbitrary @Integer + , -- TODO: this is too arbitrary, create more plausible values + Haskell.fmap (Tx.toBuiltinData . NonCanonicalRational) . Tx.unsafeRatio + Haskell.<$> arbitrary + -- unsafeRatio err's on zero denominator + Haskell.<*> arbitrary `suchThat` (Haskell./= 0) + ] + -- 1-level nested, arbitrary-level can become too expensive + arbitraryNode = Tx.toBuiltinData Haskell.<$> listOf arbitraryLeaf -- | An arbitrary context, focusing mostly on generating proposals for changing parameters newtype FakeProposedContext = FakeProposedContext - { unFakeProposedContext :: V3.ScriptContext - } - deriving newtype (Haskell.Show, ToData) + { unFakeProposedContext :: V3.ScriptContext + } + deriving newtype (Haskell.Show, ToData) -- | Make a fake proposed context given some changed parameters. -- It keeps a) the order of pairs in the input and b) any duplicates in the input list. @@ -203,7 +221,7 @@ newtype FakeProposedContext = FakeProposedContext -- In reality, the ledger guarantees sorted *AND* de-duped ChangedParams. mkFakeParameterChangeContext :: ToData b => [(ParamKey, b)] -> FakeProposedContext mkFakeParameterChangeContext = - mkFakeContextFromGovAction + mkFakeContextFromGovAction . flip (V3.ParameterChange Nothing) Nothing . V3.ChangedParameters . Tx.toBuiltinData @@ -213,7 +231,7 @@ mkFakeParameterChangeContext = mkFakeContextFromGovAction :: V3.GovernanceAction -> FakeProposedContext mkFakeContextFromGovAction = - FakeProposedContext + FakeProposedContext . V3.ScriptContext memptyTxInfo emptyRedeemer . V3.ProposingScript 0 . V3.ProposalProcedure 0 (V3.PubKeyCredential "") @@ -223,7 +241,7 @@ simpleContextWithParam param = ArbitraryContext scriptContext where scriptContext = V3.ScriptContext memptyTxInfo emptyRedeemer arbitraryScriptInfo' - arbitraryScriptInfo' :: ScriptInfo + arbitraryScriptInfo' :: ScriptInfo arbitraryScriptInfo' = ProposingScript zero arbitraryProposalProcedure' arbitraryProposalProcedure' :: ProposalProcedure @@ -232,61 +250,59 @@ simpleContextWithParam param = ArbitraryContext scriptContext arbitraryGovernanceAction' :: GovernanceAction arbitraryGovernanceAction' = ParameterChange Nothing paramChange Nothing - paramChange = ChangedParameters (Tx.toBuiltinData . Tx.unsafeFromList $ param ) + paramChange = ChangedParameters (Tx.toBuiltinData . Tx.unsafeFromList $ param) -withOneParamGen :: ToData a => Gen (ParamKey,a) -> Gen ArbitraryContext +withOneParamGen :: ToData a => Gen (ParamKey, a) -> Gen ArbitraryContext withOneParamGen gen = do - a <- gen - Haskell.pure $ simpleContextWithParam [a] + a <- gen + Haskell.pure $ simpleContextWithParam [a] mkLargeFakeProposal, mkSmallFakeProposal :: ConstitutionConfig -> FakeProposedContext -{-| Constructs a large proposal, that proposes to change *every parameter* mentioned in the given config. - -This proposal will most likely be accepted by the Validators, see `mkChangedParamsFromMinValues`. +-- | Constructs a large proposal, that proposes to change *every parameter* mentioned in the given config. +-- +-- This proposal will most likely be accepted by the Validators, see `mkChangedParamsFromMinValues`. +-- +-- We want this for budget-testing the WORST-CASE scenario. -We want this for budget-testing the WORST-CASE scenario. --} ---TODO: replaced by Guardrails.getFakeLargeParamsChange +-- TODO: replaced by Guardrails.getFakeLargeParamsChange -- ( we can't use it here because of the circular dependency ) mkLargeFakeProposal = mkFakeParameterChangeContext . mkChangedParamsFromMinValues -{-| Constructs a small proposal, that proposes to change *only one parameter* (the first one) mentioned in the given config. - -This proposal will most likely be accepted by the Validators, see `mkChangedParamsFromMinValues`. - -We want this for budget-testing the BEST-CASE scenario. We cannot use an empty proposal, -because all ConstitutionValidators guard *against* empty proposals, so they will never pass and be rejected very early. --} -mkSmallFakeProposal = mkFakeParameterChangeContext - . Haskell.pure - -- arbitrary choose one parameter keyvalue that is the smallest in serialised size - -- this does not necessary lead to smallest execution time, but it is just more explicitly defined than using `head` - . minimumBy (Haskell.compare `on` (BSL.length . serialise . toData)) - . mkChangedParamsFromMinValues - - -{-| This is is used to construct a LARGE ChangedParams. - -It does so by transforming the give constitution config to a Fake Proposal, using this arbitrary method: - -- take the LARGEST `minValue` number (integer or rational) for each (sub-)parameter. -- if a `minValue` predicate is missing, use a `def`ault 0 (if Integer), 0/1 if Rational. - -If this ChangedParams is inputted to a ConstitutionValidator, it will most likely result into a successful execution. -"Most likely" because, the chosen value may interfere with other predicates (notEqual, maxValue). --} +-- | Constructs a small proposal, that proposes to change *only one parameter* (the first one) mentioned in the given config. +-- +-- This proposal will most likely be accepted by the Validators, see `mkChangedParamsFromMinValues`. +-- +-- We want this for budget-testing the BEST-CASE scenario. We cannot use an empty proposal, +-- because all ConstitutionValidators guard *against* empty proposals, so they will never pass and be rejected very early. +mkSmallFakeProposal = + mkFakeParameterChangeContext + . Haskell.pure + -- arbitrary choose one parameter keyvalue that is the smallest in serialised size + -- this does not necessary lead to smallest execution time, but it is just more explicitly defined than using `head` + . minimumBy (Haskell.compare `on` (BSL.length . serialise . toData)) + . mkChangedParamsFromMinValues + +-- | This is is used to construct a LARGE ChangedParams. +-- +-- It does so by transforming the give constitution config to a Fake Proposal, using this arbitrary method: +-- +-- - take the LARGEST `minValue` number (integer or rational) for each (sub-)parameter. +-- - if a `minValue` predicate is missing, use a `def`ault 0 (if Integer), 0/1 if Rational. +-- +-- If this ChangedParams is inputted to a ConstitutionValidator, it will most likely result into a successful execution. +-- "Most likely" because, the chosen value may interfere with other predicates (notEqual, maxValue). mkChangedParamsFromMinValues :: ConstitutionConfig -> [(ParamKey, BuiltinData)] mkChangedParamsFromMinValues = Haskell.fmap (Haskell.second getLargestMinValue) . unConstitutionConfig - where + where getLargestMinValue :: ParamValue -> BuiltinData getLargestMinValue = \case - ParamInteger preds -> toBuiltinData $ maximum $ fromMaybe [0] $ List.lookup MinValue $ unPredicates preds - ParamRational preds -> toBuiltinData $ NonCanonicalRational $ maximum $ fromMaybe [Tx.unsafeRatio 0 1] $ List.lookup MinValue $ unPredicates preds - ParamList values -> toBuiltinData $ Haskell.fmap getLargestMinValue values - -- Currently we only have param 18 as "any". So this generation applies only for 18. - -- Here we try to generate an 1000-integer-list for the 18 parameter. - -- Note: This is not the correct encoding of the 18 parameter, it is only for simulating a large size of proposal. - -- Even with a wrong encoding, it will be accepted by the constitution script, - -- because "any" in the config means accept any encoding: the script does not check the encoding at all. - ParamAny -> toBuiltinData $ replicate 1000 (Haskell.toInteger $ Haskell.maxBound @Int64) + ParamInteger preds -> toBuiltinData $ maximum $ fromMaybe [0] $ List.lookup MinValue $ unPredicates preds + ParamRational preds -> toBuiltinData $ NonCanonicalRational $ maximum $ fromMaybe [Tx.unsafeRatio 0 1] $ List.lookup MinValue $ unPredicates preds + ParamList values -> toBuiltinData $ Haskell.fmap getLargestMinValue values + -- Currently we only have param 18 as "any". So this generation applies only for 18. + -- Here we try to generate an 1000-integer-list for the 18 parameter. + -- Note: This is not the correct encoding of the 18 parameter, it is only for simulating a large size of proposal. + -- Even with a wrong encoding, it will be accepted by the constitution script, + -- because "any" in the config means accept any encoding: the script does not check the encoding at all. + ParamAny -> toBuiltinData $ replicate 1000 (Haskell.toInteger $ Haskell.maxBound @Int64) diff --git a/doc/docusaurus/static/code/AuctionValidator.hs b/doc/docusaurus/static/code/AuctionValidator.hs index 979d7d24218..42ae28b719a 100644 --- a/doc/docusaurus/static/code/AuctionValidator.hs +++ b/doc/docusaurus/static/code/AuctionValidator.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} @@ -34,15 +34,34 @@ import PlutusTx.Prelude import PlutusLedgerApi.V1 (lovelaceValueOf, toPubKeyHash, valueOf) import PlutusLedgerApi.V1.Interval (contains) -import PlutusLedgerApi.V3 (CurrencySymbol, Datum (Datum, getDatum), Lovelace, - OutputDatum (NoOutputDatum, OutputDatum, OutputDatumHash), POSIXTime, - PubKeyHash, Redeemer (getRedeemer), ScriptContext (..), - ScriptInfo (SpendingScript), TokenName, - TxInfo (txInfoOutputs, txInfoValidRange), - TxOut (txOutAddress, txOutDatum, txOutValue), from, to) +import PlutusLedgerApi.V3 ( + CurrencySymbol, + Datum (Datum, getDatum), + Lovelace, + OutputDatum (NoOutputDatum, OutputDatum, OutputDatumHash), + POSIXTime, + PubKeyHash, + Redeemer (getRedeemer), + ScriptContext (..), + ScriptInfo (SpendingScript), + TokenName, + TxInfo (txInfoOutputs, txInfoValidRange), + TxOut (txOutAddress, txOutDatum, txOutValue), + from, + to, + ) import PlutusLedgerApi.V3.Contexts (getContinuingOutputs) -import PlutusTx (CompiledCode, FromData (..), ToData, UnsafeFromData (..), compile, liftCodeDef, - makeIsDataSchemaIndexed, makeLift, unsafeApplyCode) +import PlutusTx ( + CompiledCode, + FromData (..), + ToData, + UnsafeFromData (..), + compile, + liftCodeDef, + makeIsDataSchemaIndexed, + makeLift, + unsafeApplyCode, + ) import PlutusTx.AsData qualified as PlutusTx import PlutusTx.Blueprint (HasBlueprintDefinition, definitionRef) import PlutusTx.List qualified as List @@ -52,17 +71,17 @@ import PlutusTx.Show qualified as PlutusTx -- BLOCK1 -- AuctionValidator.hs data AuctionParams = AuctionParams - { apSeller :: PubKeyHash + { apSeller :: PubKeyHash -- ^ Seller's public key hash. The highest bid (if exists) will be sent to the seller. -- If there is no bid, the asset auctioned will be sent to the seller. , apCurrencySymbol :: CurrencySymbol -- ^ The currency symbol of the token being auctioned. - , apTokenName :: TokenName + , apTokenName :: TokenName -- ^ The name of the token being auctioned. -- These can all be encoded as a `Value`. - , apMinBid :: Lovelace + , apMinBid :: Lovelace -- ^ The minimum bid in Lovelace. - , apEndTime :: POSIXTime + , apEndTime :: POSIXTime -- ^ The deadline for placing a bid. This is the earliest time the auction can be closed. } deriving stock (Generic) @@ -72,9 +91,9 @@ PlutusTx.makeLift ''AuctionParams PlutusTx.makeIsDataSchemaIndexed ''AuctionParams [('AuctionParams, 0)] data Bid = Bid - { bAddr :: PlutusTx.BuiltinByteString + { bAddr :: PlutusTx.BuiltinByteString -- ^ Bidder's wallet address - , bPkh :: PubKeyHash + , bPkh :: PubKeyHash -- ^ Bidder's public key hash. , bAmount :: Lovelace -- ^ Bid amount in Lovelace. @@ -93,9 +112,8 @@ instance PlutusTx.Eq Bid where PlutusTx.&& bAmount bid PlutusTx.== bAmount bid' -{- | Datum represents the state of a smart contract. In this case -it contains the highest bid so far (if exists). --} +-- | Datum represents the state of a smart contract. In this case +-- it contains the highest bid so far (if exists). newtype AuctionDatum = AuctionDatum {adHighestBid :: Maybe Bid} deriving stock (Generic) deriving newtype @@ -105,10 +123,9 @@ newtype AuctionDatum = AuctionDatum {adHighestBid :: Maybe Bid} , PlutusTx.UnsafeFromData ) -{- | Redeemer is the input that changes the state of a smart contract. -In this case it is either a new bid, or a request to close the auction -and pay out the seller and the highest bidder. --} +-- | Redeemer is the input that changes the state of a smart contract. +-- In this case it is either a new bid, or a request to close the auction +-- and pay out the seller and the highest bidder. data AuctionRedeemer = NewBid Bid | Payout deriving stock (Generic) deriving anyclass (HasBlueprintDefinition) @@ -119,9 +136,8 @@ PlutusTx.makeIsDataSchemaIndexed ''AuctionRedeemer [('NewBid, 0), ('Payout, 1)] -- AuctionValidator.hs {-# INLINEABLE auctionTypedValidator #-} -{- | Given the auction parameters, determines whether the transaction is allowed to -spend the UTXO. --} +-- | Given the auction parameters, determines whether the transaction is allowed to +-- spend the UTXO. auctionTypedValidator :: AuctionParams -> AuctionDatum -> @@ -151,18 +167,18 @@ auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx = List.and c , -- The highest bidder gets the asset. highestBidderGetsAsset ] --- BLOCK3 --- AuctionValidator.hs + -- BLOCK3 + -- AuctionValidator.hs sufficientBid :: Bid -> Bool sufficientBid (Bid _ _ amt) = case highestBid of Just (Bid _ _ amt') -> amt PlutusTx.> amt' - Nothing -> amt PlutusTx.>= apMinBid params --- BLOCK4 --- AuctionValidator.hs + Nothing -> amt PlutusTx.>= apMinBid params + -- BLOCK4 + -- AuctionValidator.hs validBidTime :: Bool ~validBidTime = to (apEndTime params) `contains` txInfoValidRange (scriptContextTxInfo ctx) --- BLOCK5 --- AuctionValidator.hs + -- BLOCK5 + -- AuctionValidator.hs refundsPreviousHighestBid :: Bool ~refundsPreviousHighestBid = case highestBid of Nothing -> True @@ -173,10 +189,10 @@ auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx = List.and c PlutusTx.&& (lovelaceValueOf (txOutValue o) PlutusTx.== amt) ) (txInfoOutputs (scriptContextTxInfo ctx)) of - Just _ -> True + Just _ -> True Nothing -> PlutusTx.traceError "Not found: refund output" --- BLOCK6 --- AuctionValidator.hs + -- BLOCK6 + -- AuctionValidator.hs currencySymbol :: CurrencySymbol currencySymbol = apCurrencySymbol params @@ -212,8 +228,8 @@ auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx = List.and c ( "Expected exactly one continuing output, got " PlutusTx.<> PlutusTx.show (List.length os) ) --- BLOCK7 --- AuctionValidator.hs + -- BLOCK7 + -- AuctionValidator.hs validPayoutTime :: Bool ~validPayoutTime = from (apEndTime params) `contains` txInfoValidRange (scriptContextTxInfo ctx) @@ -227,14 +243,14 @@ auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx = List.and c PlutusTx.&& (lovelaceValueOf (txOutValue o) PlutusTx.== bAmount bid) ) (txInfoOutputs (scriptContextTxInfo ctx)) of - Just _ -> True + Just _ -> True Nothing -> PlutusTx.traceError "Not found: Output paid to seller" highestBidderGetsAsset :: Bool ~highestBidderGetsAsset = let highestBidder = case highestBid of -- If there are no bids, the asset should go back to the seller - Nothing -> apSeller params + Nothing -> apSeller params Just bid -> bPkh bid in case List.find ( \o -> @@ -242,7 +258,7 @@ auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx = List.and c PlutusTx.&& (valueOf (txOutValue o) currencySymbol tokenName PlutusTx.== 1) ) (txInfoOutputs (scriptContextTxInfo ctx)) of - Just _ -> True + Just _ -> True Nothing -> PlutusTx.traceError "Not found: Output paid to highest bidder" -- BLOCK8 @@ -263,7 +279,6 @@ auctionUntypedValidator params ctx = auctionRedeemer :: AuctionRedeemer auctionRedeemer = PlutusTx.unsafeFromBuiltinData (getRedeemer (scriptContextRedeemer scriptContext)) - {-# INLINEABLE auctionUntypedValidator #-} auctionValidatorScript :: AuctionParams -> CompiledCode (BuiltinData -> BuiltinUnit) diff --git a/doc/docusaurus/static/code/BasicPlutusTx.hs b/doc/docusaurus/static/code/BasicPlutusTx.hs index 21c34208e7a..aaf746e6f28 100644 --- a/doc/docusaurus/static/code/BasicPlutusTx.hs +++ b/doc/docusaurus/static/code/BasicPlutusTx.hs @@ -1,20 +1,22 @@ -- BLOCK1 -- Necessary language extensions for the Plutus Tx compiler to work. -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} module BasicPlutusTx where import PlutusCore.Version (plcVersion100) + -- Main Plutus Tx module. import PlutusTx + -- Builtin functions. import PlutusTx.Builtins + -- The Plutus Tx Prelude, discussed further below. import PlutusTx.Prelude @@ -23,28 +25,30 @@ integerOne :: CompiledCode Integer {- 'compile' turns the 'TExpQ Integer' into a 'TExpQ (CompiledCode Integer)' and the splice inserts it into the program. -} -integerOne = $$(compile - {- The quote has type 'TExpQ Integer'. - We always use unbounded integers in Plutus Core, so we have to pin - down this numeric literal to an ``Integer`` rather than an ``Int``. -} - [|| (1 :: Integer) ||]) - -{- | ->>> pretty $ getPlc integerOne -(program 1.0.0 - (con 1) -) --} +integerOne = + $$( compile + {- The quote has type 'TExpQ Integer'. + We always use unbounded integers in Plutus Core, so we have to pin + down this numeric literal to an ``Integer`` rather than an ``Int``. -} + [||(1 :: Integer)||] + ) + +-- | +-- >>> pretty $ getPlc integerOne +-- (program 1.0.0 +-- (con 1) +-- ) + -- BLOCK3 integerIdentity :: CompiledCode (Integer -> Integer) -integerIdentity = $$(compile [|| \(x:: Integer) -> x ||]) - -{- | ->>> pretty $ getPlc integerIdentity -(program 1.0.0 - (lam ds (con integer) ds) -) --} +integerIdentity = $$(compile [||\(x :: Integer) -> x||]) + +-- | +-- >>> pretty $ getPlc integerIdentity +-- (program 1.0.0 +-- (lam ds (con integer) ds) +-- ) + -- BLOCK4 {- Functions which will be used in Plutus Tx programs should be marked with GHC’s 'INLINABLE' pragma. This is usually necessary for @@ -56,59 +60,79 @@ plusOne :: Integer -> Integer {- 'addInteger' comes from 'PlutusTx.Builtins', and is mapped to the builtin integer addition function in Plutus Core. -} plusOne x = x `addInteger` 1 -{-# INLINABLE plusOne #-} +{-# INLINEABLE plusOne #-} myProgram :: Integer myProgram = - let - -- Local functions do not need to be marked as 'INLINABLE'. - plusOneLocal :: Integer -> Integer - plusOneLocal x = x `addInteger` 1 + let + -- Local functions do not need to be marked as 'INLINABLE'. + plusOneLocal :: Integer -> Integer + plusOneLocal x = x `addInteger` 1 - localTwo = plusOneLocal 1 - externalTwo = plusOne 1 - in localTwo `addInteger` externalTwo -{-# INLINABLE myProgram #-} + localTwo = plusOneLocal 1 + externalTwo = plusOne 1 + in + localTwo `addInteger` externalTwo +{-# INLINEABLE myProgram #-} functions :: CompiledCode Integer -functions = $$(compile [|| myProgram ||]) +functions = $$(compile [||myProgram||]) {- We’ve used the CK evaluator for Plutus Core to evaluate the program and check that the result was what we expected. -} -{- | ->>> pretty $ unsafeEvaluateCk $ toTerm $ getPlc functions -(con 4) --} + +-- | +-- >>> pretty $ unsafeEvaluateCk $ toTerm $ getPlc functions +-- (con 4) + -- BLOCK5 matchMaybe :: CompiledCode (Maybe Integer -> Integer) -matchMaybe = $$(compile [|| \(x:: Maybe Integer) -> case x of - Just n -> n - Nothing -> 0 - ||]) +matchMaybe = + $$( compile + [|| + \(x :: Maybe Integer) -> case x of + Just n -> n + Nothing -> 0 + ||] + ) + -- BLOCK6 + -- | Either a specific end date, or "never". data EndDate = Fixed Integer | Never -- | Check whether a given time is past the end date. pastEnd :: CompiledCode (EndDate -> Integer -> Bool) -pastEnd = $$(compile [|| \(end::EndDate) (current::Integer) -> case end of - Fixed n -> n `lessThanEqualsInteger` current - Never -> False - ||]) +pastEnd = + $$( compile + [|| + \(end :: EndDate) (current :: Integer) -> case end of + Fixed n -> n `lessThanEqualsInteger` current + Never -> False + ||] + ) + -- BLOCK7 + -- | Check whether a given time is past the end date. pastEnd' :: CompiledCode (EndDate -> Integer -> Bool) -pastEnd' = $$(compile [|| \(end::EndDate) (current::Integer) -> case end of - Fixed n -> n < current - Never -> False - ||]) +pastEnd' = + $$( compile + [|| + \(end :: EndDate) (current :: Integer) -> case end of + Fixed n -> n < current + Never -> False + ||] + ) + -- BLOCK8 addOne :: CompiledCode (Integer -> Integer) -addOne = $$(compile [|| \(x:: Integer) -> x `addInteger` 1 ||]) +addOne = $$(compile [||\(x :: Integer) -> x `addInteger` 1||]) + -- BLOCK9 addOneToN :: Integer -> CompiledCode Integer addOneToN n = - addOne + addOne -- 'unsafeApplyCode' applies one 'CompiledCode' to another. `unsafeApplyCode` -- 'liftCode' lifts the argument 'n' into a @@ -117,61 +141,59 @@ addOneToN n = -- can use 'liftCodeDef' liftCode plcVersion100 n -{- | ->>> pretty $ getPlc addOne -(program 1.0.0 - [ - (lam - addInteger - (fun (con integer) (fun (con integer) (con integer))) - (lam ds (con integer) [ [ addInteger ds ] (con 1) ]) - ) - (lam - arg - (con integer) - (lam arg (con integer) [ [ (builtin addInteger) arg ] arg ]) - ) - ] -) ->>> let program = getPlc $ addOneToN 4 ->>> pretty program -(program 1.0.0 - [ - [ - (lam - addInteger - (fun (con integer) (fun (con integer) (con integer))) - (lam ds (con integer) [ [ addInteger ds ] (con 1) ]) - ) - (lam - arg - (con integer) - (lam arg (con integer) [ [ (builtin addInteger) arg ] arg ]) - ) - ] - (con 4) - ] -) ->>> pretty $ unsafeEvaluateCk $ toTerm program -(con 5) --} +-- | +-- >>> pretty $ getPlc addOne +-- (program 1.0.0 +-- [ +-- (lam +-- addInteger +-- (fun (con integer) (fun (con integer) (con integer))) +-- (lam ds (con integer) [ [ addInteger ds ] (con 1) ]) +-- ) +-- (lam +-- arg +-- (con integer) +-- (lam arg (con integer) [ [ (builtin addInteger) arg ] arg ]) +-- ) +-- ] +-- ) +-- >>> let program = getPlc $ addOneToN 4 +-- >>> pretty program +-- (program 1.0.0 +-- [ +-- [ +-- (lam +-- addInteger +-- (fun (con integer) (fun (con integer) (con integer))) +-- (lam ds (con integer) [ [ addInteger ds ] (con 1) ]) +-- ) +-- (lam +-- arg +-- (con integer) +-- (lam arg (con integer) [ [ (builtin addInteger) arg ] arg ]) +-- ) +-- ] +-- (con 4) +-- ] +-- ) +-- >>> pretty $ unsafeEvaluateCk $ toTerm program +-- (con 5) + -- BLOCK10 -- 'makeLift' generates instances of 'Lift' automatically. makeLift ''EndDate pastEndAt :: EndDate -> Integer -> CompiledCode Bool pastEndAt end current = - pastEnd - `unsafeApplyCode` - liftCode plcVersion100 end - `unsafeApplyCode` - liftCode plcVersion100 current - -{- | ->>> let program = getPlc $ pastEndAt Never 5 ->>> pretty $ unsafeEvaluateCk $ toTerm program -(abs - out_Bool (type) (lam case_True out_Bool (lam case_False out_Bool case_False)) -) --} + pastEnd + `unsafeApplyCode` liftCode plcVersion100 end + `unsafeApplyCode` liftCode plcVersion100 current + +-- | +-- >>> let program = getPlc $ pastEndAt Never 5 +-- >>> pretty $ unsafeEvaluateCk $ toTerm program +-- (abs +-- out_Bool (type) (lam case_True out_Bool (lam case_False out_Bool case_False)) +-- ) + -- BLOCK11 diff --git a/doc/docusaurus/static/code/BasicPolicies.hs b/doc/docusaurus/static/code/BasicPolicies.hs index 79a1b922750..fb5f5ddff5c 100644 --- a/doc/docusaurus/static/code/BasicPolicies.hs +++ b/doc/docusaurus/static/code/BasicPolicies.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} + module BasicPolicies where import PlutusTx @@ -22,34 +23,37 @@ key = error () -- BLOCK1 oneAtATimePolicy :: () -> ScriptContext -> Bool oneAtATimePolicy _ ctx = - -- 'ownCurrencySymbol' lets us get our own hash (= currency symbol) - -- from the context - let ownSymbol = ownCurrencySymbol ctx - txinfo = scriptContextTxInfo ctx - minted = txInfoMint txinfo - -- Here we're looking at some specific token name, which we - -- will assume we've got from elsewhere for now. - in currencyValueOf minted ownSymbol == singleton ownSymbol tname 1 + -- 'ownCurrencySymbol' lets us get our own hash (= currency symbol) + -- from the context + let ownSymbol = ownCurrencySymbol ctx + txinfo = scriptContextTxInfo ctx + minted = txInfoMint txinfo + in -- Here we're looking at some specific token name, which we + -- will assume we've got from elsewhere for now. + currencyValueOf minted ownSymbol == singleton ownSymbol tname 1 -- | Get the quantities of just the given 'CurrencySymbol' in the 'Value'. currencyValueOf :: Value -> CurrencySymbol -> Value currencyValueOf (Value m) c = case Map.lookup c m of - Nothing -> mempty - Just t -> Value (Map.singleton c t) -{-# INLINABLE currencyValueOf #-} + Nothing -> mempty + Just t -> Value (Map.singleton c t) +{-# INLINEABLE currencyValueOf #-} + -- BLOCK2 -- The 'plutus-ledger' package from 'plutus-apps' provides helper functions to automate -- some of this boilerplate. oneAtATimePolicyUntyped :: BuiltinData -> BuiltinData -> BuiltinUnit -- 'check' fails with 'error' if the argument is not 'True'. oneAtATimePolicyUntyped r c = - check $ oneAtATimePolicy (unsafeFromBuiltinData r) (unsafeFromBuiltinData c) + check $ oneAtATimePolicy (unsafeFromBuiltinData r) (unsafeFromBuiltinData c) -- We can use 'compile' to turn a minting policy into a compiled Plutus Core program, -- just as for validator scripts. oneAtATimeCompiled :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinUnit) -oneAtATimeCompiled = $$(compile [|| oneAtATimePolicyUntyped ||]) +oneAtATimeCompiled = $$(compile [||oneAtATimePolicyUntyped||]) + -- BLOCK3 singleSignerPolicy :: () -> ScriptContext -> Bool singleSignerPolicy _ ctx = txSignedBy (scriptContextTxInfo ctx) key + -- BLOCK4 diff --git a/doc/docusaurus/static/code/BasicValidators.hs b/doc/docusaurus/static/code/BasicValidators.hs index 5e5e3a07673..59eeaddaa13 100644 --- a/doc/docusaurus/static/code/BasicValidators.hs +++ b/doc/docusaurus/static/code/BasicValidators.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + module BasicValidators where import PlutusTx @@ -25,8 +26,10 @@ myKeyHash :: PubKeyHash myKeyHash = Haskell.undefined -- BLOCK1 + -- | A specific date. newtype Date = Date Integer + -- | Either a specific end date, or "never". data EndDate = Fixed Integer | Never @@ -36,6 +39,7 @@ data EndDate = Fixed Integer | Never -- which ensures that the output is stable across time. unstableMakeIsData ''Date unstableMakeIsData ''EndDate + -- BLOCK2 alwaysSucceeds :: BuiltinData -> BuiltinData -> BuiltinData -> () alwaysSucceeds _ _ _ = () @@ -46,35 +50,39 @@ alwaysFails _ _ _ = error () -- We can use 'compile' to turn a validator function into a compiled Plutus Core program. -- Here's a reminder of how to do it. alwaysSucceedsCompiled :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -alwaysSucceedsCompiled = $$(compile [|| alwaysSucceeds ||]) +alwaysSucceedsCompiled = $$(compile [||alwaysSucceeds||]) + -- BLOCK3 + -- | Checks if a date is before the given end date. beforeEnd :: Date -> EndDate -> Bool beforeEnd (Date d) (Fixed e) = d <= e -beforeEnd (Date _) Never = True +beforeEnd (Date _) Never = True -- | Check that the date in the redeemer is before the limit in the datum. validateDate :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit -- The 'check' function takes a 'Bool' and fails if it is false. -- This is handy since it's more natural to talk about booleans. validateDate datum redeemer _ = - check $ beforeEnd (unsafeFromBuiltinData datum) (unsafeFromBuiltinData redeemer) + check $ beforeEnd (unsafeFromBuiltinData datum) (unsafeFromBuiltinData redeemer) dateValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit) -dateValidator = $$(compile [|| validateDate ||]) +dateValidator = $$(compile [||validateDate||]) + -- BLOCK4 validatePayment :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit validatePayment _ _ ctx = - let valCtx = unsafeFromBuiltinData ctx - -- The 'TxInfo' in the validation context is the representation of the - -- transaction being validated - txinfo = scriptContextTxInfo valCtx - -- 'pubKeyOutputsAt' collects the 'Value' at all outputs which pay to - -- the given public key hash - values = pubKeyOutputsAt myKeyHash txinfo - -- 'fold' sums up all the values, we assert that there must be more - -- than 1 Ada (more stuff is fine!) - in check $ lovelaceValueOf (fold values) >= 1_000_000 + let valCtx = unsafeFromBuiltinData ctx + -- The 'TxInfo' in the validation context is the representation of the + -- transaction being validated + txinfo = scriptContextTxInfo valCtx + -- 'pubKeyOutputsAt' collects the 'Value' at all outputs which pay to + -- the given public key hash + values = pubKeyOutputsAt myKeyHash txinfo + in -- 'fold' sums up all the values, we assert that there must be more + -- than 1 Ada (more stuff is fine!) + check $ lovelaceValueOf (fold values) >= 1_000_000 + --- BLOCK5 -- We can serialize a 'Validator' directly to CBOR serialisedDateValidator :: SerialisedScript @@ -83,9 +91,11 @@ serialisedDateValidator = serialiseCompiledCode dateValidator -- The serialized forms can be written or read using normal Haskell IO functionality. showSerialised :: IO () showSerialised = print serialisedDateValidator + -- BLOCK6 -- The 'loadFromFile' function is a drop-in replacement for 'compile', but -- takes the file path instead of the code to compile. validatorCodeFromFile :: CompiledCode (() -> () -> ScriptContext -> Bool) validatorCodeFromFile = $$(loadFromFile "static/code/myscript.uplc") + -- BLOCK7 diff --git a/doc/docusaurus/static/code/Example/Builtin/Array/Main.hs b/doc/docusaurus/static/code/Example/Builtin/Array/Main.hs index b5e74c670c4..ab38181360c 100644 --- a/doc/docusaurus/static/code/Example/Builtin/Array/Main.hs +++ b/doc/docusaurus/static/code/Example/Builtin/Array/Main.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} @@ -30,23 +30,23 @@ import Unsafe.Coerce (unsafeCoerce) usesSopList :: Plinth.CompiledCode Integer usesSopList = $$(Plinth.compile [||lookupByIndex sopListOfInts||]) - where - lookupByIndex :: [Integer] -> Integer - lookupByIndex xs = xs SOP.!! 99 + where + lookupByIndex :: [Integer] -> Integer + lookupByIndex xs = xs SOP.!! 99 usesBuiltinList :: Plinth.CompiledCode Integer usesBuiltinList = $$(Plinth.compile [||lookupByIndex (toOpaque sopListOfInts)||]) - where - lookupByIndex :: BuiltinList Integer -> Integer - lookupByIndex xs = xs BuiltinList.!! 99 + where + lookupByIndex :: BuiltinList Integer -> Integer + lookupByIndex xs = xs BuiltinList.!! 99 usesArray :: Plinth.CompiledCode Integer usesArray = $$(Plinth.compile [||lookupByIndex (sopListToArray sopListOfInts)||]) - where - lookupByIndex :: BuiltinArray Integer -> Integer - lookupByIndex xs = indexArray xs 99 + where + lookupByIndex :: BuiltinArray Integer -> Integer + lookupByIndex xs = indexArray xs 99 sopListConstruction :: Plinth.CompiledCode [Integer] sopListConstruction = $$(Plinth.compile [||sopListOfInts||]) @@ -145,23 +145,23 @@ printPercentage oldResult newResult = do putStrLn $ improvementPercentage cpuOld cpuNew putStr "MEM change: " putStrLn $ improvementPercentage memOld memNew - where - improvementPercentage :: Double -> Double -> String - improvementPercentage old new = - printf "%+.2f" ((new - old) / old * 100.0) <> " %" - - evalResultToCpuMem :: ExBudget -> (Double, Double) - evalResultToCpuMem - ExBudget - { exBudgetCPU = ExCPU cpu - , exBudgetMemory = ExMemory mem - } = (toDouble cpu, toDouble mem) - where - toDouble :: CostingInteger -> Double - toDouble x = fromIntegral (unsafeCoerce x :: Int) + where + improvementPercentage :: Double -> Double -> String + improvementPercentage old new = + printf "%+.2f" ((new - old) / old * 100.0) <> " %" + + evalResultToCpuMem :: ExBudget -> (Double, Double) + evalResultToCpuMem + ExBudget + { exBudgetCPU = ExCPU cpu + , exBudgetMemory = ExMemory mem + } = (toDouble cpu, toDouble mem) + where + toDouble :: CostingInteger -> Double + toDouble x = fromIntegral (unsafeCoerce x :: Int) subtractBudget :: ExBudget -> ExBudget -> ExBudget subtractBudget - ExBudget{exBudgetCPU = ExCPU cpu1, exBudgetMemory = ExMemory mem1} - ExBudget{exBudgetCPU = ExCPU cpu2, exBudgetMemory = ExMemory mem2} = + ExBudget {exBudgetCPU = ExCPU cpu1, exBudgetMemory = ExMemory mem1} + ExBudget {exBudgetCPU = ExCPU cpu2, exBudgetMemory = ExMemory mem2} = ExBudget (ExCPU (cpu1 - cpu2)) (ExMemory (mem1 - mem2)) diff --git a/doc/docusaurus/static/code/Example/Cip57/Blueprint/Main.hs b/doc/docusaurus/static/code/Example/Cip57/Blueprint/Main.hs index 034df82f159..9621c791e13 100644 --- a/doc/docusaurus/static/code/Example/Cip57/Blueprint/Main.hs +++ b/doc/docusaurus/static/code/Example/Cip57/Blueprint/Main.hs @@ -1,24 +1,24 @@ -- BEGIN pragmas -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -74,30 +74,30 @@ type MyDatum = Integer data MyRedeemer = R0 | R1 V3.Lovelace | R2 V3.Value data MyParams = MkMyParams - { myBool :: Bool - , myInteger :: Integer - , myMap :: Map Integer Bool - , myDCert :: V1.DCert - , myScriptTag :: V1.ScriptTag - , myRedeemerPtr :: V1.RedeemerPtr - , myDiffMillis :: V1.DiffMilliSeconds - , myTxId :: V3.TxId - , myTokenName :: V3.TokenName - , myAddress :: V3.Address - , myPubKey :: V3.PubKeyHash - , myPOSIXTime :: V3.POSIXTime - , myLedgerBytes :: V3.LedgerBytes - , myCredential :: V3.Credential - , myDatum :: V3.Datum - , myLovelace :: V3.Lovelace - , myInterval :: V3.Interval Integer - , myScriptHash :: V3.ScriptHash - , myRedeemer :: V3.Redeemer - , myRedeemerHash :: V3.RedeemerHash - , myDatum_ :: V3.Datum - , myDatumHash :: V3.DatumHash - , myTxInInfo :: V3.TxInInfo - , myTxInfo :: V3.TxInfo + { myBool :: Bool + , myInteger :: Integer + , myMap :: Map Integer Bool + , myDCert :: V1.DCert + , myScriptTag :: V1.ScriptTag + , myRedeemerPtr :: V1.RedeemerPtr + , myDiffMillis :: V1.DiffMilliSeconds + , myTxId :: V3.TxId + , myTokenName :: V3.TokenName + , myAddress :: V3.Address + , myPubKey :: V3.PubKeyHash + , myPOSIXTime :: V3.POSIXTime + , myLedgerBytes :: V3.LedgerBytes + , myCredential :: V3.Credential + , myDatum :: V3.Datum + , myLovelace :: V3.Lovelace + , myInterval :: V3.Interval Integer + , myScriptHash :: V3.ScriptHash + , myRedeemer :: V3.Redeemer + , myRedeemerHash :: V3.RedeemerHash + , myDatum_ :: V3.Datum + , myDatumHash :: V3.DatumHash + , myTxInInfo :: V3.TxInInfo + , myTxInfo :: V3.TxInfo , myScriptPurpose :: V3.ScriptPurpose , myScriptContext :: V3.ScriptContext } @@ -121,11 +121,11 @@ deriving anyclass instance HasBlueprintDefinition MyRedeemer -- BEGIN validator typedValidator :: MyParams -> MyDatum -> MyRedeemer -> Bool -typedValidator MkMyParams{..} datum redeemer = +typedValidator MkMyParams {..} datum redeemer = case redeemer of - R0 -> myBool - R1{} -> myBool - R2{} -> myInteger == datum + R0 -> myBool + R1 {} -> myBool + R2 {} -> myInteger == datum untypedValidator :: MyParams -> BuiltinData -> BuiltinUnit untypedValidator params scriptContext = diff --git a/doc/docusaurus/static/code/Example/Evaluation/Main.hs b/doc/docusaurus/static/code/Example/Evaluation/Main.hs index f580b094b98..ce00558e0b2 100644 --- a/doc/docusaurus/static/code/Example/Evaluation/Main.hs +++ b/doc/docusaurus/static/code/Example/Evaluation/Main.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} @@ -76,9 +76,9 @@ argumentLifted = liftCodeDef 2 errorOrResult :: Either String EvalResult errorOrResult = fmap evaluateCompiledCode appliedSafely - where - appliedSafely :: Either String (CompiledCode Integer) - appliedSafely = compiledCode `applyCode` argumentLifted + where + appliedSafely :: Either String (CompiledCode Integer) + appliedSafely = compiledCode `applyCode` argumentLifted -- END SafeApplicationResult @@ -86,9 +86,9 @@ errorOrResult = fmap evaluateCompiledCode appliedSafely result :: EvalResult result = evaluateCompiledCode appliedUnsafely - where - appliedUnsafely :: CompiledCode Integer - appliedUnsafely = compiledCode `unsafeApplyCode` argumentCompiled + where + appliedUnsafely :: CompiledCode Integer + appliedUnsafely = compiledCode `unsafeApplyCode` argumentCompiled -- END UnsafeApplicationResult @@ -110,11 +110,10 @@ main = do Text.putStrLn "the latest Protocol Version evaluation:" Text.putStrLn "--------------------------------------------" Text.putStrLn $ displayEvalResult result --- END PrintResult + -- END PrintResult Text.putStrLn "" Text.putStrLn "Simulating PlutusV2 / Alonzo Protocol Version evaluation:" Text.putStrLn "--------------------------------------------------------" Text.putStrLn $ displayEvalResult resultV2 Text.putStrLn "" - diff --git a/doc/docusaurus/static/code/QuickStart.hs b/doc/docusaurus/static/code/QuickStart.hs index 188136569d5..cb260696349 100644 --- a/doc/docusaurus/static/code/QuickStart.hs +++ b/doc/docusaurus/static/code/QuickStart.hs @@ -1,7 +1,7 @@ -- BLOCK1 {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} module Main where @@ -17,32 +17,34 @@ import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteStringHex) main :: IO () main = - B.writeFile "validator.uplc.hex" - $ Base16.encode - $ BS.fromShort - $ serialiseCompiledCode - $ auctionValidatorScript AuctionParams - { apSeller = - -- Replace with the hex-encoded seller's public key hash: - Crypto.PubKeyHash ( - stringToBuiltinByteStringHex - "0000000000000000000000000000000000000000\ - \0000000000000000000000000000000000000000" - ) - , apCurrencySymbol = - -- Replace with your desired currency symbol (minting policy hash): - Value.CurrencySymbol ( - stringToBuiltinByteStringHex - "00000000000000000000000000000000000000000000000000000000" - ) - , apTokenName = - -- Replace with your desired token name: - Value.tokenName "MY_TOKEN" - , apMinBid = - -- Minimal bid in lovelace: - 100 - , apEndTime = - -- Replace with your desired end time in milliseconds: - Time.fromMilliSeconds 1_725_227_091_000 - } + B.writeFile "validator.uplc.hex" $ + Base16.encode $ + BS.fromShort $ + serialiseCompiledCode $ + auctionValidatorScript + AuctionParams + { apSeller = + -- Replace with the hex-encoded seller's public key hash: + Crypto.PubKeyHash + ( stringToBuiltinByteStringHex + "0000000000000000000000000000000000000000\ + \0000000000000000000000000000000000000000" + ) + , apCurrencySymbol = + -- Replace with your desired currency symbol (minting policy hash): + Value.CurrencySymbol + ( stringToBuiltinByteStringHex + "00000000000000000000000000000000000000000000000000000000" + ) + , apTokenName = + -- Replace with your desired token name: + Value.tokenName "MY_TOKEN" + , apMinBid = + -- Minimal bid in lovelace: + 100 + , apEndTime = + -- Replace with your desired end time in milliseconds: + Time.fromMilliSeconds 1_725_227_091_000 + } + -- BLOCK2 diff --git a/doc/notes/fomega/app/Main.hs b/doc/notes/fomega/app/Main.hs index 7d1bae41e6f..6dabcac65fa 100644 --- a/doc/notes/fomega/app/Main.hs +++ b/doc/notes/fomega/app/Main.hs @@ -2,23 +2,15 @@ import Examples main :: IO () main = do - -- deterministic tests. comment out after first run. - testFixed veryDense [1..10] "worst-case.dat" - testFixed thinCycle [1..20] "small-nontrivial.dat" - testFixed diagonal [1..20] "trivial.dat" - + testFixed veryDense [1 .. 10] "worst-case.dat" + testFixed thinCycle [1 .. 20] "small-nontrivial.dat" + testFixed diagonal [1 .. 20] "trivial.dat" -- randomized tests. - let range = [1..9] -- we test systems of 1..9 types at each density. - times = 100 -- each size/density pairing is run 100 times. + let range = [1 .. 9] -- we test systems of 1..9 types at each density. + times = 100 -- each size/density pairing is run 100 times. test :: Probability -> IO () test density = testRandom range times density ("density " ++ (show density) ++ ".dat") - mapM_ test [10,20,30,40,50,60,70,80,90] - - - - - - + mapM_ test [10, 20, 30, 40, 50, 60, 70, 80, 90] diff --git a/doc/notes/fomega/scott-encoding-benchmarks/Benchmarks.hs b/doc/notes/fomega/scott-encoding-benchmarks/Benchmarks.hs index c1a7d62605c..3f60ddecf99 100644 --- a/doc/notes/fomega/scott-encoding-benchmarks/Benchmarks.hs +++ b/doc/notes/fomega/scott-encoding-benchmarks/Benchmarks.hs @@ -11,7 +11,7 @@ import Test.QuickCheck -- Scott Encoding -- -------------------- -newtype SList a = SList (forall r . r -> (a -> SList a -> r) -> r) +newtype SList a = SList (forall r. r -> (a -> SList a -> r) -> r) nil :: SList a nil = SList (\n c -> n) @@ -19,7 +19,7 @@ nil = SList (\n c -> n) cons :: a -> SList a -> SList a cons x xs = SList (\n c -> c x xs) -instance (Show a) => Show (SList a) where +instance Show a => Show (SList a) where show (SList l) = l "[]" (\x xs -> (show x) ++ ":" ++ (show xs)) headS :: SList a -> a @@ -39,81 +39,139 @@ filterS :: (a -> Bool) -> SList a -> SList a filterS p (SList l) = l nil (\x xs -> if p x then cons x (filterS p xs) else (filterS p xs)) -- does cl@ have performance implications? -quickSortS :: (Ord a) => SList a -> SList a -quickSortS cl@(SList l) = l nil (\h t -> appendS (quickSortS (filterS (\x -> x < h) cl)) - (appendS (filterS (\x -> x == h) cl) - (quickSortS (filterS (\x -> h < x) cl)))) +quickSortS :: Ord a => SList a -> SList a +quickSortS cl@(SList l) = + l + nil + ( \h t -> + appendS + (quickSortS (filterS (\x -> x < h) cl)) + ( appendS + (filterS (\x -> x == h) cl) + (quickSortS (filterS (\x -> h < x) cl)) + ) + ) fromList :: [a] -> SList a -fromList = foldr (\ x xs -> cons x xs) nil +fromList = foldr (\x xs -> cons x xs) nil + ------------------- -- Builtin Lists -- ------------------- headTail :: [a] -> a -headTail [] = undefined -headTail (x:xs) = head xs +headTail [] = undefined +headTail (x : xs) = head xs -- 'sum' is defined for Foldable things, and is significantly slower -- than sumS, so a more comparable sum function is warranted. directSum :: [Int] -> Int -directSum [] = 0 -directSum (x:xs) = x + (directSum xs) +directSum [] = 0 +directSum (x : xs) = x + (directSum xs) -quickSort :: (Ord a) => [a] -> [a] +quickSort :: Ord a => [a] -> [a] quickSort [] = [] -quickSort cl@(h:xs) = (quickSort (filter (\x -> x < h) cl)) ++ - (filter (\x -> x == h) cl) ++ - (quickSort (filter (\x -> h < x) cl)) +quickSort cl@(h : xs) = + (quickSort (filter (\x -> x < h) cl)) + ++ (filter (\x -> x == h) cl) + ++ (quickSort (filter (\x -> h < x) cl)) ---------------- -- Benchmarks -- ---------------- head_tail :: Benchmark -head_tail = bgroup "head_tail" [head_tail_scott,head_tail_builtin] +head_tail = bgroup "head_tail" [head_tail_scott, head_tail_builtin] head_tail_scott :: Benchmark -head_tail_scott = bgroup "scott" (map (\m -> bench ("m = " ++ (show m)) - (whnf headTailS (fromList [1..m] :: SList Int))) - [2,10,10^2,10^3,10^4,10^5]) +head_tail_scott = + bgroup + "scott" + ( map + ( \m -> + bench + ("m = " ++ (show m)) + (whnf headTailS (fromList [1 .. m] :: SList Int)) + ) + [2, 10, 10 ^ 2, 10 ^ 3, 10 ^ 4, 10 ^ 5] + ) head_tail_builtin :: Benchmark -head_tail_builtin = bgroup "builtin" (map (\m -> bench ("m = " ++ (show m)) - (whnf headTail ([1..m] :: [Int]))) - [2,10,10^2,10^3,10^4,10^5]) +head_tail_builtin = + bgroup + "builtin" + ( map + ( \m -> + bench + ("m = " ++ (show m)) + (whnf headTail ([1 .. m] :: [Int])) + ) + [2, 10, 10 ^ 2, 10 ^ 3, 10 ^ 4, 10 ^ 5] + ) sum_ints :: Benchmark -sum_ints = bgroup "sum" [sum_ints_scott,sum_ints_builtin] +sum_ints = bgroup "sum" [sum_ints_scott, sum_ints_builtin] sum_ints_scott :: Benchmark -sum_ints_scott = bgroup "scott" (map (\m -> bench ("m = " ++ (show m)) - (whnf sumS (fromList [1..m] :: SList Int))) - [1,10,10^2,10^3,10^4,10^5,10^6,10^7]) +sum_ints_scott = + bgroup + "scott" + ( map + ( \m -> + bench + ("m = " ++ (show m)) + (whnf sumS (fromList [1 .. m] :: SList Int)) + ) + [1, 10, 10 ^ 2, 10 ^ 3, 10 ^ 4, 10 ^ 5, 10 ^ 6, 10 ^ 7] + ) sum_ints_builtin :: Benchmark -sum_ints_builtin = bgroup "builtin" (map (\m -> bench ("m = " ++ (show m)) - (whnf directSum ([1..m] :: [Int]))) - [1,10,10^2,10^3,10^4,10^5,10^6,10^7]) - -quicksort_ints :: [(Int,[Int])] -> Benchmark -quicksort_ints = \testData -> bgroup "quicksort" [qs_scott testData,qs_builtin testData] - -qs_scott :: [(Int,[Int])] -> Benchmark -qs_scott = \testData -> bgroup "scott" (map (\ (m,xs) -> bench ("m = " ++ (show m)) - (whnf quickSortS (fromList xs))) - testData) - -qs_builtin :: [(Int,[Int])] -> Benchmark -qs_builtin = \testData -> bgroup "builtin" (map (\ (m,xs) -> bench ("m = " ++ (show m)) - (whnf quickSort xs)) - testData) +sum_ints_builtin = + bgroup + "builtin" + ( map + ( \m -> + bench + ("m = " ++ (show m)) + (whnf directSum ([1 .. m] :: [Int])) + ) + [1, 10, 10 ^ 2, 10 ^ 3, 10 ^ 4, 10 ^ 5, 10 ^ 6, 10 ^ 7] + ) + +quicksort_ints :: [(Int, [Int])] -> Benchmark +quicksort_ints = \testData -> bgroup "quicksort" [qs_scott testData, qs_builtin testData] + +qs_scott :: [(Int, [Int])] -> Benchmark +qs_scott = \testData -> + bgroup + "scott" + ( map + ( \(m, xs) -> + bench + ("m = " ++ (show m)) + (whnf quickSortS (fromList xs)) + ) + testData + ) + +qs_builtin :: [(Int, [Int])] -> Benchmark +qs_builtin = \testData -> + bgroup + "builtin" + ( map + ( \(m, xs) -> + bench + ("m = " ++ (show m)) + (whnf quickSort xs) + ) + testData + ) main :: IO () main = do - let g :: Gen [Int] - g = infiniteListOf (elements [0..999]) - nums <- generate g - let qs_data = map (\x -> (x,take x nums)) [1,10,10^2,10^3,10^4,10^5,10^6,10^7] - defaultMainWith defaultConfig - [head_tail,sum_ints,quicksort_ints qs_data] - + let g :: Gen [Int] + g = infiniteListOf (elements [0 .. 999]) + nums <- generate g + let qs_data = map (\x -> (x, take x nums)) [1, 10, 10 ^ 2, 10 ^ 3, 10 ^ 4, 10 ^ 5, 10 ^ 6, 10 ^ 7] + defaultMainWith + defaultConfig + [head_tail, sum_ints, quicksort_ints qs_data] diff --git a/doc/notes/fomega/src/Examples.hs b/doc/notes/fomega/src/Examples.hs index 96249430dac..afc93f1cdd5 100644 --- a/doc/notes/fomega/src/Examples.hs +++ b/doc/notes/fomega/src/Examples.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} + module Examples where import AlgTypes @@ -19,45 +20,55 @@ translate :: AlgSignature -> FSignature translate = scottSig . demutualize runExample :: AlgSignature -> IO () -runExample sig = (putStrLn ("before: size = " ++ (show (size sig)))) >> - (prettySignature sig) >> - (putStrLn "----------") >> - (putStrLn ("after: size = " ++ (show (size (demutualize sig))))) >> - (prettySignature (demutualize sig)) +runExample sig = + (putStrLn ("before: size = " ++ (show (size sig)))) + >> (prettySignature sig) + >> (putStrLn "----------") + >> (putStrLn ("after: size = " ++ (show (size (demutualize sig))))) + >> (prettySignature (demutualize sig)) onlySizes :: AlgSignature -> IO () -onlySizes sig = (putStrLn ("before: size = " ++ (show (size sig)))) >> - (putStrLn ("after: size = " ++ (show (size (demutualize sig))))) +onlySizes sig = + (putStrLn ("before: size = " ++ (show (size sig)))) + >> (putStrLn ("after: size = " ++ (show (size (demutualize sig))))) -beforeAfter :: AlgSignature -> (Integer,Integer) -beforeAfter sig = (size sig , size (demutualize sig)) +beforeAfter :: AlgSignature -> (Integer, Integer) +beforeAfter sig = (size sig, size (demutualize sig)) -- 'randomTest p size n' generates n random systems of mutually recursive types where each bit is 1 -- with probability p of size 'size', and returns the size of each system before and after -- demutualization. randomTest :: Probability -> Int -> Int -> IO TestResult randomTest p size n = randomTest' p size n >>= (return . TR p size) - where - randomTest' :: Probability -> Int -> Int -> IO [(Integer,Integer)] - randomTest' p size 0 = return [] - randomTest' p size n = do - dens <- generate (randomDensity p size) - let sig = instantiate dens - rest <- randomTest' p size (pred n) - return ((beforeAfter sig) : rest) + randomTest' :: Probability -> Int -> Int -> IO [(Integer, Integer)] + randomTest' p size 0 = return [] + randomTest' p size n = do + dens <- generate (randomDensity p size) + let sig = instantiate dens + rest <- randomTest' p size (pred n) + return ((beforeAfter sig) : rest) data TestResult where - TR :: Probability -> Int -> [(Integer,Integer)] -> TestResult + TR :: Probability -> Int -> [(Integer, Integer)] -> TestResult instance Show TestResult where - show (TR p size rs) = "number of types: " ++ (show size) ++ "\n" ++ - "density: " ++ (show p) ++ "\n" ++ - "number of tests: " ++ (show (length rs)) ++ "\n" ++ - "results: " ++ "(size before , size after)" ++ "\n" ++ - let longshow [] = "" - longshow (x:xs) = (show x) ++ "\n" ++ longshow xs in - (longshow rs) + show (TR p size rs) = + "number of types: " + ++ (show size) + ++ "\n" + ++ "density: " + ++ (show p) + ++ "\n" + ++ "number of tests: " + ++ (show (length rs)) + ++ "\n" + ++ "results: " + ++ "(size before , size after)" + ++ "\n" + ++ let longshow [] = "" + longshow (x : xs) = (show x) ++ "\n" ++ longshow xs + in (longshow rs) -- TODAY: -- + get test data: run a bunch of tests for each density, each number of types in system @@ -80,19 +91,20 @@ testFixed dgen rng path = writeDat path (map (\i -> beforeAfter (instantiate (dg writeResults :: FilePath -> [TestResult] -> IO () writeResults path rs = writeDat path (concatResults rs) -concatResults :: [TestResult] -> [(Integer,Integer)] +concatResults :: [TestResult] -> [(Integer, Integer)] concatResults = foldr (\(TR _ _ p) ps -> p ++ ps) [] -- 'writeDat "name" points' creates / overwrites a file "name" containing the list of points -- stored in gnuplot's .dat format. -writeDat :: FilePath -> [(Integer,Integer)] -> IO () +writeDat :: FilePath -> [(Integer, Integer)] -> IO () writeDat path points = do file <- openFile path WriteMode mapM_ (writePoint file) points hClose file -writePoint :: Handle -> (Integer,Integer) -> IO () -writePoint file (x,y) = hPutStrLn file ((show x) ++ " " ++ (show y)) +writePoint :: Handle -> (Integer, Integer) -> IO () +writePoint file (x, y) = hPutStrLn file ((show x) ++ " " ++ (show y)) + -------------- -- Examples -- -------------- @@ -125,17 +137,16 @@ typeH :: Decl AlgType typeH = algDecl [declExp| h = (all a . (f a) * (g a))|] treeForest :: AlgSignature -treeForest = algSignature [tree,forest] +treeForest = algSignature [tree, forest] fgh :: AlgSignature -fgh = algSignature [typeF,typeG,typeH] +fgh = algSignature [typeF, typeG, typeH] onlyList :: AlgSignature onlyList = algSignature [list] multi :: AlgSignature -multi = algSignature [typeF,typeG,typeH,tree,forest,binarytree,list,rosetree] - +multi = algSignature [typeF, typeG, typeH, tree, forest, binarytree, list, rosetree] ------------------------- -- Generating Examples -- @@ -165,16 +176,18 @@ Useful for testing! type Density = [[Int]] -- really "nxn matrices of Nats". use responsibly instantiate :: Density -> AlgSignature -instantiate rows = algSignature $ - map (\(i,t) -> Decl ("t" ++ (show i)) t) - (zip [1..] (map (simplify . (instantiateOne 1)) rows)) +instantiate rows = + algSignature $ + map + (\(i, t) -> Decl ("t" ++ (show i)) t) + (zip [1 ..] (map (simplify . (instantiateOne 1)) rows)) where - instantiateOne :: Int -> [Int] -> AlgType - instantiateOne i [] = Zero - instantiateOne i (n:ns) = Sum (n `times` i) (instantiateOne (succ i) ns) - times :: Int -> Int -> AlgType - times 0 i = One - times k i = Prod (Var ("t" ++ (show i))) (times (pred k) i) + instantiateOne :: Int -> [Int] -> AlgType + instantiateOne i [] = Zero + instantiateOne i (n : ns) = Sum (n `times` i) (instantiateOne (succ i) ns) + times :: Int -> Int -> AlgType + times 0 i = One + times k i = Prod (Var ("t" ++ (show i))) (times (pred k) i) -- I don't think we need to be too worried about density matrices with -- entries that aren't all 0 or 1. @@ -187,24 +200,28 @@ veryDense x = (replicate x (replicate x 1)) diagonal :: Int -> Density diagonal n = count 0 n where - count x n = if x == n then [] - else ((replicate x 0) ++ (1 : (replicate (n - (succ x)) 0))) : (count (succ x) n) + count x n = + if x == n + then [] + else ((replicate x 0) ++ (1 : (replicate (n - (succ x)) 0))) : (count (succ x) n) -- in which each definition refers only to the next definition, ensuring that all definitions rely -- on each other. thinCycle :: Int -> Density thinCycle n = map shift (diagonal n) where - shift xs = (last xs) : (init xs) + shift xs = (last xs) : (init xs) type Probability = Int -- between 0 and 100 (inclusive) -- 'randomBit p' is 1 with probability p, 0 with probability (p-1) randomBit :: Probability -> Gen Int -randomBit p = frequency [(p,elements [1]) - ,((100-p), elements [0])] +randomBit p = + frequency + [ (p, elements [1]) + , ((100 - p), elements [0]) + ] -- 'randomDensity p n' is an nxn matrix of (randomBit p). randomDensity :: Probability -> Int -> Gen [[Int]] randomDensity p n = vectorOf n (vectorOf n (randomBit p)) - diff --git a/doc/notes/fomega/src/Large.hs b/doc/notes/fomega/src/Large.hs index bcb79f83066..8f8b6c9e501 100644 --- a/doc/notes/fomega/src/Large.hs +++ b/doc/notes/fomega/src/Large.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -module Large (alfaSig,bnfcSig,javaSig) where +module Large (alfaSig, bnfcSig, javaSig) where import AlgTypes @@ -12,17 +12,35 @@ list = [declExp| list = all a.(1 + (a * (list a))) |] alfaSig = algSignature - (map algDecl - [ - list,alfa1,alfa2,alfa3,alfa4,alfa5,alfa6,alfa7,alfa8,alfa9,alfa10,alfa11,alfa12,alfa13, - alfa14,alfa15,alfa16,alfa17] + ( map + algDecl + [ list + , alfa1 + , alfa2 + , alfa3 + , alfa4 + , alfa5 + , alfa6 + , alfa7 + , alfa8 + , alfa9 + , alfa10 + , alfa11 + , alfa12 + , alfa13 + , alfa14 + , alfa15 + , alfa16 + , alfa17 + ] ) alfa1 = [declExp| module = list decl |] alfa2 = [declExp| decl = ((list defAttr) * def) + import |] -alfa3 = [declExp| def = (1 * (list varDecl) * exp * exp) +alfa3 = + [declExp| def = (1 * (list varDecl) * exp * exp) + (1 * exp) + (1 * (list typing) * packageBody) + (exp * (list openArg)) @@ -32,7 +50,8 @@ alfa3 = [declExp| def = (1 * (list varDecl) * exp * exp) + (list def) + comment |] -alfa4 = [declExp| exp = 1 +alfa4 = + [declExp| exp = 1 + 1 + 1 + 1 @@ -63,7 +82,6 @@ alfa4 = [declExp| exp = 1 + integer |] - alfa5 = [declExp| arrow = 1 + 1|] alfa6 = [declExp| typing = varDecl + exp|] @@ -74,11 +92,13 @@ alfa8 = [declExp| bound = 1 + 1|] alfa9 = [declExp| fieldDecl = 1 * exp|] -alfa10 = [declExp| branch = (1 * (list 1) * exp) +alfa10 = + [declExp| branch = (1 * (list 1) * exp) + (1 * 1 * 1 * exp) + (1 * exp) |] -alfa11 = [declExp| constructor = (1 * (list typing)) +alfa11 = + [declExp| constructor = (1 * (list typing)) + 1 |] alfa12 = [declExp| indConstructor = (1 * (list typing) * (list exp)) |] @@ -87,7 +107,8 @@ alfa13 = [declExp| binding = 1 * exp|] alfa14 = [declExp| packageBody = (list decl) * exp|] -alfa15 = [declExp| openArg = ((list defAttr) * 1) +alfa15 = + [declExp| openArg = ((list defAttr) * 1) + ((list defAttr) * 1 * exp) + ((list defAttr) * 1 * exp) + ((list defAttr) * 1 * exp * exp) |] @@ -96,14 +117,14 @@ alfa16 = [declExp| defAttr = 1 + 1 + 1 + 1|] alfa17 = [declExp| import = 1|] - -- type generated (I suppose) by bnfc for the bnfc grammar -- at https://github.com/BNFC/bnfc/blob/master/examples/LBNF/LBNF.cf bnfcSig = algSignature - (map - algDecl [list,bnfc1,bnfc2,bnfc3,bnfc4,bnfc5,bnfc6,bnfc7,bnfc8,bnfc9,bnfc10,bnfc11] + ( map + algDecl + [list, bnfc1, bnfc2, bnfc3, bnfc4, bnfc5, bnfc6, bnfc7, bnfc8, bnfc9, bnfc10, bnfc11] ) bnfc1 = [declExp| def = label * cat * (list item) |] @@ -112,13 +133,15 @@ bnfc2 = [declExp| item = 1 + cat|] bnfc3 = [declExp| cat = cat + 1|] -bnfc4 = [declExp| label = 1 + (1 * (list profItem)) +bnfc4 = + [declExp| label = 1 + (1 * (list profItem)) + (1 * 1 * (list profItem)) + (1 * 1)|] bnfc5 = [declExp| profItem = (list 1) * (list 1)|] -bnfc6 = [declExp| def = 1 + (1 * 1) +bnfc6 = + [declExp| def = 1 + (1 * 1) + (label * cat * (list item)) + (1 * reg) + (list 1) @@ -138,29 +161,67 @@ bnfc9 = [declExp| reg2 = reg2 reg3 |] bnfc10 = [declExp| reg1 = (reg1 * reg2) + (reg2 * reg2)|] -bnfc11 = [declExp| reg3 = 1 + 1 + 1 + 1 + 1 + 1 + 1 +bnfc11 = + [declExp| reg3 = 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 |] -- as above, for the java grammar at http://people.cs.uchicago.edu/~mrainey/java.cf javaSig = algSignature - (map algDecl [ - java1,java2,java3,java4,java5,java6,java7,java8,java9,java10,java11,java12,java13,java14, - java15,java16,java17,java18,java19,java20,java21,java22,java23,java24,java25,java26,java27, - java28,java29,java30,java31,java32,java33,java34,java35] + ( map + algDecl + [ java1 + , java2 + , java3 + , java4 + , java5 + , java6 + , java7 + , java8 + , java9 + , java10 + , java11 + , java12 + , java13 + , java14 + , java15 + , java16 + , java17 + , java18 + , java19 + , java20 + , java21 + , java22 + , java23 + , java24 + , java25 + , java26 + , java27 + , java28 + , java29 + , java30 + , java31 + , java32 + , java33 + , java34 + , java35 + ] ) -java1 = [declExp| programFile = ((list 1) * (list 1) +java1 = + [declExp| programFile = ((list 1) * (list 1) * (list import) * (list typeDecl)) + ((list import) * (list typeDecl))|] -java2 = [declExp| import = ((list ident) * (list 1)) +java2 = + [declExp| import = ((list ident) * (list 1)) + ((list ident) * (list 1))|] java3 = [declExp| typeDecl = classHeader * (list fileDeclaration)|] -java4 = [declExp| classHeader = ((list modifier) * 1) +java4 = + [declExp| classHeader = ((list modifier) * 1) + ((list modifier) * 1 * (list typeName)) + ((list modifier) * 1) + ((list modifier) * 1 * (list typeName)) @@ -169,7 +230,8 @@ java4 = [declExp| classHeader = ((list modifier) * 1) + ((list modifier) * 1 * (list typeName)) + ((list modifier) * 1 * (list typeName) * (list typeName)) |] -java5 = [declExp| fieldDeclaration = +java5 = + [declExp| fieldDeclaration = ((list modifier) * typeSpec * (list varDecl)) + ((list modifier) * typeSpec * methodDecl * methodBody) + ((list modifier) * typeSpec * methodDecl * (list typeName) * methodBody) @@ -181,14 +243,16 @@ java5 = [declExp| fieldDeclaration = java6 = [declExp| methodBody = 1 + body |] -java7 = [declExp| lVarStatement = +java7 = + [declExp| lVarStatement = (typeSpec * (list varDecl)) + (typeSpec * (list varDecl)) + stm + 1 |] java8 = [declExp| body = (list lVarStatement) |] -java9 = [declExp| stm = 1 + 1 + exp + 1 + exp +java9 = + [declExp| stm = 1 + 1 + exp + 1 + exp + (list lVarStatement) + jumpStm + guardStm + iterStm + selectionStm |] @@ -199,51 +263,62 @@ java11 = [declExp| varDecl = (declaratorName * variableInits) java12 = [declExp| variableInits = exp + 1 + arrayInits|] -java13 = [declExp| arrayInits = variableInits +java13 = + [declExp| arrayInits = variableInits + (arrayInits * variableinits) + arrayInits |] -java14 = [declExp| methodDecl = (declaratorName * (list parameter)) +java14 = + [declExp| methodDecl = (declaratorName * (list parameter)) + (methodDecl * bracketsOpt)|] -java15 = [declExp| parameter = (typeSpec * declaratorName) +java15 = + [declExp| parameter = (typeSpec * declaratorName) + (typeSpec * declaratorName) |] -java16 = [declExp| selectionStm = (exp * stm * (list elseIf)) +java16 = + [declExp| selectionStm = (exp * stm * (list elseIf)) + (exp * stm * (list elseIf) * stm) + (exp * body)|] java17 = [declExp| elseIf = exp * stm |] -java18 = [declExp| jumpStm = 1 + (1 * 1) + 1 + (1 * 1) + 1 +java18 = + [declExp| jumpStm = 1 + (1 * 1) + 1 + (1 * 1) + 1 + (1 * exp) + (1 * exp)|] -java19 = [declExp| guardStm = (exp * body) +java19 = + [declExp| guardStm = (exp * body) + (body * (list catch)) + (body * (list catch) * body)|] -java20 = [declExp| catch = (typeSpec * 1 * body) +java20 = + [declExp| catch = (typeSpec * 1 * body) + (typeSpec * body)|] -java21 = [declExp| iterStm = (exp * stm) +java21 = + [declExp| iterStm = (exp * stm) + (stm * exp) + (forInit * (list exp) * (list exp) * stm) + (list exp) + (typeSpec * (list varDecl)) + (typeSpec * (list varDecl))|] -java22 = [declExp| forInit = (list exp) +java22 = + [declExp| forInit = (list exp) + (typeSpec * (list varDecl)) + (typeSpec * (list varDecl))|] java23 = [declExp| modifier = 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 |] -java24 = [declExp| typeSpec = (typeName * (list bracketsOps)) +java24 = + [declExp| typeSpec = (typeName * (list bracketsOps)) + typeName |] java25 = [declExp| typeName = 1 + (list 1) |] java26 = [declExp| bracketsOpt = 1|] -java27 = [declExp| exp = (exp * 1 * exp) +java27 = + [declExp| exp = (exp * 1 * exp) + (exp * typeName) + (exp * exp * exp) + (exp * exp) @@ -270,7 +345,8 @@ java27 = [declExp| exp = (exp * 1 * exp) + newAllow + (list 1)|] -java28 = [declExp| newAlloc = (typeName * args) +java28 = + [declExp| newAlloc = (typeName * args) + (typeName * args * (list fieldDeclaration)) + (typeName * (list dimExpr)) + (typeName * (list dimExpr)) @@ -282,16 +358,16 @@ java30 = [declExp| specExp = exp + specExpNp + 1|] java31 = [declExp| specExpNp = 1 + arrAcc + mthCall + fieldAcc |] -java32 = [declExp| mthCall = ((list 1) * args) +java32 = + [declExp| mthCall = ((list 1) * args) + (specExpNp * args) + (1 * args)|] -java33 = [declExp| fieldAcc = (specExp * 1) +java33 = + [declExp| fieldAcc = (specExp * 1) + (newAlloc * 1) + (list 1) + (list 1) + basicType|] java34 = [declExp| args = list exp|] java35 = [declExp| dimExpr = exp|] - - diff --git a/doc/notes/fomega/src/SystemF.hs b/doc/notes/fomega/src/SystemF.hs index d4148714098..da8ce4509d3 100644 --- a/doc/notes/fomega/src/SystemF.hs +++ b/doc/notes/fomega/src/SystemF.hs @@ -1,7 +1,5 @@ {-# LANGUAGE GADTs #-} - - module SystemF where ------------------------------- @@ -19,24 +17,24 @@ data Type where TyAbs :: VarName -> Type -> Type TyApp :: Type -> Type -> Type TyFix :: Type -> Type - TyMu :: VarName -> Type -> Type + TyMu :: VarName -> Type -> Type instance Show Type where - show (TyVar x) = x + show (TyVar x) = x show (TyFun t1 t2) = "(" ++ (show t1) ++ " -> " ++ (show t2) ++ ")" - show (TyAll x t) = "(" ++ "all " ++ x ++ "." ++ (show t) ++ ")" - show (TyAbs x t) = "(" ++ "lam " ++ x ++ "." ++ (show t) ++ ")" + show (TyAll x t) = "(" ++ "all " ++ x ++ "." ++ (show t) ++ ")" + show (TyAbs x t) = "(" ++ "lam " ++ x ++ "." ++ (show t) ++ ")" show (TyApp t1 t2) = "(" ++ (show t1) ++ " " ++ (show t2) ++ ")" - show (TyFix t) = "(" ++ "fix " ++ (show t) ++ ")" - show (TyMu x t) = "(" ++ "mu " ++ x ++ "." ++ (show t) ++ ")" + show (TyFix t) = "(" ++ "fix " ++ (show t) ++ ")" + show (TyMu x t) = "(" ++ "mu " ++ x ++ "." ++ (show t) ++ ")" data Kind where - Star :: Kind + Star :: Kind Arrow :: Kind -> Kind -> Kind deriving stock (Eq) instance Show Kind where - show Star = "*" + show Star = "*" show (Arrow k1 k2) = "(" ++ (show k1) ++ " -> " ++ (show k2) ++ ")" data Binding where @@ -50,13 +48,13 @@ instance Show Binding where type Context = [Binding] addBinding :: Context -> Binding -> Context -addBinding ctx b = b:ctx +addBinding ctx b = b : ctx getBinding :: Context -> VarName -> Either Type Kind getBinding [] x = error ("variable " ++ x ++ " isn't bound in the current context") -getBinding (b:bs) x = case b of - (TermBind y t) -> if x == y then Left t else getBinding bs x - (TypeBind y k) -> if x == y then Right k else getBinding bs x +getBinding (b : bs) x = case b of + (TermBind y t) -> if x == y then Left t else getBinding bs x + (TypeBind y k) -> if x == y then Right k else getBinding bs x -------------------- -- Kind Inference -- @@ -114,23 +112,21 @@ reduce (TyAll x t) = TyAll x t reduce (TyAbs x t) = TyAbs x t reduce (TyFix t) = TyFix (reduce t) reduce (TyApp t1 t2) = case t1 of - (TyAbs x t) -> sub t2 x t - _ -> (TyApp (reduce t1) t2) + (TyAbs x t) -> sub t2 x t + _ -> (TyApp (reduce t1) t2) -- sub a x t is t[a/x]. sub :: Type -> VarName -> Type -> Type sub = subExcept [] where - subExcept :: [VarName] -> Type -> VarName -> Type -> Type - subExcept bound t x t' = - if x `elem` bound then t' - else - case t' of - (TyVar y) -> if x == y then t else (TyVar y) - (TyFun t1 t2) -> TyFun (subExcept bound t x t1) (subExcept bound t x t2) - (TyAll x' t') -> TyAll x' (subExcept (x:bound) t x t') - (TyAbs x' t') -> TyAbs x' (subExcept (x:bound) t x t') - (TyFix t') -> TyFix (subExcept (bound) t x t') - (TyApp t1 t2) -> TyApp (subExcept bound t x t1) (subExcept bound t x t2) - - + subExcept :: [VarName] -> Type -> VarName -> Type -> Type + subExcept bound t x t' = + if x `elem` bound + then t' + else case t' of + (TyVar y) -> if x == y then t else (TyVar y) + (TyFun t1 t2) -> TyFun (subExcept bound t x t1) (subExcept bound t x t2) + (TyAll x' t') -> TyAll x' (subExcept (x : bound) t x t') + (TyAbs x' t') -> TyAbs x' (subExcept (x : bound) t x t') + (TyFix t') -> TyFix (subExcept (bound) t x t') + (TyApp t1 t2) -> TyApp (subExcept bound t x t1) (subExcept bound t x t2) diff --git a/doc/notes/fomega/z-combinator-benchmarks/Benchmarks.hs b/doc/notes/fomega/z-combinator-benchmarks/Benchmarks.hs index 964a8c9672c..7ccfaac0739 100644 --- a/doc/notes/fomega/z-combinator-benchmarks/Benchmarks.hs +++ b/doc/notes/fomega/z-combinator-benchmarks/Benchmarks.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} + module Main where import Criterion.Main @@ -40,36 +41,41 @@ z1 = \f -> let a = \r -> f (\x -> unroll r $! x) in a (Self a) z2 :: ((a -> b) -> a -> b) -> a -> b z2 = \f -> let a = \r x -> (f $! unroll r) $! x in a (Self a) -countdownBy - :: (((Int -> Bool) -> Int -> Bool) -> Int -> Bool) - -> Int -> Bool +countdownBy :: + (((Int -> Bool) -> Int -> Bool) -> Int -> Bool) -> + Int -> + Bool countdownBy recurse = recurse $ \r x -> x == 0 || r (x - 1) -natSumUpToBy - :: (((Int -> Int -> Int) -> Int -> Int -> Int) -> Int -> Int -> Int) - -> Int -> Int +natSumUpToBy :: + (((Int -> Int -> Int) -> Int -> Int -> Int) -> Int -> Int -> Int) -> + Int -> + Int natSumUpToBy recurse = recurse (\r a x -> if x == 0 then 0 else r (a + x) (x - 1)) 0 -leakingNatSumUpToBy - :: (((Int -> Int) -> Int -> Int) -> Int -> Int) - -> Int -> Int +leakingNatSumUpToBy :: + (((Int -> Int) -> Int -> Int) -> Int -> Int) -> + Int -> + Int leakingNatSumUpToBy recurse = recurse $ \r x -> if x == 0 then 0 else x + r (x - 1) ---------------- -- Benchmarks -- ---------------- -bench_fixed_points - :: String - -> ((forall a b. ((a -> b) -> a -> b) -> a -> b) -> Int -> c) - -> Benchmark -bench_fixed_points name fun = bgroup name $ [10^5, 10^6, 10^7] >>= \n -> - [ bench ("fix'/" ++ show n) $ whnf (fun fix') n - , bench ("bz1/" ++ show n) $ whnf (fun bz1 ) n - , bench ("bz2/" ++ show n) $ whnf (fun bz2 ) n - , bench ("z1/" ++ show n) $ whnf (fun z1 ) n - , bench ("z2/" ++ show n) $ whnf (fun z2 ) n - ] +bench_fixed_points :: + String -> + ((forall a b. ((a -> b) -> a -> b) -> a -> b) -> Int -> c) -> + Benchmark +bench_fixed_points name fun = + bgroup name $ + [10 ^ 5, 10 ^ 6, 10 ^ 7] >>= \n -> + [ bench ("fix'/" ++ show n) $ whnf (fun fix') n + , bench ("bz1/" ++ show n) $ whnf (fun bz1) n + , bench ("bz2/" ++ show n) $ whnf (fun bz2) n + , bench ("z1/" ++ show n) $ whnf (fun z1) n + , bench ("z2/" ++ show n) $ whnf (fun z2) n + ] bench_countdownBy :: Benchmark bench_countdownBy = bench_fixed_points "countdownBy" countdownBy @@ -81,8 +87,9 @@ bench_leakingNatSumUpToBy :: Benchmark bench_leakingNatSumUpToBy = bench_fixed_points "leakingNatSumUpToBy" leakingNatSumUpToBy main :: IO () -main = defaultMain - [ bench_countdownBy - , bench_natSumUpToBy - , bench_leakingNatSumUpToBy - ] +main = + defaultMain + [ bench_countdownBy + , bench_natSumUpToBy + , bench_leakingNatSumUpToBy + ] diff --git a/doc/notes/model/UTxO.hsproj/Examples/Keys.hs b/doc/notes/model/UTxO.hsproj/Examples/Keys.hs index 8e4b8c9cbab..e2aec85f6fd 100644 --- a/doc/notes/model/UTxO.hsproj/Examples/Keys.hs +++ b/doc/notes/model/UTxO.hsproj/Examples/Keys.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Examples.Keys where -import "crypton" Crypto.PubKey.ECC.ECDSA import Crypto.PubKey.ECC.Generate import Crypto.PubKey.ECC.Types +import "crypton" Crypto.PubKey.ECC.ECDSA import "crypton" Crypto.Random import Data.Map (Map) @@ -14,11 +14,11 @@ import Data.Map qualified as Map import Data.Set (Set) import Data.Set qualified as Set - myKeyPair1 :: KeyPair myKeyPair1 = KeyPair (private_curve . snd $ keys) (public_q . fst $ keys) (private_d . snd $ keys) where - curve = getCurveByName SEC_p112r1 - drg = drgNewSeed (seedFromInteger 42) - (keys, _) = withDRG drg $ - generate curve + curve = getCurveByName SEC_p112r1 + drg = drgNewSeed (seedFromInteger 42) + (keys, _) = + withDRG drg $ + generate curve diff --git a/doc/notes/model/UTxO.hsproj/Examples/PubKey.hs b/doc/notes/model/UTxO.hsproj/Examples/PubKey.hs index 16ef229e0d0..66e2d467a6e 100644 --- a/doc/notes/model/UTxO.hsproj/Examples/PubKey.hs +++ b/doc/notes/model/UTxO.hsproj/Examples/PubKey.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Examples.PubKey where -import "cryptonite" Crypto.PubKey.ECC.ECDSA import Crypto.PubKey.ECC.Generate import Crypto.PubKey.ECC.Types +import "cryptonite" Crypto.PubKey.ECC.ECDSA import "cryptonite" Crypto.Random import Data.Map (Map) @@ -14,23 +14,37 @@ import Data.Map qualified as Map import Data.Set (Set) import Data.Set qualified as Set - import Examples.Keys import Examples.PubKeyHashes import Ledger import UTxO import Witness - pubKeyLedger = [t2, t1] where - t1 = Tx [] - [TxOut val1Hash 1000] 1000 0 - t2 = Tx [txIn (hashTx t1) 0 wit1] - [TxOut (vhash wit2) 800, TxOut val1Hash 200] 0 0 - - vhash = validatorHash - wit1 = $(lockWithKeyPair myKeyPair1 - (preHashTx $ Tx [txIn t1Hash 0 noWitness] -- need a copy due to TH stage re - [TxOut wit2Hash 800, TxOut val1Hash 200] 0 0)) - wit2 = $(revealPreimage "2") + t1 = + Tx + [] + [TxOut val1Hash 1000] + 1000 + 0 + t2 = + Tx + [txIn (hashTx t1) 0 wit1] + [TxOut (vhash wit2) 800, TxOut val1Hash 200] + 0 + 0 + + vhash = validatorHash + wit1 = + $( lockWithKeyPair + myKeyPair1 + ( preHashTx $ + Tx + [txIn t1Hash 0 noWitness] -- need a copy due to TH stage re + [TxOut wit2Hash 800, TxOut val1Hash 200] + 0 + 0 + ) + ) + wit2 = $(revealPreimage "2") diff --git a/doc/notes/model/UTxO.hsproj/Examples/PubKeyHashes.hs b/doc/notes/model/UTxO.hsproj/Examples/PubKeyHashes.hs index 52d8e79ac7e..308b3f11c15 100644 --- a/doc/notes/model/UTxO.hsproj/Examples/PubKeyHashes.hs +++ b/doc/notes/model/UTxO.hsproj/Examples/PubKeyHashes.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Examples.PubKeyHashes where -import "cryptonite" Crypto.PubKey.ECC.ECDSA import Crypto.PubKey.ECC.Generate import Crypto.PubKey.ECC.Types +import "cryptonite" Crypto.PubKey.ECC.ECDSA import "cryptonite" Crypto.Random import Data.Map (Map) @@ -19,14 +19,17 @@ import Ledger import UTxO import Witness - -- Template Haskell splices can't use local definitions, but only imported ones (stage restriction); -- hence, we have got some defintions here that we want to use in 'Examples.PubKey'. -- This is very sad! -t1Hash = hashTx $ - Tx [] - [TxOut val1Hash 1000] 1000 0 +t1Hash = + hashTx $ + Tx + [] + [TxOut val1Hash 1000] + 1000 + 0 where val1Hash = scriptHash $$(lockWithPublicKeyValidator (toPublicKey myKeyPair1)) diff --git a/doc/notes/model/UTxO.hsproj/Examples/Simple.hs b/doc/notes/model/UTxO.hsproj/Examples/Simple.hs index d8bb6b9f844..d60941ecdb5 100644 --- a/doc/notes/model/UTxO.hsproj/Examples/Simple.hs +++ b/doc/notes/model/UTxO.hsproj/Examples/Simple.hs @@ -12,34 +12,65 @@ import Ledger import UTxO import Witness - simpleLedger = [t6, t5, t4, t3, t2, t1] where - t1 = Tx [] - [TxOut (vhash wit1) 1000] 1000 0 - t2 = Tx [txIn (hashTx t1) 0 wit1] - [TxOut (vhash wit2) 800, TxOut (vhash wit1) 200] 0 0 - t3 = Tx [txIn (hashTx t2) 1 wit1] - [TxOut (vhash wit3) 199] 0 1 - t4 = Tx [txIn (hashTx t3) 0 wit3] - [TxOut (vhash wit2) 207] 10 2 - t5 = Tx [txIn (hashTx t4) 0 wit2, txIn (hashTx t2) 0 wit2] - [TxOut (vhash wit2) 500, TxOut (vhash wit3) 500] 0 7 - t6 = Tx [txIn (hashTx t5) 0 wit2, txIn (hashTx t5) 1 wit3] - [TxOut (vhash wit3) 999] 0 1 + t1 = + Tx + [] + [TxOut (vhash wit1) 1000] + 1000 + 0 + t2 = + Tx + [txIn (hashTx t1) 0 wit1] + [TxOut (vhash wit2) 800, TxOut (vhash wit1) 200] + 0 + 0 + t3 = + Tx + [txIn (hashTx t2) 1 wit1] + [TxOut (vhash wit3) 199] + 0 + 1 + t4 = + Tx + [txIn (hashTx t3) 0 wit3] + [TxOut (vhash wit2) 207] + 10 + 2 + t5 = + Tx + [txIn (hashTx t4) 0 wit2, txIn (hashTx t2) 0 wit2] + [TxOut (vhash wit2) 500, TxOut (vhash wit3) 500] + 0 + 7 + t6 = + Tx + [txIn (hashTx t5) 0 wit2, txIn (hashTx t5) 1 wit3] + [TxOut (vhash wit3) 999] + 0 + 1 vhash = validatorHash - wit1 = $(revealPreimage "1") - wit2 = $(revealPreimage "2") - wit3 = $(revealPreimage "3") + wit1 = $(revealPreimage "1") + wit2 = $(revealPreimage "2") + wit3 = $(revealPreimage "3") failingLedger = [t2, t1] where - t1 = Tx [] - [TxOut (vhash wit1) 1000] 1000 0 - t2 = Tx [txIn (hashTx t1) 0 wit1] - [TxOut (vhash wit2) 800, TxOut (vhash wit1) 200] 0 0 + t1 = + Tx + [] + [TxOut (vhash wit1) 1000] + 1000 + 0 + t2 = + Tx + [txIn (hashTx t1) 0 wit1] + [TxOut (vhash wit2) 800, TxOut (vhash wit1) 200] + 0 + 0 vhash = validatorHash - wit1 = $(witness (revealPreimageValidator "1") (script [|| const "wrong" ||])) - wit2 = $(revealPreimage "2") + wit1 = $(witness (revealPreimageValidator "1") (script [||const "wrong"||])) + wit2 = $(revealPreimage "2") diff --git a/doc/notes/model/UTxO.hsproj/Ledger.hs b/doc/notes/model/UTxO.hsproj/Ledger.hs index bff66984a88..0c0259ba2b2 100644 --- a/doc/notes/model/UTxO.hsproj/Ledger.hs +++ b/doc/notes/model/UTxO.hsproj/Ledger.hs @@ -1,95 +1,94 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} module Ledger ( - -- ** Ledger & transaction types - Ledger, Tx(..), TxIn(..), TxOut(..), TxOutRef(..), txIn, + Ledger, + Tx (..), + TxIn (..), + TxOut (..), + TxOutRef (..), + txIn, -- ** Ledger & transaction state for scripts - hashTx, preHashTx, validValuesTx, state + hashTx, + preHashTx, + validValuesTx, + state, ) where -import "cryptonite" Crypto.Hash import Data.ByteArray qualified as BA import Data.ByteString.Char8 qualified as BS import Data.Set (Set) import Data.Set qualified as Set +import "cryptonite" Crypto.Hash import Types import Witness - -- Ledger and transaction types -- ---------------------------- --- |An UTxO ledger --- -type Ledger = [Tx] -- last transaction first +-- | An UTxO ledger +type Ledger = [Tx] -- last transaction first --- |A single transaction --- +-- | A single transaction data Tx = Tx - { inputsTX :: [TxIn] - , outputsTX :: [TxOut] - , mintTX :: Value - , feeTX :: Value - } - deriving stock (Show) + { inputsTX :: [TxIn] + , outputsTX :: [TxOut] + , mintTX :: Value + , feeTX :: Value + } + deriving stock (Show) data TxStripped = TxStripped - { inputsTXS :: Set TxOutRef - , outputsTXS :: [TxOut] - , mintTXS :: Value - , feeTXS :: Value - } - deriving stock (Show) + { inputsTXS :: Set TxOutRef + , outputsTXS :: [TxOut] + , mintTXS :: Value + , feeTXS :: Value + } + deriving stock (Show) stripTx :: Tx -> TxStripped -stripTx Tx{..} - = TxStripped{..} +stripTx Tx {..} = + TxStripped {..} where - inputsTXS = Set.fromList . map refTI $ inputsTX - outputsTXS = outputsTX - mintTXS = mintTX - feeTXS = feeTX + inputsTXS = Set.fromList . map refTI $ inputsTX + outputsTXS = outputsTX + mintTXS = mintTX + feeTXS = feeTX --- |Hash (double) the given transaction *without* witnesses. --- +-- | Hash (double) the given transaction *without* witnesses. hashTx :: Tx -> Digest SHA256 hashTx = hash . preHashTx --- |Hash (once) the given transaction *without* witnesses. --- +-- | Hash (once) the given transaction *without* witnesses. preHashTx :: Tx -> Digest SHA256 preHashTx tx = hash (stripTx tx) --- |Check that all values in a transaction are no. --- +-- | Check that all values in a transaction are no. validValuesTx :: Tx -> Bool -validValuesTx Tx{..} - = all ((>= 0) . valueTO) outputsTX && mintTX >= 0 && feeTX >= 0 +validValuesTx Tx {..} = + all ((>= 0) . valueTO) outputsTX && mintTX >= 0 && feeTX >= 0 data TxOutRef = TxOutRef - { idTOR :: TxId - , indexTOR :: Int - } - deriving stock (Show, Eq, Ord) + { idTOR :: TxId + , indexTOR :: Int + } + deriving stock (Show, Eq, Ord) --- |A single transaction input --- +-- | A single transaction input data TxIn = TxIn - { refTI :: TxOutRef - , witnessTI :: Witness - } - deriving stock (Show) + { refTI :: TxOutRef + , witnessTI :: Witness + } + deriving stock (Show) --- |Convenience constructor for inputs. --- +-- | Convenience constructor for inputs. txIn :: TxId -> Int -> Witness -> TxIn txIn txId idx wit = TxIn (TxOutRef txId idx) wit @@ -97,47 +96,43 @@ txIn txId idx wit = TxIn (TxOutRef txId idx) wit ---- refers to, *not* on the witness. This is crucial so that two 'TxIn values ---- spending the same input are considered the same. ---- ---instance Eq TxIn where +-- instance Eq TxIn where -- txIn1 == txIn2 = idTI txIn1 == idTI txIn2 && indexTI txIn1 == indexTI txIn2 -- ---- As for equality ---- ---instance Ord TxIn where +-- instance Ord TxIn where -- txIn1 <= txIn2 -- = idTI txIn1 < idTI txIn2 || (idTI txIn1 == idTI txIn2 && indexTI txIn1 < indexTI txIn2) --- |A single transaction output, paying a value to a script address --- +-- | A single transaction output, paying a value to a script address data TxOut = TxOut - { addressTO :: Address - , valueTO :: Value - } - deriving stock (Eq, Show) + { addressTO :: Address + , valueTO :: Value + } + deriving stock (Eq, Show) instance BA.ByteArrayAccess Tx where - length = BA.length . BS.pack . show -- FIXME: we should serialise properly - withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly + length = BA.length . BS.pack . show -- FIXME: we should serialise properly + withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly instance BA.ByteArrayAccess TxStripped where - length = BA.length . BS.pack . show -- FIXME: we should serialise properly - withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly + length = BA.length . BS.pack . show -- FIXME: we should serialise properly + withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly instance BA.ByteArrayAccess TxIn where - length = BA.length . BS.pack . show -- FIXME: we should serialise properly - withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly + length = BA.length . BS.pack . show -- FIXME: we should serialise properly + withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly instance BA.ByteArrayAccess TxOut where - length = BA.length . BS.pack . show -- FIXME: we should serialise properly - withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly - + length = BA.length . BS.pack . show -- FIXME: we should serialise properly + withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly -- Ledger & transaction state for scripts -- -------------------------------------- --- |Given a transaction and a ledger that the transaction is to be validated against, extract --- the state information needed by validation scripts. --- +-- | Given a transaction and a ledger that the transaction is to be validated against, extract +-- the state information needed by validation scripts. state :: Tx -> Ledger -> State state tx ledger = State (length ledger) (hashTx tx) (preHashTx tx) - diff --git a/doc/notes/model/UTxO.hsproj/Types.hs b/doc/notes/model/UTxO.hsproj/Types.hs index 1fcd1d44cce..27bbe61655f 100644 --- a/doc/notes/model/UTxO.hsproj/Types.hs +++ b/doc/notes/model/UTxO.hsproj/Types.hs @@ -9,39 +9,31 @@ -- Stability : experimental -- -- Basic type definitions - module Types where import "crypton" Crypto.Hash - -- Basic types --- |Crypotocurrency value --- +-- | Crypotocurrency value type Value = Integer --- |A transaction's ID is a double SHA256 hash of the transaction structure. --- +-- | A transaction's ID is a double SHA256 hash of the transaction structure. type TxId = Digest SHA256 --- |A payment address is a SHA256 hash followed by another SHA256 hash of a UTxO --- output's validator script. This corresponds to a Bitcoin pay-to-witness-script-hash --- (P2WSH) address. --- +-- | A payment address is a SHA256 hash followed by another SHA256 hash of a UTxO +-- output's validator script. This corresponds to a Bitcoin pay-to-witness-script-hash +-- (P2WSH) address. type Address = Digest SHA256 --- |Transaction height --- +-- | Transaction height type Height = Int --- |Ledger and transaction state available to both the validator and redeemer scripts --- +-- | Ledger and transaction state available to both the validator and redeemer scripts data State = State - { stateHeight :: Height - , stateTxHash :: TxId -- double SHA256 hash - , stateTxPreHash :: TxId -- single SHA256 hash - } - + { stateHeight :: Height + , stateTxHash :: TxId -- double SHA256 hash + , stateTxPreHash :: TxId -- single SHA256 hash + } diff --git a/doc/notes/model/UTxO.hsproj/UTxO.hs b/doc/notes/model/UTxO.hsproj/UTxO.hs index ad05e462ea1..fb4056a9f12 100644 --- a/doc/notes/model/UTxO.hsproj/UTxO.hs +++ b/doc/notes/model/UTxO.hsproj/UTxO.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} -- This code models a UTxO-style ledger using the approach from @@ -18,137 +18,127 @@ -- Stability : experimental -- -- UTxO model definition - module UTxO where -import "cryptonite" Crypto.Hash import Data.List import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe import Data.Set (Set) import Data.Set qualified as Set +import "cryptonite" Crypto.Hash import Ledger import Types import Witness - --- |Determine the transaction that an input refers to. --- --- NB: Arguments swapped wrt to the paper. +-- | Determine the transaction that an input refers to. -- +-- NB: Arguments swapped wrt to the paper. tx :: Ledger -> TxOutRef -> Maybe Tx -tx ledger txOutRef - = case [t | t <- ledger, hashTx t == idTOR txOutRef] of - [] -> Nothing - (t:_) -> Just t +tx ledger txOutRef = + case [t | t <- ledger, hashTx t == idTOR txOutRef] of + [] -> Nothing + (t : _) -> Just t --- |Determine the unspent output that an input refers to. --- --- NB: Arguments swapped wrt to the paper. +-- | Determine the unspent output that an input refers to. -- +-- NB: Arguments swapped wrt to the paper. out :: Ledger -> TxOutRef -> Maybe TxOut -out ledger txOutRef - = do - { t <- tx ledger txOutRef - ; if length (outputsTX t) <= indexTOR txOutRef - then fail "" - else return $ outputsTX t !! indexTOR txOutRef - } - --- |Determine the unspent value that an input refers to. --- --- NB: Arguments swapped wrt to the paper. +out ledger txOutRef = + do + t <- tx ledger txOutRef + if length (outputsTX t) <= indexTOR txOutRef + then fail "" + else return $ outputsTX t !! indexTOR txOutRef + +-- | Determine the unspent value that an input refers to. -- +-- NB: Arguments swapped wrt to the paper. value :: Ledger -> TxOutRef -> Maybe Value -value ledger txOutRef - = do - { outTx <- out ledger txOutRef - ; return $ valueTO outTx - } +value ledger txOutRef = + do + outTx <- out ledger txOutRef + return $ valueTO outTx -- --- |The unspent outputs of a transaction. --- --- Compared to the paper, we use a map and not a set. This saves expensive ledger --- traversals in 'valid'. +-- | The unspent outputs of a transaction. -- +-- Compared to the paper, we use a map and not a set. This saves expensive ledger +-- traversals in 'valid'. unspentOutputsTx :: Tx -> Map TxOutRef Address -unspentOutputsTx tx - = Map.fromList $ - [ (TxOutRef{ idTOR = hashTx tx, indexTOR = ix }, addressTO txOut) - | (txOut, ix) <- zip (outputsTX tx) [0..] - ] +unspentOutputsTx tx = + Map.fromList $ + [ (TxOutRef {idTOR = hashTx tx, indexTOR = ix}, addressTO txOut) + | (txOut, ix) <- zip (outputsTX tx) [0 ..] + ] --- |The outputs spent by a transaction (represented as inputs). --- +-- | The outputs spent by a transaction (represented as inputs). spentOutputsTx :: Tx -> Set TxOutRef spentOutputsTx = Set.fromList . map refTI . inputsTX -- --- |Unspent outputs of a ledger. --- --- Compared to the paper, we use a map and not a set. This saves expensive ledger --- traversals in 'valid'. +-- | Unspent outputs of a ledger. -- +-- Compared to the paper, we use a map and not a set. This saves expensive ledger +-- traversals in 'valid'. unspentOutputs :: Ledger -> Map TxOutRef Address -unspentOutputs - = foldr - (\t unspent -> - (unspent `Map.difference` lift (spentOutputsTx t)) `Map.union` unspentOutputsTx t) - Map.empty +unspentOutputs = + foldr + ( \t unspent -> + (unspent `Map.difference` lift (spentOutputsTx t)) `Map.union` unspentOutputsTx t + ) + Map.empty where lift = Map.fromSet (const ()) --- |Determine whether a transaction is valid in a given ledger. --- --- * The inputs refer to unspent outputs, which they unlock (input validity). +-- | Determine whether a transaction is valid in a given ledger. -- --- * The transaction preserves value (value preservation). +-- * The inputs refer to unspent outputs, which they unlock (input validity). -- --- * All values in the transaction are non-negative. +-- * The transaction preserves value (value preservation). -- +-- * All values in the transaction are non-negative. validTx :: Tx -> Ledger -> Bool validTx t ledger = inputsAreValid && valueIsPreserved && validValuesTx t where - inputsAreValid = all (`validatesIn` unspentOutputs ledger) (inputsTX t) - valueIsPreserved = mintTX t + sum (map (fromJust . value ledger) (map refTI $ inputsTX t)) - == feeTX t + sum (map valueTO (outputsTX t)) - -- NB: the 'fromMaybe' is safe as 'inputsAreUnspent' holds if we get here - - txIn `validatesIn` txOuts - = case refTI txIn `Map.lookup` txOuts of - Just addr -> validate addr (state t ledger) (witnessTI txIn) - _ -> False - --- |Determine whether the given ledger is valid; i.e., all transactions are valid where they appear. --- + inputsAreValid = all (`validatesIn` unspentOutputs ledger) (inputsTX t) + valueIsPreserved = + mintTX t + sum (map (fromJust . value ledger) (map refTI $ inputsTX t)) + == feeTX t + sum (map valueTO (outputsTX t)) + -- NB: the 'fromMaybe' is safe as 'inputsAreUnspent' holds if we get here + + txIn `validatesIn` txOuts = + case refTI txIn `Map.lookup` txOuts of + Just addr -> validate addr (state t ledger) (witnessTI txIn) + _ -> False + +-- | Determine whether the given ledger is valid; i.e., all transactions are valid where they appear. valid :: Ledger -> Bool -valid [] = True -valid (t:ledger) = validTx t ledger && valid ledger +valid [] = True +valid (t : ledger) = validTx t ledger && valid ledger --- |The UTxO balance of a given address in a valid transaction for the given ledger. --- +-- | The UTxO balance of a given address in a valid transaction for the given ledger. balanceTx :: Address -> Tx -> Ledger -> Value balanceTx addr t ledger - | not (t `validTx` ledger) - = error "transaction not valid in ledger" + | not (t `validTx` ledger) = + error "transaction not valid in ledger" | otherwise = received - spent where - received = sum [ valueTO txOut | txOut <- outputsTX t, addressTO txOut == addr ] - spent = sum [ valueTO txOut - | txOut <- catMaybes . map (out ledger . refTI) $ inputsTX t - , addressTO txOut == addr - ] - --- |The UTxO balance of a given address in a ledger. --- + received = sum [valueTO txOut | txOut <- outputsTX t, addressTO txOut == addr] + spent = + sum + [ valueTO txOut + | txOut <- catMaybes . map (out ledger . refTI) $ inputsTX t + , addressTO txOut == addr + ] + +-- | The UTxO balance of a given address in a ledger. balance :: Address -> Ledger -> Value balance addr = bal 0 where - bal !acc [] = acc - bal !acc (t:ts) = bal (acc + balanceTx addr t ts) ts + bal !acc [] = acc + bal !acc (t : ts) = bal (acc + balanceTx addr t ts) ts diff --git a/doc/notes/model/UTxO.hsproj/Witness.hs b/doc/notes/model/UTxO.hsproj/Witness.hs index b1485f9fbbb..47c8e18162d 100644 --- a/doc/notes/model/UTxO.hsproj/Witness.hs +++ b/doc/notes/model/UTxO.hsproj/Witness.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -- | @@ -15,131 +15,153 @@ -- Stability : experimental -- -- Definition of script witnesses, including common witness functions - module Witness ( - -- ** Scripts - Script, script, scriptHash, - revealPreimageValidator, lockWithPublicKeyValidator, lockWithMultiSigValidator, - lockWithPublicKeyHashValidator, revealCollisionValidator, revealFixedPointValidator, + Script, + script, + scriptHash, + revealPreimageValidator, + lockWithPublicKeyValidator, + lockWithMultiSigValidator, + lockWithPublicKeyHashValidator, + revealCollisionValidator, + revealFixedPointValidator, lockUntilValidator, -- ** Witnesses - Height, Witness, witness, noWitness, validatorHash, redeemerHash, - revealPreimage, lockWithPublicKey, lockWithKeyPair, lockWithMultiSig, lockWithPublicKeyHash, - revealCollision, revealFixedPoint, lockUntil, + Height, + Witness, + witness, + noWitness, + validatorHash, + redeemerHash, + revealPreimage, + lockWithPublicKey, + lockWithKeyPair, + lockWithMultiSig, + lockWithPublicKeyHash, + revealCollision, + revealFixedPoint, + lockUntil, -- ** Witness validation - validate + validate, ) where -import "crypton" Crypto.Hash -import "crypton" Crypto.PubKey.ECC.ECDSA import Data.ByteArray qualified as BA import Data.ByteString.Char8 qualified as BS import Language.Haskell.TH import Language.Haskell.TH.Syntax +import "crypton" Crypto.Hash +import "crypton" Crypto.PubKey.ECC.ECDSA import Types - instance BA.ByteArrayAccess String where - length = BA.length . BS.pack + length = BA.length . BS.pack withByteArray = BA.withByteArray . BS.pack - -- Scripts -- ------- -data Script t = Script { scriptText :: String, scriptValue :: t } +data Script t = Script {scriptText :: String, scriptValue :: t} script :: Q (TExp t) -> Q (TExp (Script t)) -script scriptQ - = do - { scriptString <- (pprint . unType) <$> scriptQ - ; [|| Script scriptString $$scriptQ ||] - } +script scriptQ = + do + scriptString <- (pprint . unType) <$> scriptQ + [||Script scriptString $$scriptQ||] scriptHash :: Script t -> Digest SHA256 -scriptHash Script{..} = hash (hash . BS.pack $ scriptText :: Digest SHA256) - -- FIXME: we should serialise properly +scriptHash Script {..} = hash (hash . BS.pack $ scriptText :: Digest SHA256) +-- FIXME: we should serialise properly -- Common scripts -- -------------- instance Lift PublicKey where - lift pubkey = [| read $(lift $ show pubkey) |] - -- cheap'n'cheesy lifting of public keys into the Q monad + lift pubkey = [|read $(lift $ show pubkey)|] --- |This validator checks that the given preimage has the SHA256 hash embedded in the script. --- +-- cheap'n'cheesy lifting of public keys into the Q monad + +-- | This validator checks that the given preimage has the SHA256 hash embedded in the script. revealPreimageValidator :: BA.ByteArrayAccess v => v -> Q (TExp (Script (State -> v -> Bool))) -revealPreimageValidator preimage - = script [|| \state preimage -> show (hash preimage :: Digest SHA256) == digest ||] +revealPreimageValidator preimage = + script [||\state preimage -> show (hash preimage :: Digest SHA256) == digest||] where digest = show (hash preimage :: Digest SHA256) --- |This validator checks that the transaction signature matches the given public key. --- +-- | This validator checks that the transaction signature matches the given public key. lockWithPublicKeyValidator :: PublicKey -> Q (TExp (Script (State -> Signature -> Bool))) -lockWithPublicKeyValidator pubkey - = script [|| \state sig -> verify SHA256 pubkey sig (stateTxPreHash state) ||] +lockWithPublicKeyValidator pubkey = + script [||\state sig -> verify SHA256 pubkey sig (stateTxPreHash state)||] --- |This validator checks that the specified number of transaction signatures are distinct and --- each match one of the given public keys. --- +-- | This validator checks that the specified number of transaction signatures are distinct and +-- each match one of the given public keys. lockWithMultiSigValidator :: [PublicKey] -> Int -> Q (TExp (Script (State -> [Signature] -> Bool))) -lockWithMultiSigValidator pubkeys requiredSigCount - = script [|| \state sigs -> - let disjoint [] = True - disjoint (x:xs) = x `notElem` xs && disjoint xs - in - length sigs == requiredSigCount - && disjoint sigs - && all (\sig -> - any - (\pubkey -> verify SHA256 pubkey sig (stateTxPreHash state)) - pubkeys) - sigs - ||] - --- |This validator checks that the transaction signature matches the public key with the given hash. --- -lockWithPublicKeyHashValidator :: PublicKey - -> Q (TExp (Script (State -> (PublicKey, Signature) -> Bool))) -lockWithPublicKeyHashValidator pubKey - = script [|| \state (pubKey, sig) -> - show (hash (show pubKey) :: Digest SHA256) == digest - && verify SHA256 pubKey sig (stateTxPreHash state) ||] +lockWithMultiSigValidator pubkeys requiredSigCount = + script + [|| + \state sigs -> + let disjoint [] = True + disjoint (x : xs) = x `notElem` xs && disjoint xs + in length sigs == requiredSigCount + && disjoint sigs + && all + ( \sig -> + any + (\pubkey -> verify SHA256 pubkey sig (stateTxPreHash state)) + pubkeys + ) + sigs + ||] + +-- | This validator checks that the transaction signature matches the public key with the given hash. +lockWithPublicKeyHashValidator :: + PublicKey -> + Q (TExp (Script (State -> (PublicKey, Signature) -> Bool))) +lockWithPublicKeyHashValidator pubKey = + script + [|| + \state (pubKey, sig) -> + show (hash (show pubKey) :: Digest SHA256) == digest + && verify SHA256 pubKey sig (stateTxPreHash state) + ||] where - digest = show (hash (show pubKey) :: Digest SHA256) -- hash of public key - --- |This validator checks that the given two values produce a SHA1 collision. --- -revealCollisionValidator :: (BA.ByteArrayAccess v, Eq v) - => Q (TExp (Script (State -> (v, v) -> Bool))) -revealCollisionValidator - = script [|| \state (value1, value2) -> - value1 /= value2 - && hash value1 == (hash value2 :: Digest SHA1) ||] - --- |This validator checks that the value is a SHA256 fixed point. --- + digest = show (hash (show pubKey) :: Digest SHA256) -- hash of public key + +-- | This validator checks that the given two values produce a SHA1 collision. +revealCollisionValidator :: + (BA.ByteArrayAccess v, Eq v) => + Q (TExp (Script (State -> (v, v) -> Bool))) +revealCollisionValidator = + script + [|| + \state (value1, value2) -> + value1 /= value2 + && hash value1 == (hash value2 :: Digest SHA1) + ||] + +-- | This validator checks that the value is a SHA256 fixed point. revealFixedPointValidator :: BA.ByteArrayAccess v => Q (TExp (Script (State -> v -> Bool))) -revealFixedPointValidator - = script [|| \state value -> - digestFromByteString value == Just (hash value :: Digest SHA256) ||] - --- |This validator checks that the transaction signature matches the given public key --- and isn't added to the ledger before the ledger reaches the specified height. --- +revealFixedPointValidator = + script + [|| + \state value -> + digestFromByteString value == Just (hash value :: Digest SHA256) + ||] + +-- | This validator checks that the transaction signature matches the given public key +-- and isn't added to the ledger before the ledger reaches the specified height. lockUntilValidator :: PublicKey -> Height -> Q (TExp (Script (State -> Signature -> Bool))) -lockUntilValidator pubkey minHeight - = script [|| \state sig -> - stateHeight state >= minHeight - && verify SHA256 pubkey sig (stateTxPreHash state) ||] - +lockUntilValidator pubkey minHeight = + script + [|| + \state sig -> + stateHeight state >= minHeight + && verify SHA256 pubkey sig (stateTxPreHash state) + ||] -- Witness types -- ------------- @@ -147,26 +169,26 @@ lockUntilValidator pubkey minHeight data Witness where Witness :: { validator :: Script (State -> proof -> Bool) - , redeemer :: Script (State -> proof) - } -> Witness + , redeemer :: Script (State -> proof) + } -> + Witness -witness :: Q (TExp (Script (State -> proof -> Bool))) - -> Q (TExp (Script (State -> proof))) - -> Q (TExp Witness) -witness validatorQ redeemerQ = [|| Witness $$validatorQ $$redeemerQ ||] +witness :: + Q (TExp (Script (State -> proof -> Bool))) -> + Q (TExp (Script (State -> proof))) -> + Q (TExp Witness) +witness validatorQ redeemerQ = [||Witness $$validatorQ $$redeemerQ||] noWitness :: Witness noWitness = Witness (error "no validator") (error "no redeemer") --- |The hash of the witness' validator. --- +-- | The hash of the witness' validator. validatorHash :: Witness -> Digest SHA256 -validatorHash Witness{..} = scriptHash validator +validatorHash Witness {..} = scriptHash validator --- |The hash of the witness' redeemer. --- +-- | The hash of the witness' redeemer. redeemerHash :: Witness -> Digest SHA256 -redeemerHash Witness{..} = scriptHash validator +redeemerHash Witness {..} = scriptHash validator instance Show (Script t) where show = scriptText @@ -174,65 +196,65 @@ instance Show (Script t) where deriving instance Show Witness instance BA.ByteArrayAccess Witness where - length = BA.length . BS.pack . show -- FIXME: we should serialise properly - withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly - + length = BA.length . BS.pack . show -- FIXME: we should serialise properly + withByteArray = BA.withByteArray . BS.pack . show -- FIXME: we should serialise properly -- Common witnesses -- ---------------- instance Lift Signature where - lift sig = [| read $(lift $ show sig) |] - -- cheap'n'cheesy lifting of signature into the Q monad + lift sig = [|read $(lift $ show sig)|] + +-- cheap'n'cheesy lifting of signature into the Q monad revealPreimage :: (BA.ByteArrayAccess v, Lift v) => v -> Q (TExp Witness) -revealPreimage preimage = witness (revealPreimageValidator preimage) (script [|| const preimage ||]) +revealPreimage preimage = witness (revealPreimageValidator preimage) (script [||const preimage||]) lockWithPublicKey :: PublicKey -> Signature -> Q (TExp Witness) -lockWithPublicKey pubKey sig - = witness (lockWithPublicKeyValidator pubKey) - (script [|| const sig ||]) +lockWithPublicKey pubKey sig = + witness + (lockWithPublicKeyValidator pubKey) + (script [||const sig||]) lockWithKeyPair :: BA.ByteArrayAccess h => KeyPair -> h -> Q (TExp Witness) -lockWithKeyPair keys h - = do - { sig <- runIO $ sign (toPrivateKey keys) SHA256 h - ; lockWithPublicKey (toPublicKey keys) sig - } +lockWithKeyPair keys h = + do + sig <- runIO $ sign (toPrivateKey keys) SHA256 h + lockWithPublicKey (toPublicKey keys) sig lockWithMultiSig :: [PublicKey] -> Int -> [Signature] -> Q (TExp Witness) -lockWithMultiSig pubkeys requiredSigCount sigs - = witness (lockWithMultiSigValidator pubkeys requiredSigCount) - (script [|| const sigs ||]) +lockWithMultiSig pubkeys requiredSigCount sigs = + witness + (lockWithMultiSigValidator pubkeys requiredSigCount) + (script [||const sigs||]) lockWithPublicKeyHash :: PublicKey -> Signature -> Q (TExp Witness) -lockWithPublicKeyHash pubKey sig - = witness (lockWithPublicKeyHashValidator pubKey) - (script [|| const $ (pubKey, sig) ||]) +lockWithPublicKeyHash pubKey sig = + witness + (lockWithPublicKeyHashValidator pubKey) + (script [||const $ (pubKey, sig)||]) revealCollision :: (BA.ByteArrayAccess v, Eq v, Lift v) => v -> v -> Q (TExp Witness) revealCollision value1 value2 = - witness revealCollisionValidator (script [|| const (value1, value2) ||]) + witness revealCollisionValidator (script [||const (value1, value2)||]) revealFixedPoint :: (BA.ByteArrayAccess v, Lift v) => v -> Q (TExp Witness) -revealFixedPoint value = witness revealFixedPointValidator (script [|| const value ||]) +revealFixedPoint value = witness revealFixedPointValidator (script [||const value||]) lockUntil :: PublicKey -> Signature -> Height -> Q (TExp Witness) -lockUntil pubKey sig minHeight - = witness (lockUntilValidator pubKey minHeight) - (script [|| const sig ||]) - +lockUntil pubKey sig minHeight = + witness + (lockUntilValidator pubKey minHeight) + (script [||const sig||]) -- Witness validation -- ------------------ --- |Validate a witness whose validator must have the given hash under succeeds with --- the given transaction height. --- +-- | Validate a witness whose validator must have the given hash under succeeds with +-- the given transaction height. validate :: Digest SHA256 -> State -> Witness -> Bool -validate validatorHash state Witness{..} - | validatorHash /= scriptHash validator - = False - | otherwise - = (scriptValue validator) state (scriptValue redeemer state) - +validate validatorHash state Witness {..} + | validatorHash /= scriptHash validator = + False + | otherwise = + (scriptValue validator) state (scriptValue redeemer state) diff --git a/doc/notes/untyped-plutus-core/representation/src/IndexedTypity.hs b/doc/notes/untyped-plutus-core/representation/src/IndexedTypity.hs index e20cdad16f0..04f1690ed88 100644 --- a/doc/notes/untyped-plutus-core/representation/src/IndexedTypity.hs +++ b/doc/notes/untyped-plutus-core/representation/src/IndexedTypity.hs @@ -1,104 +1,107 @@ -{-# OPTIONS_GHC -Wall #-} - {-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Wall #-} module IndexedTypity where type Constant = () type Builtin = () -data Name = Name +data Name = Name data TyName = TyName data Kind = Kind data Type = Type data TypedTerm - = TypedConstant Constant - | TypedBuiltin Builtin - | TypedVar Name - | TypedLamAbs Name Type TypedTerm - | TypedApply TypedTerm TypedTerm - | TypedTyAbs TyName Kind TypedTerm - | TypedTyInst TypedTerm Type - | TypedUnwrap TypedTerm - | TypedIWrap Type Type TypedTerm - | TypedError Type + = TypedConstant Constant + | TypedBuiltin Builtin + | TypedVar Name + | TypedLamAbs Name Type TypedTerm + | TypedApply TypedTerm TypedTerm + | TypedTyAbs TyName Kind TypedTerm + | TypedTyInst TypedTerm Type + | TypedUnwrap TypedTerm + | TypedIWrap Type Type TypedTerm + | TypedError Type data UntypedTerm - = UntypedConstant Constant - | UntypedBuiltin Builtin - | UntypedVar Name - | UntypedLamAbs Name UntypedTerm - | UntypedApply UntypedTerm UntypedTerm - | UntypedDelay UntypedTerm - | UntypedForce UntypedTerm - | UntypedError + = UntypedConstant Constant + | UntypedBuiltin Builtin + | UntypedVar Name + | UntypedLamAbs Name UntypedTerm + | UntypedApply UntypedTerm UntypedTerm + | UntypedDelay UntypedTerm + | UntypedForce UntypedTerm + | UntypedError data Typity ty where - Typed :: Typity Type - Untyped :: Typity () + Typed :: Typity Type + Untyped :: Typity () data Term (typity :: Typity ty) where - Constant :: Constant -> Term typity - Builtin :: Builtin -> Term typity - Var :: Name -> Term typity - LamAbs :: Name -> ty -> Term typity -> Term (typity :: Typity ty) - Apply :: Term typity -> Term typity -> Term typity - TyAbs :: TyName -> Kind -> Term 'Typed -> Term 'Typed - TyInst :: Term 'Typed -> Type -> Term 'Typed - Unwrap :: Term 'Typed -> Term 'Typed - IWrap :: Type -> Type -> Term 'Typed -> Term 'Typed - Delay :: Term 'Untyped -> Term 'Untyped - Force :: Term 'Untyped -> Term 'Untyped - Error :: ty -> Term (typity :: Typity ty) + Constant :: Constant -> Term typity + Builtin :: Builtin -> Term typity + Var :: Name -> Term typity + LamAbs :: Name -> ty -> Term typity -> Term (typity :: Typity ty) + Apply :: Term typity -> Term typity -> Term typity + TyAbs :: TyName -> Kind -> Term 'Typed -> Term 'Typed + TyInst :: Term 'Typed -> Type -> Term 'Typed + Unwrap :: Term 'Typed -> Term 'Typed + IWrap :: Type -> Type -> Term 'Typed -> Term 'Typed + Delay :: Term 'Untyped -> Term 'Untyped + Force :: Term 'Untyped -> Term 'Untyped + Error :: ty -> Term (typity :: Typity ty) termToTypedTerm :: Term 'Typed -> TypedTerm -termToTypedTerm = go where - go (Constant con) = TypedConstant con - go (Builtin bn) = TypedBuiltin bn - go (Var name) = TypedVar name - go (LamAbs name ty body) = TypedLamAbs name ty (go body) - go (Apply fun arg) = TypedApply (go fun) (go arg) +termToTypedTerm = go + where + go (Constant con) = TypedConstant con + go (Builtin bn) = TypedBuiltin bn + go (Var name) = TypedVar name + go (LamAbs name ty body) = TypedLamAbs name ty (go body) + go (Apply fun arg) = TypedApply (go fun) (go arg) go (TyAbs name kind body) = TypedTyAbs name kind (go body) - go (TyInst term ty) = TypedTyInst (go term) ty - go (IWrap pat arg term) = TypedIWrap pat arg (go term) - go (Unwrap term) = TypedUnwrap (go term) - go (Error ty) = TypedError ty + go (TyInst term ty) = TypedTyInst (go term) ty + go (IWrap pat arg term) = TypedIWrap pat arg (go term) + go (Unwrap term) = TypedUnwrap (go term) + go (Error ty) = TypedError ty typedTermToTerm :: TypedTerm -> Term 'Typed -typedTermToTerm = go where - go (TypedConstant con) = Constant con - go (TypedBuiltin bn) = Builtin bn - go (TypedVar name) = Var name - go (TypedLamAbs name ty body) = LamAbs name ty (go body) - go (TypedApply fun arg) = Apply (go fun) (go arg) +typedTermToTerm = go + where + go (TypedConstant con) = Constant con + go (TypedBuiltin bn) = Builtin bn + go (TypedVar name) = Var name + go (TypedLamAbs name ty body) = LamAbs name ty (go body) + go (TypedApply fun arg) = Apply (go fun) (go arg) go (TypedTyAbs name kind body) = TyAbs name kind (go body) - go (TypedTyInst term ty) = TyInst (go term) ty - go (TypedIWrap pat arg term) = IWrap pat arg (go term) - go (TypedUnwrap term) = Unwrap (go term) - go (TypedError ty) = Error ty + go (TypedTyInst term ty) = TyInst (go term) ty + go (TypedIWrap pat arg term) = IWrap pat arg (go term) + go (TypedUnwrap term) = Unwrap (go term) + go (TypedError ty) = Error ty termToUntypedTerm :: Term 'Untyped -> UntypedTerm -termToUntypedTerm = go where - go (Constant con) = UntypedConstant con - go (Builtin bn) = UntypedBuiltin bn - go (Var name) = UntypedVar name +termToUntypedTerm = go + where + go (Constant con) = UntypedConstant con + go (Builtin bn) = UntypedBuiltin bn + go (Var name) = UntypedVar name go (LamAbs name () body) = UntypedLamAbs name (go body) - go (Apply fun arg) = UntypedApply (go fun) (go arg) - go (Delay term) = UntypedDelay (go term) - go (Force term) = UntypedForce (go term) - go (Error ()) = UntypedError + go (Apply fun arg) = UntypedApply (go fun) (go arg) + go (Delay term) = UntypedDelay (go term) + go (Force term) = UntypedForce (go term) + go (Error ()) = UntypedError untypedTermToTerm :: UntypedTerm -> Term 'Untyped -untypedTermToTerm = go where - go (UntypedConstant con) = Constant con - go (UntypedBuiltin bn) = Builtin bn - go (UntypedVar name) = Var name +untypedTermToTerm = go + where + go (UntypedConstant con) = Constant con + go (UntypedBuiltin bn) = Builtin bn + go (UntypedVar name) = Var name go (UntypedLamAbs name body) = LamAbs name () (go body) - go (UntypedApply fun arg) = Apply (go fun) (go arg) - go (UntypedDelay term) = Delay (go term) - go (UntypedForce term) = Force (go term) - go UntypedError = Error () + go (UntypedApply fun arg) = Apply (go fun) (go arg) + go (UntypedDelay term) = Delay (go term) + go (UntypedForce term) = Force (go term) + go UntypedError = Error () diff --git a/doc/notes/untyped-plutus-core/representation/src/Main.hs b/doc/notes/untyped-plutus-core/representation/src/Main.hs index e8dc9214f7b..8ab11b9233a 100644 --- a/doc/notes/untyped-plutus-core/representation/src/Main.hs +++ b/doc/notes/untyped-plutus-core/representation/src/Main.hs @@ -1,15 +1,14 @@ -{-# OPTIONS_GHC -Wall #-} - -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} module Main where type Constant = () type Builtin = () -data Name = Name +data Name = Name data TyName = TyName data Kind = Kind @@ -83,97 +82,101 @@ exists in @Term 'Untyped@ and not @Term 'Typed@. GHC also sees that and doesn't -} data TypedTerm - = TypedConstant Constant - | TypedBuiltin Builtin - | TypedVar Name - | TypedLamAbs Name Type TypedTerm - | TypedApply TypedTerm TypedTerm - | TypedTyAbs TyName Kind TypedTerm - | TypedTyInst TypedTerm Type - | TypedUnwrap TypedTerm - | TypedIWrap Type Type TypedTerm - | TypedError Type + = TypedConstant Constant + | TypedBuiltin Builtin + | TypedVar Name + | TypedLamAbs Name Type TypedTerm + | TypedApply TypedTerm TypedTerm + | TypedTyAbs TyName Kind TypedTerm + | TypedTyInst TypedTerm Type + | TypedUnwrap TypedTerm + | TypedIWrap Type Type TypedTerm + | TypedError Type data UntypedTerm - = UntypedConstant Constant - | UntypedBuiltin Builtin - | UntypedVar Name - | UntypedLamAbs Name UntypedTerm - | UntypedApply UntypedTerm UntypedTerm - | UntypedDelay UntypedTerm - | UntypedForce UntypedTerm - | UntypedError + = UntypedConstant Constant + | UntypedBuiltin Builtin + | UntypedVar Name + | UntypedLamAbs Name UntypedTerm + | UntypedApply UntypedTerm UntypedTerm + | UntypedDelay UntypedTerm + | UntypedForce UntypedTerm + | UntypedError data Typity - = Typed - | Untyped + = Typed + | Untyped type family ToType (typity :: Typity) where - ToType 'Typed = Type - ToType 'Untyped = () + ToType 'Typed = Type + ToType 'Untyped = () -- See Note [Encoding]. data Term (typity :: Typity) - = Constant Constant - | Builtin Builtin - | Var Name - | LamAbs Name (ToType typity) (Term typity) - | Apply (Term typity) (Term typity) - | typity ~ 'Typed => TyAbs TyName Kind (Term typity) - | typity ~ 'Typed => TyInst (Term typity) Type - | typity ~ 'Typed => Unwrap (Term typity) - | typity ~ 'Typed => IWrap Type Type (Term typity) - | typity ~ 'Untyped => Delay (Term typity) - | typity ~ 'Untyped => Force (Term typity) - | Error (ToType typity) + = Constant Constant + | Builtin Builtin + | Var Name + | LamAbs Name (ToType typity) (Term typity) + | Apply (Term typity) (Term typity) + | typity ~ 'Typed => TyAbs TyName Kind (Term typity) + | typity ~ 'Typed => TyInst (Term typity) Type + | typity ~ 'Typed => Unwrap (Term typity) + | typity ~ 'Typed => IWrap Type Type (Term typity) + | typity ~ 'Untyped => Delay (Term typity) + | typity ~ 'Untyped => Force (Term typity) + | Error (ToType typity) termToTypedTerm :: Term 'Typed -> TypedTerm -termToTypedTerm = go where - go (Constant con) = TypedConstant con - go (Builtin bn) = TypedBuiltin bn - go (Var name) = TypedVar name - go (LamAbs name ty body) = TypedLamAbs name ty (go body) - go (Apply fun arg) = TypedApply (go fun) (go arg) +termToTypedTerm = go + where + go (Constant con) = TypedConstant con + go (Builtin bn) = TypedBuiltin bn + go (Var name) = TypedVar name + go (LamAbs name ty body) = TypedLamAbs name ty (go body) + go (Apply fun arg) = TypedApply (go fun) (go arg) go (TyAbs name kind body) = TypedTyAbs name kind (go body) - go (TyInst term ty) = TypedTyInst (go term) ty - go (IWrap pat arg term) = TypedIWrap pat arg (go term) - go (Unwrap term) = TypedUnwrap (go term) - go (Error ty) = TypedError ty + go (TyInst term ty) = TypedTyInst (go term) ty + go (IWrap pat arg term) = TypedIWrap pat arg (go term) + go (Unwrap term) = TypedUnwrap (go term) + go (Error ty) = TypedError ty typedTermToTerm :: TypedTerm -> Term 'Typed -typedTermToTerm = go where - go (TypedConstant con) = Constant con - go (TypedBuiltin bn) = Builtin bn - go (TypedVar name) = Var name - go (TypedLamAbs name ty body) = LamAbs name ty (go body) - go (TypedApply fun arg) = Apply (go fun) (go arg) +typedTermToTerm = go + where + go (TypedConstant con) = Constant con + go (TypedBuiltin bn) = Builtin bn + go (TypedVar name) = Var name + go (TypedLamAbs name ty body) = LamAbs name ty (go body) + go (TypedApply fun arg) = Apply (go fun) (go arg) go (TypedTyAbs name kind body) = TyAbs name kind (go body) - go (TypedTyInst term ty) = TyInst (go term) ty - go (TypedIWrap pat arg term) = IWrap pat arg (go term) - go (TypedUnwrap term) = Unwrap (go term) - go (TypedError ty) = Error ty + go (TypedTyInst term ty) = TyInst (go term) ty + go (TypedIWrap pat arg term) = IWrap pat arg (go term) + go (TypedUnwrap term) = Unwrap (go term) + go (TypedError ty) = Error ty termToUntypedTerm :: Term 'Untyped -> UntypedTerm -termToUntypedTerm = go where - go (Constant con) = UntypedConstant con - go (Builtin bn) = UntypedBuiltin bn - go (Var name) = UntypedVar name +termToUntypedTerm = go + where + go (Constant con) = UntypedConstant con + go (Builtin bn) = UntypedBuiltin bn + go (Var name) = UntypedVar name go (LamAbs name () body) = UntypedLamAbs name (go body) - go (Apply fun arg) = UntypedApply (go fun) (go arg) - go (Delay term) = UntypedDelay (go term) - go (Force term) = UntypedForce (go term) - go (Error ()) = UntypedError + go (Apply fun arg) = UntypedApply (go fun) (go arg) + go (Delay term) = UntypedDelay (go term) + go (Force term) = UntypedForce (go term) + go (Error ()) = UntypedError untypedTermToTerm :: UntypedTerm -> Term 'Untyped -untypedTermToTerm = go where - go (UntypedConstant con) = Constant con - go (UntypedBuiltin bn) = Builtin bn - go (UntypedVar name) = Var name +untypedTermToTerm = go + where + go (UntypedConstant con) = Constant con + go (UntypedBuiltin bn) = Builtin bn + go (UntypedVar name) = Var name go (UntypedLamAbs name body) = LamAbs name () (go body) - go (UntypedApply fun arg) = Apply (go fun) (go arg) - go (UntypedDelay term) = Delay (go term) - go (UntypedForce term) = Force (go term) - go UntypedError = Error () + go (UntypedApply fun arg) = Apply (go fun) (go arg) + go (UntypedDelay term) = Delay (go term) + go (UntypedForce term) = Force (go term) + go UntypedError = Error () main :: IO () main = mempty diff --git a/fourmolu.yaml b/fourmolu.yaml index 6a37f27c98e..939ec5e84e2 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -2,10 +2,10 @@ indentation: 2 # Max line length for automatic line breaking -column-limit: 100 +column-limit: none # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) -function-arrows: leading +function-arrows: trailing # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) comma-style: leading @@ -14,19 +14,19 @@ comma-style: leading import-export-style: diff-friendly # Whether to full-indent or half-indent 'where' bindings past the preceding body -indent-wheres: false +indent-wheres: true # Whether to leave a space before an opening record brace -record-brace-space: false +record-brace-space: true # Number of spaces between top-level declarations newlines-between-decls: 1 # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) -haddock-style: multi-line-compact +haddock-style: single-line # How to print module docstring -haddock-style-module: null +haddock-style-module: single-line # Styling of let blocks (choices: auto, inline, newline, or mixed) let-style: auto @@ -35,10 +35,10 @@ let-style: auto in-style: right-align # Whether to put parentheses around a single constraint (choices: auto, always, or never) -single-constraint-parens: always +single-constraint-parens: never # Whether to put parentheses around a single deriving class (choices: auto, always, or never) -single-deriving-parens: auto +single-deriving-parens: always # Output Unicode syntax (choices: detect, always, or never) unicode: never diff --git a/nix/shell.nix b/nix/shell.nix index 18012354b82..8f31796002b 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -27,16 +27,10 @@ let enable = true; package = tools.cabal-fmt; }; - stylish-haskell = { - enable = true; - package = tools.stylish-haskell; - args = [ "--config" ".stylish-haskell.yaml" ]; - excludes = [ "^plutus-metatheory/src/MAlonzo" ]; - }; fourmolu = { - enable = false; + enable = true; package = tools.fourmolu; - args = [ "--mode" "inplace" ]; + excludes = [ "^plutus-metatheory/src/MAlonzo" ]; }; hlint = { enable = false; diff --git a/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs b/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs index db9e5a3db62..166171fa1b6 100644 --- a/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs +++ b/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs @@ -1,7 +1,7 @@ -module PlutusBenchmark.Agda.Common - ( benchTermAgdaCek - , benchProgramAgdaCek - ) +module PlutusBenchmark.Agda.Common ( + benchTermAgdaCek, + benchProgramAgdaCek, +) where import PlutusCore qualified as PLC @@ -21,13 +21,12 @@ type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun () benchTermAgdaCek :: Term -> Benchmarkable benchTermAgdaCek term = - nf unsafeRunAgdaCek $! term + nf unsafeRunAgdaCek $! term benchProgramAgdaCek :: Program -> Benchmarkable benchProgramAgdaCek (UPLC.Program _ _ term) = - nf unsafeRunAgdaCek $! term + nf unsafeRunAgdaCek $! term unsafeRunAgdaCek :: Term -> PLC.EvaluationResult Term unsafeRunAgdaCek = - either (error . \e -> "Agda evaluation error: " ++ show e) PLC.EvaluationSuccess . runUAgda - + either (error . \e -> "Agda evaluation error: " ++ show e) PLC.EvaluationSuccess . runUAgda diff --git a/plutus-benchmark/bitwise/bench/Main.hs b/plutus-benchmark/bitwise/bench/Main.hs index 82cfa7df55a..7803aec80c2 100644 --- a/plutus-benchmark/bitwise/bench/Main.hs +++ b/plutus-benchmark/bitwise/bench/Main.hs @@ -1,5 +1,5 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where @@ -11,9 +11,10 @@ import PlutusBenchmark.NQueens.Compiled (dimAsData, nqueensCompiled) import PlutusTx.Code (getPlcNoAnn, unsafeApplyCode) main :: IO () -main = defaultMain [ - bench "Ed25519" . benchProgramCek mkMostRecentEvalCtx . getPlcNoAnn $ - checkValidCompiled `unsafeApplyCode` signatureAsData `unsafeApplyCode` msgAsData `unsafeApplyCode` pkAsData, - bench "8-queens" . benchProgramCek mkMostRecentEvalCtx . getPlcNoAnn $ - nqueensCompiled `unsafeApplyCode` dimAsData - ] +main = + defaultMain + [ bench "Ed25519" . benchProgramCek mkMostRecentEvalCtx . getPlcNoAnn $ + checkValidCompiled `unsafeApplyCode` signatureAsData `unsafeApplyCode` msgAsData `unsafeApplyCode` pkAsData + , bench "8-queens" . benchProgramCek mkMostRecentEvalCtx . getPlcNoAnn $ + nqueensCompiled `unsafeApplyCode` dimAsData + ] diff --git a/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519.hs b/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519.hs index 21955f41eec..e13a7ac03e3 100644 --- a/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519.hs +++ b/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} module PlutusBenchmark.Ed25519 (checkValid) where @@ -92,10 +92,10 @@ q = 5789604461865809771178549250434395392663499233282028201972879200395656481994 xRecover :: Integer -> Integer xRecover y = if - | cond1 && not cond2 -> xA - | cond1 && cond2 -> xAB - | not cond1 && cond2 -> xB - | otherwise -> x + | cond1 && not cond2 -> xA + | cond1 && cond2 -> xAB + | not cond1 && cond2 -> xB + | otherwise -> x where xx :: Integer xx = (y * y - 1) * inv (d * y * y + 1) diff --git a/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519/Compiled.hs b/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519/Compiled.hs index 4006c564291..2968b625aa4 100644 --- a/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519/Compiled.hs +++ b/plutus-benchmark/bitwise/src/PlutusBenchmark/Ed25519/Compiled.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} -module PlutusBenchmark.Ed25519.Compiled - ( checkValidCompiled - , msgAsData - , signatureAsData - , pkAsData - ) where +module PlutusBenchmark.Ed25519.Compiled ( + checkValidCompiled, + msgAsData, + signatureAsData, + pkAsData, +) where import PlutusBenchmark.Ed25519 (checkValid) import PlutusTx.Code (CompiledCode) @@ -19,8 +19,8 @@ import PlutusTx.Plugin () import PlutusTx.Prelude import PlutusTx.TH (compile) -checkValidCompiled - :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> Bool) +checkValidCompiled :: + CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> Bool) checkValidCompiled = $$( compile [|| diff --git a/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens.hs b/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens.hs index 3c868472dac..0e1fe07842d 100644 --- a/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens.hs +++ b/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens.hs @@ -1,5 +1,5 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} module PlutusBenchmark.NQueens (nqueens) where @@ -54,7 +54,7 @@ nqueens dim -- than recomputing it every time we modify selectIx. newControl = complementByteString . orByteString False newDown . orByteString False newLeft $ newRight in case go 0 newRow newDown newLeft newRight newControl of - [] -> go (selectIx + 1) row down left right control + [] -> go (selectIx + 1) row down left right control next -> (row, available) : next lastRow :: Integer lastRow = dim - 1 @@ -65,10 +65,11 @@ nqueens dim selectByteString :: Integer -> BuiltinByteString -> Integer selectByteString which bs | which <= 0 = findFirstSetBit bs - | otherwise = let i = selectByteString (which - 1) bs - in if i == (-1) - then (-1) - else i + 1 + findFirstSetBit (shiftByteString bs $ negate (i + 1)) + | otherwise = + let i = selectByteString (which - 1) bs + in if i == (-1) + then (-1) + else i + 1 + findFirstSetBit (shiftByteString bs $ negate (i + 1)) {-# INLINE selectByteString #-} writeBit :: BuiltinByteString -> Integer -> Bool -> BuiltinByteString diff --git a/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens/Compiled.hs b/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens/Compiled.hs index c2e8546d65c..3feea66e5e0 100644 --- a/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens/Compiled.hs +++ b/plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens/Compiled.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.NQueens.Compiled ( nqueensCompiled, - dimAsData - ) where + dimAsData, +) where import PlutusBenchmark.NQueens (nqueens) import PlutusTx.Code (CompiledCode) @@ -16,7 +16,7 @@ import PlutusTx.Prelude import PlutusTx.TH (compile) nqueensCompiled :: CompiledCode (BuiltinData -> [(Integer, Integer)]) -nqueensCompiled = $$(compile [|| \dim -> nqueens (unsafeFromBuiltinData dim) ||]) +nqueensCompiled = $$(compile [||\dim -> nqueens (unsafeFromBuiltinData dim)||]) dimAsData :: CompiledCode BuiltinData dimAsData = liftCodeDef (toBuiltinData (8 :: Integer)) diff --git a/plutus-benchmark/bitwise/src/PlutusBenchmark/SHA512.hs b/plutus-benchmark/bitwise/src/PlutusBenchmark/SHA512.hs index 97975eafb5a..2e447724878 100644 --- a/plutus-benchmark/bitwise/src/PlutusBenchmark/SHA512.hs +++ b/plutus-benchmark/bitwise/src/PlutusBenchmark/SHA512.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} module PlutusBenchmark.SHA512 (sha512) where @@ -91,26 +91,28 @@ data SHA512State UInt64 initialState :: SHA512State -initialState = SHA512State (integerToUInt64 0x6a09_e667_f3bc_c908) - (integerToUInt64 0xbb67_ae85_84ca_a73b) - (integerToUInt64 0x3c6e_f372_fe94_f82b) - (integerToUInt64 0xa54f_f53a_5f1d_36f1) - (integerToUInt64 0x510e_527f_ade6_82d1) - (integerToUInt64 0x9b05_688c_2b3e_6c1f) - (integerToUInt64 0x1f83_d9ab_fb41_bd6b) - (integerToUInt64 0x5be0_cd19_137e_2179) +initialState = + SHA512State + (integerToUInt64 0x6a09_e667_f3bc_c908) + (integerToUInt64 0xbb67_ae85_84ca_a73b) + (integerToUInt64 0x3c6e_f372_fe94_f82b) + (integerToUInt64 0xa54f_f53a_5f1d_36f1) + (integerToUInt64 0x510e_527f_ade6_82d1) + (integerToUInt64 0x9b05_688c_2b3e_6c1f) + (integerToUInt64 0x1f83_d9ab_fb41_bd6b) + (integerToUInt64 0x5be0_cd19_137e_2179) {-# INLINEABLE initialState #-} extract :: SHA512State -> BuiltinByteString extract (SHA512State x1 x2 x3 x4 x5 x6 x7 x8) = - uint64ToBS x1 <> - uint64ToBS x2 <> - uint64ToBS x3 <> - uint64ToBS x4 <> - uint64ToBS x5 <> - uint64ToBS x6 <> - uint64ToBS x7 <> - uint64ToBS x8 + uint64ToBS x1 + <> uint64ToBS x2 + <> uint64ToBS x3 + <> uint64ToBS x4 + <> uint64ToBS x5 + <> uint64ToBS x6 + <> uint64ToBS x7 + <> uint64ToBS x8 {-# INLINEABLE extract #-} data SHA512Sched @@ -198,168 +200,168 @@ data SHA512Sched getSHA512Sched :: BuiltinByteString -> (SHA512Sched, BuiltinByteString) getSHA512Sched bs = - let (w00, rest00) = next64 bs - (w01, rest01) = next64 rest00 - (w02, rest02) = next64 rest01 - (w03, rest03) = next64 rest02 - (w04, rest04) = next64 rest03 - (w05, rest05) = next64 rest04 - (w06, rest06) = next64 rest05 - (w07, rest07) = next64 rest06 - (w08, rest08) = next64 rest07 - (w09, rest09) = next64 rest08 - (w10, rest10) = next64 rest09 - (w11, rest11) = next64 rest10 - (w12, rest12) = next64 rest11 - (w13, rest13) = next64 rest12 - (w14, rest14) = next64 rest13 - (w15, cont) = next64 rest14 - w16 = lsig512_1 w14 #+ w09 #+ lsig512_0 w01 #+ w00 - w17 = lsig512_1 w15 #+ w10 #+ lsig512_0 w02 #+ w01 - w18 = lsig512_1 w16 #+ w11 #+ lsig512_0 w03 #+ w02 - w19 = lsig512_1 w17 #+ w12 #+ lsig512_0 w04 #+ w03 - w20 = lsig512_1 w18 #+ w13 #+ lsig512_0 w05 #+ w04 - w21 = lsig512_1 w19 #+ w14 #+ lsig512_0 w06 #+ w05 - w22 = lsig512_1 w20 #+ w15 #+ lsig512_0 w07 #+ w06 - w23 = lsig512_1 w21 #+ w16 #+ lsig512_0 w08 #+ w07 - w24 = lsig512_1 w22 #+ w17 #+ lsig512_0 w09 #+ w08 - w25 = lsig512_1 w23 #+ w18 #+ lsig512_0 w10 #+ w09 - w26 = lsig512_1 w24 #+ w19 #+ lsig512_0 w11 #+ w10 - w27 = lsig512_1 w25 #+ w20 #+ lsig512_0 w12 #+ w11 - w28 = lsig512_1 w26 #+ w21 #+ lsig512_0 w13 #+ w12 - w29 = lsig512_1 w27 #+ w22 #+ lsig512_0 w14 #+ w13 - w30 = lsig512_1 w28 #+ w23 #+ lsig512_0 w15 #+ w14 - w31 = lsig512_1 w29 #+ w24 #+ lsig512_0 w16 #+ w15 - w32 = lsig512_1 w30 #+ w25 #+ lsig512_0 w17 #+ w16 - w33 = lsig512_1 w31 #+ w26 #+ lsig512_0 w18 #+ w17 - w34 = lsig512_1 w32 #+ w27 #+ lsig512_0 w19 #+ w18 - w35 = lsig512_1 w33 #+ w28 #+ lsig512_0 w20 #+ w19 - w36 = lsig512_1 w34 #+ w29 #+ lsig512_0 w21 #+ w20 - w37 = lsig512_1 w35 #+ w30 #+ lsig512_0 w22 #+ w21 - w38 = lsig512_1 w36 #+ w31 #+ lsig512_0 w23 #+ w22 - w39 = lsig512_1 w37 #+ w32 #+ lsig512_0 w24 #+ w23 - w40 = lsig512_1 w38 #+ w33 #+ lsig512_0 w25 #+ w24 - w41 = lsig512_1 w39 #+ w34 #+ lsig512_0 w26 #+ w25 - w42 = lsig512_1 w40 #+ w35 #+ lsig512_0 w27 #+ w26 - w43 = lsig512_1 w41 #+ w36 #+ lsig512_0 w28 #+ w27 - w44 = lsig512_1 w42 #+ w37 #+ lsig512_0 w29 #+ w28 - w45 = lsig512_1 w43 #+ w38 #+ lsig512_0 w30 #+ w29 - w46 = lsig512_1 w44 #+ w39 #+ lsig512_0 w31 #+ w30 - w47 = lsig512_1 w45 #+ w40 #+ lsig512_0 w32 #+ w31 - w48 = lsig512_1 w46 #+ w41 #+ lsig512_0 w33 #+ w32 - w49 = lsig512_1 w47 #+ w42 #+ lsig512_0 w34 #+ w33 - w50 = lsig512_1 w48 #+ w43 #+ lsig512_0 w35 #+ w34 - w51 = lsig512_1 w49 #+ w44 #+ lsig512_0 w36 #+ w35 - w52 = lsig512_1 w50 #+ w45 #+ lsig512_0 w37 #+ w36 - w53 = lsig512_1 w51 #+ w46 #+ lsig512_0 w38 #+ w37 - w54 = lsig512_1 w52 #+ w47 #+ lsig512_0 w39 #+ w38 - w55 = lsig512_1 w53 #+ w48 #+ lsig512_0 w40 #+ w39 - w56 = lsig512_1 w54 #+ w49 #+ lsig512_0 w41 #+ w40 - w57 = lsig512_1 w55 #+ w50 #+ lsig512_0 w42 #+ w41 - w58 = lsig512_1 w56 #+ w51 #+ lsig512_0 w43 #+ w42 - w59 = lsig512_1 w57 #+ w52 #+ lsig512_0 w44 #+ w43 - w60 = lsig512_1 w58 #+ w53 #+ lsig512_0 w45 #+ w44 - w61 = lsig512_1 w59 #+ w54 #+ lsig512_0 w46 #+ w45 - w62 = lsig512_1 w60 #+ w55 #+ lsig512_0 w47 #+ w46 - w63 = lsig512_1 w61 #+ w56 #+ lsig512_0 w48 #+ w47 - w64 = lsig512_1 w62 #+ w57 #+ lsig512_0 w49 #+ w48 - w65 = lsig512_1 w63 #+ w58 #+ lsig512_0 w50 #+ w49 - w66 = lsig512_1 w64 #+ w59 #+ lsig512_0 w51 #+ w50 - w67 = lsig512_1 w65 #+ w60 #+ lsig512_0 w52 #+ w51 - w68 = lsig512_1 w66 #+ w61 #+ lsig512_0 w53 #+ w52 - w69 = lsig512_1 w67 #+ w62 #+ lsig512_0 w54 #+ w53 - w70 = lsig512_1 w68 #+ w63 #+ lsig512_0 w55 #+ w54 - w71 = lsig512_1 w69 #+ w64 #+ lsig512_0 w56 #+ w55 - w72 = lsig512_1 w70 #+ w65 #+ lsig512_0 w57 #+ w56 - w73 = lsig512_1 w71 #+ w66 #+ lsig512_0 w58 #+ w57 - w74 = lsig512_1 w72 #+ w67 #+ lsig512_0 w59 #+ w58 - w75 = lsig512_1 w73 #+ w68 #+ lsig512_0 w60 #+ w59 - w76 = lsig512_1 w74 #+ w69 #+ lsig512_0 w61 #+ w60 - w77 = lsig512_1 w75 #+ w70 #+ lsig512_0 w62 #+ w61 - w78 = lsig512_1 w76 #+ w71 #+ lsig512_0 w63 #+ w62 - w79 = lsig512_1 w77 #+ w72 #+ lsig512_0 w64 #+ w63 - in (,cont) - $ SHA512Sched - w00 - w01 - w02 - w03 - w04 - w05 - w06 - w07 - w08 - w09 - w10 - w11 - w12 - w13 - w14 - w15 - w16 - w17 - w18 - w19 - w20 - w21 - w22 - w23 - w24 - w25 - w26 - w27 - w28 - w29 - w30 - w31 - w32 - w33 - w34 - w35 - w36 - w37 - w38 - w39 - w40 - w41 - w42 - w43 - w44 - w45 - w46 - w47 - w48 - w49 - w50 - w51 - w52 - w53 - w54 - w55 - w56 - w57 - w58 - w59 - w60 - w61 - w62 - w63 - w64 - w65 - w66 - w67 - w68 - w69 - w70 - w71 - w72 - w73 - w74 - w75 - w76 - w77 - w78 - w79 + let (w00, rest00) = next64 bs + (w01, rest01) = next64 rest00 + (w02, rest02) = next64 rest01 + (w03, rest03) = next64 rest02 + (w04, rest04) = next64 rest03 + (w05, rest05) = next64 rest04 + (w06, rest06) = next64 rest05 + (w07, rest07) = next64 rest06 + (w08, rest08) = next64 rest07 + (w09, rest09) = next64 rest08 + (w10, rest10) = next64 rest09 + (w11, rest11) = next64 rest10 + (w12, rest12) = next64 rest11 + (w13, rest13) = next64 rest12 + (w14, rest14) = next64 rest13 + (w15, cont) = next64 rest14 + w16 = lsig512_1 w14 #+ w09 #+ lsig512_0 w01 #+ w00 + w17 = lsig512_1 w15 #+ w10 #+ lsig512_0 w02 #+ w01 + w18 = lsig512_1 w16 #+ w11 #+ lsig512_0 w03 #+ w02 + w19 = lsig512_1 w17 #+ w12 #+ lsig512_0 w04 #+ w03 + w20 = lsig512_1 w18 #+ w13 #+ lsig512_0 w05 #+ w04 + w21 = lsig512_1 w19 #+ w14 #+ lsig512_0 w06 #+ w05 + w22 = lsig512_1 w20 #+ w15 #+ lsig512_0 w07 #+ w06 + w23 = lsig512_1 w21 #+ w16 #+ lsig512_0 w08 #+ w07 + w24 = lsig512_1 w22 #+ w17 #+ lsig512_0 w09 #+ w08 + w25 = lsig512_1 w23 #+ w18 #+ lsig512_0 w10 #+ w09 + w26 = lsig512_1 w24 #+ w19 #+ lsig512_0 w11 #+ w10 + w27 = lsig512_1 w25 #+ w20 #+ lsig512_0 w12 #+ w11 + w28 = lsig512_1 w26 #+ w21 #+ lsig512_0 w13 #+ w12 + w29 = lsig512_1 w27 #+ w22 #+ lsig512_0 w14 #+ w13 + w30 = lsig512_1 w28 #+ w23 #+ lsig512_0 w15 #+ w14 + w31 = lsig512_1 w29 #+ w24 #+ lsig512_0 w16 #+ w15 + w32 = lsig512_1 w30 #+ w25 #+ lsig512_0 w17 #+ w16 + w33 = lsig512_1 w31 #+ w26 #+ lsig512_0 w18 #+ w17 + w34 = lsig512_1 w32 #+ w27 #+ lsig512_0 w19 #+ w18 + w35 = lsig512_1 w33 #+ w28 #+ lsig512_0 w20 #+ w19 + w36 = lsig512_1 w34 #+ w29 #+ lsig512_0 w21 #+ w20 + w37 = lsig512_1 w35 #+ w30 #+ lsig512_0 w22 #+ w21 + w38 = lsig512_1 w36 #+ w31 #+ lsig512_0 w23 #+ w22 + w39 = lsig512_1 w37 #+ w32 #+ lsig512_0 w24 #+ w23 + w40 = lsig512_1 w38 #+ w33 #+ lsig512_0 w25 #+ w24 + w41 = lsig512_1 w39 #+ w34 #+ lsig512_0 w26 #+ w25 + w42 = lsig512_1 w40 #+ w35 #+ lsig512_0 w27 #+ w26 + w43 = lsig512_1 w41 #+ w36 #+ lsig512_0 w28 #+ w27 + w44 = lsig512_1 w42 #+ w37 #+ lsig512_0 w29 #+ w28 + w45 = lsig512_1 w43 #+ w38 #+ lsig512_0 w30 #+ w29 + w46 = lsig512_1 w44 #+ w39 #+ lsig512_0 w31 #+ w30 + w47 = lsig512_1 w45 #+ w40 #+ lsig512_0 w32 #+ w31 + w48 = lsig512_1 w46 #+ w41 #+ lsig512_0 w33 #+ w32 + w49 = lsig512_1 w47 #+ w42 #+ lsig512_0 w34 #+ w33 + w50 = lsig512_1 w48 #+ w43 #+ lsig512_0 w35 #+ w34 + w51 = lsig512_1 w49 #+ w44 #+ lsig512_0 w36 #+ w35 + w52 = lsig512_1 w50 #+ w45 #+ lsig512_0 w37 #+ w36 + w53 = lsig512_1 w51 #+ w46 #+ lsig512_0 w38 #+ w37 + w54 = lsig512_1 w52 #+ w47 #+ lsig512_0 w39 #+ w38 + w55 = lsig512_1 w53 #+ w48 #+ lsig512_0 w40 #+ w39 + w56 = lsig512_1 w54 #+ w49 #+ lsig512_0 w41 #+ w40 + w57 = lsig512_1 w55 #+ w50 #+ lsig512_0 w42 #+ w41 + w58 = lsig512_1 w56 #+ w51 #+ lsig512_0 w43 #+ w42 + w59 = lsig512_1 w57 #+ w52 #+ lsig512_0 w44 #+ w43 + w60 = lsig512_1 w58 #+ w53 #+ lsig512_0 w45 #+ w44 + w61 = lsig512_1 w59 #+ w54 #+ lsig512_0 w46 #+ w45 + w62 = lsig512_1 w60 #+ w55 #+ lsig512_0 w47 #+ w46 + w63 = lsig512_1 w61 #+ w56 #+ lsig512_0 w48 #+ w47 + w64 = lsig512_1 w62 #+ w57 #+ lsig512_0 w49 #+ w48 + w65 = lsig512_1 w63 #+ w58 #+ lsig512_0 w50 #+ w49 + w66 = lsig512_1 w64 #+ w59 #+ lsig512_0 w51 #+ w50 + w67 = lsig512_1 w65 #+ w60 #+ lsig512_0 w52 #+ w51 + w68 = lsig512_1 w66 #+ w61 #+ lsig512_0 w53 #+ w52 + w69 = lsig512_1 w67 #+ w62 #+ lsig512_0 w54 #+ w53 + w70 = lsig512_1 w68 #+ w63 #+ lsig512_0 w55 #+ w54 + w71 = lsig512_1 w69 #+ w64 #+ lsig512_0 w56 #+ w55 + w72 = lsig512_1 w70 #+ w65 #+ lsig512_0 w57 #+ w56 + w73 = lsig512_1 w71 #+ w66 #+ lsig512_0 w58 #+ w57 + w74 = lsig512_1 w72 #+ w67 #+ lsig512_0 w59 #+ w58 + w75 = lsig512_1 w73 #+ w68 #+ lsig512_0 w60 #+ w59 + w76 = lsig512_1 w74 #+ w69 #+ lsig512_0 w61 #+ w60 + w77 = lsig512_1 w75 #+ w70 #+ lsig512_0 w62 #+ w61 + w78 = lsig512_1 w76 #+ w71 #+ lsig512_0 w63 #+ w62 + w79 = lsig512_1 w77 #+ w72 #+ lsig512_0 w64 #+ w63 + in (,cont) + $ SHA512Sched + w00 + w01 + w02 + w03 + w04 + w05 + w06 + w07 + w08 + w09 + w10 + w11 + w12 + w13 + w14 + w15 + w16 + w17 + w18 + w19 + w20 + w21 + w22 + w23 + w24 + w25 + w26 + w27 + w28 + w29 + w30 + w31 + w32 + w33 + w34 + w35 + w36 + w37 + w38 + w39 + w40 + w41 + w42 + w43 + w44 + w45 + w46 + w47 + w48 + w49 + w50 + w51 + w52 + w53 + w54 + w55 + w56 + w57 + w58 + w59 + w60 + w61 + w62 + w63 + w64 + w65 + w66 + w67 + w68 + w69 + w70 + w71 + w72 + w73 + w74 + w75 + w76 + w77 + w78 + w79 {-# INLINEABLE getSHA512Sched #-} next64 :: BuiltinByteString -> (UInt64, BuiltinByteString) @@ -373,17 +375,18 @@ pad :: BuiltinByteString -> BuiltinByteString pad bs = bs <> padding where padding :: BuiltinByteString - padding = let lenBits = 8 * lengthOfByteString bs - r = 896 - lenBits `modulo` 1024 - 1 - k = if r <= (-1) then r + 1024 else r - -- INVARIANT: k is necessarily > 0, and (k + 1) is a - -- multiple of 8. - kBytes = (k + 1) `divide` 8 - zeroBytes = kBytes - 1 - paddingZeroes = replicateByte zeroBytes 0x0 - paddingWith1 = consByteString 0x80 paddingZeroes - lengthSuffix = integerToByteString BigEndian 16 lenBits - in paddingWith1 <> lengthSuffix + padding = + let lenBits = 8 * lengthOfByteString bs + r = 896 - lenBits `modulo` 1024 - 1 + k = if r <= (-1) then r + 1024 else r + -- INVARIANT: k is necessarily > 0, and (k + 1) is a + -- multiple of 8. + kBytes = (k + 1) `divide` 8 + zeroBytes = kBytes - 1 + paddingZeroes = replicateByte zeroBytes 0x0 + paddingWith1 = consByteString 0x80 paddingZeroes + lengthSuffix = integerToByteString BigEndian 16 lenBits + in paddingWith1 <> lengthSuffix {-# INLINEABLE pad #-} processBlock :: BuiltinByteString -> SHA512State -> (SHA512State, BuiltinByteString) @@ -468,8 +471,8 @@ processBlock bs s00@(SHA512State a00 b00 c00 d00 e00 f00 g00 h00) = w76 w77 w78 - w79, - cont + w79 + , cont ) = getSHA512Sched bs s01 = step512 s00 0x428a_2f98_d728_ae22 w00 s02 = step512 s01 0x7137_4491_23ef_65cd w01 @@ -562,7 +565,7 @@ processBlock bs s00@(SHA512State a00 b00 c00 d00 e00 f00 g00 h00) = (f00 #+ f80) (g00 #+ g80) (h00 #+ h80) - in (newState, cont) + in (newState, cont) {-# INLINEABLE processBlock #-} step512 :: SHA512State -> Integer -> UInt64 -> SHA512State @@ -597,12 +600,14 @@ maj :: UInt64 -> UInt64 -> UInt64 -> UInt64 maj x y z = (x .&. (y .|. z)) .|. (y .&. z) {-# INLINEABLE maj #-} -runSha :: SHA512State -> +runSha :: + SHA512State -> (BuiltinByteString -> SHA512State -> (SHA512State, BuiltinByteString)) -> BuiltinByteString -> SHA512State runSha state next input | lengthOfByteString input == 0 = state - | otherwise = let (state', rest) = next input state - in runSha state' next rest + | otherwise = + let (state', rest) = next input state + in runSha state' next rest {-# INLINEABLE runSha #-} diff --git a/plutus-benchmark/bitwise/test/Main.hs b/plutus-benchmark/bitwise/test/Main.hs index 45da19831cf..f731776bd74 100644 --- a/plutus-benchmark/bitwise/test/Main.hs +++ b/plutus-benchmark/bitwise/test/Main.hs @@ -19,23 +19,28 @@ import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc) import Test.Tasty.HUnit (assertEqual, testCase) main :: IO () -main = defaultMain . testGroup "bitwise" $ [ - testGroup "N-queens" [ - testCase "solves for 8 queens" $ assertEqual "" - [(0,0), (1,4), (2,7), (3,5), (4,2), (5,6), (6,1), (7,3)] - (nqueens 8), - runTestGhc - [goldenBundle' "8 queens" $ nqueensCompiled `unsafeApplyCode` dimAsData] - ], - testGroup "Ed25519" [ - testCase "SHA512 works" sha512Case, - testCase "Ed25519 works" ed25519Case, - runTestGhc - [ goldenBundle' "Ed25519" $ - checkValidCompiled `unsafeApplyCode` signatureAsData `unsafeApplyCode` msgAsData `unsafeApplyCode` pkAsData - ] +main = + defaultMain . testGroup "bitwise" $ + [ testGroup + "N-queens" + [ testCase "solves for 8 queens" $ + assertEqual + "" + [(0, 0), (1, 4), (2, 7), (3, 5), (4, 2), (5, 6), (6, 1), (7, 3)] + (nqueens 8) + , runTestGhc + [goldenBundle' "8 queens" $ nqueensCompiled `unsafeApplyCode` dimAsData] + ] + , testGroup + "Ed25519" + [ testCase "SHA512 works" sha512Case + , testCase "Ed25519 works" ed25519Case + , runTestGhc + [ goldenBundle' "Ed25519" $ + checkValidCompiled `unsafeApplyCode` signatureAsData `unsafeApplyCode` msgAsData `unsafeApplyCode` pkAsData + ] + ] ] - ] -- Cases diff --git a/plutus-benchmark/bls12-381-costs/bench/Bench.hs b/plutus-benchmark/bls12-381-costs/bench/Bench.hs index 0936da36674..d0cdf50e006 100644 --- a/plutus-benchmark/bls12-381-costs/bench/Bench.hs +++ b/plutus-benchmark/bls12-381-costs/bench/Bench.hs @@ -1,7 +1,8 @@ -- editorconfig-checker-disable-file -{- | Plutus benchmarks measuring actual execution times of some BSL12-381 - operations, mainly intended to give us an idea of what we can do within the - on-chain execution limits. -} + +-- | Plutus benchmarks measuring actual execution times of some BSL12-381 +-- operations, mainly intended to give us an idea of what we can do within the +-- on-chain execution limits. module Main where import Criterion.Main @@ -14,39 +15,38 @@ import PlutusTx.Prelude qualified as Tx import Control.Exception (evaluate) import Data.ByteString qualified as BS (empty) - benchHashAndAddG1 :: EvaluationContext -> Integer -> Benchmark benchHashAndAddG1 ctx n = - let prog = mkHashAndAddG1Script (listOfByteStringsOfLength n 4) - in bench (show n) $ benchProgramCek ctx prog + let prog = mkHashAndAddG1Script (listOfByteStringsOfLength n 4) + in bench (show n) $ benchProgramCek ctx prog benchHashAndAddG2 :: EvaluationContext -> Integer -> Benchmark benchHashAndAddG2 ctx n = - let prog = mkHashAndAddG2Script (listOfByteStringsOfLength n 4) - in bench (show n) $ benchProgramCek ctx prog + let prog = mkHashAndAddG2Script (listOfByteStringsOfLength n 4) + in bench (show n) $ benchProgramCek ctx prog benchUncompressAndAddG1 :: EvaluationContext -> Integer -> Benchmark benchUncompressAndAddG1 ctx n = - let prog = mkUncompressAndAddG1Script (listOfByteStringsOfLength n 4) - in bench (show n) $ benchProgramCek ctx prog + let prog = mkUncompressAndAddG1Script (listOfByteStringsOfLength n 4) + in bench (show n) $ benchProgramCek ctx prog benchUncompressAndAddG2 :: EvaluationContext -> Integer -> Benchmark benchUncompressAndAddG2 ctx n = - let prog = mkUncompressAndAddG2Script (listOfByteStringsOfLength n 4) - in bench (show n) $ benchProgramCek ctx prog + let prog = mkUncompressAndAddG2Script (listOfByteStringsOfLength n 4) + in bench (show n) $ benchProgramCek ctx prog benchPairing :: EvaluationContext -> Benchmark benchPairing ctx = - case listOfByteStringsOfLength 4 4 of - [b1, b2, b3, b4] -> - let emptyDst = Tx.toBuiltin BS.empty - p1 = Tx.bls12_381_G1_hashToGroup (Tx.toBuiltin b1) emptyDst - p2 = Tx.bls12_381_G2_hashToGroup (Tx.toBuiltin b2) emptyDst - q1 = Tx.bls12_381_G1_hashToGroup (Tx.toBuiltin b3) emptyDst - q2 = Tx.bls12_381_G2_hashToGroup (Tx.toBuiltin b4) emptyDst - prog = mkPairingScript p1 p2 q1 q2 - in bench "pairing" $ benchProgramCek ctx prog - _ -> error "Unexpected list returned by listOfByteStringsOfLength" + case listOfByteStringsOfLength 4 4 of + [b1, b2, b3, b4] -> + let emptyDst = Tx.toBuiltin BS.empty + p1 = Tx.bls12_381_G1_hashToGroup (Tx.toBuiltin b1) emptyDst + p2 = Tx.bls12_381_G2_hashToGroup (Tx.toBuiltin b2) emptyDst + q1 = Tx.bls12_381_G1_hashToGroup (Tx.toBuiltin b3) emptyDst + q2 = Tx.bls12_381_G2_hashToGroup (Tx.toBuiltin b4) emptyDst + prog = mkPairingScript p1 p2 q1 q2 + in bench "pairing" $ benchProgramCek ctx prog + _ -> error "Unexpected list returned by listOfByteStringsOfLength" benchGroth16Verify :: EvaluationContext -> Benchmark benchGroth16Verify ctx = bench "groth16Verify" $ benchProgramCek ctx mkGroth16VerifyScript @@ -78,19 +78,19 @@ schnorrG2Verify ctx = bench "schnorrG2Verify" $ benchProgramCek ctx mkSchnorrG2V main :: IO () main = do evalCtx <- evaluate mkMostRecentEvalCtx - defaultMain [ - bgroup "hashAndAddG1" $ fmap (benchHashAndAddG1 evalCtx) [0, 10..150] - , bgroup "hashAndAddG2" $ fmap (benchHashAndAddG2 evalCtx) [0, 10..150] - , bgroup "uncompressAndAddG1" $ fmap (benchUncompressAndAddG1 evalCtx) [0, 10..150] - , bgroup "uncompressAndAddG2" $ fmap (benchUncompressAndAddG2 evalCtx) [0, 10..150] - , benchPairing evalCtx - , benchGroth16Verify evalCtx - , benchSimpleVerify evalCtx - , benchVrf evalCtx - , benchG1Verify evalCtx - , benchG2Verify evalCtx - , aggregateSigSingleKey evalCtx - , aggregateSigMultiKey evalCtx - , schnorrG1Verify evalCtx - , schnorrG2Verify evalCtx - ] + defaultMain + [ bgroup "hashAndAddG1" $ fmap (benchHashAndAddG1 evalCtx) [0, 10 .. 150] + , bgroup "hashAndAddG2" $ fmap (benchHashAndAddG2 evalCtx) [0, 10 .. 150] + , bgroup "uncompressAndAddG1" $ fmap (benchUncompressAndAddG1 evalCtx) [0, 10 .. 150] + , bgroup "uncompressAndAddG2" $ fmap (benchUncompressAndAddG2 evalCtx) [0, 10 .. 150] + , benchPairing evalCtx + , benchGroth16Verify evalCtx + , benchSimpleVerify evalCtx + , benchVrf evalCtx + , benchG1Verify evalCtx + , benchG2Verify evalCtx + , aggregateSigSingleKey evalCtx + , aggregateSigMultiKey evalCtx + , schnorrG1Verify evalCtx + , schnorrG2Verify evalCtx + ] diff --git a/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/RunTests.hs b/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/RunTests.hs index 5bdeb76d69a..3887657cd9d 100644 --- a/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/RunTests.hs +++ b/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/RunTests.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file -{- | Print out the costs of various test scripts involving the BLS12_381 - primitives. Most of these work on varying numbers of inputs so that we can - get an idea of what we can do within the on-chain execution limits. --} + +-- | Print out the costs of various test scripts involving the BLS12_381 +-- primitives. Most of these work on varying numbers of inputs so that we can +-- get an idea of what we can do within the on-chain execution limits. module PlutusBenchmark.BLS12_381.RunTests (runTests) where @@ -21,55 +21,54 @@ import Prelude (IO, mapM_) printCosts_HashAndAddG1 :: Handle -> Integer -> IO () printCosts_HashAndAddG1 h n = - let script = mkHashAndAddG1Script (listOfByteStringsOfLength n 4) - in printSizeStatistics h (TestSize n) script + let script = mkHashAndAddG1Script (listOfByteStringsOfLength n 4) + in printSizeStatistics h (TestSize n) script printCosts_HashAndAddG2 :: Handle -> Integer -> IO () printCosts_HashAndAddG2 h n = - let script = mkHashAndAddG2Script (listOfByteStringsOfLength n 4) - in printSizeStatistics h (TestSize n) script + let script = mkHashAndAddG2Script (listOfByteStringsOfLength n 4) + in printSizeStatistics h (TestSize n) script printCosts_UncompressAndAddG1 :: Handle -> Integer -> IO () printCosts_UncompressAndAddG1 h n = - let script = mkUncompressAndAddG1Script (listOfByteStringsOfLength n 4) - in printSizeStatistics h (TestSize n) script + let script = mkUncompressAndAddG1Script (listOfByteStringsOfLength n 4) + in printSizeStatistics h (TestSize n) script printCosts_UncompressAndAddG2 :: Handle -> Integer -> IO () printCosts_UncompressAndAddG2 h n = - let script = mkUncompressAndAddG2Script (listOfByteStringsOfLength n 4) - in printSizeStatistics h (TestSize n) script + let script = mkUncompressAndAddG2Script (listOfByteStringsOfLength n 4) + in printSizeStatistics h (TestSize n) script printCosts_Pairing :: Handle -> IO () printCosts_Pairing h = do - let emptyDST = toBuiltin BS.empty - p1 = Tx.bls12_381_G1_hashToGroup (toBuiltin . BS.pack $ [0x23, 0x43, 0x56, 0xf2]) emptyDST - p2 = Tx.bls12_381_G2_hashToGroup (toBuiltin . BS.pack $ [0x10, 0x00, 0xff, 0x88]) emptyDST - q1 = Tx.bls12_381_G1_hashToGroup (toBuiltin . BS.pack $ [0x11, 0x22, 0x33, 0x44]) emptyDST - q2 = Tx.bls12_381_G2_hashToGroup (toBuiltin . BS.pack $ [0xa0, 0xb1, 0xc2, 0xd3]) emptyDST - script = mkPairingScript p1 p2 q1 q2 - printSizeStatistics h NoSize script + let emptyDST = toBuiltin BS.empty + p1 = Tx.bls12_381_G1_hashToGroup (toBuiltin . BS.pack $ [0x23, 0x43, 0x56, 0xf2]) emptyDST + p2 = Tx.bls12_381_G2_hashToGroup (toBuiltin . BS.pack $ [0x10, 0x00, 0xff, 0x88]) emptyDST + q1 = Tx.bls12_381_G1_hashToGroup (toBuiltin . BS.pack $ [0x11, 0x22, 0x33, 0x44]) emptyDST + q2 = Tx.bls12_381_G2_hashToGroup (toBuiltin . BS.pack $ [0xa0, 0xb1, 0xc2, 0xd3]) emptyDST + script = mkPairingScript p1 p2 q1 q2 + printSizeStatistics h NoSize script runTests :: Handle -> IO () runTests h = do - hPrintf h "Hash n bytestrings onto G1 and add points\n\n" printHeader h - mapM_ (printCosts_HashAndAddG1 h) [0, 10..150] + mapM_ (printCosts_HashAndAddG1 h) [0, 10 .. 150] hPrintf h "\n\n" hPrintf h "Hash n bytestrings onto G2 and add points\n\n" printHeader h - mapM_ (printCosts_HashAndAddG2 h) [0, 10..150] + mapM_ (printCosts_HashAndAddG2 h) [0, 10 .. 150] hPrintf h "\n\n" hPrintf h "Uncompress n G1 points and add the results\n\n" printHeader h - mapM_ (printCosts_UncompressAndAddG1 h) [0, 10..150] + mapM_ (printCosts_UncompressAndAddG1 h) [0, 10 .. 150] hPrintf h "\n\n" hPrintf h "Uncompress n G2 points and add the results\n\n" printHeader h - mapM_ (printCosts_UncompressAndAddG2 h) [0, 10..150] + mapM_ (printCosts_UncompressAndAddG2 h) [0, 10 .. 150] hPrintf h "\n\n" hPrintf h "Apply pairing to two pairs of points in G1 x G2 and run finalVerify on the results\n\n" @@ -118,37 +117,37 @@ runTests h = do hPrintf h "\n" if checkGroth16Verify_Haskell - then hPrintf h "Groth16Verify succeeded\n" - else hPrintf h "Groth16Verify failed\n" + then hPrintf h "Groth16Verify succeeded\n" + else hPrintf h "Groth16Verify failed\n" if checkVerifyBlsSimpleScript - then hPrintf h "Simple Verify succeeded\n" - else hPrintf h "Simple Verify failed\n" + then hPrintf h "Simple Verify succeeded\n" + else hPrintf h "Simple Verify failed\n" if checkVrfBlsScript - then hPrintf h "VRF succeeded\n" - else hPrintf h "VRF failed\n" + then hPrintf h "VRF succeeded\n" + else hPrintf h "VRF failed\n" if checkG1VerifyScript - then hPrintf h "G1 Verify succeeded\n" - else hPrintf h "G1 Verify failed\n" + then hPrintf h "G1 Verify succeeded\n" + else hPrintf h "G1 Verify failed\n" if checkG2VerifyScript - then hPrintf h "G2 Verify succeeded\n" - else hPrintf h "G2 Verify failed\n" + then hPrintf h "G2 Verify succeeded\n" + else hPrintf h "G2 Verify failed\n" if checkAggregateSingleKeyG1Script - then hPrintf h "Aggregate Signature Single Key G1 Verify succeeded\n" - else hPrintf h "Aggregate Signature Single Key G1 Verify failed\n" + then hPrintf h "Aggregate Signature Single Key G1 Verify succeeded\n" + else hPrintf h "Aggregate Signature Single Key G1 Verify failed\n" if checkAggregateMultiKeyG2Script - then hPrintf h "Aggregate Signature Multi Key G2 Verify succeeded\n" - else hPrintf h "Aggregate Signature Multi Key G2 Verify failed\n" + then hPrintf h "Aggregate Signature Multi Key G2 Verify succeeded\n" + else hPrintf h "Aggregate Signature Multi Key G2 Verify failed\n" if checkSchnorrG1VerifyScript - then hPrintf h "Schnorr G1 Verify succeeded\n" - else hPrintf h "Schnorr G1 Verify failed\n" + then hPrintf h "Schnorr G1 Verify succeeded\n" + else hPrintf h "Schnorr G1 Verify failed\n" if checkSchnorrG2VerifyScript - then hPrintf h "Schnorr G2 Verify succeeded\n" - else hPrintf h "Schnorr G2 Verify failed\n" + then hPrintf h "Schnorr G2 Verify succeeded\n" + else hPrintf h "Schnorr G2 Verify failed\n" diff --git a/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs b/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs index b82129c5045..2b7142c4f32 100644 --- a/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs +++ b/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs @@ -1,47 +1,47 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} -{- | Approximations of the sort of computations involving BLS12-381 primitives - that one might wish to perform on the chain. Real on-chain code will have - extra overhead, but these examples help to give us an idea of the sort of - computation that can feasibly be carried out within the validation budget - limits. - - Some of these test vectors were produced using https://github.com/input-output-hk/bls-e2e-testvectors - -} -module PlutusBenchmark.BLS12_381.Scripts - ( checkGroth16Verify_Haskell - , listOfByteStringsOfLength - , mkGroth16VerifyScript - , mkHashAndAddG1Script - , mkHashAndAddG2Script - , mkPairingScript - , mkUncompressAndAddG1Script - , mkUncompressAndAddG2Script - , mkVerifyBlsSimplePolicy - , checkVerifyBlsSimpleScript - , mkVrfBlsPolicy - , checkVrfBlsScript - , mkG1VerifyPolicy - , checkG1VerifyScript - , mkG2VerifyPolicy - , checkG2VerifyScript - , mkAggregateSingleKeyG1Policy - , checkAggregateSingleKeyG1Script - , mkAggregateMultiKeyG2Policy - , checkAggregateMultiKeyG2Script - , mkSchnorrG1VerifyPolicy - , checkSchnorrG1VerifyScript - , mkSchnorrG2VerifyPolicy - , checkSchnorrG2VerifyScript - ) +-- | Approximations of the sort of computations involving BLS12-381 primitives +-- that one might wish to perform on the chain. Real on-chain code will have +-- extra overhead, but these examples help to give us an idea of the sort of +-- computation that can feasibly be carried out within the validation budget +-- limits. +-- +-- Some of these test vectors were produced using https://github.com/input-output-hk/bls-e2e-testvectors +module PlutusBenchmark.BLS12_381.Scripts ( + checkGroth16Verify_Haskell, + listOfByteStringsOfLength, + mkGroth16VerifyScript, + mkHashAndAddG1Script, + mkHashAndAddG2Script, + mkPairingScript, + mkUncompressAndAddG1Script, + mkUncompressAndAddG2Script, + mkVerifyBlsSimplePolicy, + checkVerifyBlsSimpleScript, + mkVrfBlsPolicy, + checkVrfBlsScript, + mkG1VerifyPolicy, + checkG1VerifyScript, + mkG2VerifyPolicy, + checkG2VerifyScript, + mkAggregateSingleKeyG1Policy, + checkAggregateSingleKeyG1Script, + mkAggregateMultiKeyG2Policy, + checkAggregateMultiKeyG2Script, + mkSchnorrG1VerifyPolicy, + checkSchnorrG1VerifyScript, + mkSchnorrG2VerifyPolicy, + checkSchnorrG2VerifyScript, +) where + import PlutusCore (DefaultFun, DefaultUni) import PlutusLedgerApi.V1.Bytes qualified as P (bytes, fromHex) import PlutusTx qualified as Tx @@ -63,16 +63,19 @@ import Prelude (fromIntegral) -- Create a list containing n bytestrings of length l. This could be better. listOfByteStringsOfLength :: Integer -> Integer -> [ByteString] -listOfByteStringsOfLength n l = unsafePerformIO . G.sample $ - G.list (R.singleton $ fromIntegral n) - (G.bytes (R.singleton $ fromIntegral l)) +listOfByteStringsOfLength n l = + unsafePerformIO + . G.sample + $ G.list + (R.singleton $ fromIntegral n) + (G.bytes (R.singleton $ fromIntegral l)) {-# OPAQUE listOfByteStringsOfLength #-} -- | Treat string of hexidecimal bytes literally, without encoding. Useful for hashes. bytesFromHex :: BS.ByteString -> BuiltinByteString bytesFromHex = toBuiltin . P.bytes . fromEither . P.fromHex where - fromEither (Left _) = traceError "bytesFromHex failed" + fromEither (Left _) = traceError "bytesFromHex failed" fromEither (Right bs) = bs blsSigBls12381G2XmdSha256SswuRoNul :: BuiltinByteString @@ -80,12 +83,12 @@ blsSigBls12381G2XmdSha256SswuRoNul = toBuiltin $ C8.pack "BLS_SIG_BLS12381G2_XMD byteString16Null :: BuiltinByteString byteString16Null = bytesFromHex "00000000000000000000000000000000" -{-# INLINABLE byteString16Null #-} +{-# INLINEABLE byteString16Null #-} -- Little-endian bytestring to integer conversion byteStringToIntegerLE :: BuiltinByteString -> Integer byteStringToIntegerLE = Tx.byteStringToInteger LittleEndian -{-# INLINABLE byteStringToIntegerLE #-} +{-# INLINEABLE byteStringToIntegerLE #-} ---------------- Examples ---------------- @@ -93,102 +96,106 @@ byteStringToIntegerLE = Tx.byteStringToInteger LittleEndian hashAndAddG1 :: [BuiltinByteString] -> BuiltinBLS12_381_G1_Element hashAndAddG1 l = - go l (Tx.bls12_381_G1_uncompress Tx.bls12_381_G1_compressed_zero) - where go [] !acc = acc - go (q:qs) !acc = go qs $ Tx.bls12_381_G1_add (Tx.bls12_381_G1_hashToGroup q emptyByteString) acc -{-# INLINABLE hashAndAddG1 #-} + go l (Tx.bls12_381_G1_uncompress Tx.bls12_381_G1_compressed_zero) + where + go [] !acc = acc + go (q : qs) !acc = go qs $ Tx.bls12_381_G1_add (Tx.bls12_381_G1_hashToGroup q emptyByteString) acc +{-# INLINEABLE hashAndAddG1 #-} mkHashAndAddG1Script :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkHashAndAddG1Script l = - let points = List.map toBuiltin l - in Tx.getPlcNoAnn $ $$(Tx.compile [|| hashAndAddG1 ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points + let points = List.map toBuiltin l + in Tx.getPlcNoAnn $ $$(Tx.compile [||hashAndAddG1||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points -- Hash some bytestrings onto G2 and add them all together hashAndAddG2 :: [BuiltinByteString] -> BuiltinBLS12_381_G2_Element hashAndAddG2 l = - go l (Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_zero) - where go [] !acc = acc - go (q:qs) !acc = go qs $ Tx.bls12_381_G2_add (Tx.bls12_381_G2_hashToGroup q emptyByteString) acc -{-# INLINABLE hashAndAddG2 #-} + go l (Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_zero) + where + go [] !acc = acc + go (q : qs) !acc = go qs $ Tx.bls12_381_G2_add (Tx.bls12_381_G2_hashToGroup q emptyByteString) acc +{-# INLINEABLE hashAndAddG2 #-} mkHashAndAddG2Script :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkHashAndAddG2Script l = - let points = List.map toBuiltin l - in Tx.getPlcNoAnn $ $$(Tx.compile [|| hashAndAddG2 ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points + let points = List.map toBuiltin l + in Tx.getPlcNoAnn $ $$(Tx.compile [||hashAndAddG2||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points -- Uncompress a list of compressed G1 points and add them all together uncompressAndAddG1 :: [BuiltinByteString] -> BuiltinBLS12_381_G1_Element uncompressAndAddG1 l = - go l (Tx.bls12_381_G1_uncompress Tx.bls12_381_G1_compressed_zero) - where go [] acc = acc - go (q:qs) acc = go qs $ Tx.bls12_381_G1_add (Tx.bls12_381_G1_uncompress q) acc -{-# INLINABLE uncompressAndAddG1 #-} + go l (Tx.bls12_381_G1_uncompress Tx.bls12_381_G1_compressed_zero) + where + go [] acc = acc + go (q : qs) acc = go qs $ Tx.bls12_381_G1_add (Tx.bls12_381_G1_uncompress q) acc +{-# INLINEABLE uncompressAndAddG1 #-} mkUncompressAndAddG1Script :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkUncompressAndAddG1Script l = - let ramdomPoint bs = Tx.bls12_381_G1_hashToGroup bs emptyByteString - points = List.map (Tx.bls12_381_G1_compress . ramdomPoint . toBuiltin) l - in Tx.getPlcNoAnn $ $$(Tx.compile [|| uncompressAndAddG1 ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points + let ramdomPoint bs = Tx.bls12_381_G1_hashToGroup bs emptyByteString + points = List.map (Tx.bls12_381_G1_compress . ramdomPoint . toBuiltin) l + in Tx.getPlcNoAnn $ $$(Tx.compile [||uncompressAndAddG1||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points -- Uncompress a list of compressed G1 points and add them all together uncompressAndAddG2 :: [BuiltinByteString] -> BuiltinBLS12_381_G2_Element uncompressAndAddG2 l = - go l (Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_zero) - where go [] acc = acc - go (q:qs) acc = go qs $ Tx.bls12_381_G2_add (Tx.bls12_381_G2_uncompress q) acc -{-# INLINABLE uncompressAndAddG2 #-} + go l (Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_zero) + where + go [] acc = acc + go (q : qs) acc = go qs $ Tx.bls12_381_G2_add (Tx.bls12_381_G2_uncompress q) acc +{-# INLINEABLE uncompressAndAddG2 #-} mkUncompressAndAddG2Script :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkUncompressAndAddG2Script l = - let ramdomPoint bs = Tx.bls12_381_G2_hashToGroup bs emptyByteString - points = List.map (Tx.bls12_381_G2_compress . ramdomPoint . toBuiltin) l - in Tx.getPlcNoAnn $ $$(Tx.compile [|| uncompressAndAddG2 ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points + let ramdomPoint bs = Tx.bls12_381_G2_hashToGroup bs emptyByteString + points = List.map (Tx.bls12_381_G2_compress . ramdomPoint . toBuiltin) l + in Tx.getPlcNoAnn $ $$(Tx.compile [||uncompressAndAddG2||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points -- Pairing operations -- Take two points p1 and p2 in G1 and two points q1 and q2 in G2, apply the -- Miller loop to (p1,q1) and (p2,q2), and then call finalVerify on the results. -runPairingFunctions - :: BuiltinByteString -- G1 - -> BuiltinByteString -- G2 - -> BuiltinByteString -- G1 - -> BuiltinByteString -- G2 - -> Bool +runPairingFunctions :: + BuiltinByteString -> -- G1 + BuiltinByteString -> -- G2 + BuiltinByteString -> -- G1 + BuiltinByteString -> -- G2 + Bool runPairingFunctions p1 q1 p2 q2 = - let r1 = Tx.bls12_381_millerLoop (Tx.bls12_381_G1_uncompress p1) (Tx.bls12_381_G2_uncompress q1) - r2 = Tx.bls12_381_millerLoop (Tx.bls12_381_G1_uncompress p2) (Tx.bls12_381_G2_uncompress q2) - in Tx.bls12_381_finalVerify r1 r2 -{-# INLINABLE runPairingFunctions #-} - -mkPairingScript - :: BuiltinBLS12_381_G1_Element - -> BuiltinBLS12_381_G2_Element - -> BuiltinBLS12_381_G1_Element - -> BuiltinBLS12_381_G2_Element - -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () + let r1 = Tx.bls12_381_millerLoop (Tx.bls12_381_G1_uncompress p1) (Tx.bls12_381_G2_uncompress q1) + r2 = Tx.bls12_381_millerLoop (Tx.bls12_381_G1_uncompress p2) (Tx.bls12_381_G2_uncompress q2) + in Tx.bls12_381_finalVerify r1 r2 +{-# INLINEABLE runPairingFunctions #-} + +mkPairingScript :: + BuiltinBLS12_381_G1_Element -> + BuiltinBLS12_381_G2_Element -> + BuiltinBLS12_381_G1_Element -> + BuiltinBLS12_381_G2_Element -> + UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkPairingScript p1 q1 p2 q2 = - Tx.getPlcNoAnn $ $$(Tx.compile [|| runPairingFunctions ||]) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G1_compress p1) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G2_compress q1) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G1_compress p2) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G2_compress q2) - + Tx.getPlcNoAnn + $ $$(Tx.compile [||runPairingFunctions||]) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G1_compress p1) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G2_compress q1) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G1_compress p2) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ Tx.bls12_381_G2_compress q2) ---------------- Groth16 verification ---------------- -{- | An example of the on-chain computation required for verification of a Groth16 - proof. The data here is derived from - https://github.com/achimcc/groth16-example/blob/main/src/lib.rs -} +-- | An example of the on-chain computation required for verification of a Groth16 +-- proof. The data here is derived from +-- https://github.com/achimcc/groth16-example/blob/main/src/lib.rs -- Wrappers for compressed group elements for slightly better type safety -newtype CompressedG1Element = CompressedG1Element { g1 :: BuiltinByteString } - deriving newtype (Tx.Lift DefaultUni) +newtype CompressedG1Element = CompressedG1Element {g1 :: BuiltinByteString} + deriving newtype (Tx.Lift DefaultUni) -mkG1Element :: ByteString -> CompressedG1Element +mkG1Element :: ByteString -> CompressedG1Element mkG1Element = CompressedG1Element . bytesFromHex -newtype CompressedG2Element = CompressedG2Element { g2 :: BuiltinByteString } - deriving newtype (Tx.Lift DefaultUni) +newtype CompressedG2Element = CompressedG2Element {g2 :: BuiltinByteString} + deriving newtype (Tx.Lift DefaultUni) mkG2Element :: ByteString -> CompressedG2Element mkG2Element = CompressedG2Element . bytesFromHex @@ -199,113 +206,150 @@ groth16scalar = 0x1884d0cbcc5947434e46d19b3e904e18a8ee8d0d39ce9d315f3b00e338c8f6 -- Lots of group elements for input to the computation groth16alpha :: CompressedG1Element -groth16alpha = mkG1Element ("b71db1fa5f41362e93025b3556d76ead1225cf590d1cdb9e" <> - "382a1febb7963dcd24a51e18df04ab221becaf29169faf25") +groth16alpha = + mkG1Element + ( "b71db1fa5f41362e93025b3556d76ead1225cf590d1cdb9e" + <> "382a1febb7963dcd24a51e18df04ab221becaf29169faf25" + ) groth16beta :: CompressedG2Element -groth16beta = mkG2Element ("b3a26b0b4712e78d5d71786d96132a7c585023a36632cada" <> - "44171ac3f45db524c3f6570c8a3f7dec35ae1ac3309b05dd" <> - "0b306db4f74fd9ec421ca70c54425d922eac4c403b00db91" <> - "6fdedf065bdce00ece17b97a4e97173e4d5989818edfaa4c") +groth16beta = + mkG2Element + ( "b3a26b0b4712e78d5d71786d96132a7c585023a36632cada" + <> "44171ac3f45db524c3f6570c8a3f7dec35ae1ac3309b05dd" + <> "0b306db4f74fd9ec421ca70c54425d922eac4c403b00db91" + <> "6fdedf065bdce00ece17b97a4e97173e4d5989818edfaa4c" + ) groth16gamma :: CompressedG2Element -groth16gamma = mkG2Element ("b5acb800cd49ed8cbddbf491a1fcf8abfc93f09d38bbb2ec" <> - "b6b08e23a4642ce59c9b0386539ac3cecdfb66a9f027fc21" <> - "0f259510756444bc5eef654f4d0612b5d6375f9526b1b966" <> - "ce53b8f12594e1b399d08231cfe6c269a44aa8d587f2369d") +groth16gamma = + mkG2Element + ( "b5acb800cd49ed8cbddbf491a1fcf8abfc93f09d38bbb2ec" + <> "b6b08e23a4642ce59c9b0386539ac3cecdfb66a9f027fc21" + <> "0f259510756444bc5eef654f4d0612b5d6375f9526b1b966" + <> "ce53b8f12594e1b399d08231cfe6c269a44aa8d587f2369d" + ) groth16delta :: CompressedG2Element -groth16delta = mkG2Element ("b3aa797bafa39a48f6f87c2483c894c281c807821c47301f" <> - "fb755acfcfd22c2323cedf6349c7fedd3200a4ae558631e5" <> - "01d299eb93135c07cf694ca118d1b386490529c60f57935c" <> - "efa89fcafa13a83f84207b76fe078dc859d402743d468c15") +groth16delta = + mkG2Element + ( "b3aa797bafa39a48f6f87c2483c894c281c807821c47301f" + <> "fb755acfcfd22c2323cedf6349c7fedd3200a4ae558631e5" + <> "01d299eb93135c07cf694ca118d1b386490529c60f57935c" + <> "efa89fcafa13a83f84207b76fe078dc859d402743d468c15" + ) groth16gamma_abc_1 :: CompressedG1Element -groth16gamma_abc_1 = mkG1Element ("b7f6d06dd3e5246ef6b51b075c30b68fd490fbf85e0205f7" <> - "9fa04d81133192139463b5e8efb22c39ef3dd1c5092015b8") +groth16gamma_abc_1 = + mkG1Element + ( "b7f6d06dd3e5246ef6b51b075c30b68fd490fbf85e0205f7" + <> "9fa04d81133192139463b5e8efb22c39ef3dd1c5092015b8" + ) groth16gamma_abc_2 :: CompressedG1Element -groth16gamma_abc_2 = mkG1Element ("a2e637dbff52a1e4a8c5d985b3411fc5fd44af607e42923e" <> - "abb47ad876e1f02b5be034adaf73952ae8affee5f51841de") +groth16gamma_abc_2 = + mkG1Element + ( "a2e637dbff52a1e4a8c5d985b3411fc5fd44af607e42923e" + <> "abb47ad876e1f02b5be034adaf73952ae8affee5f51841de" + ) groth16a :: CompressedG1Element -groth16a = mkG1Element ("a05be50fab5795bb8784393a5045f98747173ad287f55e21" <> - "3471bd559745551452453c4c3a39e7c88310849f3c7a1fc3") +groth16a = + mkG1Element + ( "a05be50fab5795bb8784393a5045f98747173ad287f55e21" + <> "3471bd559745551452453c4c3a39e7c88310849f3c7a1fc3" + ) groth16b :: CompressedG2Element -groth16b = mkG2Element ("ad6348b6b7b34c86bf37a748cd2d82a250dfc64846756688" <> - "25a16f7da6a04d3424113e325ce734ec44956082c0a06e5f" <> - "1868e1f1a6e559b9fe81f1a901f8a6341b301c45b25d3080" <> - "fbc5039353d8f71b550b274ec4c07c70cd1153562c314c97") +groth16b = + mkG2Element + ( "ad6348b6b7b34c86bf37a748cd2d82a250dfc64846756688" + <> "25a16f7da6a04d3424113e325ce734ec44956082c0a06e5f" + <> "1868e1f1a6e559b9fe81f1a901f8a6341b301c45b25d3080" + <> "fbc5039353d8f71b550b274ec4c07c70cd1153562c314c97" + ) groth16c :: CompressedG1Element -groth16c = mkG1Element ("b569cc491b4df035cbf49e951fd4fe30aa8236b0e2af68f4" <> - "c1592cd40debeb718af33639db6bc1e2da9d98e553e5eaed") +groth16c = + mkG1Element + ( "b569cc491b4df035cbf49e951fd4fe30aa8236b0e2af68f4" + <> "c1592cd40debeb718af33639db6bc1e2da9d98e553e5eaed" + ) +groth16Verify :: + BuiltinByteString -> -- G1 + BuiltinByteString -> -- G2 + BuiltinByteString -> -- G2 + BuiltinByteString -> -- G2 + BuiltinByteString -> -- G1 + BuiltinByteString -> -- G1 + BuiltinByteString -> -- G1 + BuiltinByteString -> -- G2 + BuiltinByteString -> -- G1 + Integer -> + Bool groth16Verify - :: BuiltinByteString -- G1 - -> BuiltinByteString -- G2 - -> BuiltinByteString -- G2 - -> BuiltinByteString -- G2 - -> BuiltinByteString -- G1 - -> BuiltinByteString -- G1 - -> BuiltinByteString -- G1 - -> BuiltinByteString -- G2 - -> BuiltinByteString -- G1 - -> Integer - -> Bool -groth16Verify (Tx.bls12_381_G1_uncompress -> alpha) - (Tx.bls12_381_G2_uncompress -> beta) - (Tx.bls12_381_G2_uncompress -> gamma) - (Tx.bls12_381_G2_uncompress -> delta) - (Tx.bls12_381_G1_uncompress -> abc1) - (Tx.bls12_381_G1_uncompress -> abc2) - (Tx.bls12_381_G1_uncompress -> a) - (Tx.bls12_381_G2_uncompress -> b) - (Tx.bls12_381_G1_uncompress -> c) - s = let l1 = Tx.bls12_381_millerLoop a b - l2 = Tx.bls12_381_millerLoop alpha beta - l3 = Tx.bls12_381_millerLoop c delta - p = Tx.bls12_381_G1_add abc1 (Tx.bls12_381_G1_scalarMul s abc2) - l4 = Tx.bls12_381_millerLoop p gamma - y = Tx.bls12_381_mulMlResult l2 (Tx.bls12_381_mulMlResult l3 l4) - in Tx.bls12_381_finalVerify l1 y -{-# INLINABLE groth16Verify #-} - -{- | Make a UPLC script applying groth16Verify to the inputs. Passing the - newtype inputs increases the size and CPU cost slightly, so we unwrap them - first. This should return `True`. -} + (Tx.bls12_381_G1_uncompress -> alpha) + (Tx.bls12_381_G2_uncompress -> beta) + (Tx.bls12_381_G2_uncompress -> gamma) + (Tx.bls12_381_G2_uncompress -> delta) + (Tx.bls12_381_G1_uncompress -> abc1) + (Tx.bls12_381_G1_uncompress -> abc2) + (Tx.bls12_381_G1_uncompress -> a) + (Tx.bls12_381_G2_uncompress -> b) + (Tx.bls12_381_G1_uncompress -> c) + s = + let l1 = Tx.bls12_381_millerLoop a b + l2 = Tx.bls12_381_millerLoop alpha beta + l3 = Tx.bls12_381_millerLoop c delta + p = Tx.bls12_381_G1_add abc1 (Tx.bls12_381_G1_scalarMul s abc2) + l4 = Tx.bls12_381_millerLoop p gamma + y = Tx.bls12_381_mulMlResult l2 (Tx.bls12_381_mulMlResult l3 l4) + in Tx.bls12_381_finalVerify l1 y +{-# INLINEABLE groth16Verify #-} + +-- | Make a UPLC script applying groth16Verify to the inputs. Passing the +-- newtype inputs increases the size and CPU cost slightly, so we unwrap them +-- first. This should return `True`. mkGroth16VerifyScript :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkGroth16VerifyScript = - Tx.getPlcNoAnn $ $$(Tx.compile [|| groth16Verify ||]) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16alpha) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16beta) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16gamma) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16delta) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16gamma_abc_1) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16gamma_abc_2) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16a) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16b) - `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16c) - `Tx.unsafeApplyCode` Tx.liftCodeDef groth16scalar + Tx.getPlcNoAnn + $ $$(Tx.compile [||groth16Verify||]) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16alpha) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16beta) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16gamma) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16delta) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16gamma_abc_1) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16gamma_abc_2) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16a) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g2 groth16b) + `Tx.unsafeApplyCode` (Tx.liftCodeDef $ g1 groth16c) + `Tx.unsafeApplyCode` Tx.liftCodeDef groth16scalar -- | Check that the Haskell version returns the correct result. checkGroth16Verify_Haskell :: Bool checkGroth16Verify_Haskell = - groth16Verify (g1 groth16alpha) (g2 groth16beta) (g2 groth16gamma) (g2 groth16delta) - (g1 groth16gamma_abc_1) (g1 groth16gamma_abc_2) (g1 groth16a) (g2 groth16b) (g1 groth16c) groth16scalar - - + groth16Verify + (g1 groth16alpha) + (g2 groth16beta) + (g2 groth16gamma) + (g2 groth16delta) + (g1 groth16gamma_abc_1) + (g1 groth16gamma_abc_2) + (g1 groth16a) + (g2 groth16b) + (g1 groth16c) + groth16scalar ---------------- Simple Sign and Verify ---------------- simpleVerifyPrivKey :: Integer simpleVerifyPrivKey = 50166937291276222007610100461546392414157570314060957244808461481762532157524 -{-# INLINABLE simpleVerifyPrivKey #-} +{-# INLINEABLE simpleVerifyPrivKey #-} simpleVerifyMessage :: BuiltinByteString -simpleVerifyMessage = "I am a message" -{-# INLINABLE simpleVerifyMessage #-} +simpleVerifyMessage = "I am a message" +{-# INLINEABLE simpleVerifyMessage #-} verifyBlsSimpleScript :: Integer -> BuiltinByteString -> Bool verifyBlsSimpleScript privKey message = @@ -319,19 +363,19 @@ verifyBlsSimpleScript privKey message = -- Create signature artifact in G2 with private key sigma = Tx.bls12_381_G2_scalarMul privKey msgToG2 - - -- verify the msg with signature sigma with the check e(g1,sigma)=e(pub,msgToG2) - in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop g1generator sigma) (Tx.bls12_381_millerLoop pubKey msgToG2) -{-# INLINABLE verifyBlsSimpleScript #-} + in -- verify the msg with signature sigma with the check e(g1,sigma)=e(pub,msgToG2) + Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop g1generator sigma) (Tx.bls12_381_millerLoop pubKey msgToG2) +{-# INLINEABLE verifyBlsSimpleScript #-} checkVerifyBlsSimpleScript :: Bool checkVerifyBlsSimpleScript = verifyBlsSimpleScript simpleVerifyPrivKey simpleVerifyMessage mkVerifyBlsSimplePolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkVerifyBlsSimplePolicy = - Tx.getPlcNoAnn $ $$(Tx.compile [|| verifyBlsSimpleScript ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef simpleVerifyPrivKey - `Tx.unsafeApplyCode` Tx.liftCodeDef simpleVerifyMessage + Tx.getPlcNoAnn + $ $$(Tx.compile [||verifyBlsSimpleScript||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef simpleVerifyPrivKey + `Tx.unsafeApplyCode` Tx.liftCodeDef simpleVerifyMessage ---------------- VRF ---------------- @@ -342,23 +386,23 @@ mkVerifyBlsSimplePolicy = vrfPrivKey :: Integer vrfPrivKey = 50166937291276222007610100461546392414157570314060957244808461481762532157524 :: Integer -{-# INLINABLE vrfPrivKey #-} +{-# INLINEABLE vrfPrivKey #-} vrfMessage :: BuiltinByteString vrfMessage = "I am a message" :: BuiltinByteString -{-# INLINABLE vrfMessage #-} +{-# INLINEABLE vrfMessage #-} data VrfProof = VrfProof { vrfProofGamma :: BuiltinByteString - , vrfProofC :: BuiltinByteString - , vrfProofS :: Integer + , vrfProofC :: BuiltinByteString + , vrfProofS :: Integer } Tx.makeLift ''VrfProof Tx.unstableMakeIsData ''VrfProof data VrfProofWithOutput = VrfProofWithOutput { vrfProofOutput :: BuiltinByteString - , vrfProofProof :: VrfProof + , vrfProofProof :: VrfProof } Tx.makeLift ''VrfProofWithOutput Tx.unstableMakeIsData ''VrfProofWithOutput @@ -366,27 +410,29 @@ Tx.unstableMakeIsData ''VrfProofWithOutput vrfBlsScript :: BuiltinByteString -> BuiltinByteString -> VrfProofWithOutput -> Bool vrfBlsScript message pubKey (VrfProofWithOutput beta (VrfProof gamma c s)) = let - -- cofactor of G2 - f = 305502333931268344200999753193121504214466019254188142667664032982267604182971884026507427359259977847832272839041692990889188039904403802465579155252111 :: Integer - - -- The proof of that the VRF hash of input alpha under our priv key is beta - -- To verify a VRF hash given an - -- input alpha - -- output beta - -- proof pi (gamma, c, s) - -- pubkey pub - -- do the following calculation - pubKey' = Tx.bls12_381_G2_uncompress pubKey - g2generator = Tx.bls12_381_G2_uncompress bls12_381_G2_compressed_generator - u = Tx.bls12_381_G2_add (Tx.bls12_381_G2_scalarMul (byteStringToIntegerLE c) pubKey') (Tx.bls12_381_G2_scalarMul s g2generator) - h = Tx.bls12_381_G2_hashToGroup message emptyByteString - v = Tx.bls12_381_G2_add (Tx.bls12_381_G2_scalarMul (byteStringToIntegerLE c) (Tx.bls12_381_G2_uncompress gamma)) (Tx.bls12_381_G2_scalarMul s h) + -- cofactor of G2 + f = 305502333931268344200999753193121504214466019254188142667664032982267604182971884026507427359259977847832272839041692990889188039904403802465579155252111 :: Integer + + -- The proof of that the VRF hash of input alpha under our priv key is beta + -- To verify a VRF hash given an + -- input alpha + -- output beta + -- proof pi (gamma, c, s) + -- pubkey pub + -- do the following calculation + pubKey' = Tx.bls12_381_G2_uncompress pubKey + g2generator = Tx.bls12_381_G2_uncompress bls12_381_G2_compressed_generator + u = Tx.bls12_381_G2_add (Tx.bls12_381_G2_scalarMul (byteStringToIntegerLE c) pubKey') (Tx.bls12_381_G2_scalarMul s g2generator) + h = Tx.bls12_381_G2_hashToGroup message emptyByteString + v = Tx.bls12_381_G2_add (Tx.bls12_381_G2_scalarMul (byteStringToIntegerLE c) (Tx.bls12_381_G2_uncompress gamma)) (Tx.bls12_381_G2_scalarMul s h) + in -- and check - in c == (sha2_256 . mconcat $ Tx.bls12_381_G2_compress <$> [g2generator, h, pubKey', Tx.bls12_381_G2_uncompress gamma, u, v]) - && - beta == (sha2_256 . Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul f (Tx.bls12_381_G2_uncompress gamma)) -{-# INLINABLE vrfBlsScript #-} + c + == (sha2_256 . mconcat $ Tx.bls12_381_G2_compress <$> [g2generator, h, pubKey', Tx.bls12_381_G2_uncompress gamma, u, v]) + && beta + == (sha2_256 . Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul f (Tx.bls12_381_G2_uncompress gamma)) +{-# INLINEABLE vrfBlsScript #-} -- used offchain to generate the vrf proof output generateVrfProof :: Integer -> BuiltinByteString -> VrfProofWithOutput @@ -410,9 +456,11 @@ generateVrfProof privKey message = -- define second element of the proof of correct VRF -- the paper notes that this can actually be truncated to 128 bits without loss of the 128 bits security. -- truncating this will allow for smaller proof sizes. - c = sha2_256 . mconcat $ - Tx.bls12_381_G2_compress - <$> [g2generator, h, pub, gamma, Tx.bls12_381_G2_scalarMul k g2generator, Tx.bls12_381_G2_scalarMul k h] + c = + sha2_256 + . mconcat + $ Tx.bls12_381_G2_compress + <$> [g2generator, h, pub, gamma, Tx.bls12_381_G2_scalarMul k g2generator, Tx.bls12_381_G2_scalarMul k h] -- define the third and last element of a proof of correct VRF s = (k - (byteStringToIntegerLE c) * privKey) `modulo` 52435875175126190479447740508185965837690552500527637822603658699938581184513 @@ -422,24 +470,22 @@ generateVrfProof privKey message = -- create our VRF hash output beta = sha2_256 . Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul f gamma - - in VrfProofWithOutput beta (VrfProof (Tx.bls12_381_G2_compress gamma) c s) + in VrfProofWithOutput beta (VrfProof (Tx.bls12_381_G2_compress gamma) c s) checkVrfBlsScript :: Bool -checkVrfBlsScript = let g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator - pk = Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul vrfPrivKey g2generator - in vrfBlsScript vrfMessage pk (generateVrfProof vrfPrivKey vrfMessage) +checkVrfBlsScript = + let g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator + pk = Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul vrfPrivKey g2generator + in vrfBlsScript vrfMessage pk (generateVrfProof vrfPrivKey vrfMessage) mkVrfBlsPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkVrfBlsPolicy = - let g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator - in Tx.getPlcNoAnn $ - $$(Tx.compile [|| vrfBlsScript ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef vrfMessage - `Tx.unsafeApplyCode` Tx.liftCodeDef (Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul vrfPrivKey g2generator) - `Tx.unsafeApplyCode` Tx.liftCodeDef (generateVrfProof vrfPrivKey vrfMessage) - - + let g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator + in Tx.getPlcNoAnn + $ $$(Tx.compile [||vrfBlsScript||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef vrfMessage + `Tx.unsafeApplyCode` Tx.liftCodeDef (Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul vrfPrivKey g2generator) + `Tx.unsafeApplyCode` Tx.liftCodeDef (generateVrfProof vrfPrivKey vrfMessage) ---------------- Verify over G1 ---------------- @@ -452,46 +498,52 @@ mkVrfBlsPolicy = -} g1VerifyMessage :: BuiltinByteString -g1VerifyMessage = bytesFromHex "3e00ef2f895f40d67f5bb8e81f09a5a12c840ec3ce9a7f3b181be188ef711a1e" -{-# INLINABLE g1VerifyMessage #-} +g1VerifyMessage = bytesFromHex "3e00ef2f895f40d67f5bb8e81f09a5a12c840ec3ce9a7f3b181be188ef711a1e" +{-# INLINEABLE g1VerifyMessage #-} g1VerifyPubKey :: BuiltinByteString -g1VerifyPubKey = bytesFromHex ("aa04a34d4db073e41505ebb84eee16c0094fde9fa22ec974" <> - "adb36e5b3df5b2608639f091bff99b5f090b3608c3990173") -{-# INLINABLE g1VerifyPubKey #-} +g1VerifyPubKey = + bytesFromHex + ( "aa04a34d4db073e41505ebb84eee16c0094fde9fa22ec974" + <> "adb36e5b3df5b2608639f091bff99b5f090b3608c3990173" + ) +{-# INLINEABLE g1VerifyPubKey #-} g1VerifySignature :: BuiltinByteString -g1VerifySignature = bytesFromHex - ("808ccec5435a63ae01e10d81be2707ab55cd0dfc235dfdf9f70ad32799e42510d67c9f61d98a6578a96a76cf6f4c105d" <> - "09262ec1d86b06515360b290e7d52d347e48438de2ea2233f3c72a0c2221ed2da5e115367bca7a2712165032340e0b29") -{-# INLINABLE g1VerifySignature #-} +g1VerifySignature = + bytesFromHex + ( "808ccec5435a63ae01e10d81be2707ab55cd0dfc235dfdf9f70ad32799e42510d67c9f61d98a6578a96a76cf6f4c105d" + <> "09262ec1d86b06515360b290e7d52d347e48438de2ea2233f3c72a0c2221ed2da5e115367bca7a2712165032340e0b29" + ) +{-# INLINEABLE g1VerifySignature #-} g1VerifyScript :: - BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> Bool + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + Bool g1VerifyScript message pubKey signature dst = let g1generator = Tx.bls12_381_G1_uncompress Tx.bls12_381_G1_compressed_generator pkDeser = Tx.bls12_381_G1_uncompress pubKey sigDeser = Tx.bls12_381_G2_uncompress signature hashedMsg = Tx.bls12_381_G2_hashToGroup message dst - - in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop pkDeser hashedMsg) - (Tx.bls12_381_millerLoop g1generator sigDeser) -{-# INLINABLE g1VerifyScript #-} + in Tx.bls12_381_finalVerify + (Tx.bls12_381_millerLoop pkDeser hashedMsg) + (Tx.bls12_381_millerLoop g1generator sigDeser) +{-# INLINEABLE g1VerifyScript #-} checkG1VerifyScript :: Bool checkG1VerifyScript = g1VerifyScript g1VerifyMessage g1VerifyPubKey g1VerifySignature blsSigBls12381G2XmdSha256SswuRoNul mkG1VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkG1VerifyPolicy = - Tx.getPlcNoAnn $ $$(Tx.compile [|| g1VerifyScript ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef g1VerifyMessage - `Tx.unsafeApplyCode` Tx.liftCodeDef g1VerifyPubKey - `Tx.unsafeApplyCode` Tx.liftCodeDef g1VerifySignature - `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul + Tx.getPlcNoAnn + $ $$(Tx.compile [||g1VerifyScript||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef g1VerifyMessage + `Tx.unsafeApplyCode` Tx.liftCodeDef g1VerifyPubKey + `Tx.unsafeApplyCode` Tx.liftCodeDef g1VerifySignature + `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul ---------------- Verify over G2 ---------------- @@ -504,34 +556,38 @@ mkG1VerifyPolicy = -} g2VerifyMessage :: BuiltinByteString -g2VerifyMessage = bytesFromHex "5032ec38bbc5da98ee0c6f568b872a65a08abf251deb21bb4b56e5d8821e68aa" -{-# INLINABLE g2VerifyMessage #-} +g2VerifyMessage = bytesFromHex "5032ec38bbc5da98ee0c6f568b872a65a08abf251deb21bb4b56e5d8821e68aa" +{-# INLINEABLE g2VerifyMessage #-} g2VerifyPubKey :: BuiltinByteString -g2VerifyPubKey = bytesFromHex - ("b4953c4ba10c4d4196f90169e76faf154c260ed73fc77bb65dc3be31e0cec614a7287cda94195343676c2c57494f0e65" <> - "1527e6504c98408e599a4eb96f7c5a8cfb85d2fdc772f28504580084ef559b9b623bc84ce30562ed320f6b7f65245ad4") -{-# INLINABLE g2VerifyPubKey #-} +g2VerifyPubKey = + bytesFromHex + ( "b4953c4ba10c4d4196f90169e76faf154c260ed73fc77bb65dc3be31e0cec614a7287cda94195343676c2c57494f0e65" + <> "1527e6504c98408e599a4eb96f7c5a8cfb85d2fdc772f28504580084ef559b9b623bc84ce30562ed320f6b7f65245ad4" + ) +{-# INLINEABLE g2VerifyPubKey #-} g2VerifySignature :: BuiltinByteString -g2VerifySignature = bytesFromHex ("a9d4de7b0b2805fe52bccb86415ef7b8ffecb313c3c25404" <> - "4dfc1bdc531d3eae999d87717822a052692140774bd7245c") -{-# INLINABLE g2VerifySignature #-} +g2VerifySignature = + bytesFromHex + ( "a9d4de7b0b2805fe52bccb86415ef7b8ffecb313c3c25404" + <> "4dfc1bdc531d3eae999d87717822a052692140774bd7245c" + ) +{-# INLINEABLE g2VerifySignature #-} g2VerifyScript :: - BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> Bool + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + Bool g2VerifyScript message pubKey signature dst = let g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator pkDeser = Tx.bls12_381_G2_uncompress pubKey sigDeser = Tx.bls12_381_G1_uncompress signature hashedMsg = Tx.bls12_381_G1_hashToGroup message dst - - in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop hashedMsg pkDeser) (Tx.bls12_381_millerLoop sigDeser g2generator) -{-# INLINABLE g2VerifyScript #-} + in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop hashedMsg pkDeser) (Tx.bls12_381_millerLoop sigDeser g2generator) +{-# INLINEABLE g2VerifyScript #-} checkG2VerifyScript :: Bool checkG2VerifyScript = @@ -539,11 +595,12 @@ checkG2VerifyScript = mkG2VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkG2VerifyPolicy = - Tx.getPlcNoAnn $ $$(Tx.compile [|| g2VerifyScript ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef g2VerifyMessage - `Tx.unsafeApplyCode` Tx.liftCodeDef g2VerifyPubKey - `Tx.unsafeApplyCode` Tx.liftCodeDef g2VerifySignature - `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul + Tx.getPlcNoAnn + $ $$(Tx.compile [||g2VerifyScript||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef g2VerifyMessage + `Tx.unsafeApplyCode` Tx.liftCodeDef g2VerifyPubKey + `Tx.unsafeApplyCode` Tx.liftCodeDef g2VerifySignature + `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul ---------------- Aggregate signature with single key and different messages over G1 ---------------- @@ -559,71 +616,75 @@ mkG2VerifyPolicy = -} aggregateSingleKeyG1Messages :: [BuiltinByteString] -aggregateSingleKeyG1Messages = [ - bytesFromHex "2ba037cdb63cb5a7277dc5d6dc549e4e28a15c70670f0e97787c170485829264" - , bytesFromHex "ecbf14bddeb68410f423e8849e0ce35c10d20a802bbc3d9a6ca01c386279bf01" - , bytesFromHex "e8f75f478cb0d159db767341602fa02d3e01c3d9aacf9b686eccf1bb5ff4c8fd" - , bytesFromHex "21473e89d50f51f9a1ced2390c72ee7e37f15728e61d1fb2c8c839495e489052" - , bytesFromHex "8c146d00fe2e1caec31b159fc42dcd7e06865c6fa5267c6ca9c5284e651e175a" - , bytesFromHex "362f469b6e722347de959f76533315542ffa440d37cde8862da3b3331e53b60d" - , bytesFromHex "73baeb620e63a2e646ea148974350aa337491e5f5fc087cb429173d1eeb74f5a" - , bytesFromHex "73acc6c3d72b59b8bf5ab58cdcf76aa001689aac938a75b1bb25d77b5382898c" - , bytesFromHex "4e73ba04bae3a083c8a2109f15b8c4680ae4ba1c70df5b513425349a77e95d3b" - , bytesFromHex "565825a0227d45068e61eb90aa1a4dc414c0976911a52d46b39f40c5849e5abe" - ] -{-# INLINABLE aggregateSingleKeyG1Messages #-} +aggregateSingleKeyG1Messages = + [ bytesFromHex "2ba037cdb63cb5a7277dc5d6dc549e4e28a15c70670f0e97787c170485829264" + , bytesFromHex "ecbf14bddeb68410f423e8849e0ce35c10d20a802bbc3d9a6ca01c386279bf01" + , bytesFromHex "e8f75f478cb0d159db767341602fa02d3e01c3d9aacf9b686eccf1bb5ff4c8fd" + , bytesFromHex "21473e89d50f51f9a1ced2390c72ee7e37f15728e61d1fb2c8c839495e489052" + , bytesFromHex "8c146d00fe2e1caec31b159fc42dcd7e06865c6fa5267c6ca9c5284e651e175a" + , bytesFromHex "362f469b6e722347de959f76533315542ffa440d37cde8862da3b3331e53b60d" + , bytesFromHex "73baeb620e63a2e646ea148974350aa337491e5f5fc087cb429173d1eeb74f5a" + , bytesFromHex "73acc6c3d72b59b8bf5ab58cdcf76aa001689aac938a75b1bb25d77b5382898c" + , bytesFromHex "4e73ba04bae3a083c8a2109f15b8c4680ae4ba1c70df5b513425349a77e95d3b" + , bytesFromHex "565825a0227d45068e61eb90aa1a4dc414c0976911a52d46b39f40c5849e5abe" + ] +{-# INLINEABLE aggregateSingleKeyG1Messages #-} aggregateSingleKeyG1PubKey :: BuiltinByteString -aggregateSingleKeyG1PubKey = bytesFromHex ("97c919babda8d928d771d107a69adfd85a75cee2cedc4afa" <> - "4c0a7e902f38b340ea21a701a46df825210dd6942632b46c") -{-# INLINABLE aggregateSingleKeyG1PubKey #-} +aggregateSingleKeyG1PubKey = + bytesFromHex + ( "97c919babda8d928d771d107a69adfd85a75cee2cedc4afa" + <> "4c0a7e902f38b340ea21a701a46df825210dd6942632b46c" + ) +{-# INLINEABLE aggregateSingleKeyG1PubKey #-} aggregateSingleKeyG1Signature :: BuiltinByteString -aggregateSingleKeyG1Signature = bytesFromHex - ("b425291f423235b022cdd038e1a3cbdcc73b5a4470251634" <> - "abb874c7585a3a05b8ea54ceb93286edb0e9184bf9a852a1" <> - "138c6dd860e4b756c63dff65c433a6c5aa06834f00ac5a1a" <> - "1acf6bedc44bd4354f9d36d4f20f66318f39116428fabb88") -{-# INLINABLE aggregateSingleKeyG1Signature #-} - -aggregateSingleKeyG1Script - :: [BuiltinByteString] - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> Bool +aggregateSingleKeyG1Signature = + bytesFromHex + ( "b425291f423235b022cdd038e1a3cbdcc73b5a4470251634" + <> "abb874c7585a3a05b8ea54ceb93286edb0e9184bf9a852a1" + <> "138c6dd860e4b756c63dff65c433a6c5aa06834f00ac5a1a" + <> "1acf6bedc44bd4354f9d36d4f20f66318f39116428fabb88" + ) +{-# INLINEABLE aggregateSingleKeyG1Signature #-} + +aggregateSingleKeyG1Script :: + [BuiltinByteString] -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + Bool aggregateSingleKeyG1Script messages pubKey aggregateSignature dst = let g1generator = Tx.bls12_381_G1_uncompress Tx.bls12_381_G1_compressed_generator hashedMsgs = List.map (\x -> Tx.bls12_381_G2_hashToGroup x dst) messages pkDeser = Tx.bls12_381_G1_uncompress pubKey aggrSigDeser = Tx.bls12_381_G2_uncompress aggregateSignature aggrMsg = foldl1 Tx.bls12_381_G2_add hashedMsgs - - in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop pkDeser aggrMsg) (Tx.bls12_381_millerLoop g1generator aggrSigDeser) - where - -- PlutusTx.Foldable has no foldl1 - foldl1 :: (a -> a -> a) -> [a] -> a - foldl1 _ [] = traceError "foldr1: empty list" - foldl1 _ [_] = traceError "foldr1: only one element in list" - foldl1 f (x:xs) = List.foldl f x xs -{-# INLINABLE aggregateSingleKeyG1Script #-} - + in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop pkDeser aggrMsg) (Tx.bls12_381_millerLoop g1generator aggrSigDeser) + where + -- PlutusTx.Foldable has no foldl1 + foldl1 :: (a -> a -> a) -> [a] -> a + foldl1 _ [] = traceError "foldr1: empty list" + foldl1 _ [_] = traceError "foldr1: only one element in list" + foldl1 f (x : xs) = List.foldl f x xs +{-# INLINEABLE aggregateSingleKeyG1Script #-} checkAggregateSingleKeyG1Script :: Bool checkAggregateSingleKeyG1Script = - aggregateSingleKeyG1Script - aggregateSingleKeyG1Messages - aggregateSingleKeyG1PubKey - aggregateSingleKeyG1Signature - blsSigBls12381G2XmdSha256SswuRoNul + aggregateSingleKeyG1Script + aggregateSingleKeyG1Messages + aggregateSingleKeyG1PubKey + aggregateSingleKeyG1Signature + blsSigBls12381G2XmdSha256SswuRoNul mkAggregateSingleKeyG1Policy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkAggregateSingleKeyG1Policy = - Tx.getPlcNoAnn $ $$(Tx.compile [|| aggregateSingleKeyG1Script ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateSingleKeyG1Messages - `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateSingleKeyG1PubKey - `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateSingleKeyG1Signature - `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul + Tx.getPlcNoAnn + $ $$(Tx.compile [||aggregateSingleKeyG1Script||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateSingleKeyG1Messages + `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateSingleKeyG1PubKey + `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateSingleKeyG1Signature + `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul ---------------- Aggregate signature with multiple keys and single message over G1 ---------------- @@ -640,94 +701,113 @@ mkAggregateSingleKeyG1Policy = -} aggregateMultiKeyG2Message :: BuiltinByteString -aggregateMultiKeyG2Message = bytesFromHex - "e345b7f2c017b16bb335c696bc0cc302f3db897fa25365a2ead1f149d87a97e8" -{-# INLINABLE aggregateMultiKeyG2Message #-} +aggregateMultiKeyG2Message = + bytesFromHex + "e345b7f2c017b16bb335c696bc0cc302f3db897fa25365a2ead1f149d87a97e8" +{-# INLINEABLE aggregateMultiKeyG2Message #-} aggregateMultiKeyG2PubKeys :: [BuiltinByteString] -aggregateMultiKeyG2PubKeys = [ - bytesFromHex - ("83718f20d08471565b3a6ca6ea82c1928e8730f87e2afe460b74842f2880facd8e63b8abcdcd7350fe5813a08aa0efed" <> - "13216b10de1c56dc059c3a8910bd97ae133046ae031d2a53a44e460ab71ebda94bab64ed7478cf1a91b6d3981e32fc95") +aggregateMultiKeyG2PubKeys = + [ bytesFromHex + ( "83718f20d08471565b3a6ca6ea82c1928e8730f87e2afe460b74842f2880facd8e63b8abcdcd7350fe5813a08aa0efed" + <> "13216b10de1c56dc059c3a8910bd97ae133046ae031d2a53a44e460ab71ebda94bab64ed7478cf1a91b6d3981e32fc95" + ) , bytesFromHex - ("814f825911bd066855333b74a3cc564d512503ee29ea1ec3bd57a3c07fa5768ad27ea1ddd8047f43fbc9a4ebda897c14" <> - "06415fefbb8838b8782aa747e2fde7b1813d0f89fad06c8971041c9427abf848503e34e3ca033ba85d50b72ffac4be4a") + ( "814f825911bd066855333b74a3cc564d512503ee29ea1ec3bd57a3c07fa5768ad27ea1ddd8047f43fbc9a4ebda897c14" + <> "06415fefbb8838b8782aa747e2fde7b1813d0f89fad06c8971041c9427abf848503e34e3ca033ba85d50b72ffac4be4a" + ) , bytesFromHex - ("9974c70513ed5538a8e55f5ce1a0267282b9e8431e25ae566950b2d0793a44a0a3c52110f4d83d694a5296615ee68573" <> - "098c14d255783a9b1a169d2be1baefbef914a4f830a9099f720063914cc919064d2244582bb9f302eac39c8b195cf3d2") + ( "9974c70513ed5538a8e55f5ce1a0267282b9e8431e25ae566950b2d0793a44a0a3c52110f4d83d694a5296615ee68573" + <> "098c14d255783a9b1a169d2be1baefbef914a4f830a9099f720063914cc919064d2244582bb9f302eac39c8b195cf3d2" + ) , bytesFromHex - ("894a3a01d38169a38bea13097cf904dd3ff9dceefb51e8b539725a237ae55a361758be1cdf0e21a7b8db3599adaf2305" <> - "050f1d8450b924a4b910ff536fc2f7960cd3251c2a457b975d46f7c0f74493cc9b5e8d2fed2e489363e641cc79933d1e") + ( "894a3a01d38169a38bea13097cf904dd3ff9dceefb51e8b539725a237ae55a361758be1cdf0e21a7b8db3599adaf2305" + <> "050f1d8450b924a4b910ff536fc2f7960cd3251c2a457b975d46f7c0f74493cc9b5e8d2fed2e489363e641cc79933d1e" + ) , bytesFromHex - ("9646da0149ed140e33a99e1ffc5fe9c97c2368ca273544024993cdcb7aa04c0be936e6d4427747e62c4caea4fe1f69e5" <> - "162fad222e0487f5556524c9d3db74921e1c0f5893f0e26c759e3873e8fd6637e6051f70ef9a3363cf284e8eee67bcf3") + ( "9646da0149ed140e33a99e1ffc5fe9c97c2368ca273544024993cdcb7aa04c0be936e6d4427747e62c4caea4fe1f69e5" + <> "162fad222e0487f5556524c9d3db74921e1c0f5893f0e26c759e3873e8fd6637e6051f70ef9a3363cf284e8eee67bcf3" + ) , bytesFromHex - ("b75743fb2f8321ac56cee19aacd7e141a3592b7230992ea84d8800d45ad71924a477f61cf9d4a2783df59dac21cd17e7" <> - "0e4ce5d526cbe73edc4a10b78fa56a2ef34d2009f2756d2d50188031e026a6a1dadcd5e753f5e7f7276048277d3819f1") + ( "b75743fb2f8321ac56cee19aacd7e141a3592b7230992ea84d8800d45ad71924a477f61cf9d4a2783df59dac21cd17e7" + <> "0e4ce5d526cbe73edc4a10b78fa56a2ef34d2009f2756d2d50188031e026a6a1dadcd5e753f5e7f7276048277d3819f1" + ) , bytesFromHex - ("873c1e7d525265afa8c037d33874261a90daaa2c6ed5e46ed043ec48a28b7111d0de65800aa72448c1fdb1026ba076bd" <> - "04193bd2d04e0de63e7a008b8417420eb4920767a1d32f6330ed25bdb4dc7726d989d6cf192db6b32728bb388195ba27") + ( "873c1e7d525265afa8c037d33874261a90daaa2c6ed5e46ed043ec48a28b7111d0de65800aa72448c1fdb1026ba076bd" + <> "04193bd2d04e0de63e7a008b8417420eb4920767a1d32f6330ed25bdb4dc7726d989d6cf192db6b32728bb388195ba27" + ) , bytesFromHex - ("b993f867f9f1f84c3c5c3e5b80013055da7705491c36a80e1201a6a503d7364000c50bc27e03477646874a3074cc4e39" <> - "0febfea78a2b4d0e40c57d6deaf9fae430a19fcce0c03f43ff8f7e788de0c7b8ce1b69b69d1d026175c8f2730777866d") + ( "b993f867f9f1f84c3c5c3e5b80013055da7705491c36a80e1201a6a503d7364000c50bc27e03477646874a3074cc4e39" + <> "0febfea78a2b4d0e40c57d6deaf9fae430a19fcce0c03f43ff8f7e788de0c7b8ce1b69b69d1d026175c8f2730777866d" + ) , bytesFromHex - ("99836a204576636f34a4663cfa7e02a05cb2d4fd1b582427d199ac3ddac6f087968d2290198aa15e04f6e7e0d070b7dd" <> - "03607db9c2e4b17709853c30b2f6490261599408fbbc17371de74d0a2a76ff10cd8c9b55461c444bbebc82547bb40c9f") + ( "99836a204576636f34a4663cfa7e02a05cb2d4fd1b582427d199ac3ddac6f087968d2290198aa15e04f6e7e0d070b7dd" + <> "03607db9c2e4b17709853c30b2f6490261599408fbbc17371de74d0a2a76ff10cd8c9b55461c444bbebc82547bb40c9f" + ) , bytesFromHex - ("96f8d678f40dd83b2060e14372d0bc43a423fecac44f082afd89cb481b855885ac83fb366516dc74023cc41a0c606be2" <> - "067ba826ea612f84c9f0e895d02bc04d6c34e201ff8c26cc22cb4c426c53f503d8948eafceb12e2f4b6ad49b4e051690") + ( "96f8d678f40dd83b2060e14372d0bc43a423fecac44f082afd89cb481b855885ac83fb366516dc74023cc41a0c606be2" + <> "067ba826ea612f84c9f0e895d02bc04d6c34e201ff8c26cc22cb4c426c53f503d8948eafceb12e2f4b6ad49b4e051690" + ) ] -{-# INLINABLE aggregateMultiKeyG2PubKeys #-} +{-# INLINEABLE aggregateMultiKeyG2PubKeys #-} aggregateMultiKeyG2Signature :: BuiltinByteString -aggregateMultiKeyG2Signature = bytesFromHex ("b24d876661d0d1190c796bf7eaa7e02b807ff603093b1733" <> - "6289d4de0477f6c17afb487275cb9de44325016edfeda042") -{-# INLINABLE aggregateMultiKeyG2Signature #-} - -aggregateMultiKeyG2Script - :: BuiltinByteString - -> [BuiltinByteString] - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> Bool +aggregateMultiKeyG2Signature = + bytesFromHex + ( "b24d876661d0d1190c796bf7eaa7e02b807ff603093b1733" + <> "6289d4de0477f6c17afb487275cb9de44325016edfeda042" + ) +{-# INLINEABLE aggregateMultiKeyG2Signature #-} + +aggregateMultiKeyG2Script :: + BuiltinByteString -> + [BuiltinByteString] -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + Bool aggregateMultiKeyG2Script message pubKeys aggregateSignature bs16Null dst = let g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator hashedMsg = Tx.bls12_381_G1_hashToGroup message dst pksDeser = List.map Tx.bls12_381_G2_uncompress pubKeys -- scalar calcuates to (142819114285630344964654001480828217341 :: Integer) - dsScalar = byteStringToIntegerLE (Tx.sliceByteString 0 16 - (Tx.sha2_256 (foldl1 Tx.appendByteString pubKeys)) `Tx.appendByteString` bs16Null) + dsScalar = + byteStringToIntegerLE + ( Tx.sliceByteString + 0 + 16 + (Tx.sha2_256 (foldl1 Tx.appendByteString pubKeys)) + `Tx.appendByteString` bs16Null + ) aggrSigDeser = Tx.bls12_381_G1_uncompress aggregateSignature aggrPk = calcAggregatedPubkeys dsScalar pksDeser - - in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop hashedMsg aggrPk) (Tx.bls12_381_millerLoop aggrSigDeser g2generator) - where - -- PlutusTx.Foldable has no foldl1 - foldl1 :: (a -> a -> a) -> [a] -> a - foldl1 _ [] = traceError "foldr1: empty list" - foldl1 _ [_] = traceError "foldr1: only one element in list" - foldl1 f (x:xs) = List.foldl f x xs - - calcAggregatedPubkeys :: Integer -> [BuiltinBLS12_381_G2_Element] -> BuiltinBLS12_381_G2_Element - calcAggregatedPubkeys dsScalar' pksDeser' = - let dsScalars = calcDsScalars pksDeser' [dsScalar'] - in go 1 (List.drop 1 pksDeser') (List.drop 1 dsScalars) (calcAggregatedPubkey (List.head pksDeser') (List.head dsScalars)) - - calcDsScalars :: [BuiltinBLS12_381_G2_Element] -> [Integer] -> [Integer] - calcDsScalars [] acc = acc - calcDsScalars (_:xs) [x'] = calcDsScalars xs [x', x' * x'] - calcDsScalars (_:xs) acc@(x':xs') = calcDsScalars xs (acc List.++ [List.last xs' * x']) - calcDsScalars _ _ = traceError "calcDsScalars: unexpected" - - go :: Integer -> [BuiltinBLS12_381_G2_Element] -> [Integer] -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element - go _ [] _ acc = acc - go i (x:xs) (x':xs') acc = go (i + 1) xs xs' (acc `Tx.bls12_381_G2_add` (calcAggregatedPubkey x x')) - go _ _ _ _ = traceError "go: unexpected" - - calcAggregatedPubkey :: BuiltinBLS12_381_G2_Element -> Integer -> BuiltinBLS12_381_G2_Element - calcAggregatedPubkey pk ds = ds `Tx.bls12_381_G2_scalarMul` pk -{-# INLINABLE aggregateMultiKeyG2Script #-} + in Tx.bls12_381_finalVerify (Tx.bls12_381_millerLoop hashedMsg aggrPk) (Tx.bls12_381_millerLoop aggrSigDeser g2generator) + where + -- PlutusTx.Foldable has no foldl1 + foldl1 :: (a -> a -> a) -> [a] -> a + foldl1 _ [] = traceError "foldr1: empty list" + foldl1 _ [_] = traceError "foldr1: only one element in list" + foldl1 f (x : xs) = List.foldl f x xs + + calcAggregatedPubkeys :: Integer -> [BuiltinBLS12_381_G2_Element] -> BuiltinBLS12_381_G2_Element + calcAggregatedPubkeys dsScalar' pksDeser' = + let dsScalars = calcDsScalars pksDeser' [dsScalar'] + in go 1 (List.drop 1 pksDeser') (List.drop 1 dsScalars) (calcAggregatedPubkey (List.head pksDeser') (List.head dsScalars)) + + calcDsScalars :: [BuiltinBLS12_381_G2_Element] -> [Integer] -> [Integer] + calcDsScalars [] acc = acc + calcDsScalars (_ : xs) [x'] = calcDsScalars xs [x', x' * x'] + calcDsScalars (_ : xs) acc@(x' : xs') = calcDsScalars xs (acc List.++ [List.last xs' * x']) + calcDsScalars _ _ = traceError "calcDsScalars: unexpected" + + go :: Integer -> [BuiltinBLS12_381_G2_Element] -> [Integer] -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element + go _ [] _ acc = acc + go i (x : xs) (x' : xs') acc = go (i + 1) xs xs' (acc `Tx.bls12_381_G2_add` (calcAggregatedPubkey x x')) + go _ _ _ _ = traceError "go: unexpected" + + calcAggregatedPubkey :: BuiltinBLS12_381_G2_Element -> Integer -> BuiltinBLS12_381_G2_Element + calcAggregatedPubkey pk ds = ds `Tx.bls12_381_G2_scalarMul` pk +{-# INLINEABLE aggregateMultiKeyG2Script #-} {- An alternative implementation of calcAggregatedPubkeys which uses a different -- means of scalar exponentiation. It results in a slightly smaller script using less CPU but @@ -758,13 +838,13 @@ checkAggregateMultiKeyG2Script = mkAggregateMultiKeyG2Policy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkAggregateMultiKeyG2Policy = - Tx.getPlcNoAnn $ $$(Tx.compile [|| aggregateMultiKeyG2Script ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateMultiKeyG2Message - `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateMultiKeyG2PubKeys - `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateMultiKeyG2Signature - `Tx.unsafeApplyCode` Tx.liftCodeDef byteString16Null - `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul - + Tx.getPlcNoAnn + $ $$(Tx.compile [||aggregateMultiKeyG2Script||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateMultiKeyG2Message + `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateMultiKeyG2PubKeys + `Tx.unsafeApplyCode` Tx.liftCodeDef aggregateMultiKeyG2Signature + `Tx.unsafeApplyCode` Tx.liftCodeDef byteString16Null + `Tx.unsafeApplyCode` Tx.liftCodeDef blsSigBls12381G2XmdSha256SswuRoNul ---------------- Schnorr signature in G1 ---------------- @@ -778,57 +858,72 @@ mkAggregateMultiKeyG2Policy = -} schnorrG1VerifyMessage :: BuiltinByteString -schnorrG1VerifyMessage = bytesFromHex "0558db9aff738e5421439601e7f30e88b74f43b80c1d172b5d371ce0dc05c912" -{-# INLINABLE schnorrG1VerifyMessage #-} +schnorrG1VerifyMessage = bytesFromHex "0558db9aff738e5421439601e7f30e88b74f43b80c1d172b5d371ce0dc05c912" +{-# INLINEABLE schnorrG1VerifyMessage #-} schnorrG1VerifyPubKey :: BuiltinByteString -schnorrG1VerifyPubKey = bytesFromHex ("b91cacee903a53383c504e9e9a39e57d1eaa6403d5d38fc9" <> - "496e5007d54ca92d106d1059f09461972aa98514d07000ae") -{-# INLINABLE schnorrG1VerifyPubKey #-} +schnorrG1VerifyPubKey = + bytesFromHex + ( "b91cacee903a53383c504e9e9a39e57d1eaa6403d5d38fc9" + <> "496e5007d54ca92d106d1059f09461972aa98514d07000ae" + ) +{-# INLINEABLE schnorrG1VerifyPubKey #-} schnorrG1VerifySignature :: (BuiltinByteString, BuiltinByteString) schnorrG1VerifySignature = - (bytesFromHex - "8477e8491acc1cfbcf675acf7cf6b92e027cad7dd604a0e8205703aa2cc590066c1746f89e10d492d0230e6620c29726", - bytesFromHex "4e908280c0100cfe53501171ffa93528b9e2bb551d1025decb4a5b416a0aee53") -{-# INLINABLE schnorrG1VerifySignature #-} + ( bytesFromHex + "8477e8491acc1cfbcf675acf7cf6b92e027cad7dd604a0e8205703aa2cc590066c1746f89e10d492d0230e6620c29726" + , bytesFromHex "4e908280c0100cfe53501171ffa93528b9e2bb551d1025decb4a5b416a0aee53" + ) +{-# INLINEABLE schnorrG1VerifySignature #-} schnorrG1VerifyScript :: - BuiltinByteString - -> BuiltinByteString - -> (BuiltinByteString, BuiltinByteString) - -> BuiltinByteString - -> Bool + BuiltinByteString -> + BuiltinByteString -> + (BuiltinByteString, BuiltinByteString) -> + BuiltinByteString -> + Bool schnorrG1VerifyScript message pubKey signature bs16Null = let a = Tx.fst signature r = Tx.snd signature - c = byteStringToIntegerLE (Tx.sliceByteString 0 16 - (Tx.sha2_256 (a `Tx.appendByteString` pubKey `Tx.appendByteString` message)) `Tx.appendByteString` bs16Null) + c = + byteStringToIntegerLE + ( Tx.sliceByteString + 0 + 16 + (Tx.sha2_256 (a `Tx.appendByteString` pubKey `Tx.appendByteString` message)) + `Tx.appendByteString` bs16Null + ) pkDeser = Tx.bls12_381_G1_uncompress pubKey aDeser = Tx.bls12_381_G1_uncompress a rDeser = byteStringToIntegerLE r g1generator = Tx.bls12_381_G1_uncompress Tx.bls12_381_G1_compressed_generator - in (rDeser `Tx.bls12_381_G1_scalarMul` g1generator) == - (aDeser `Tx.bls12_381_G1_add` (c `Tx.bls12_381_G1_scalarMul` pkDeser)) - -- additional check using negation is for testing the function - -- it can be removed to improve performance - && - (rDeser `Tx.bls12_381_G1_scalarMul` g1generator) - `Tx.bls12_381_G1_add` (Tx.bls12_381_G1_neg aDeser) - == c `Tx.bls12_381_G1_scalarMul` pkDeser -{-# INLINABLE schnorrG1VerifyScript #-} + in (rDeser `Tx.bls12_381_G1_scalarMul` g1generator) + == (aDeser `Tx.bls12_381_G1_add` (c `Tx.bls12_381_G1_scalarMul` pkDeser)) + -- additional check using negation is for testing the function + -- it can be removed to improve performance + && (rDeser `Tx.bls12_381_G1_scalarMul` g1generator) + `Tx.bls12_381_G1_add` (Tx.bls12_381_G1_neg aDeser) + == c + `Tx.bls12_381_G1_scalarMul` pkDeser +{-# INLINEABLE schnorrG1VerifyScript #-} checkSchnorrG1VerifyScript :: Bool -checkSchnorrG1VerifyScript = schnorrG1VerifyScript schnorrG1VerifyMessage schnorrG1VerifyPubKey - schnorrG1VerifySignature byteString16Null +checkSchnorrG1VerifyScript = + schnorrG1VerifyScript + schnorrG1VerifyMessage + schnorrG1VerifyPubKey + schnorrG1VerifySignature + byteString16Null mkSchnorrG1VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkSchnorrG1VerifyPolicy = - Tx.getPlcNoAnn $ $$(Tx.compile [|| schnorrG1VerifyScript ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG1VerifyMessage - `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG1VerifyPubKey - `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG1VerifySignature - `Tx.unsafeApplyCode` Tx.liftCodeDef byteString16Null + Tx.getPlcNoAnn + $ $$(Tx.compile [||schnorrG1VerifyScript||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG1VerifyMessage + `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG1VerifyPubKey + `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG1VerifySignature + `Tx.unsafeApplyCode` Tx.liftCodeDef byteString16Null ---------------- Schnorr signature in G2 ---------------- @@ -842,56 +937,72 @@ mkSchnorrG1VerifyPolicy = -} schnorrG2VerifyMessage :: BuiltinByteString -schnorrG2VerifyMessage = bytesFromHex "2b71175d0486006a33f14bc4e1fe711a3d4a3a3549b230013240e8f80e54372f" -{-# INLINABLE schnorrG2VerifyMessage #-} +schnorrG2VerifyMessage = bytesFromHex "2b71175d0486006a33f14bc4e1fe711a3d4a3a3549b230013240e8f80e54372f" +{-# INLINEABLE schnorrG2VerifyMessage #-} schnorrG2VerifyPubKey :: BuiltinByteString -schnorrG2VerifyPubKey = bytesFromHex - ("88370a4b4ddc627613b0396498fb068f1c1ff8f2aa6b946a9fc65f930d24394ddc45042e602094f6a88d49a8a037e781" <> - "08dce014586ff5ff5744842f382e3917d180c7eb969585748d20ae8c6e07ca786e8da7ea2c7bdef5ae1becebe4da59ad") -{-# INLINABLE schnorrG2VerifyPubKey #-} +schnorrG2VerifyPubKey = + bytesFromHex + ( "88370a4b4ddc627613b0396498fb068f1c1ff8f2aa6b946a9fc65f930d24394ddc45042e602094f6a88d49a8a037e781" + <> "08dce014586ff5ff5744842f382e3917d180c7eb969585748d20ae8c6e07ca786e8da7ea2c7bdef5ae1becebe4da59ad" + ) +{-# INLINEABLE schnorrG2VerifyPubKey #-} schnorrG2VerifySignature :: (BuiltinByteString, BuiltinByteString) -schnorrG2VerifySignature = - (bytesFromHex - ("964851eb8823492c8720bf8c515b87043f5bab648000e63cfb6fc6fcdf6709061e0035c315cd23d239866471dea907d9" <> - "1568b69297dc8c4360f65d0bd399c2de19781c13bbf3a82ff1fcab8ac9f688ed96d6f2ea9a8ed057e76f0347d858ae22"), - bytesFromHex "2c5a22cb1e2fb77586c0c6908060b38107675a6277b8a61b1d6394a162af6718") -{-# INLINABLE schnorrG2VerifySignature #-} +schnorrG2VerifySignature = + ( bytesFromHex + ( "964851eb8823492c8720bf8c515b87043f5bab648000e63cfb6fc6fcdf6709061e0035c315cd23d239866471dea907d9" + <> "1568b69297dc8c4360f65d0bd399c2de19781c13bbf3a82ff1fcab8ac9f688ed96d6f2ea9a8ed057e76f0347d858ae22" + ) + , bytesFromHex "2c5a22cb1e2fb77586c0c6908060b38107675a6277b8a61b1d6394a162af6718" + ) +{-# INLINEABLE schnorrG2VerifySignature #-} schnorrG2VerifyScript :: - BuiltinByteString - -> BuiltinByteString - -> (BuiltinByteString, BuiltinByteString) - -> BuiltinByteString - -> Bool + BuiltinByteString -> + BuiltinByteString -> + (BuiltinByteString, BuiltinByteString) -> + BuiltinByteString -> + Bool schnorrG2VerifyScript message pubKey signature bs16Null = let a = Tx.fst signature r = Tx.snd signature - c = byteStringToIntegerLE (Tx.sliceByteString 0 16 - (Tx.sha2_256 (a `Tx.appendByteString` pubKey `Tx.appendByteString` message)) `Tx.appendByteString` bs16Null) + c = + byteStringToIntegerLE + ( Tx.sliceByteString + 0 + 16 + (Tx.sha2_256 (a `Tx.appendByteString` pubKey `Tx.appendByteString` message)) + `Tx.appendByteString` bs16Null + ) pkDeser = Tx.bls12_381_G2_uncompress pubKey aDeser = Tx.bls12_381_G2_uncompress a rDeser = byteStringToIntegerLE r g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator - in rDeser `Tx.bls12_381_G2_scalarMul` g2generator == - (aDeser `Tx.bls12_381_G2_add` (c `Tx.bls12_381_G2_scalarMul` pkDeser)) - -- additional check using negation is for testing the function - -- it can be removed to improve performance - && - (rDeser `Tx.bls12_381_G2_scalarMul` g2generator) - `Tx.bls12_381_G2_add` (Tx.bls12_381_G2_neg aDeser) - == c `Tx.bls12_381_G2_scalarMul` pkDeser -{-# INLINABLE schnorrG2VerifyScript #-} + in rDeser + `Tx.bls12_381_G2_scalarMul` g2generator + == (aDeser `Tx.bls12_381_G2_add` (c `Tx.bls12_381_G2_scalarMul` pkDeser)) + -- additional check using negation is for testing the function + -- it can be removed to improve performance + && (rDeser `Tx.bls12_381_G2_scalarMul` g2generator) + `Tx.bls12_381_G2_add` (Tx.bls12_381_G2_neg aDeser) + == c + `Tx.bls12_381_G2_scalarMul` pkDeser +{-# INLINEABLE schnorrG2VerifyScript #-} checkSchnorrG2VerifyScript :: Bool -checkSchnorrG2VerifyScript = schnorrG2VerifyScript schnorrG2VerifyMessage schnorrG2VerifyPubKey - schnorrG2VerifySignature byteString16Null +checkSchnorrG2VerifyScript = + schnorrG2VerifyScript + schnorrG2VerifyMessage + schnorrG2VerifyPubKey + schnorrG2VerifySignature + byteString16Null mkSchnorrG2VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkSchnorrG2VerifyPolicy = - Tx.getPlcNoAnn $ $$(Tx.compile [|| schnorrG2VerifyScript ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG2VerifyMessage - `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG2VerifyPubKey - `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG2VerifySignature - `Tx.unsafeApplyCode` Tx.liftCodeDef byteString16Null + Tx.getPlcNoAnn + $ $$(Tx.compile [||schnorrG2VerifyScript||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG2VerifyMessage + `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG2VerifyPubKey + `Tx.unsafeApplyCode` Tx.liftCodeDef schnorrG2VerifySignature + `Tx.unsafeApplyCode` Tx.liftCodeDef byteString16Null diff --git a/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs b/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs index 7e4037a7baf..5c53694190c 100644 --- a/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs +++ b/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Strict #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE NoImplicitPrelude #-} module CardanoLoans.Test where @@ -29,57 +29,56 @@ testScriptContext = , scriptContextRedeemer , scriptContextScriptInfo } - where - txInfo = - TxInfo - { txInfoInputs = - [ - TxInInfo - { txInInfoOutRef = txOutRef - , txInInfoResolved = Tx.pubKeyHashTxOut (Value.lovelaceValue 1000) testBeneficiaryPKH - } - ] - , txInfoReferenceInputs = mempty - , txInfoOutputs = [ - TxOut - { txOutAddress = pubKeyHashAddress testBeneficiaryPKH - , txOutValue = Value.lovelaceValue 1000 - , txOutDatum = NoOutputDatum - , txOutReferenceScript = Nothing - } - ] - , txInfoTxCerts = mempty - , txInfoRedeemers = Map.empty - , txInfoVotes = Map.empty - , txInfoProposalProcedures = mempty - , txInfoCurrentTreasuryAmount = Nothing - , txInfoTreasuryDonation = Nothing - , txInfoFee = 0 - , txInfoMint = emptyMintValue - , txInfoWdrl = Map.empty - , txInfoValidRange = - Interval - (LowerBound (Finite 110) True) - (UpperBound (Finite 1100) True) - , txInfoSignatories = [testBeneficiaryPKH] - , txInfoData = Map.empty - , txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" - } + where + txInfo = + TxInfo + { txInfoInputs = + [ TxInInfo + { txInInfoOutRef = txOutRef + , txInInfoResolved = Tx.pubKeyHashTxOut (Value.lovelaceValue 1000) testBeneficiaryPKH + } + ] + , txInfoReferenceInputs = mempty + , txInfoOutputs = + [ TxOut + { txOutAddress = pubKeyHashAddress testBeneficiaryPKH + , txOutValue = Value.lovelaceValue 1000 + , txOutDatum = NoOutputDatum + , txOutReferenceScript = Nothing + } + ] + , txInfoTxCerts = mempty + , txInfoRedeemers = Map.empty + , txInfoVotes = Map.empty + , txInfoProposalProcedures = mempty + , txInfoCurrentTreasuryAmount = Nothing + , txInfoTreasuryDonation = Nothing + , txInfoFee = 0 + , txInfoMint = emptyMintValue + , txInfoWdrl = Map.empty + , txInfoValidRange = + Interval + (LowerBound (Finite 110) True) + (UpperBound (Finite 1100) True) + , txInfoSignatories = [testBeneficiaryPKH] + , txInfoData = Map.empty + , txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" + } - scriptContextRedeemer :: Redeemer - scriptContextRedeemer = Redeemer $ toBuiltinData CloseAsk + scriptContextRedeemer :: Redeemer + scriptContextRedeemer = Redeemer $ toBuiltinData CloseAsk - txOutRef :: TxOutRef - txOutRef = TxOutRef txOutRefId txOutRefIdx - where - txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" - txOutRefIdx = 0 + txOutRef :: TxOutRef + txOutRef = TxOutRef txOutRefId txOutRefIdx + where + txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" + txOutRefIdx = 0 - scriptContextScriptInfo :: ScriptInfo - scriptContextScriptInfo = SpendingScript txOutRef (Just datum) - where - datum :: Datum - datum = Datum (toBuiltinData testLoanDatum) + scriptContextScriptInfo :: ScriptInfo + scriptContextScriptInfo = SpendingScript txOutRef (Just datum) + where + datum :: Datum + datum = Datum (toBuiltinData testLoanDatum) testLoanDatum :: LoanDatum testLoanDatum = askDatum @@ -91,14 +90,15 @@ testLoanDatum = askDatum testTokName = TokenName "mytoken" askDatum :: LoanDatum - askDatum = AskDatum - { collateral = [(testCurSym, testTokName)] - , askBeacon = (testCurSym, testTokName) - , borrowerId = (testCurSym, testTokName) - , loanAsset = (testCurSym, testTokName) - , loanPrinciple = 10 - , loanTerm = 10 - } + askDatum = + AskDatum + { collateral = [(testCurSym, testTokName)] + , askBeacon = (testCurSym, testTokName) + , borrowerId = (testCurSym, testTokName) + , loanAsset = (testCurSym, testTokName) + , loanPrinciple = 10 + , loanTerm = 10 + } testBeneficiaryPKH :: PubKeyHash testBeneficiaryPKH = PubKeyHash "" diff --git a/plutus-benchmark/cardano-loans/src/CardanoLoans/Validator.hs b/plutus-benchmark/cardano-loans/src/CardanoLoans/Validator.hs index 7eb832bd049..a466315b380 100644 --- a/plutus-benchmark/cardano-loans/src/CardanoLoans/Validator.hs +++ b/plutus-benchmark/cardano-loans/src/CardanoLoans/Validator.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} @@ -23,27 +24,27 @@ {-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} {-# OPTIONS_GHC -fno-unbox-strict-fields #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-conservative-optimisation #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-remove-trace #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:preserve-logging #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant if" #-} +{-# HLINT ignore "Redundant if" #-} -module CardanoLoans.Validator -( - LoanDatum(..), - LoanRedeemer(..), - CurrencySymbol(..), - TokenName(..), - POSIXTime(..), +module CardanoLoans.Validator ( + LoanDatum (..), + LoanRedeemer (..), + CurrencySymbol (..), + TokenName (..), + POSIXTime (..), tokenAsPubKey, adaSymbol, adaToken, fromGHC, unsafeRatio, - (-),(*),(+), + (-), + (*), + (+), loanValidatorCode, ) where @@ -59,51 +60,73 @@ import PlutusTx.Prelude -- Data Types ------------------------------------------------- data LoanDatum - -- | The datum for the ask phase. - = AskDatum - { askBeacon :: (CurrencySymbol,TokenName) - , borrowerId :: (CurrencySymbol,TokenName) - , loanAsset :: (CurrencySymbol,TokenName) + = -- | The datum for the ask phase. + AskDatum + { askBeacon :: (CurrencySymbol, TokenName) + , borrowerId :: (CurrencySymbol, TokenName) + , loanAsset :: (CurrencySymbol, TokenName) , loanPrinciple :: Integer - , loanTerm :: POSIXTime - , collateral :: [(CurrencySymbol,TokenName)] + , loanTerm :: POSIXTime + , collateral :: [(CurrencySymbol, TokenName)] } - -- | The datum for the offer phase. - | OfferDatum - { offerBeacon :: (CurrencySymbol,TokenName) - , lenderId :: (CurrencySymbol,TokenName) - , loanAsset :: (CurrencySymbol,TokenName) - , loanPrinciple :: Integer - , loanTerm :: POSIXTime - , loanInterest :: Rational - , loanBacking :: Integer -- ^ How much of the loan needs to be collateralized. In units of the - -- loanAsset. - , collateralRates :: [((CurrencySymbol,TokenName),Rational)] -- ^ Rates: collateralAsset/loanAsset + | -- | The datum for the offer phase. + OfferDatum + { offerBeacon :: (CurrencySymbol, TokenName) + , lenderId :: (CurrencySymbol, TokenName) + , loanAsset :: (CurrencySymbol, TokenName) + , loanPrinciple :: Integer + , loanTerm :: POSIXTime + , loanInterest :: Rational + , loanBacking :: Integer + -- ^ How much of the loan needs to be collateralized. In units of the + -- loanAsset. + , collateralRates :: [((CurrencySymbol, TokenName), Rational)] + -- ^ Rates: collateralAsset/loanAsset } - -- | The datum for the active phase. This also has information useful for the credit history. - | ActiveDatum - { activeBeacon :: (CurrencySymbol,TokenName) - , lenderId :: (CurrencySymbol,TokenName) - , borrowerId :: (CurrencySymbol,TokenName) - , loanAsset :: (CurrencySymbol,TokenName) - , loanPrinciple :: Integer - , loanTerm :: POSIXTime - , loanInterest :: Rational - , loanBacking :: Integer - , collateralRates :: [((CurrencySymbol,TokenName),Rational)] - , loanExpiration :: POSIXTime + | -- | The datum for the active phase. This also has information useful for the credit history. + ActiveDatum + { activeBeacon :: (CurrencySymbol, TokenName) + , lenderId :: (CurrencySymbol, TokenName) + , borrowerId :: (CurrencySymbol, TokenName) + , loanAsset :: (CurrencySymbol, TokenName) + , loanPrinciple :: Integer + , loanTerm :: POSIXTime + , loanInterest :: Rational + , loanBacking :: Integer + , collateralRates :: [((CurrencySymbol, TokenName), Rational)] + , loanExpiration :: POSIXTime , loanOutstanding :: Rational } instance Eq LoanDatum where - {-# INLINABLE (==) #-} + {-# INLINEABLE (==) #-} (AskDatum a b c d e f) == (AskDatum a' b' c' d' e' f') = a == a' && b == b' && c == c' && d == d' && e == e' && f == f' (OfferDatum a b c d e f g h) == (OfferDatum a' b' c' d' e' f' g' h') = a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g' && h == h' (ActiveDatum a b c d e f g h i j k) == (ActiveDatum a' b' c' d' e' f' g' h' i' j' k') = - a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g' && h == h' && - i == i' && j == j' && k == k' + a + == a' + && b + == b' + && c + == c' + && d + == d' + && e + == e' + && f + == f' + && g + == g' + && h + == h' + && i + == i' + && j + == j' + && k + == k' _ == _ = False data LoanRedeemer @@ -122,65 +145,66 @@ PlutusTx.unstableMakeIsData ''LoanRedeemer ------------------------------------------------- -- Helper Functions ------------------------------------------------- + -- | Used to create a testing set of beacons/IDs without having to change the logic. app :: AppName app = "testing" -{-# INLINABLE tokenAsPubKey #-} +{-# INLINEABLE tokenAsPubKey #-} tokenAsPubKey :: TokenName -> PubKeyHash tokenAsPubKey (TokenName pkh) = PubKeyHash pkh -{-# INLINABLE encodeDatum #-} +{-# INLINEABLE encodeDatum #-} + -- | This is a convenient way to check what kind of datum it is. encodeDatum :: LoanDatum -> Integer -encodeDatum AskDatum{} = 0 -encodeDatum OfferDatum{} = 1 -encodeDatum ActiveDatum{} = 2 +encodeDatum AskDatum {} = 0 +encodeDatum OfferDatum {} = 1 +encodeDatum ActiveDatum {} = 2 -{-# INLINABLE signed #-} +{-# INLINEABLE signed #-} signed :: [PubKeyHash] -> PubKeyHash -> Bool signed [] _ = False -signed (k:ks) k' +signed (k : ks) k' | k == k' = True | otherwise = signed ks k' -{-# INLINABLE ownInput #-} +{-# INLINEABLE ownInput #-} ownInput :: ScriptContext -> TxOut ownInput (ScriptContext info _ (SpendingScript ref _)) = getScriptInput (txInfoInputs info) ref -ownInput _ = traceError "script input error ownInput" +ownInput _ = traceError "script input error ownInput" -{-# INLINABLE getScriptInput #-} +{-# INLINEABLE getScriptInput #-} getScriptInput :: [TxInInfo] -> TxOutRef -> TxOut getScriptInput [] _ = traceError "script input error getScriptInput" getScriptInput ((TxInInfo iRef ot) : tl) ref | iRef == ref = ot | otherwise = getScriptInput tl ref -{-# INLINABLE parseLoanDatum #-} +{-# INLINEABLE parseLoanDatum #-} parseLoanDatum :: OutputDatum -> LoanDatum parseLoanDatum d = case d of (OutputDatum (Datum d')) -> unsafeFromBuiltinData d' - _ -> traceError "All loan datums must be inline datums." + _ -> traceError "All loan datums must be inline datums." -- | This is only used by the validator to prevent permanent locking when a staking script -- is accidentally used. The beacons require that the address uses a staking pubkey. -{-# INLINABLE stakingCredApproves #-} +{-# INLINEABLE stakingCredApproves #-} stakingCredApproves :: Address -> TxInfo -> Bool stakingCredApproves addr info = case addressStakingCredential addr of - -- | This is to prevent permanent locking of funds. + -- \| This is to prevent permanent locking of funds. -- The DEX is not meant to be used without a staking credential. Nothing -> True - - -- | Check if staking credential signals approval. + -- \| Check if staking credential signals approval. Just (StakingHash cred) -> case cred of PubKeyCredential pkh -> signed (txInfoSignatories info) pkh - ScriptCredential _ -> isJust $ Map.lookup cred $ txInfoWdrl info - + ScriptCredential _ -> isJust $ Map.lookup cred $ txInfoWdrl info Just _ -> traceError "Wrong kind of staking credential." ------------------------------------------------- -- On-Chain Loan Validator ------------------------------------------------- + -- | The purpose of this validator is to guarantee that loan negotiations and repayment go -- smoothly without needing to trust the other party. -- @@ -214,115 +238,127 @@ stakingCredApproves addr info = case addressStakingCredential addr of -- The interest for these loans is non-compounding. mkLoan :: LoanDatum -> LoanRedeemer -> ScriptContext -> Bool mkLoan loanDatum r ctx = - case r of - CloseAsk -> - -- | The datum must be an AskDatum. This must be checked first since not all fields are the - -- same across the datum types. - traceIfFalse "Datum is not an AskDatum" (encodeDatum loanDatum == 0) && - -- | The address' staking credential must signal approval. This is required regardless + case r of + CloseAsk -> + -- \| The datum must be an AskDatum. This must be checked first since not all fields are the + -- same across the datum types. + traceIfFalse "Datum is not an AskDatum" (encodeDatum loanDatum == 0) + && + -- \| The address' staking credential must signal approval. This is required regardless -- of whether or not the ask is valid. This is due to the address owner having custody -- of invalid utxos. - traceIfFalse "Staking credential did not approve" stakingCredApproves' && - -- | All ask beacons among tx inputs must be burned. This is not meant to be composable + traceIfFalse "Staking credential did not approve" stakingCredApproves' + && + -- \| All ask beacons among tx inputs must be burned. This is not meant to be composable -- with the other redeemers. - traceIfFalse "Ask beacons not burned." - (uncurry (valueOf allVal) (askBeacon loanDatum) == - negate (uncurry (valueOf minted) (askBeacon loanDatum))) - - CloseOffer -> - -- | The datum must be an OfferDatum. This must be checked first since not all fields are the - -- same across the datum types. - traceIfFalse "Datum is not an OfferDatum" (encodeDatum loanDatum == 1) && - -- | If the offer beacon is present, that means it is a valid offer and the lender has + traceIfFalse + "Ask beacons not burned." + ( uncurry (valueOf allVal) (askBeacon loanDatum) + == negate (uncurry (valueOf minted) (askBeacon loanDatum)) + ) + CloseOffer -> + -- \| The datum must be an OfferDatum. This must be checked first since not all fields are the + -- same across the datum types. + traceIfFalse "Datum is not an OfferDatum" (encodeDatum loanDatum == 1) + && + -- \| If the offer beacon is present, that means it is a valid offer and the lender has -- custody of the utxo. This also means the lender ID is present in the utxo. if uncurry (valueOf inputValue) (offerBeacon loanDatum) == 1 - then - -- | The lender in the lender ID must sign the tx. The ID has the lender's pubkey hash - -- as the token name. - traceIfFalse "Lender did not sign" - (signed (txInfoSignatories info) (tokenAsPubKey $ snd $ lenderId loanDatum)) && - -- | All offer beacons in tx inputs must be burned. This is not meant to be composable - -- with the other redeemers. - traceIfFalse "Offer beacons not burned" - (uncurry (valueOf allVal) (offerBeacon loanDatum) == - negate (uncurry (valueOf minted) (offerBeacon loanDatum))) && - -- | All the lender IDs for this lender in tx inputs must be burned. This is not meant - -- to be composable with the other redeemers. - traceIfFalse "Lender IDs not burned" - (uncurry (valueOf allVal) (lenderId loanDatum) == - negate (uncurry (valueOf minted) (lenderId loanDatum))) - -- | Otherwise the offer is an invalid utxo and the address owner has custody. This also - -- means no lender IDs are present. - else - -- | The staking credential must signal approval. - traceIfFalse "Staking credential did not approve" stakingCredApproves' - _ -> - True + then + -- \| The lender in the lender ID must sign the tx. The ID has the lender's pubkey hash + -- as the token name. + traceIfFalse + "Lender did not sign" + (signed (txInfoSignatories info) (tokenAsPubKey $ snd $ lenderId loanDatum)) + && + -- \| All offer beacons in tx inputs must be burned. This is not meant to be composable + -- with the other redeemers. + traceIfFalse + "Offer beacons not burned" + ( uncurry (valueOf allVal) (offerBeacon loanDatum) + == negate (uncurry (valueOf minted) (offerBeacon loanDatum)) + ) + && + -- \| All the lender IDs for this lender in tx inputs must be burned. This is not meant + -- to be composable with the other redeemers. + traceIfFalse + "Lender IDs not burned" + ( uncurry (valueOf allVal) (lenderId loanDatum) + == negate (uncurry (valueOf minted) (lenderId loanDatum)) + ) + -- \| Otherwise the offer is an invalid utxo and the address owner has custody. This also + -- means no lender IDs are present. + else + -- \| The staking credential must signal approval. + traceIfFalse "Staking credential did not approve" stakingCredApproves' + _ -> + True where - ScriptContext{scriptContextTxInfo=info} = ctx + ScriptContext {scriptContextTxInfo = info} = ctx - -- | Get the credential for this input as well as its value. + -- \| Get the credential for this input as well as its value. -- Credential is used to check asset flux for address and ensure staking credential approves -- when necessary. The value is used to quickly check for beacon tokens. - (inputCredentials,inputValue) = - let TxOut{txOutAddress=addr,txOutValue=iVal} = ownInput ctx - in (addr,iVal) + (inputCredentials, inputValue) = + let TxOut {txOutAddress = addr, txOutValue = iVal} = ownInput ctx + in (addr, iVal) - -- | This tends to build up a thunk so its evaluation is forced even though it is not always + -- \| This tends to build up a thunk so its evaluation is forced even though it is not always -- needed. stakingCredApproves' :: Bool !stakingCredApproves' = stakingCredApproves inputCredentials info - -- | The total input value for this tx. + -- \| The total input value for this tx. allVal :: Value !allVal = valueSpent info minted :: Value !minted = mintValueMinted (txInfoMint info) - -- | Returns a list of inputs from this address. + -- \| Returns a list of inputs from this address. allAddrInputs :: [TxOut] allAddrInputs = let inputs = txInfoInputs info foo _ acc [] = acc - foo iCred !acc (TxInInfo{txInInfoResolved=x@TxOut{txOutAddress=addr}}:xs) = + foo iCred !acc (TxInInfo {txInInfoResolved = x@TxOut {txOutAddress = addr}} : xs) = if addr == iCred - then foo iCred (x : acc) xs - else foo iCred acc xs - in foo inputCredentials [] inputs + then foo iCred (x : acc) xs + else foo iCred acc xs + in foo inputCredentials [] inputs - -- | Get the loan repayment time from the tx's validity range. + -- \| Get the loan repayment time from the tx's validity range. -- It uses to upper bound of the tx's validity range so that a borrower can't -- set an earlier time than has already passed to trick the script. repaymentTime :: POSIXTime repaymentTime = case (\(UpperBound t _) -> t) $ ivTo $ txInfoValidRange info of - PosInf -> traceError "invalid-hereafter not specified" + PosInf -> traceError "invalid-hereafter not specified" Finite t -> t - _ -> traceError "Shouldn't be NegInf." + _ -> traceError "Shouldn't be NegInf." - -- | Check if the expiration has passed. + -- \| Check if the expiration has passed. loanIsExpired :: POSIXTime -> Bool loanIsExpired endTime = repaymentTime > endTime - -- | Gets the output to this address. + -- \| Gets the output to this address. -- Throws an error if there is more than one since all redeemers require no more than -- one output to this address. - TxOut{txOutValue=oVal,txOutDatum = od} = + TxOut {txOutValue = oVal, txOutDatum = od} = let outputs = txInfoOutputs info foo _ acc [] = acc - foo iCred !acc (x'@TxOut{txOutAddress = addr}:xs') = do + foo iCred !acc (x'@TxOut {txOutAddress = addr} : xs') = do let x = x' let xs = xs' if addr == iCred - then if List.null acc - then foo iCred (x : acc) xs - else traceError "There can only be one output to address" - else foo iCred acc xs - in case foo inputCredentials [] outputs of - [x] -> x - _ -> traceError "Missing output to address" - - -- | The value flux of this address. + then + if List.null acc + then foo iCred (x : acc) xs + else traceError "There can only be one output to address" + else foo iCred acc xs + in case foo inputCredentials [] outputs of + [x] -> x + _ -> traceError "Missing output to address" + + -- \| The value flux of this address. -- Positive values mean the address gained the asset. -- Negative values mean the address lost the asset. addrDiff :: Value @@ -331,7 +367,6 @@ mkLoan loanDatum r ctx = repaidAmount :: Rational repaidAmount = fromInteger $ uncurry (valueOf addrDiff) $ loanAsset loanDatum - loanValidatorCode :: CompiledCode (BuiltinData -> BuiltinUnit) loanValidatorCode = $$(compile [||untypedValidator||]) where @@ -343,16 +378,16 @@ loanValidatorCode = $$(compile [||untypedValidator||]) let SpendingScript _ (Just (Datum datum)) = scriptContextScriptInfo context case fromBuiltinData datum of Nothing -> traceError "Failed to parse Datum" - Just r -> trace "Parsed Datum" r + Just r -> trace "Parsed Datum" r loanRedeemer :: LoanRedeemer loanRedeemer = case fromBuiltinData (getRedeemer (scriptContextRedeemer context)) of Nothing -> traceError "Failed to parse Redeemer" - Just r -> trace "Parsed Redeemer" r + Just r -> trace "Parsed Redeemer" r untypedValidator :: BuiltinData -> BuiltinUnit untypedValidator scriptContextData = case trace "Parsing ScriptContext..." (fromBuiltinData scriptContextData) of - Nothing -> traceError "Failed to parse ScriptContext" + Nothing -> traceError "Failed to parse ScriptContext" Just ctx -> check $ typedValidator $ trace "Parsed ScriptContext" ctx diff --git a/plutus-benchmark/cardano-loans/test/Main.hs b/plutus-benchmark/cardano-loans/test/Main.hs index 4bfb0ed4f95..52dfdea7988 100644 --- a/plutus-benchmark/cardano-loans/test/Main.hs +++ b/plutus-benchmark/cardano-loans/test/Main.hs @@ -7,15 +7,13 @@ import PlutusTx.Test (goldenBundle') import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc) - main :: IO () main = defaultMain $ do - testGroup "cardano-loans" - [ - runTestGhc [goldenBundle' "main" validatorCodeFullyApplied] + testGroup + "cardano-loans" + [ runTestGhc [goldenBundle' "main" validatorCodeFullyApplied] ] - runTestGhc :: [TestNested] -> TestTree runTestGhc = runTestNested ["cardano-loans", "test"] . pure . testNestedGhc diff --git a/plutus-benchmark/casing/bench/Bench.hs b/plutus-benchmark/casing/bench/Bench.hs index c13c3693298..e259b1184ef 100644 --- a/plutus-benchmark/casing/bench/Bench.hs +++ b/plutus-benchmark/casing/bench/Bench.hs @@ -1,9 +1,7 @@ {-# LANGUAGE BangPatterns #-} -{- | This benchmark cases measures efficiency of builtin case operations. Each branches exclusively - contain casing operations only. --} - +-- | This benchmark cases measures efficiency of builtin case operations. Each branches exclusively +-- contain casing operations only. module Main (main) where import Criterion.Main @@ -18,7 +16,8 @@ import Data.Functor benchmarks :: EvaluationContext -> [Benchmark] benchmarks ctx = - [ bgroup "casing" + [ bgroup + "casing" [ mkBMs "pairFstSnd" Casing.pairFstSnd , mkBMs "pairCasing" Casing.pairCasing , mkBMs "chooseUnit" Casing.chooseUnit @@ -33,10 +32,11 @@ benchmarks ctx = , mkBMsSmall "regularApply" Casing.regularApply , mkBMsSmall "caseApply" Casing.caseApply ] - ] - where - mkBMs name f = - bgroup name $ [2000, 4000..12000] <&> \n -> + ] + where + mkBMs name f = + bgroup name $ + [2000, 4000 .. 12000] <&> \n -> bench (show n) $ benchTermCek ctx (f n) mkBMsSmall name f = bgroup name $ [3, 10, 30, 100, 500, 1000] <&> \n -> diff --git a/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs b/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs index 59d50837ac2..82f31b6c362 100644 --- a/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs +++ b/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module PlutusBenchmark.Casing where @@ -13,39 +13,44 @@ import PlutusCore.Builtin qualified as PLC import PlutusCore.MkPlc import UntypedPlutusCore qualified as UPLC -debruijnTermUnsafe :: UPLC.Term UPLC.Name uni fun ann - -> UPLC.Term UPLC.NamedDeBruijn uni fun ann +debruijnTermUnsafe :: + UPLC.Term UPLC.Name uni fun ann -> + UPLC.Term UPLC.NamedDeBruijn uni fun ann debruijnTermUnsafe = - fromRight (Prelude.error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm + fromRight (Prelude.error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm nonMatchingBranch :: TermLike term tyname name UPLC.DefaultUni UPLC.DefaultFun => term () nonMatchingBranch = mkConstant @Integer () (-1) -- Note that we don't need to generate casings for the none maching branches because -- only matching branches get executed. + -- | Generate a term that does a lot of casing on boolean casingBool :: Integer -> Term casingBool 0 = mkConstant @Integer () 42 casingBool i | i `mod` 2 == 0 = - kase () - (TyBuiltin () (SomeTypeIn DefaultUniInteger)) - (mkConstant @Bool () False) - [casingBool (i-1), nonMatchingBranch] + kase + () + (TyBuiltin () (SomeTypeIn DefaultUniInteger)) + (mkConstant @Bool () False) + [casingBool (i - 1), nonMatchingBranch] | otherwise = - kase () - (TyBuiltin () (SomeTypeIn DefaultUniInteger)) - (mkConstant @Bool () True) - [nonMatchingBranch, casingBool (i-1)] + kase + () + (TyBuiltin () (SomeTypeIn DefaultUniInteger)) + (mkConstant @Bool () True) + [nonMatchingBranch, casingBool (i - 1)] -- | Generate a term that does a lot of boolean casing with single branch. casingBoolOneBranch :: Integer -> Term casingBoolOneBranch 0 = mkConstant @Integer () 42 casingBoolOneBranch i = - kase () + kase + () (TyBuiltin () (SomeTypeIn DefaultUniInteger)) (mkConstant @Bool () False) - [casingBoolOneBranch (i-1)] + [casingBoolOneBranch (i - 1)] -- | Generate a term that does a lot of integer casing. casingInteger :: Integer -> Term @@ -55,25 +60,27 @@ casingInteger i = numBranches = 5 -- 5 is arbitrary, this indicates the number of branches to have on each casing currentI = i `mod` numBranches - in kase () - (TyBuiltin () (SomeTypeIn DefaultUniInteger)) - (mkConstant @Integer () currentI) - (replicate (fromIntegral currentI) nonMatchingBranch - <> [casingInteger (i-1)] - <> replicate (fromIntegral $ numBranches - 1 - currentI) nonMatchingBranch - ) + in + kase + () + (TyBuiltin () (SomeTypeIn DefaultUniInteger)) + (mkConstant @Integer () currentI) + ( replicate (fromIntegral currentI) nonMatchingBranch + <> [casingInteger (i - 1)] + <> replicate (fromIntegral $ numBranches - 1 - currentI) nonMatchingBranch + ) -- | UPLC 'cons' parameterized in Haskell. -listConsHandler - :: TermLike term tyname UPLC.Name UPLC.DefaultUni UPLC.DefaultFun - => (term () -> term () -> term ()) -> term () +listConsHandler :: + TermLike term tyname UPLC.Name UPLC.DefaultUni UPLC.DefaultFun => + (term () -> term () -> term ()) -> term () listConsHandler f = runQuote $ do x <- freshName "x" xs <- freshName "xs" pure $ lamAbs () x (TyBuiltin () (SomeTypeIn DefaultUniInteger)) $ lamAbs () xs (TyBuiltin () (SomeTypeIn $ DefaultUniApply DefaultUniProtoList DefaultUniInteger)) $ - f (var () x) (var () xs) + f (var () x) (var () xs) -- | Generate a term that does a lot of casing on list. casingList :: Integer -> Term @@ -82,10 +89,11 @@ casingList i = debruijnTermUnsafe $ go i arg arg = mkConstant @[Integer] () $ replicate (fromIntegral i) 42 go 0 t = t go n t = - kase () + kase + () (TyBuiltin () (SomeTypeIn $ DefaultUniApply DefaultUniProtoList DefaultUniInteger)) t - [listConsHandler (\_x xs -> go (n-1) xs), nonMatchingBranch] + [listConsHandler (\_x xs -> go (n - 1) xs), nonMatchingBranch] -- | Generate a term that does a lot of casing on list with one branch. casingListOneBranch :: Integer -> Term @@ -97,17 +105,18 @@ casingListOneBranch i = debruijnTermUnsafe $ go i arg go 0 t = t go n t = - kase () + kase + () (TyBuiltin () (SomeTypeIn $ DefaultUniApply DefaultUniProtoList DefaultUniInteger)) t - [listConsHandler (\_x xs -> go (n-1) xs)] + [listConsHandler (\_x xs -> go (n - 1) xs)] -- | Generate a term that does a lot of casing on pairs using 'FstPair' and 'SndPair'. It -- will case first and then second term on each iteration. pairFstSnd :: Integer -> Term pairFstSnd i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () pairVal = mkConstant @(Integer, Integer) () (42, 42) @@ -115,20 +124,24 @@ pairFstSnd i = x <- freshName "x" y <- freshName "y" pure $ - apply () - (apply () - (lamAbs () x intTy $ - lamAbs () y intTy $ - t) - (apply () (tyInst () (tyInst () (builtin () PLC.FstPair) intTy) intTy) pairVal)) - (apply () (tyInst () (tyInst () (builtin () PLC.SndPair) intTy) intTy) pairVal) + apply + () + ( apply + () + ( lamAbs () x intTy $ + lamAbs () y intTy $ + t + ) + (apply () (tyInst () (tyInst () (builtin () PLC.FstPair) intTy) intTy) pairVal) + ) + (apply () (tyInst () (tyInst () (builtin () PLC.SndPair) intTy) intTy) pairVal) -- | Generate a term that does a lot of casing on pairs. It will case first and then -- second term on each iteration. pairCasing :: Integer -> Term pairCasing i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () pairVal = mkConstant @(Integer, Integer) () (42, 42) @@ -140,32 +153,37 @@ pairCasing i = sndL <- freshName "sndL" sndR <- freshName "sndR" pure $ - apply () - (apply () - (lamAbs () x intTy $ - lamAbs () y intTy $ - t) - (kase () intTy pairVal [lamAbs () sndL intTy $ lamAbs () sndR intTy $ var () sndL])) - (kase () intTy pairVal [lamAbs () fstL intTy $ lamAbs () fstR intTy $ var () fstR]) + apply + () + ( apply + () + ( lamAbs () x intTy $ + lamAbs () y intTy $ + t + ) + (kase () intTy pairVal [lamAbs () sndL intTy $ lamAbs () sndR intTy $ var () sndL]) + ) + (kase () intTy pairVal [lamAbs () fstL intTy $ lamAbs () fstR intTy $ var () fstR]) -- | Generate a term that does a lot of casing on unit using 'ChooseUnit'. chooseUnit :: Integer -> Term chooseUnit i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () unitVal = mkConstant () () comp t = - apply () + apply + () (apply () (tyInst () (builtin () PLC.ChooseUnit) intTy) unitVal) - t + t -- | Generate a term that does a lot of casing on unit. unitCasing :: Integer -> Term unitCasing i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () unitVal = mkConstant () () @@ -176,22 +194,23 @@ unitCasing i = headList :: Integer -> Term headList i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () listVal = mkConstant @[Integer] () [1, 2, 3] comp t = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x intTy t) - (apply () (tyInst () (builtin () PLC.HeadList) intTy) listVal) + (apply () (tyInst () (builtin () PLC.HeadList) intTy) listVal) -- | Generate a term that does a lot of casing on head of list. headListCasing :: Integer -> Term headListCasing i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () intListTy = PLC.mkTyBuiltin @_ @[Integer] () @@ -201,8 +220,10 @@ headListCasing i = y <- freshName "y" ys <- freshName "ys" pure $ - apply () + apply + () (lamAbs () x intTy t) +<<<<<<< HEAD (kase () intTy listVal [lamAbs () y intTy $ lamAbs () ys intListTy $ var () y]) regularApply :: Integer -> Term @@ -224,3 +245,6 @@ caseApply i = unitVal = mkConstant @() () () lam = runQuote $ do foldr (\x -> lamAbs () x unitTy) unitVal <$> replicateM (fromIntegral i) (freshName "x") +======= + (kase () intTy listVal [lamAbs () y intTy $ lamAbs () ys intListTy $ var () y]) +>>>>>>> 6fbfe64588 (Apply fourmolu to the codebase) diff --git a/plutus-benchmark/cek-calibration/Main.hs b/plutus-benchmark/cek-calibration/Main.hs index 74f210cc0d8..10e2f0cb03e 100644 --- a/plutus-benchmark/cek-calibration/Main.hs +++ b/plutus-benchmark/cek-calibration/Main.hs @@ -1,19 +1,18 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} -{- | Benchmarks for some simple functions operating on lists. These are used to -get an idea of the average cost of the basic CEK operations. --} -- TODO: these are currently run manually, but the process should be automated. -- See plutus-core/cost-model/CostModelGeneration.hs -module Main (main) where +-- | Benchmarks for some simple functions operating on lists. These are used to +-- get an idea of the average cost of the basic CEK operations. +module Main (main) where import Prelude qualified as Haskell @@ -36,38 +35,40 @@ type PlainTerm = UPLC.Term Name DefaultUni DefaultFun () rev :: [()] -> [()] rev l0 = rev' l0 [] - where rev' l acc = - case l of - [] -> acc - x:xs -> rev' xs (x:acc) -{-# INLINABLE rev #-} + where + rev' l acc = + case l of + [] -> acc + x : xs -> rev' xs (x : acc) +{-# INLINEABLE rev #-} mkList :: Integer -> [()] mkList m = mkList' m [] - where mkList' n acc = - if n == 0 then acc - else mkList' (n-1) (():acc) -{-# INLINABLE mkList #-} + where + mkList' n acc = + if n == 0 + then acc + else mkList' (n - 1) (() : acc) +{-# INLINEABLE mkList #-} zipl :: [()] -> [()] -> [()] -zipl [] [] = [] -zipl l [] = l -zipl [] l = l -zipl (x:xs) (y:ys) = x:y:(zipl xs ys) -{-# INLINABLE zipl #-} +zipl [] [] = [] +zipl l [] = l +zipl [] l = l +zipl (x : xs) (y : ys) = x : y : (zipl xs ys) +{-# INLINEABLE zipl #-} go :: Integer -> [()] go n = zipl (mkList n) (rev $ mkList n) -{-# INLINABLE go #-} - +{-# INLINEABLE go #-} mkListProg :: Integer -> UPLC.Program NamedDeBruijn DefaultUni DefaultFun () -mkListProg n = Tx.getPlcNoAnn $ $$(Tx.compile [|| go ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef n +mkListProg n = Tx.getPlcNoAnn $ $$(Tx.compile [||go||]) `Tx.unsafeApplyCode` Tx.liftCodeDef n mkListTerm :: Integer -> UPLC.Term NamedDeBruijn DefaultUni DefaultFun () mkListTerm n = let (UPLC.Program _ _ code) = mkListProg n - in code + in code mkListBM :: EvaluationContext -> Integer -> Benchmark mkListBM ctx n = bench (Haskell.show n) $ benchTermCek ctx (mkListTerm n) @@ -77,20 +78,18 @@ mkListBMs ctx ns = bgroup "List" [mkListBM ctx n | n <- ns] writePlc :: UPLC.Program NamedDeBruijn DefaultUni DefaultFun () -> Haskell.IO () writePlc p = - case runExcept @UPLC.FreeVariableError $ - runQuoteT $ - traverseOf UPLC.progTerm UPLC.unDeBruijnTerm p - of - Left e -> throw e - Right p' -> Haskell.print . PP.prettyPlcClassicSimple $ p' - + case runExcept @UPLC.FreeVariableError + $ runQuoteT + $ traverseOf UPLC.progTerm UPLC.unDeBruijnTerm p of + Left e -> throw e + Right p' -> Haskell.print . PP.prettyPlcClassicSimple $ p' main1 :: Haskell.IO () main1 = do evalCtx <- evaluate mkMostRecentEvalCtx defaultMainWith - (defaultConfig { C.csvFile = Just "cek-lists.csv" }) - [mkListBMs evalCtx [0,10..1000]] + (defaultConfig {C.csvFile = Just "cek-lists.csv"}) + [mkListBMs evalCtx [0, 10 .. 1000]] main2 :: Haskell.IO () main2 = writePlc (mkListProg 999) diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 67338f63a04..7c0a5b64192 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -1,31 +1,32 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} + +-- | Miscellaneous shared code for benchmarking-related things. +module PlutusBenchmark.Common ( + module Export, + Program, + Term, + getConfig, + toAnonDeBruijnTerm, + toNamedDeBruijnTerm, + compiledCodeToTerm, + benchProgramCek, + cekResultMatchesHaskellValue, + mkEvalCtx, + mkMostRecentEvalCtx, + evaluateCekLikeInProd, + benchTermCek, + TestSize (..), + printHeader, + printSizeStatistics, + goldenVsTextualOutput, + checkGoldenFileExists, +) +where -{- | Miscellaneous shared code for benchmarking-related things. -} -module PlutusBenchmark.Common - ( module Export - , Program - , Term - , getConfig - , toAnonDeBruijnTerm - , toNamedDeBruijnTerm - , compiledCodeToTerm - , benchProgramCek - , cekResultMatchesHaskellValue - , mkEvalCtx - , mkMostRecentEvalCtx - , evaluateCekLikeInProd - , benchTermCek - , TestSize (..) - , printHeader - , printSizeStatistics - , goldenVsTextualOutput - , checkGoldenFileExists - ) -- ### CAUTION! ###. Changing the number and/or order of the exports here may -- change the execution times of the validation benchmarks. See -- https://github.com/IntersectMBO/plutus/issues/5906. -where import Paths_plutus_benchmark as Export import PlutusBenchmark.ProtocolParameters as PP @@ -39,8 +40,15 @@ import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) -import PlutusTx.Test.Util.Compiled (Program, Term, cekResultMatchesHaskellValue, compiledCodeToTerm, - toAnonDeBruijnProg, toAnonDeBruijnTerm, toNamedDeBruijnTerm) +import PlutusTx.Test.Util.Compiled ( + Program, + Term, + cekResultMatchesHaskellValue, + compiledCodeToTerm, + toAnonDeBruijnProg, + toAnonDeBruijnTerm, + toNamedDeBruijnTerm, + ) import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek as Cek import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC @@ -60,52 +68,53 @@ import Test.Tasty import Test.Tasty.Golden import Text.Printf (hPrintf, printf) -{- | The Criterion configuration returned by `getConfig` will cause an HTML report - to be generated. If run via stack/cabal this will be written to the - `plutus-benchmark` directory by default. The -o option can be used to change - this, but an absolute path will probably be required (eg, "-o=$PWD/report.html") . -} +-- | The Criterion configuration returned by `getConfig` will cause an HTML report +-- to be generated. If run via stack/cabal this will be written to the +-- `plutus-benchmark` directory by default. The -o option can be used to change +-- this, but an absolute path will probably be required (eg, "-o=$PWD/report.html") . getConfig :: Double -> IO Config getConfig limit = do templateDir <- getDataFileName ("common" "templates") -- Include number of iterations in HTML report let templateFile = templateDir "with-iterations" <.> "tpl" - pure $ defaultConfig { - template = templateFile, - reportFile = Just "report.html", - timeLimit = limit - } + pure $ + defaultConfig + { template = templateFile + , reportFile = Just "report.html" + , timeLimit = limit + } -- | Evaluate a script and return the CPU and memory costs (according to the cost model) getCostsCek :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () -> (Integer, Integer) getCostsCek (UPLC.Program _ _ prog) = - case Cek.runCekDeBruijn PLC.defaultCekParametersForTesting Cek.tallying Cek.noEmitter prog of - Cek.CekReport _res (Cek.TallyingSt _ budget) _logs -> - let ExBudget (ExCPU cpu)(ExMemory mem) = budget - in (fromSatInt cpu, fromSatInt mem) + case Cek.runCekDeBruijn PLC.defaultCekParametersForTesting Cek.tallying Cek.noEmitter prog of + Cek.CekReport _res (Cek.TallyingSt _ budget) _logs -> + let ExBudget (ExCPU cpu) (ExMemory mem) = budget + in (fromSatInt cpu, fromSatInt mem) -- | Create the evaluation context for the benchmarks. This doesn't exactly -- match how it's done on-chain, but that's okay because the evaluation context -- is cached by the ledger, so we're deliberately not including it in the -- benchmarks. Different benchmarks may depend on different language versions -- and semantic variants, so we have to specify those here. -mkEvalCtx - :: LedgerApi.PlutusLedgerLanguage - -> BuiltinSemanticsVariant DefaultFun - -> LedgerApi.EvaluationContext +mkEvalCtx :: + LedgerApi.PlutusLedgerLanguage -> + BuiltinSemanticsVariant DefaultFun -> + LedgerApi.EvaluationContext mkEvalCtx ll semvar = - case PLC.defaultCostModelParamsForVariant semvar of - Just p -> - let errOrCtx = - LedgerApi.mkDynEvaluationContext - ll - (\_ -> PLC.CaserBuiltin PLC.caseBuiltin) - [semvar] - (const semvar) - p - in case errOrCtx of - Right ec -> ec - Left err -> error $ show err - Nothing -> error $ "Couldn't get cost model params for " ++ (show semvar) + case PLC.defaultCostModelParamsForVariant semvar of + Just p -> + let errOrCtx = + LedgerApi.mkDynEvaluationContext + ll + (\_ -> PLC.CaserBuiltin PLC.caseBuiltin) + [semvar] + (const semvar) + p + in case errOrCtx of + Right ec -> ec + Left err -> error $ show err + Nothing -> error $ "Couldn't get cost model params for " ++ (show semvar) -- Many of our benchmarks should use an evaluation context for the most recent -- Plutus language version and the ost recent semantic variant. @@ -113,30 +122,32 @@ mkMostRecentEvalCtx :: LedgerApi.EvaluationContext mkMostRecentEvalCtx = mkEvalCtx maxBound maxBound -- | Evaluate a term as it would be evaluated using the on-chain evaluator. -evaluateCekLikeInProd - :: LedgerApi.EvaluationContext - -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () - -> Either - (UPLC.CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) - (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) +evaluateCekLikeInProd :: + LedgerApi.EvaluationContext -> + UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () -> + Either + (UPLC.CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) evaluateCekLikeInProd evalCtx term = - let -- The validation benchmarks were all created from PlutusV1 scripts - pv = LedgerApi.ledgerLanguageIntroducedIn LedgerApi.PlutusV1 - in Cek.cekResultToEither . Cek._cekReportResult $ - LedgerApi.evaluateTerm UPLC.restrictingEnormous pv LedgerApi.Quiet evalCtx term + let + -- The validation benchmarks were all created from PlutusV1 scripts + pv = LedgerApi.ledgerLanguageIntroducedIn LedgerApi.PlutusV1 + in + Cek.cekResultToEither . Cek._cekReportResult $ + LedgerApi.evaluateTerm UPLC.restrictingEnormous pv LedgerApi.Quiet evalCtx term -- | Evaluate a term and either throw if evaluation fails or discard the result and return '()'. -- Useful for benchmarking. -evaluateCekForBench - :: LedgerApi.EvaluationContext - -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () - -> () +evaluateCekForBench :: + LedgerApi.EvaluationContext -> + UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () -> + () evaluateCekForBench evalCtx = either (error . show) (\_ -> ()) . evaluateCekLikeInProd evalCtx benchTermCek :: LedgerApi.EvaluationContext -> Term -> Benchmarkable benchTermCek evalCtx term = - let !term' = force term - in whnf (evaluateCekForBench evalCtx) term' + let !term' = force term + in whnf (evaluateCekForBench evalCtx) term' benchProgramCek :: LedgerApi.EvaluationContext -> Program -> Benchmarkable benchProgramCek evalCtx (UPLC.Program _ _ term) = @@ -144,22 +155,22 @@ benchProgramCek evalCtx (UPLC.Program _ _ term) = ---------------- Printing tables of information about costs ---------------- -data TestSize = - NoSize +data TestSize + = NoSize | TestSize Integer stringOfTestSize :: TestSize -> String stringOfTestSize = - \case - NoSize -> "-" - TestSize n -> show n + \case + NoSize -> "-" + TestSize n -> show n -- Printing utilities percentage :: (Integral a, Integral b) => a -> b -> Double percentage a b = - let a' = fromIntegral a :: Double - b' = fromIntegral b :: Double - in (a'* 100) / b' + let a' = fromIntegral a :: Double + b' = fromIntegral b :: Double + in (a' * 100) / b' percentTxt :: (Integral a, Integral b) => a -> b -> String percentTxt a b = printf "(%.1f%%)" (percentage a b) @@ -173,45 +184,49 @@ printHeader h = do -- | Evaluate a script and print out the serialised size and the CPU and memory -- usage, both as absolute values and percentages of the maxima specified in the -- protocol parameters. -printSizeStatistics - :: Handle - -> TestSize - -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> IO () +printSizeStatistics :: + Handle -> + TestSize -> + UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () -> + IO () printSizeStatistics h n script = do - let serialised = Flat.flat (UPLC.UnrestrictedProgram $ toAnonDeBruijnProg script) - size = BS.length serialised - (cpu, mem) = getCostsCek script - hPrintf h " %3s %7d %8s %15d %8s %15d %8s \n" - (stringOfTestSize n) - size (percentTxt size PP.max_tx_size) - cpu (percentTxt cpu PP.max_tx_ex_steps) - mem (percentTxt mem PP.max_tx_ex_mem) - + let serialised = Flat.flat (UPLC.UnrestrictedProgram $ toAnonDeBruijnProg script) + size = BS.length serialised + (cpu, mem) = getCostsCek script + hPrintf + h + " %3s %7d %8s %15d %8s %15d %8s \n" + (stringOfTestSize n) + size + (percentTxt size PP.max_tx_size) + cpu + (percentTxt cpu PP.max_tx_ex_steps) + mem + (percentTxt mem PP.max_tx_ex_mem) ---------------- Golden tests for tabular output ---------------- -{- | Run a program which produces textual output and compare the results with a - golden file. This is intended for tests which produce a lot of formatted - text. The output is written to a file in the system temporary directory and - deleted if the test passes. If the test fails then the output is retained - for further inspection. -} -goldenVsTextualOutput - :: TestName -- The name of the test. - -> FilePath -- The path to the golden file. - -> FilePath -- The name of the results file (may be extended to make it unique). - -> (Handle -> IO a) -- A function which runs tests and writes output to the given handle. - -> IO () -goldenVsTextualOutput testName goldenFile filename runTest = do +-- | Run a program which produces textual output and compare the results with a +-- golden file. This is intended for tests which produce a lot of formatted +-- text. The output is written to a file in the system temporary directory and +-- deleted if the test passes. If the test fails then the output is retained +-- for further inspection. +goldenVsTextualOutput :: + TestName -> -- The name of the test. + FilePath -> -- The path to the golden file. + FilePath -> -- The name of the results file (may be extended to make it unique). + (Handle -> IO a) -> -- A function which runs tests and writes output to the given handle. + IO () +goldenVsTextualOutput testName goldenFile filename runTest = do setLocaleEncoding utf8 tmpdir <- getCanonicalTemporaryDirectory (resultsFile, handle) <- openBinaryTempFile tmpdir filename - -- ^ Binary mode to avoid problems with line endings. See documentation for Test.Tasty.Golden + -- \^ Binary mode to avoid problems with line endings. See documentation for Test.Tasty.Golden Test.Tasty.defaultMain $ - localOption OnPass $ -- Delete the output if the test succeeds. + localOption OnPass $ -- Delete the output if the test succeeds. goldenVsFileDiff testName - (\expected actual -> ["diff", "-u", expected, actual]) -- How to to display differences. + (\expected actual -> ["diff", "-u", expected, actual]) -- How to to display differences. goldenFile resultsFile (runTest handle >> hClose handle) @@ -245,16 +260,20 @@ checkGoldenFileExists path = do fullPath <- makeAbsolute path fileExists <- doesFileExist path if not fileExists - then errorWithExplanation $ "golden file " ++ fullPath ++ " does not exist." - else do - perms <- getPermissions path - if not (writable perms) - then errorWithExplanation $ "golden file " ++ fullPath ++ " is not writable." - else pure () - where errorWithExplanation s = - let msg = "\n* ERROR: " ++ s ++ "\n" - ++ "* To ensure that the correct path is used, either use `cabal test` " - ++ "or run the test in the root directory of the relevant package.\n" - ++ "* If this is the first time this test has been run, create an " - ++ "initial golden file manually." - in error msg + then errorWithExplanation $ "golden file " ++ fullPath ++ " does not exist." + else do + perms <- getPermissions path + if not (writable perms) + then errorWithExplanation $ "golden file " ++ fullPath ++ " is not writable." + else pure () + where + errorWithExplanation s = + let msg = + "\n* ERROR: " + ++ s + ++ "\n" + ++ "* To ensure that the correct path is used, either use `cabal test` " + ++ "or run the test in the root directory of the relevant package.\n" + ++ "* If this is the first time this test has been run, create an " + ++ "initial golden file manually." + in error msg diff --git a/plutus-benchmark/common/PlutusBenchmark/NaturalSort.hs b/plutus-benchmark/common/PlutusBenchmark/NaturalSort.hs index e3bd13a0f23..dc96eb40b42 100644 --- a/plutus-benchmark/common/PlutusBenchmark/NaturalSort.hs +++ b/plutus-benchmark/common/PlutusBenchmark/NaturalSort.hs @@ -6,35 +6,34 @@ where import Data.Char (isDigit) import Data.List (sortBy) -{- | If we have the list of file names ["multisig-sm-1", "multisig-sm-2", - "multisig-sm-10"] then Haskell's standard 'sort' function will return - ["multisig-sm-1", "multisig-sm-10", "multisig-sm-2"], which is annoying. The - 'naturalSort' function here sorts it into the order you'd probably expect. - It does this by splitting strings into sequences of numeric and non-numeric - substrings and then comparing those sequences. --} - -data Component = - Numeric Int +-- | If we have the list of file names ["multisig-sm-1", "multisig-sm-2", +-- "multisig-sm-10"] then Haskell's standard 'sort' function will return +-- ["multisig-sm-1", "multisig-sm-10", "multisig-sm-2"], which is annoying. The +-- 'naturalSort' function here sorts it into the order you'd probably expect. +-- It does this by splitting strings into sequences of numeric and non-numeric +-- substrings and then comparing those sequences. +data Component + = Numeric Int | Other String - deriving stock (Eq, Ord, Show) - -- Numeric < Other + deriving stock (Eq, Ord, Show) + +-- Numeric < Other getComponent :: String -> Maybe (Component, String) getComponent "" = Nothing -getComponent s@(c:_) - | isDigit c = - case span isDigit s of - (p,q) -> Just (Numeric (read p), q) - | otherwise = - case span (not . isDigit) s of - (p,q) -> Just (Other p, q) +getComponent s@(c : _) + | isDigit c = + case span isDigit s of + (p, q) -> Just (Numeric (read p), q) + | otherwise = + case span (not . isDigit) s of + (p, q) -> Just (Other p, q) toComponents :: String -> [Component] toComponents s = - case getComponent s of - Nothing -> [] - Just (p,q) -> p : (toComponents q) + case getComponent s of + Nothing -> [] + Just (p, q) -> p : (toComponents q) {- Compare two strings according to their components. A difficulty arises because, for example, "file1" and "file01" have the same components but aren't @@ -48,12 +47,11 @@ toComponents s = -} naturalCompare :: String -> String -> Ordering naturalCompare s1 s2 = - let c1 = toComponents s1 - c2 = toComponents s2 - in if c1==c2 - then compare s1 s2 - else compare c1 c2 + let c1 = toComponents s1 + c2 = toComponents s2 + in if c1 == c2 + then compare s1 s2 + else compare c1 c2 naturalSort :: [String] -> [String] naturalSort = sortBy naturalCompare - diff --git a/plutus-benchmark/common/PlutusBenchmark/ProtocolParameters.hs b/plutus-benchmark/common/PlutusBenchmark/ProtocolParameters.hs index 0eaae92de93..9e54a90fbbb 100644 --- a/plutus-benchmark/common/PlutusBenchmark/ProtocolParameters.hs +++ b/plutus-benchmark/common/PlutusBenchmark/ProtocolParameters.hs @@ -17,5 +17,3 @@ max_tx_ex_steps = 10_000_000_000 max_tx_ex_mem :: Integer max_tx_ex_mem = 14_000_000 - - diff --git a/plutus-benchmark/coop/exe/Main.hs b/plutus-benchmark/coop/exe/Main.hs index ecef1478414..12118c26d34 100644 --- a/plutus-benchmark/coop/exe/Main.hs +++ b/plutus-benchmark/coop/exe/Main.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {- This module itself won't run any benchmark on it's own. It will only generate `.flat` file, if @@ -42,7 +42,7 @@ createIfNotExists name term = do () <$ UPLC.Program ann ver (UPLC.termMapNames UPLC.unNameDeBruijn t) termAsBS <- case term of - SerializedCode bs _ _ -> + SerializedCode bs _ _ -> let parsed = UPLC.unUnrestrictedProgram @@ -54,10 +54,11 @@ createIfNotExists name term = do SrcSpans ) bs - in case parsed of - Left err -> error $ "failed to parse UPLC flat from compiled code" <> show err - Right parsed' -> - pure $ BSL.fromStrict $ flat $ UPLC.UnrestrictedProgram $ eraseName parsed' + in + case parsed of + Left err -> error $ "failed to parse UPLC flat from compiled code" <> show err + Right parsed' -> + pure $ BSL.fromStrict $ flat $ UPLC.UnrestrictedProgram $ eraseName parsed' DeserializedCode uplc _ _ -> pure $ BSL.fromStrict $ flat $ UPLC.UnrestrictedProgram $ eraseName uplc @@ -81,7 +82,6 @@ main = do (liftCodeDef $ Datum $ toBuiltinData ()) (liftCodeDefAsData ()) (liftCodeDefAsData correctMustBurnOwnSingletonValueContext) - , unsafeApplyCodeN Scripts.certMp (liftCodeDef certMpParams) @@ -92,7 +92,6 @@ main = do (liftCodeDef certMpParams) (liftCodeDefAsData $ Redeemer $ toBuiltinData CertMpBurn) (liftCodeDefAsData correctCertMpBurningContext) - , unsafeApplyCodeN Scripts.fsMp (liftCodeDef fsMpParams) @@ -103,7 +102,6 @@ main = do (liftCodeDef fsMpParams) (liftCodeDefAsData $ Redeemer $ toBuiltinData FsMpBurn) (liftCodeDefAsData correctFsMpBurningContext) - , unsafeApplyCodeN Scripts.authMp (liftCodeDef authMpParams) @@ -116,5 +114,5 @@ main = do (liftCodeDefAsData correctAuthMpBurningContext) ] - traverse_ (uncurry createIfNotExists) (zip ((\i -> "coop-" <> show @Integer i) <$> [1..]) scripts) + traverse_ (uncurry createIfNotExists) (zip ((\i -> "coop-" <> show @Integer i) <$> [1 ..]) scripts) pure () diff --git a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Gen.hs b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Gen.hs index 30a213874a9..2874ca60aba 100644 --- a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Gen.hs +++ b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Gen.hs @@ -4,14 +4,23 @@ script context generators are to be used as one-off to generate one script conte on every runs of the benchmark. It is important to understand changing script context will change execution unit. -} - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module PlutusBenchmark.Coop.Gen where -import Test.QuickCheck (Arbitrary (arbitrary), Gen, choose, chooseAny, chooseEnum, chooseInt, - chooseInteger, sublistOf, suchThat, vectorOf) +import Test.QuickCheck ( + Arbitrary (arbitrary), + Gen, + choose, + chooseAny, + chooseEnum, + chooseInt, + chooseInteger, + sublistOf, + suchThat, + vectorOf, + ) import Control.Monad (foldM, replicateM) import Crypto.Hash (Blake2b_256 (Blake2b_256), hashWith) @@ -95,13 +104,13 @@ genCertRdmrInputs certRdmrAc = do certRdmrAddrs <- replicateM nCertRdmrInputs genAddress return [ TxInInfo - (TxOutRef (TxId "$CERT-RDMR input") 0) - ( TxOut - addr - (assetClassValue certRdmrAc 1) - NoOutputDatum - Nothing - ) + (TxOutRef (TxId "$CERT-RDMR input") 0) + ( TxOut + addr + (assetClassValue certRdmrAc 1) + NoOutputDatum + Nothing + ) | addr <- certRdmrAddrs ] @@ -366,10 +375,10 @@ genCorrectFsMpMintingCtx fsMpParams fsCs = do let authsBurned = mconcat [Value.singleton authCs (TokenName certId) (-1) | certId <- certIds] fsVOuts = [ TxOut - fsVAddr - (Value.singleton fsCs (TokenName . toBuiltin $ hashTxInputs [authIn]) 1) - (toOutputDatum $ FsDatum (toBuiltinData True) "deadbeef" (Finite 100) submitter) - Nothing + fsVAddr + (Value.singleton fsCs (TokenName . toBuiltin $ hashTxInputs [authIn]) 1) + (toOutputDatum $ FsDatum (toBuiltinData True) "deadbeef" (Finite 100) submitter) + Nothing | authIn <- authIns ] fsMinted = mconcat [txOutValue fsVOut | fsVOut <- fsVOuts] @@ -591,11 +600,10 @@ distributeSingle total = then take' ins (i : outs) else return (outs, i : ins) -{- | Mutating functions to introduce corruptions into ScriptContext - -TODO: Use mlabs-haskell/plutus-simple-model to ensure ledger invariances for the mutated ScriptContexts -WARN: All these mutations are untested and fairly unreliable --} +-- | Mutating functions to introduce corruptions into ScriptContext +-- +-- TODO: Use mlabs-haskell/plutus-simple-model to ensure ledger invariances for the mutated ScriptContexts +-- WARN: All these mutations are untested and fairly unreliable -- | Makes a ScriptContext corruption pipeline mkCorrupt :: [ScriptContext -> ScriptContext] -> ScriptContext -> ScriptContext @@ -745,4 +753,5 @@ hashTxInputs inputs = ixs = fmap (fromInteger . Value.txOutRefIdx) sortedOrefs txIds = fmap (Value.fromBuiltin . Value.getTxId . Value.txOutRefId) sortedOrefs hashedOref = convert @_ @ByteString . hashWith Blake2b_256 . mconcat $ zipWith cons ixs txIds - in hashedOref + in + hashedOref diff --git a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Scripts.hs b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Scripts.hs index cd1288948c2..b0f519b3414 100644 --- a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Scripts.hs +++ b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Scripts.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.Coop.Scripts where @@ -15,17 +15,31 @@ import PlutusTx.Prelude import Prelude () import PlutusLedgerApi.V1.Interval (contains) -import PlutusLedgerApi.V1.Value (AssetClass (AssetClass), isZero, unAssetClass, valueOf, - withCurrencySymbol) +import PlutusLedgerApi.V1.Value ( + AssetClass (AssetClass), + isZero, + unAssetClass, + valueOf, + withCurrencySymbol, + ) import PlutusLedgerApi.V1.Value qualified as Value -import PlutusLedgerApi.V2 (Datum, Extended (PosInf), Interval (Interval, ivTo), - LedgerBytes (getLedgerBytes), LowerBound (LowerBound), - ScriptContext (ScriptContext), ScriptPurpose (Minting), - TokenName (TokenName), TxId (getTxId), TxInInfo (TxInInfo), - TxInfo (TxInfo, txInfoData, txInfoInputs, txInfoMint, txInfoOutputs, txInfoReferenceInputs, txInfoSignatories, txInfoValidRange), - TxOut (TxOut, txOutAddress, txOutDatum, txOutValue), - TxOutRef (TxOutRef, txOutRefId, txOutRefIdx), UpperBound (UpperBound), - Value (Value, getValue)) +import PlutusLedgerApi.V2 ( + Datum, + Extended (PosInf), + Interval (Interval, ivTo), + LedgerBytes (getLedgerBytes), + LowerBound (LowerBound), + ScriptContext (ScriptContext), + ScriptPurpose (Minting), + TokenName (TokenName), + TxId (getTxId), + TxInInfo (TxInInfo), + TxInfo (TxInfo, txInfoData, txInfoInputs, txInfoMint, txInfoOutputs, txInfoReferenceInputs, txInfoSignatories, txInfoValidRange), + TxOut (TxOut, txOutAddress, txOutDatum, txOutValue), + TxOutRef (TxOutRef, txOutRefId, txOutRefIdx), + UpperBound (UpperBound), + Value (Value, getValue), + ) import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.List (elem, find, foldl, null) @@ -34,135 +48,149 @@ import PlutusBenchmark.Coop.Types import PlutusBenchmark.Coop.Utils fsV :: CompiledCode (Datum -> BuiltinData -> BuiltinData -> BuiltinUnit) -fsV = $$(compile [|| \_ _ sc -> mustBurnOwnSingletonValue (unsafeFromBuiltinData sc) ||]) +fsV = $$(compile [||\_ _ sc -> mustBurnOwnSingletonValue (unsafeFromBuiltinData sc)||]) certV :: CompiledCode (Datum -> BuiltinData -> BuiltinData -> BuiltinUnit) -certV = $$(compile [|| \_ _ sc -> mustBurnOwnSingletonValue (unsafeFromBuiltinData sc) ||]) +certV = $$(compile [||\_ _ sc -> mustBurnOwnSingletonValue (unsafeFromBuiltinData sc)||]) fsMp :: CompiledCode (FsMpParams -> BuiltinData -> BuiltinData -> BuiltinUnit) -fsMp = $$(compile [|| \p r sc -> fsMp' p (unsafeFromBuiltinData r) (unsafeFromBuiltinData sc) ||]) +fsMp = $$(compile [||\p r sc -> fsMp' p (unsafeFromBuiltinData r) (unsafeFromBuiltinData sc)||]) authMp :: CompiledCode (AuthMpParams -> BuiltinData -> BuiltinData -> BuiltinUnit) -authMp = $$(compile [|| \p r sc -> authMp' p (unsafeFromBuiltinData r) (unsafeFromBuiltinData sc) ||]) +authMp = $$(compile [||\p r sc -> authMp' p (unsafeFromBuiltinData r) (unsafeFromBuiltinData sc)||]) certMp :: CompiledCode (CertMpParams -> BuiltinData -> BuiltinData -> BuiltinUnit) -certMp = $$(compile [|| \p r sc -> certMp' p (unsafeFromBuiltinData r) (unsafeFromBuiltinData sc) ||]) +certMp = $$(compile [||\p r sc -> certMp' p (unsafeFromBuiltinData r) (unsafeFromBuiltinData sc)||]) fsMp' :: FsMpParams -> FsMpRedeemer -> ScriptContext -> BuiltinUnit fsMp' _params FsMpBurn - (ScriptContext - (TxInfo {..}) - (Minting ownCs) - ) = - let - go acc (TxInInfo _ (TxOut {..})) = - let ownCurrValue = withCurrencySymbol ownCs txOutValue AssocMap.empty id - in if AssocMap.null ownCurrValue - then acc - else - let - (FsDatum {..}) = resolveDatum @FsDatum txInfoData txOutDatum - !_checkSignature = - errorIfFalse "submitter must sign" $ - elem fs'submitter txInfoSignatories - !_checkRange = - errorIfFalse "valid range is correct" $ - contains - (Interval (LowerBound fs'gcAfter False) (UpperBound PosInf True)) - txInfoValidRange - in unsafeMergeMap acc ownCurrValue + ( ScriptContext + (TxInfo {..}) + (Minting ownCs) + ) = + let + go acc (TxInInfo _ (TxOut {..})) = + let ownCurrValue = withCurrencySymbol ownCs txOutValue AssocMap.empty id + in if AssocMap.null ownCurrValue + then acc + else + let + (FsDatum {..}) = resolveDatum @FsDatum txInfoData txOutDatum + !_checkSignature = + errorIfFalse "submitter must sign" + $ elem fs'submitter txInfoSignatories + !_checkRange = + errorIfFalse "valid range is correct" + $ contains + (Interval (LowerBound fs'gcAfter False) (UpperBound PosInf True)) + txInfoValidRange + in + unsafeMergeMap acc ownCurrValue - allOwnCurrValue = negate $ Value $ AssocMap.singleton ownCs (foldl go AssocMap.empty txInfoInputs) - !_checkBurn = - errorIfFalse "" $ - currencyValue ownCs txInfoMint == allOwnCurrValue - in BI.unitval + allOwnCurrValue = negate $ Value $ AssocMap.singleton ownCs (foldl go AssocMap.empty txInfoInputs) + !_checkBurn = + errorIfFalse "" + $ currencyValue ownCs txInfoMint + == allOwnCurrValue + in + BI.unitval fsMp' (FsMpParams {fmp'fsVAddress, fmp'authParams = AuthParams {..}}) FsMpMint - (ScriptContext - (TxInfo {..}) - (Minting ownCs) - ) = - let - validCerts = - let - go' acc (TxInInfo _ (TxOut {txOutDatum = txInDat, txOutValue = txInVal})) = - let certVal = currencyValue ap'certTokenCs txInVal - in if certVal == mempty - then acc - else - let - certDat@(CertDatum {..}) = resolveDatum @CertDatum txInfoData txInDat - !_checkTokenName = - errorIfFalse "$CERT token name must match CertDatum ID" $ - valueOf certVal ap'certTokenCs (TokenName $ getLedgerBytes cert'id) == 1 - !_checkRange = - errorIfFalse "cert is invalid" $ - contains cert'validity txInfoValidRange - in certDat : acc - - in foldl go' mempty txInfoReferenceInputs + ( ScriptContext + (TxInfo {..}) + (Minting ownCs) + ) = + let + validCerts = + let + go' acc (TxInInfo _ (TxOut {txOutDatum = txInDat, txOutValue = txInVal})) = + let certVal = currencyValue ap'certTokenCs txInVal + in if certVal == mempty + then acc + else + let + certDat@(CertDatum {..}) = resolveDatum @CertDatum txInfoData txInDat + !_checkTokenName = + errorIfFalse "$CERT token name must match CertDatum ID" + $ valueOf certVal ap'certTokenCs (TokenName $ getLedgerBytes cert'id) + == 1 + !_checkRange = + errorIfFalse "cert is invalid" + $ contains cert'validity txInfoValidRange + in + certDat : acc + in + foldl go' mempty txInfoReferenceInputs - validAuthInputs = - let - go' acc@(validAuthInputs'', shouldBeBurned) txIn@(TxInInfo _ (TxOut {txOutValue = txInVal})) = - if hasCurrency ap'authTokenCs txInVal - then - let - predicate (CertDatum {..}) = - 0 < valueOf txInVal ap'authTokenCs (TokenName $ getLedgerBytes cert'id) - in case find predicate validCerts of - Nothing -> traceError "$AUTH must be validated with a $CERT" - Just (CertDatum {..}) -> + validAuthInputs = + let + go' acc@(validAuthInputs'', shouldBeBurned) txIn@(TxInInfo _ (TxOut {txOutValue = txInVal})) = + if hasCurrency ap'authTokenCs txInVal + then let - shouldbeBurned' = - shouldBeBurned - <> Value.singleton ap'authTokenCs (TokenName $ getLedgerBytes cert'id) (-1) - in (txIn : validAuthInputs'', shouldbeBurned') - else acc + predicate (CertDatum {..}) = + 0 < valueOf txInVal ap'authTokenCs (TokenName $ getLedgerBytes cert'id) + in + case find predicate validCerts of + Nothing -> traceError "$AUTH must be validated with a $CERT" + Just (CertDatum {..}) -> + let + shouldbeBurned' = + shouldBeBurned + <> Value.singleton ap'authTokenCs (TokenName $ getLedgerBytes cert'id) (-1) + in + (txIn : validAuthInputs'', shouldbeBurned') + else acc - (validAuthInputs', authTokensToBurn) = foldl go' (mempty, mempty) txInfoInputs - !_checkBurn = - errorIfFalse "" $ - currencyValue ap'authTokenCs txInfoMint == authTokensToBurn - in validAuthInputs' + (validAuthInputs', authTokensToBurn) = foldl go' (mempty, mempty) txInfoInputs + !_checkBurn = + errorIfFalse "" + $ currencyValue ap'authTokenCs txInfoMint + == authTokensToBurn + in + validAuthInputs' - go acc@(fsToMint', unusedAuthInputs) (TxOut {..}) = - let ownCurrValue = withCurrencySymbol ownCs txOutValue AssocMap.empty id - in if AssocMap.null ownCurrValue - then acc - else - let - !_checkDatum = resolveDatum @FsDatum txInfoData txOutDatum - !_checkAddress = - errorIfFalse "minted value is not sent to correct address" $ - fmp'fsVAddress == txOutAddress + go acc@(fsToMint', unusedAuthInputs) (TxOut {..}) = + let ownCurrValue = withCurrencySymbol ownCs txOutValue AssocMap.empty id + in if AssocMap.null ownCurrValue + then acc + else + let + !_checkDatum = resolveDatum @FsDatum txInfoData txOutDatum + !_checkAddress = + errorIfFalse "minted value is not sent to correct address" + $ fmp'fsVAddress + == txOutAddress - matchWithAuth (Nothing, unusedAuthInputs'') authInput = - let - fsTokenName :: TokenName - fsTokenName = TokenName $ hashInput authInput - in if (Value $ AssocMap.singleton ownCs ownCurrValue) - == Value.singleton ownCs fsTokenName 1 - then (Just fsTokenName, unusedAuthInputs'') - else (Nothing, authInput : unusedAuthInputs'') - matchWithAuth (myFsTn', unusedAuthInputs'') authInput = - (myFsTn', (authInput : unusedAuthInputs'')) + matchWithAuth (Nothing, unusedAuthInputs'') authInput = + let + fsTokenName :: TokenName + fsTokenName = TokenName $ hashInput authInput + in + if (Value $ AssocMap.singleton ownCs ownCurrValue) + == Value.singleton ownCs fsTokenName 1 + then (Just fsTokenName, unusedAuthInputs'') + else (Nothing, authInput : unusedAuthInputs'') + matchWithAuth (myFsTn', unusedAuthInputs'') authInput = + (myFsTn', (authInput : unusedAuthInputs'')) - (mayFsTn, unusedAuthInputs') = foldl matchWithAuth (Nothing, mempty) unusedAuthInputs - in case mayFsTn of - Nothing -> traceError "$FS must have a token name formed from a matching $AUTH input" - Just fsTn -> (fsToMint' <> Value.singleton ownCs fsTn 1, unusedAuthInputs') + (mayFsTn, unusedAuthInputs') = foldl matchWithAuth (Nothing, mempty) unusedAuthInputs + in + case mayFsTn of + Nothing -> traceError "$FS must have a token name formed from a matching $AUTH input" + Just fsTn -> (fsToMint' <> Value.singleton ownCs fsTn 1, unusedAuthInputs') - (fsToMint, restAuths) = foldl go (mempty, validAuthInputs) txInfoOutputs - !_checkAuthUse = errorIfFalse "Auth inputs must ALL be used" $ null restAuths - !_checkBurn = - errorIfFalse "" $ - currencyValue ownCs txInfoMint == fsToMint - in BI.unitval + (fsToMint, restAuths) = foldl go (mempty, validAuthInputs) txInfoOutputs + !_checkAuthUse = errorIfFalse "Auth inputs must ALL be used" $ null restAuths + !_checkBurn = + errorIfFalse "" + $ currencyValue ownCs txInfoMint + == fsToMint + in + BI.unitval fsMp' _ _ _ = traceError "incorrect purpose" {-# INLINE fsMp' #-} @@ -170,54 +198,57 @@ authMp' :: AuthMpParams -> AuthMpRedeemer -> ScriptContext -> BuiltinUnit authMp' _ AuthMpBurn - (ScriptContext - (TxInfo {..}) - (Minting ownCs) - ) = - let - ownValue = currencyValue ownCs txInfoMint - in errorIfTrue "Own value $AUTH in txMint must all be burned" (isZero ownValue) + ( ScriptContext + (TxInfo {..}) + (Minting ownCs) + ) = + let + ownValue = currencyValue ownCs txInfoMint + in + errorIfTrue "Own value $AUTH in txMint must all be burned" (isZero ownValue) authMp' (AuthMpParams {..}) AuthMpMint - (ScriptContext - (TxInfo {..}) - (Minting ownCs) - ) = - let - (aaCs, aaTn) = unAssetClass amp'authAuthorityAc - go - acc - (TxInInfo (TxOutRef {txOutRefId = txId, txOutRefIdx = txIdx}) (TxOut {txOutValue = txInVal})) = - if hasCurrency aaCs txInVal - then - let - (aaVal, tnBytes) = acc - tnBytes' = tnBytes <> (consByteString txIdx (getTxId txId)) - aaVal' = aaVal + valueOf txInVal aaCs aaTn - in (aaVal', tnBytes') - else acc - authId = - let - (aaTokensSpent, tnBytes) = foldl go (0, mempty) txInfoInputs - in - if amp'requiredAtLeastAaQ <= aaTokensSpent - then blake2b_256 tnBytes - else traceError "Must spend at least the specified amount of AA tokens" - - in case AssocMap.lookup ownCs (getValue txInfoMint) of - Nothing -> - traceError $ - "Must mint at least one $AUTH token:\n" - <> "Must have a specified CurrencySymbol in the Value" - Just tokenNameMap -> - case AssocMap.toList tokenNameMap of - [(k, v)] | k == (TokenName authId) -> - errorIfFalse "Must mint at least one $AUTH token" (0 < v) - _ -> - traceError $ - "Must mint at least one $AUTH token: \n" - <> "Must have exactly one TokenName under specified CurrencySymbol" + ( ScriptContext + (TxInfo {..}) + (Minting ownCs) + ) = + let + (aaCs, aaTn) = unAssetClass amp'authAuthorityAc + go + acc + (TxInInfo (TxOutRef {txOutRefId = txId, txOutRefIdx = txIdx}) (TxOut {txOutValue = txInVal})) = + if hasCurrency aaCs txInVal + then + let + (aaVal, tnBytes) = acc + tnBytes' = tnBytes <> (consByteString txIdx (getTxId txId)) + aaVal' = aaVal + valueOf txInVal aaCs aaTn + in + (aaVal', tnBytes') + else acc + authId = + let + (aaTokensSpent, tnBytes) = foldl go (0, mempty) txInfoInputs + in + if amp'requiredAtLeastAaQ <= aaTokensSpent + then blake2b_256 tnBytes + else traceError "Must spend at least the specified amount of AA tokens" + in + case AssocMap.lookup ownCs (getValue txInfoMint) of + Nothing -> + traceError + $ "Must mint at least one $AUTH token:\n" + <> "Must have a specified CurrencySymbol in the Value" + Just tokenNameMap -> + case AssocMap.toList tokenNameMap of + [(k, v)] + | k == (TokenName authId) -> + errorIfFalse "Must mint at least one $AUTH token" (0 < v) + _ -> + traceError + $ "Must mint at least one $AUTH token: \n" + <> "Must have exactly one TokenName under specified CurrencySymbol" authMp' _ _ _ = traceError "incorrect purpose" {-# INLINE authMp' #-} @@ -225,81 +256,85 @@ certMp' :: CertMpParams -> CertMpRedeemer -> ScriptContext -> BuiltinUnit certMp' (CertMpParams {..}) CertMpMint - (ScriptContext - (TxInfo {..}) - (Minting ownCs) - ) = - let - tnBytes = - let - AssetClass (aaCs, aaTn) = cmp'authAuthorityAc - go acc@(aaVal, tnBytes'') (TxInInfo (TxOutRef {txOutRefId = txId, txOutRefIdx = txIdx}) (TxOut {txOutValue = txInVal})) = - if hasCurrency aaCs txInVal - then (aaVal + valueOf txInVal aaCs aaTn, tnBytes'' <> consByteString txIdx (getTxId txId)) - else acc - (aaTokensSpent, tnBytes') = foldl go (0, mempty) txInfoInputs - in if cmp'requiredAtLeastAaQ <= aaTokensSpent - then blake2b_256 tnBytes' - else traceError "Must spend at least the specified amount of AA tokens" - certTn = TokenName tnBytes - !_mustMintCert = - errorIfFalse - "Must mint 1 $CERT" - (currencyValue ownCs txInfoMint == (Value.singleton ownCs certTn 1)) - - !_mustPayCurrencyWithDatum = - let - go paid (TxOut {txOutValue = val, txOutAddress = address, txOutDatum = dat}) = - if address == cmp'certVAddress - then - let - (CertDatum {..}) = resolveDatum @CertDatum txInfoData dat - in - if (getLedgerBytes cert'id) == tnBytes - then paid + (currencyValue ownCs val) - else traceError "Must attach a valid datum" - else paid - paidVal = foldl go mempty txInfoOutputs - in errorIfFalse "Must pay the specific value" (paidVal == Value.singleton ownCs certTn 1) - in BI.unitval + ( ScriptContext + (TxInfo {..}) + (Minting ownCs) + ) = + let + tnBytes = + let + AssetClass (aaCs, aaTn) = cmp'authAuthorityAc + go acc@(aaVal, tnBytes'') (TxInInfo (TxOutRef {txOutRefId = txId, txOutRefIdx = txIdx}) (TxOut {txOutValue = txInVal})) = + if hasCurrency aaCs txInVal + then (aaVal + valueOf txInVal aaCs aaTn, tnBytes'' <> consByteString txIdx (getTxId txId)) + else acc + (aaTokensSpent, tnBytes') = foldl go (0, mempty) txInfoInputs + in + if cmp'requiredAtLeastAaQ <= aaTokensSpent + then blake2b_256 tnBytes' + else traceError "Must spend at least the specified amount of AA tokens" + certTn = TokenName tnBytes + !_mustMintCert = + errorIfFalse + "Must mint 1 $CERT" + (currencyValue ownCs txInfoMint == (Value.singleton ownCs certTn 1)) + !_mustPayCurrencyWithDatum = + let + go paid (TxOut {txOutValue = val, txOutAddress = address, txOutDatum = dat}) = + if address == cmp'certVAddress + then + let + (CertDatum {..}) = resolveDatum @CertDatum txInfoData dat + in + if (getLedgerBytes cert'id) == tnBytes + then paid + (currencyValue ownCs val) + else traceError "Must attach a valid datum" + else paid + paidVal = foldl go mempty txInfoOutputs + in + errorIfFalse "Must pay the specific value" (paidVal == Value.singleton ownCs certTn 1) + in + BI.unitval certMp' _ CertMpBurn - (ScriptContext - (TxInfo {..}) - (Minting ownCs) - ) = - let - go shouldBurn' (TxInInfo _ (TxOut {txOutValue = txInVal, txOutDatum = txOutDatum})) = - if hasCurrency ownCs txInVal - then - let - (CertDatum {..}) = resolveDatum @CertDatum txInfoData txOutDatum - UpperBound certValidUntil _ = ivTo cert'validity - !_checkRange = - contains - (Interval (LowerBound certValidUntil False) (UpperBound PosInf True)) - txInfoValidRange - AssetClass (redeemerCs, redeemerName) = cert'redeemerAc - inputSum = - foldl (\acc (TxInInfo _ (TxOut {txOutValue})) -> acc + txOutValue) mempty txInfoInputs - !_spendAtLeast = - errorIfFalse - "Not have at least one token specified by redeemer spent" - (valueOf inputSum redeemerCs redeemerName >= 1) - certVal = Value.singleton ownCs (TokenName $ getLedgerBytes cert'id) 1 - !_mustSpendOneCERTToken = - errorIfFalse - "Must spend one $CERT token" - (currencyValue ownCs txInVal == certVal) - in shouldBurn' + (inv certVal) - else shouldBurn' - shouldBurn = foldl go mempty txInfoInputs - !_mustMintCurrency = - errorIfFalse - "Must mint specified value of currency" - (currencyValue ownCs txInfoMint == shouldBurn) - in BI.unitval + ( ScriptContext + (TxInfo {..}) + (Minting ownCs) + ) = + let + go shouldBurn' (TxInInfo _ (TxOut {txOutValue = txInVal, txOutDatum = txOutDatum})) = + if hasCurrency ownCs txInVal + then + let + (CertDatum {..}) = resolveDatum @CertDatum txInfoData txOutDatum + UpperBound certValidUntil _ = ivTo cert'validity + !_checkRange = + contains + (Interval (LowerBound certValidUntil False) (UpperBound PosInf True)) + txInfoValidRange + AssetClass (redeemerCs, redeemerName) = cert'redeemerAc + inputSum = + foldl (\acc (TxInInfo _ (TxOut {txOutValue})) -> acc + txOutValue) mempty txInfoInputs + !_spendAtLeast = + errorIfFalse + "Not have at least one token specified by redeemer spent" + (valueOf inputSum redeemerCs redeemerName >= 1) + certVal = Value.singleton ownCs (TokenName $ getLedgerBytes cert'id) 1 + !_mustSpendOneCERTToken = + errorIfFalse + "Must spend one $CERT token" + (currencyValue ownCs txInVal == certVal) + in + shouldBurn' + (inv certVal) + else shouldBurn' + shouldBurn = foldl go mempty txInfoInputs + !_mustMintCurrency = + errorIfFalse + "Must mint specified value of currency" + (currencyValue ownCs txInfoMint == shouldBurn) + in + BI.unitval certMp' _ _ _ = traceError "incorrect purpose" {-# INLINE certMp' #-} diff --git a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/TestContext.hs b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/TestContext.hs index 0c44801b68a..ea745fed65a 100644 --- a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/TestContext.hs +++ b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/TestContext.hs @@ -11,7 +11,7 @@ module PlutusBenchmark.Coop.TestContext ( correctFsMpBurningContext, correctAuthMpMintingContext, correctAuthMpBurningContext, - ) where +) where import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol (..), TokenName (..), assetClass) diff --git a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Types.hs b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Types.hs index ce53c65fa6a..07eadb07e97 100644 --- a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Types.hs +++ b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module PlutusBenchmark.Coop.Types where @@ -9,8 +9,15 @@ import Prelude qualified as HS import Control.Lens (makeFields) import PlutusLedgerApi.V1.Value (AssetClass) -import PlutusLedgerApi.V3 (Address, CurrencySymbol, Extended, LedgerBytes, POSIXTime, - POSIXTimeRange, PubKeyHash) +import PlutusLedgerApi.V3 ( + Address, + CurrencySymbol, + Extended, + LedgerBytes, + POSIXTime, + POSIXTimeRange, + PubKeyHash, + ) import PlutusTx.IsData qualified as PlutusTx import PlutusTx.Lift qualified as PlutusTx import PlutusTx.Prelude @@ -23,11 +30,11 @@ type FactStatementId = LedgerBytes -- | A datum holding the FactStatement that's locked at @FsV data FsDatum = FsDatum - { fd'fs :: FactStatement + { fd'fs :: FactStatement -- ^ Fact statement - , fd'fsId :: FactStatementId + , fd'fsId :: FactStatementId -- ^ Fact statement ID as provided by the oracle - , fs'gcAfter :: Extended POSIXTime + , fs'gcAfter :: Extended POSIXTime -- ^ After this time the Submitter can 'garbage collect' the @FsV UTxO , fs'submitter :: PubKeyHash -- ^ Public key hash of the wallet that submitted the $FS minting transaction @@ -36,8 +43,8 @@ data FsDatum = FsDatum -- | FsMp initial parameters data FsMpParams = FsMpParams - { fmp'coopAc :: AssetClass - -- ^ $COOP one-shot token asset class denoting the COOP instance + { fmp'coopAc :: AssetClass + -- ^ \$COOP one-shot token asset class denoting the COOP instance , fmp'fsVAddress :: Address -- ^ @FsV fact statement validator address where the minted $FS tokens are paid to , fmp'authParams :: AuthParams @@ -48,9 +55,9 @@ data FsMpParams = FsMpParams -- | FsMp initial authentication parameters data AuthParams = AuthParams { ap'authTokenCs :: CurrencySymbol - -- ^ $AUTH token CurrencySymbol required to authorize $FS minting + -- ^ \$AUTH token CurrencySymbol required to authorize $FS minting , ap'certTokenCs :: CurrencySymbol - -- ^ $CERT token CurrencySymbol required to authorize $FS minting + -- ^ \$CERT token CurrencySymbol required to authorize $FS minting } deriving stock (HS.Show, HS.Eq) @@ -65,12 +72,12 @@ type AuthBatchId = LedgerBytes -- | Datum locked at @CertV containing information about $AUTH tokens used in authorizing $FS minting data CertDatum = CertDatum - { cert'id :: AuthBatchId + { cert'id :: AuthBatchId -- ^ Certificate unique identifier (matches $CERT and $AUTH token names) - , cert'validity :: POSIXTimeRange + , cert'validity :: POSIXTimeRange -- ^ Certificate validity interval after which associated $AUTH tokens can't be used to authorize $FS minting , cert'redeemerAc :: AssetClass - -- ^ $CERT-RMDR asset class that must be spent to 'garbage collect' the @CertV UTxO after the certificate had expired + -- ^ \$CERT-RMDR asset class that must be spent to 'garbage collect' the @CertV UTxO after the certificate had expired } deriving stock (HS.Show, HS.Eq) @@ -80,11 +87,11 @@ data CertMpRedeemer = CertMpBurn | CertMpMint -- | CertMp initial parameters data CertMpParams = CertMpParams - { cmp'authAuthorityAc :: AssetClass - -- ^ $AA (Authentication authority) tokens required to authorize $CERT minting + { cmp'authAuthorityAc :: AssetClass + -- ^ \$AA (Authentication authority) tokens required to authorize $CERT minting , cmp'requiredAtLeastAaQ :: Integer - -- ^ $AA token quantity required to authorize $CERT minting - , cmp'certVAddress :: Address + -- ^ \$AA token quantity required to authorize $CERT minting + , cmp'certVAddress :: Address -- ^ Certificate validator @CertV address to pay the $CERT tokens to } deriving stock (HS.Show, HS.Eq) @@ -95,14 +102,13 @@ data AuthMpRedeemer = AuthMpBurn | AuthMpMint -- | AuthMp initial parameters data AuthMpParams = AuthMpParams - { amp'authAuthorityAc :: AssetClass - -- ^ $AA (Authentication authority) tokens required to authorize $AUTH minting + { amp'authAuthorityAc :: AssetClass + -- ^ \$AA (Authentication authority) tokens required to authorize $AUTH minting , amp'requiredAtLeastAaQ :: Integer - -- ^ $AA token quantity required to authorize $AUTH minting + -- ^ \$AA token quantity required to authorize $AUTH minting } deriving stock (HS.Show, HS.Eq) - PlutusTx.unstableMakeIsData ''AuthParams PlutusTx.unstableMakeIsData ''FsDatum diff --git a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Utils.hs b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Utils.hs index 3cfb6f4064a..b5f4d550735 100644 --- a/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Utils.hs +++ b/plutus-benchmark/coop/src/PlutusBenchmark/Coop/Utils.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module PlutusBenchmark.Coop.Utils where @@ -8,12 +8,19 @@ import PlutusTx.Prelude import Prelude () import PlutusLedgerApi.V1.Value (Value (Value), flattenValue, valueOf, withCurrencySymbol) -import PlutusLedgerApi.V2 (CurrencySymbol, Datum (Datum), DatumHash, - OutputDatum (NoOutputDatum, OutputDatum, OutputDatumHash), - ScriptContext (ScriptContext), ScriptPurpose (Spending), TxId (TxId), - TxInInfo (TxInInfo, txInInfoOutRef), - TxInfo (TxInfo, txInfoInputs, txInfoMint), TxOut (TxOut, txOutValue), - TxOutRef (TxOutRef)) +import PlutusLedgerApi.V2 ( + CurrencySymbol, + Datum (Datum), + DatumHash, + OutputDatum (NoOutputDatum, OutputDatum, OutputDatumHash), + ScriptContext (ScriptContext), + ScriptPurpose (Spending), + TxId (TxId), + TxInInfo (TxInInfo, txInInfoOutRef), + TxInfo (TxInfo, txInfoInputs, txInfoMint), + TxOut (TxOut, txOutValue), + TxOutRef (TxOutRef), + ) import PlutusTx.AssocMap (Map, lookup) import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins.Internal qualified as BI @@ -23,18 +30,18 @@ findOwnInput :: [TxInInfo] -> TxOutRef -> TxInInfo findOwnInput inputs oref = case find (\i -> txInInfoOutRef i == oref) inputs of Nothing -> traceError "findOwnInput: not found" - Just x -> x + Just x -> x mustBurnOwnSingletonValue :: ScriptContext -> BuiltinUnit mustBurnOwnSingletonValue (ScriptContext (TxInfo {..}) (Spending oref)) = let (TxInInfo _ (TxOut {txOutValue = ownInputValue})) = findOwnInput txInfoInputs oref - -- flattenValue actually reverses order. See plutus#7173. - in case flattenValue ownInputValue of - [(cs, tk, q), _ada] -> - if negate (valueOf txInfoMint cs tk) == q - then BI.unitval - else traceError "Must burn the all of the single asset this utxo was holding" - _ -> traceError "The UTXO should exactly have one assets besides Lovelace" + in -- flattenValue actually reverses order. See plutus#7173. + case flattenValue ownInputValue of + [(cs, tk, q), _ada] -> + if negate (valueOf txInfoMint cs tk) == q + then BI.unitval + else traceError "Must burn the all of the single asset this utxo was holding" + _ -> traceError "The UTXO should exactly have one assets besides Lovelace" mustBurnOwnSingletonValue _ = traceError "Only spending purpose is supported" {-# INLINE mustBurnOwnSingletonValue #-} @@ -44,7 +51,7 @@ resolveDatum datums outputDatum = NoOutputDatum -> traceError "expected datum but got no datum" OutputDatumHash hash -> case lookup hash datums of - Nothing -> traceError "expected datum but given datum hash have no associated datum" + Nothing -> traceError "expected datum but given datum hash have no associated datum" Just (Datum d) -> unsafeFromBuiltinData @a d OutputDatum (Datum d) -> unsafeFromBuiltinData @a d @@ -61,11 +68,11 @@ hashInput (TxInInfo (TxOutRef (TxId hash) idx) _) errorIfFalse :: BuiltinString -> Bool -> BuiltinUnit errorIfFalse msg False = traceError msg -errorIfFalse _ True = BI.unitval +errorIfFalse _ True = BI.unitval errorIfTrue :: BuiltinString -> Bool -> BuiltinUnit errorIfTrue msg True = traceError msg -errorIfTrue _ False = BI.unitval +errorIfTrue _ False = BI.unitval hasCurrency :: CurrencySymbol -> Value -> Bool hasCurrency cs (Value val) = AssocMap.member cs val diff --git a/plutus-benchmark/coop/test/Main.hs b/plutus-benchmark/coop/test/Main.hs index 28c185ec85c..5950fb45abb 100644 --- a/plutus-benchmark/coop/test/Main.hs +++ b/plutus-benchmark/coop/test/Main.hs @@ -1,6 +1,4 @@ -{- | Golden cases for Cardan Open Oracle Protocol scripts. --} - +-- | Golden cases for Cardan Open Oracle Protocol scripts. module Main (main) where import Test.Tasty @@ -22,53 +20,52 @@ liftCodeDefAsData = liftCodeDef . toBuiltinData allTests :: TestTree allTests = - runTestNested ["coop", "test"] $ pure $ testNestedGhc - [ Tx.goldenEvalCekCatchBudget "mustBurnOwnSingleton" $ - unsafeApplyCodeN - Scripts.fsV - (liftCodeDef $ Datum $ toBuiltinData ()) - (liftCodeDefAsData ()) - (liftCodeDefAsData correctMustBurnOwnSingletonValueContext) - - , Tx.goldenEvalCekCatchBudget "certMpMinting" $ - unsafeApplyCodeN - Scripts.certMp - (liftCodeDef certMpParams) - (liftCodeDefAsData $ Redeemer $ toBuiltinData CertMpMint) - (liftCodeDefAsData correctCertMpMintingContext) - , Tx.goldenEvalCekCatchBudget "certMpBurning" $ - unsafeApplyCodeN - Scripts.certMp - (liftCodeDef certMpParams) - (liftCodeDefAsData $ Redeemer $ toBuiltinData CertMpBurn) - (liftCodeDefAsData correctCertMpBurningContext) - - , Tx.goldenEvalCekCatchBudget "fsMpMinting" $ - unsafeApplyCodeN - Scripts.fsMp - (liftCodeDef fsMpParams) - (liftCodeDefAsData $ Redeemer $ toBuiltinData FsMpMint) - (liftCodeDefAsData correctFsMpMintingContext) - , Tx.goldenEvalCekCatchBudget "fsMpBurning" $ - unsafeApplyCodeN - Scripts.fsMp - (liftCodeDef fsMpParams) - (liftCodeDefAsData $ Redeemer $ toBuiltinData FsMpBurn) - (liftCodeDefAsData correctFsMpBurningContext) - - , Tx.goldenEvalCekCatchBudget "authMpMinting" $ - unsafeApplyCodeN - Scripts.authMp - (liftCodeDef authMpParams) - (liftCodeDefAsData $ Redeemer $ toBuiltinData AuthMpMint) - (liftCodeDefAsData correctAuthMpMintingContext) - , Tx.goldenEvalCekCatchBudget "authMpBurning" $ - unsafeApplyCodeN - Scripts.authMp - (liftCodeDef authMpParams) - (liftCodeDefAsData $ Redeemer $ toBuiltinData AuthMpBurn) - (liftCodeDefAsData correctAuthMpBurningContext) - ] + runTestNested ["coop", "test"] $ + pure $ + testNestedGhc + [ Tx.goldenEvalCekCatchBudget "mustBurnOwnSingleton" $ + unsafeApplyCodeN + Scripts.fsV + (liftCodeDef $ Datum $ toBuiltinData ()) + (liftCodeDefAsData ()) + (liftCodeDefAsData correctMustBurnOwnSingletonValueContext) + , Tx.goldenEvalCekCatchBudget "certMpMinting" $ + unsafeApplyCodeN + Scripts.certMp + (liftCodeDef certMpParams) + (liftCodeDefAsData $ Redeemer $ toBuiltinData CertMpMint) + (liftCodeDefAsData correctCertMpMintingContext) + , Tx.goldenEvalCekCatchBudget "certMpBurning" $ + unsafeApplyCodeN + Scripts.certMp + (liftCodeDef certMpParams) + (liftCodeDefAsData $ Redeemer $ toBuiltinData CertMpBurn) + (liftCodeDefAsData correctCertMpBurningContext) + , Tx.goldenEvalCekCatchBudget "fsMpMinting" $ + unsafeApplyCodeN + Scripts.fsMp + (liftCodeDef fsMpParams) + (liftCodeDefAsData $ Redeemer $ toBuiltinData FsMpMint) + (liftCodeDefAsData correctFsMpMintingContext) + , Tx.goldenEvalCekCatchBudget "fsMpBurning" $ + unsafeApplyCodeN + Scripts.fsMp + (liftCodeDef fsMpParams) + (liftCodeDefAsData $ Redeemer $ toBuiltinData FsMpBurn) + (liftCodeDefAsData correctFsMpBurningContext) + , Tx.goldenEvalCekCatchBudget "authMpMinting" $ + unsafeApplyCodeN + Scripts.authMp + (liftCodeDef authMpParams) + (liftCodeDefAsData $ Redeemer $ toBuiltinData AuthMpMint) + (liftCodeDefAsData correctAuthMpMintingContext) + , Tx.goldenEvalCekCatchBudget "authMpBurning" $ + unsafeApplyCodeN + Scripts.authMp + (liftCodeDef authMpParams) + (liftCodeDefAsData $ Redeemer $ toBuiltinData AuthMpBurn) + (liftCodeDefAsData correctAuthMpBurningContext) + ] main :: IO () main = defaultMain allTests diff --git a/plutus-benchmark/data/bench/Bench.hs b/plutus-benchmark/data/bench/Bench.hs index 4ada08949b0..d245d9aa218 100644 --- a/plutus-benchmark/data/bench/Bench.hs +++ b/plutus-benchmark/data/bench/Bench.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{- | This benchmark cases measures efficiency of 'Data' construction. --} - +-- | This benchmark cases measures efficiency of 'Data' construction. module Main (main) where import Criterion.Main @@ -19,7 +17,8 @@ import Data.Functor benchmarks :: EvaluationContext -> [Benchmark] benchmarks ctx = - [ bgroup "data" + [ bgroup + "data" [ mkBMs "conDeconI" Data.conDeconI , mkBMs "conI" Data.conI , mkBMs "conDeconB - short" (Data.conDeconB "helloworld") @@ -31,10 +30,11 @@ benchmarks ctx = , mkBMs "list no release, 2000 chuck size" (Data.listDataNoRelease 2000) , mkBMs "list with release, 2000 chuck size" (Data.listDataWithRelease 2000) ] - ] - where - mkBMs name f = - bgroup name $ [2000, 4000..12000] <&> \n -> + ] + where + mkBMs name f = + bgroup name $ + [2000, 4000 .. 12000] <&> \n -> bench (show n) $ benchTermCek ctx (f n) main :: IO () diff --git a/plutus-benchmark/data/src/PlutusBenchmark/Data.hs b/plutus-benchmark/data/src/PlutusBenchmark/Data.hs index ed7bab358e4..ff4eaf575a8 100644 --- a/plutus-benchmark/data/src/PlutusBenchmark/Data.hs +++ b/plutus-benchmark/data/src/PlutusBenchmark/Data.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module PlutusBenchmark.Data where @@ -14,64 +14,73 @@ import PlutusCore.Data qualified as PLC import PlutusCore.MkPlc import UntypedPlutusCore qualified as UPLC -debruijnTermUnsafe :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun ann - -> UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ann +debruijnTermUnsafe :: + UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun ann -> + UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ann debruijnTermUnsafe = - fromRight (Prelude.error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm + fromRight (Prelude.error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm conDeconI :: Integer -> Term conDeconI i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () comp t = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x intTy t) - (apply () - (builtin () PLC.UnIData) - (apply () (builtin () PLC.IData) (mkConstant @Integer () 42))) + ( apply + () + (builtin () PLC.UnIData) + (apply () (builtin () PLC.IData) (mkConstant @Integer () 42)) + ) conI :: Integer -> Term conI i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () comp t = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x intTy t) (apply () (builtin () PLC.IData) (mkConstant @Integer () 42)) conDeconB :: ByteString -> Integer -> Term conDeconB bs i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () comp t = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x intTy t) - (apply () - (builtin () PLC.UnBData) - (apply () (builtin () PLC.BData) (mkConstant @ByteString () bs))) + ( apply + () + (builtin () PLC.UnBData) + (apply () (builtin () PLC.BData) (mkConstant @ByteString () bs)) + ) conB :: ByteString -> Integer -> Term conB bs i = debruijnTermUnsafe $ - foldr (const comp) (mkConstant @Integer () 0) [1..i] + foldr (const comp) (mkConstant @Integer () 0) [1 .. i] where intTy = PLC.mkTyBuiltin @_ @Integer () comp t = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x intTy t) (apply () (builtin () PLC.BData) (mkConstant @ByteString () bs)) @@ -89,23 +98,28 @@ Given amount "i" and chuck size, -} constrDataWithRelease :: Integer -> Integer -> Term constrDataWithRelease chuckSize i = - debruijnTermUnsafe $ comp (i-1) d + debruijnTermUnsafe $ comp (i - 1) d where dataTy = PLC.mkTyBuiltin @_ @PLC.Data () nilData = mkConstant @[PLC.Data] () [] d = mkConstant @PLC.Data () (PLC.I 42) work t = - (apply () - (apply () - (builtin () PLC.ConstrData) - (mkConstant @Integer () 1)) - (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData)) + ( apply + () + ( apply + () + (builtin () PLC.ConstrData) + (mkConstant @Integer () 1) + ) + (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData) + ) comp 0 t = work t comp n t | n `mod` chuckSize == 0 = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x dataTy (comp (n - 1) d)) (work t) | otherwise = runQuote $ do @@ -129,23 +143,28 @@ We make these lambda abstractions and unit binds to keep it fair against 'constr -} constrDataNoRelease :: Integer -> Integer -> Term constrDataNoRelease chuckSize i = - debruijnTermUnsafe $ comp (i-1) d + debruijnTermUnsafe $ comp (i - 1) d where dataTy = PLC.mkTyBuiltin @_ @PLC.Data () nilData = mkConstant @[PLC.Data] () [] d = mkConstant @PLC.Data () (PLC.I 42) work t = - (apply () - (apply () - (builtin () PLC.ConstrData) - (mkConstant @Integer () 1)) - (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData)) + ( apply + () + ( apply + () + (builtin () PLC.ConstrData) + (mkConstant @Integer () 1) + ) + (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData) + ) comp 0 t = work t comp n t | n `mod` chuckSize == 0 = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x dataTy (comp (n - 1) $ work t)) (mkConstant @() () ()) | otherwise = runQuote $ do @@ -165,21 +184,24 @@ Given amount "i" and chuck size, -} listDataWithRelease :: Integer -> Integer -> Term listDataWithRelease chuckSize i = - debruijnTermUnsafe $ comp (i-1) d + debruijnTermUnsafe $ comp (i - 1) d where dataTy = PLC.mkTyBuiltin @_ @PLC.Data () nilData = mkConstant @[PLC.Data] () [] d = mkConstant @PLC.Data () (PLC.I 42) work t = - (apply () - (builtin () PLC.ListData) - (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData)) + ( apply + () + (builtin () PLC.ListData) + (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData) + ) comp 0 t = work t comp n t | n `mod` chuckSize == 0 = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x dataTy (comp (n - 1) d)) (work t) | otherwise = runQuote $ do @@ -203,21 +225,24 @@ We make these lambda abstractions and unit binds to keep it fair against 'listDa -} listDataNoRelease :: Integer -> Integer -> Term listDataNoRelease chuckSize i = - debruijnTermUnsafe $ comp (i-1) d + debruijnTermUnsafe $ comp (i - 1) d where dataTy = PLC.mkTyBuiltin @_ @PLC.Data () nilData = mkConstant @[PLC.Data] () [] d = mkConstant @PLC.Data () (PLC.I 42) work t = - (apply () - (builtin () PLC.ListData) - (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData)) + ( apply + () + (builtin () PLC.ListData) + (apply () (apply () (tyInst () (builtin () PLC.MkCons) dataTy) t) nilData) + ) comp 0 t = work t comp n t | n `mod` chuckSize == 0 = runQuote $ do x <- freshName "x" pure $ - apply () + apply + () (lamAbs () x dataTy (comp (n - 1) $ work t)) (mkConstant @() () ()) | otherwise = runQuote $ do diff --git a/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs b/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs index b7af996df0f..444824250ec 100644 --- a/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs +++ b/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs @@ -1,17 +1,15 @@ -- editorconfig-checker-disable-file {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} -{- | Check how many Ed25519 signature verifications we can perform within the - limits specified in the protocol parameters. --} - +-- | Check how many Ed25519 signature verifications we can perform within the +-- limits specified in the protocol parameters. module PlutusBenchmark.Ed25519.Common (runTests) where @@ -29,9 +27,16 @@ import UntypedPlutusCore qualified as UPLC import PlutusTx.IsData (toData, unstableMakeIsData) import PlutusTx.Prelude as Tx hiding ((*)) -import Cardano.Crypto.DSIGN.Class (ContextDSIGN, DSIGNAlgorithm, Signable, deriveVerKeyDSIGN, - genKeyDSIGN, rawSerialiseSigDSIGN, rawSerialiseVerKeyDSIGN, - signDSIGN) +import Cardano.Crypto.DSIGN.Class ( + ContextDSIGN, + DSIGNAlgorithm, + Signable, + deriveVerKeyDSIGN, + genKeyDSIGN, + rawSerialiseSigDSIGN, + rawSerialiseVerKeyDSIGN, + signDSIGN, + ) import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN) import Cardano.Crypto.Seed (mkSeedFromBytes) @@ -45,21 +50,19 @@ import Prelude (IO, fromIntegral, mapM_, (*)) ---------------- Inputs ---------------- -{- | Generate n public keys P_1,...,P_n (we'll call these the "data keys") and - hash them to get n hashes H_1,...,H_n. Sign all of the hashes with different - private keys K_1,...,K_n (with corresponding public keys V_1,...V_n) to get n - signatures S_1,...,S_n. We create a list of (V_i, H_i, S_i, P_i) tuples, - convert it to Data, and feed that to a script which - - 1. Verifies each (V_i, H_i, S_i) to check that the signatures are valid. - 2. Hashes each P_i to make sure that it matches H_i. - - This program does that for varying values of n and prints statistics about - the size, cpu cost, and memory cost of the script. --} - - +-- | Generate n public keys P_1,...,P_n (we'll call these the "data keys") and +-- hash them to get n hashes H_1,...,H_n. Sign all of the hashes with different +-- private keys K_1,...,K_n (with corresponding public keys V_1,...V_n) to get n +-- signatures S_1,...,S_n. We create a list of (V_i, H_i, S_i, P_i) tuples, +-- convert it to Data, and feed that to a script which +-- +-- 1. Verifies each (V_i, H_i, S_i) to check that the signatures are valid. +-- 2. Hashes each P_i to make sure that it matches H_i. +-- +-- This program does that for varying values of n and prints statistics about +-- the size, cpu cost, and memory cost of the script. data Inputs = Inputs [(BuiltinByteString, BuiltinByteString, BuiltinByteString, BuiltinByteString)] + type HashFun = ByteString -> ByteString type BuiltinHashFun = BuiltinByteString -> BuiltinByteString @@ -74,40 +77,44 @@ builtinHash = Tx.sha2_256 -- Create a list containing n bytestrings of length l. This could be better. listOfByteStringsOfLength :: Integer -> Integer -> [ByteString] -listOfByteStringsOfLength n l = unsafePerformIO . G.sample $ - G.list (R.singleton $ fromIntegral n) - (G.bytes (R.singleton $ fromIntegral l)) +listOfByteStringsOfLength n l = + unsafePerformIO + . G.sample + $ G.list + (R.singleton $ fromIntegral n) + (G.bytes (R.singleton $ fromIntegral l)) {-# OPAQUE listOfByteStringsOfLength #-} -{- | Create a list of valid (verification key, message, signature, data key) - quadruples. The DSIGN infrastructure lets us do this in a fairly generic - way. However, to sign an EcdsaSecp256k1DSIGN message we can't use a raw - bytestring: we have to wrap it up using Crypto.Secp256k1.msg, which checks - that the bytestring is the right length. This means that we have to add a - ByteString -> message conversion function as a parameter here. The full - generality isn't need here, but let's leave it in anyway. --} -mkInputs :: forall v msg . - (Signable v msg, DSIGNAlgorithm v, ContextDSIGN v ~ ()) - => Integer - -> (ByteString -> msg) - -> HashFun - -> Inputs +-- | Create a list of valid (verification key, message, signature, data key) +-- quadruples. The DSIGN infrastructure lets us do this in a fairly generic +-- way. However, to sign an EcdsaSecp256k1DSIGN message we can't use a raw +-- bytestring: we have to wrap it up using Crypto.Secp256k1.msg, which checks +-- that the bytestring is the right length. This means that we have to add a +-- ByteString -> message conversion function as a parameter here. The full +-- generality isn't need here, but let's leave it in anyway. +mkInputs :: + forall v msg. + (Signable v msg, DSIGNAlgorithm v, ContextDSIGN v ~ ()) => + Integer -> + (ByteString -> msg) -> + HashFun -> + Inputs mkInputs n toMsg hash = - Inputs $ List.map mkOneInput (List.zip seeds1 seeds2) - where seedSize = 128 - (seeds1, seeds2) = List.splitAt n $ listOfByteStringsOfLength (2*n) seedSize - -- ^ Seeds for key generation. For some algorithms the seed has to be - -- a certain minimal size and there's a SeedBytesExhausted error if - -- it's not big enough; 128 is big enough for everything here though. - mkOneInput (seed1, seed2) = - let signKey1 = genKeyDSIGN @v $ mkSeedFromBytes seed1 - dataKey = rawSerialiseVerKeyDSIGN $ deriveVerKeyDSIGN signKey1 -- public key to be checked - dataKeyHash = hash dataKey :: ByteString - signKey2 = genKeyDSIGN @v $ mkSeedFromBytes seed2 -- Signing key (private) - vkBytes = rawSerialiseVerKeyDSIGN $ deriveVerKeyDSIGN signKey2 -- Verification key (public) - sigBytes = rawSerialiseSigDSIGN $ signDSIGN () (toMsg dataKeyHash) signKey2 - in (toBuiltin vkBytes, toBuiltin sigBytes, toBuiltin dataKeyHash, toBuiltin dataKey) + Inputs $ List.map mkOneInput (List.zip seeds1 seeds2) + where + seedSize = 128 + (seeds1, seeds2) = List.splitAt n $ listOfByteStringsOfLength (2 * n) seedSize + -- \^ Seeds for key generation. For some algorithms the seed has to be + -- a certain minimal size and there's a SeedBytesExhausted error if + -- it's not big enough; 128 is big enough for everything here though. + mkOneInput (seed1, seed2) = + let signKey1 = genKeyDSIGN @v $ mkSeedFromBytes seed1 + dataKey = rawSerialiseVerKeyDSIGN $ deriveVerKeyDSIGN signKey1 -- public key to be checked + dataKeyHash = hash dataKey :: ByteString + signKey2 = genKeyDSIGN @v $ mkSeedFromBytes seed2 -- Signing key (private) + vkBytes = rawSerialiseVerKeyDSIGN $ deriveVerKeyDSIGN signKey2 -- Verification key (public) + sigBytes = rawSerialiseSigDSIGN $ signDSIGN () (toMsg dataKeyHash) signKey2 + in (toBuiltin vkBytes, toBuiltin sigBytes, toBuiltin dataKeyHash, toBuiltin dataKey) mkInputsAsData :: Integer -> HashFun -> BuiltinData mkInputsAsData n hash = Tx.dataToBuiltinData $ toData (mkInputs @Ed25519DSIGN n id hash) @@ -122,22 +129,23 @@ mkInputsAsData n hash = Tx.dataToBuiltinData $ toData (mkInputs @Ed25519DSIGN n -- verification always succeeds, but let's be careful just in case. verifyInputs :: BuiltinHashFun -> BuiltinData -> Bool verifyInputs hash d = - case Tx.fromBuiltinData d of - Nothing -> Tx.error () - Just (Inputs inputs) -> verify inputs True - where verify [] acc = acc - verify (i:is) acc = verify is (checkInput i && acc) -- checkInput first - checkInput (vk, sg, dkhash, dk) = - let dkhash' = hash dk - hashesEq = dkhash == dkhash' - in Tx.verifyEd25519Signature vk dkhash sg && hashesEq + case Tx.fromBuiltinData d of + Nothing -> Tx.error () + Just (Inputs inputs) -> verify inputs True + where + verify [] acc = acc + verify (i : is) acc = verify is (checkInput i && acc) -- checkInput first + checkInput (vk, sg, dkhash, dk) = + let dkhash' = hash dk + hashesEq = dkhash == dkhash' + in Tx.verifyEd25519Signature vk dkhash sg && hashesEq {-# INLINEABLE verifyInputs #-} -- | Create the input data, convert it to BuiltinData, and apply the -- verification script to that. mkSigCheckScript :: Integer -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () mkSigCheckScript n = - Tx.getPlcNoAnn $ $$(Tx.compile [|| verifyInputs builtinHash ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (mkInputsAsData n haskellHash) + Tx.getPlcNoAnn $ $$(Tx.compile [||verifyInputs builtinHash||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (mkInputsAsData n haskellHash) printSigCheckCosts :: Handle -> Integer -> IO () printSigCheckCosts h n = printSizeStatistics h (TestSize n) (mkSigCheckScript n) @@ -145,13 +153,13 @@ printSigCheckCosts h n = printSizeStatistics h (TestSize n) (mkSigCheckScript n) -- | Check that the Haskell version succeeds on a list of inputs. testHaskell :: Handle -> Integer -> IO () testHaskell h n = - if verifyInputs builtinHash $ mkInputsAsData n haskellHash + if verifyInputs builtinHash $ mkInputsAsData n haskellHash then hPrintf h "Off-chain version succeeded on %d inputs\n" n else hPrintf h "Off-chain version failed\n" runTests :: Handle -> IO () runTests h = do printHeader h - mapM_ (printSigCheckCosts h) [0, 10..150] + mapM_ (printSigCheckCosts h) [0, 10 .. 150] hPrintf h "\n" testHaskell h 100 diff --git a/plutus-benchmark/flat-decode/bench/Main.hs b/plutus-benchmark/flat-decode/bench/Main.hs index 2103a787b65..015c362a2d0 100644 --- a/plutus-benchmark/flat-decode/bench/Main.hs +++ b/plutus-benchmark/flat-decode/bench/Main.hs @@ -1,8 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Main where @@ -22,82 +22,85 @@ import Data.Functor (void) import Data.Vector.Strict qualified as V import Flat -unsafeUnflat :: forall a . Flat a => BS.ByteString -> a +unsafeUnflat :: forall a. Flat a => BS.ByteString -> a unsafeUnflat x = case unflat x of - Left _ -> errorWithoutStackTrace "Can't unflatten" - Right (y::a) -> y + Left _ -> errorWithoutStackTrace "Can't unflatten" + Right (y :: a) -> y -- Make an integer with n decimal digits using the seed k. mkInteger :: Integer -> Integer -> Integer mkInteger n k = if n <= 1 - then k `mod` 10 - else 10 * mkInteger (n-1) (k+1) + (k*k+7*k+1) `mod` 10 + then k `mod` 10 + else 10 * mkInteger (n - 1) (k + 1) + (k * k + 7 * k + 1) `mod` 10 -- Make a semi-random bytestring of length n using the seed k. This will -- repeat after a while, but that's not too important. mkByteString :: Integer -> Integer -> ByteString mkByteString k lim = BS.unfoldr f k - where f n = - if n < lim - then Just (fromIntegral $ n*n+7*n+k, n+1) - else Nothing + where + f n = + if n < lim + then Just (fromIntegral $ n * n + 7 * n + k, n + 1) + else Nothing -- Given a list of (size, object) pairs, create a benchmark for each -- object, labelled with its size. mkBM :: DefaultUni `Contains` a => (Integer, a) -> Benchmark mkBM (sz, a) = let !(script :: SerialisedScript) = force $ serialiseUPLC (mkProg a) - in bench (show sz) $ - whnf (either throw id . void . deserialiseScript futurePV) script + in bench (show sz) $ + whnf (either throw id . void . deserialiseScript futurePV) script -mkProg :: DefaultUni `Contains` a - => a - -> UPLC.Program DeBruijn DefaultUni DefaultFun () +mkProg :: + DefaultUni `Contains` a => + a -> + UPLC.Program DeBruijn DefaultUni DefaultFun () mkProg a = UPLC.Program () plcVersion100 $ mkConstant () a main :: IO () main = - let lengths :: [Integer] = fmap (100 *) [1..20] + let lengths :: [Integer] = fmap (100 *) [1 .. 20] -- For each element `n` of `lengths`, create a benchmark that measures the -- time required to deserialise a UPLC list containing `n` elements -- obtained by applying `mkInput` to [1..n] mkListBMs :: DefaultUni `Contains` a => (Integer -> a) -> [Benchmark] - mkListBMs mkInput = fmap mkBM $ fmap (\n -> (n, fmap mkInput [1..n])) lengths + mkListBMs mkInput = fmap mkBM $ fmap (\n -> (n, fmap mkInput [1 .. n])) lengths -- For each element `n` of `lengths`, create a benchmark that measures the -- time required to deserialise a UPLC array containing `n` elements -- obtained by applying `mkInput` to [1..n] mkArrayBMs :: DefaultUni `Contains` a => (Integer -> a) -> [Benchmark] - mkArrayBMs mkInput = fmap mkBM $ fmap (\n -> (n, fmap mkInput $ V.fromList [1..n])) lengths - - in defaultMain - [ bgroup "list" - [ bgroup "bool" . mkListBMs $ \i -> i `mod` 2 == 0 - , bgroup "integer" - [ - bgroup "small" . mkListBMs $ mkInteger 5 - , bgroup "big" . mkListBMs $ mkInteger 100 - ] - , bgroup "bytestring" - [ - bgroup "small" . mkListBMs $ mkByteString 16 - , bgroup "big" . mkListBMs $ mkByteString 1024 - ] - ] - , bgroup "array" - [ bgroup "bool" . mkArrayBMs $ \i -> i `mod` 2 == 0 - , bgroup "integer" - [ - bgroup "small" . mkArrayBMs $ mkInteger 5 - , bgroup "big" . mkArrayBMs $ mkInteger 100 - ] - , bgroup "bytestring" - [ - bgroup "small" . mkArrayBMs $ mkByteString 16 - , bgroup "big" . mkArrayBMs $ mkByteString 1024 - ] - ] - ] + mkArrayBMs mkInput = fmap mkBM $ fmap (\n -> (n, fmap mkInput $ V.fromList [1 .. n])) lengths + in defaultMain + [ bgroup + "list" + [ bgroup "bool" . mkListBMs $ \i -> i `mod` 2 == 0 + , bgroup + "integer" + [ bgroup "small" . mkListBMs $ mkInteger 5 + , bgroup "big" . mkListBMs $ mkInteger 100 + ] + , bgroup + "bytestring" + [ bgroup "small" . mkListBMs $ mkByteString 16 + , bgroup "big" . mkListBMs $ mkByteString 1024 + ] + ] + , bgroup + "array" + [ bgroup "bool" . mkArrayBMs $ \i -> i `mod` 2 == 0 + , bgroup + "integer" + [ bgroup "small" . mkArrayBMs $ mkInteger 5 + , bgroup "big" . mkArrayBMs $ mkInteger 100 + ] + , bgroup + "bytestring" + [ bgroup "small" . mkArrayBMs $ mkByteString 16 + , bgroup "big" . mkArrayBMs $ mkByteString 1024 + ] + ] + ] diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs index 78dc0d664cf..94dd34e218c 100644 --- a/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Strict #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE NoImplicitPrelude #-} module LinearVesting.Test where @@ -28,41 +28,41 @@ testScriptContext = , scriptContextRedeemer , scriptContextScriptInfo } - where - txInfo = - TxInfo - { txInfoInputs = mempty - , txInfoReferenceInputs = mempty - , txInfoOutputs = mempty - , txInfoTxCerts = mempty - , txInfoRedeemers = Map.empty - , txInfoVotes = Map.empty - , txInfoProposalProcedures = mempty - , txInfoCurrentTreasuryAmount = Nothing - , txInfoTreasuryDonation = Nothing - , txInfoFee = 0 - , txInfoMint = emptyMintValue - , txInfoWdrl = Map.empty - , txInfoValidRange = - Interval - (LowerBound (Finite 110) True) - (UpperBound (Finite 1100) True) - , txInfoSignatories = List.singleton testBeneficiaryPKH - , txInfoData = Map.empty - , txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" - } + where + txInfo = + TxInfo + { txInfoInputs = mempty + , txInfoReferenceInputs = mempty + , txInfoOutputs = mempty + , txInfoTxCerts = mempty + , txInfoRedeemers = Map.empty + , txInfoVotes = Map.empty + , txInfoProposalProcedures = mempty + , txInfoCurrentTreasuryAmount = Nothing + , txInfoTreasuryDonation = Nothing + , txInfoFee = 0 + , txInfoMint = emptyMintValue + , txInfoWdrl = Map.empty + , txInfoValidRange = + Interval + (LowerBound (Finite 110) True) + (UpperBound (Finite 1100) True) + , txInfoSignatories = List.singleton testBeneficiaryPKH + , txInfoData = Map.empty + , txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" + } - scriptContextRedeemer :: Redeemer - scriptContextRedeemer = Redeemer (toBuiltinData FullUnlock) + scriptContextRedeemer :: Redeemer + scriptContextRedeemer = Redeemer (toBuiltinData FullUnlock) - scriptContextScriptInfo :: ScriptInfo - scriptContextScriptInfo = - SpendingScript (TxOutRef txOutRefId txOutRefIdx) (Just datum) - where - txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" - txOutRefIdx = 0 - datum :: Datum - datum = Datum (toBuiltinData testVestingDatum) + scriptContextScriptInfo :: ScriptInfo + scriptContextScriptInfo = + SpendingScript (TxOutRef txOutRefId txOutRefIdx) (Just datum) + where + txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" + txOutRefIdx = 0 + datum :: Datum + datum = Datum (toBuiltinData testVestingDatum) testVestingDatum :: VestingDatum testVestingDatum = diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs index b7ebec3e837..a6b252fa3bc 100644 --- a/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -22,9 +22,9 @@ {-# OPTIONS_GHC -fno-unbox-strict-fields #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-remove-trace #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:preserve-logging #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module LinearVesting.Validator where @@ -39,13 +39,13 @@ import PlutusTx.Data.List (List) import PlutusTx.Data.List qualified as List data VestingDatum = VestingDatum - { beneficiary :: Address - , vestingAsset :: AssetClass - , totalVestingQty :: Integer - , vestingPeriodStart :: Integer - , vestingPeriodEnd :: Integer + { beneficiary :: Address + , vestingAsset :: AssetClass + , totalVestingQty :: Integer + , vestingPeriodStart :: Integer + , vestingPeriodEnd :: Integer , firstUnlockPossibleAfter :: Integer - , totalInstallments :: Integer + , totalInstallments :: Integer } deriving stock (Haskell.Show) @@ -62,12 +62,12 @@ $( PlutusTx.makeIsDataIndexed countInputsAtScript :: ScriptHash -> List TxInInfo -> Integer countInputsAtScript scriptHash = go 0 - where - go :: Integer -> List TxInInfo -> Integer - go n = List.caseList' n \txIn txIns -> - case addressCredential (txOutAddress (txInInfoResolved txIn)) of - ScriptCredential vh | vh == scriptHash -> go (n + 1) txIns - _ -> go n txIns + where + go :: Integer -> List TxInInfo -> Integer + go n = List.caseList' n \txIn txIns -> + case addressCredential (txOutAddress (txInInfoResolved txIn)) of + ScriptCredential vh | vh == scriptHash -> go (n + 1) txIns + _ -> go n txIns validateVestingPartialUnlock :: ScriptContext -> Bool validateVestingPartialUnlock ctx = @@ -162,19 +162,19 @@ typedValidator context = validateVestingFullUnlock $ trace "Full unlock requested" context PartialUnlock -> validateVestingPartialUnlock $ trace "Partial unlock requested" context - where - {-# INLINEABLE redeemer #-} - redeemer :: VestingRedeemer - redeemer = - case fromBuiltinData (getRedeemer (scriptContextRedeemer context)) of - Nothing -> traceError "Failed to parse Redeemer" - Just r -> trace "Parsed Redeemer" r + where + {-# INLINEABLE redeemer #-} + redeemer :: VestingRedeemer + redeemer = + case fromBuiltinData (getRedeemer (scriptContextRedeemer context)) of + Nothing -> traceError "Failed to parse Redeemer" + Just r -> trace "Parsed Redeemer" r {-# INLINEABLE untypedValidator #-} untypedValidator :: BuiltinData -> BuiltinUnit untypedValidator scriptContextData = case trace "Parsing ScriptContext..." (fromBuiltinData scriptContextData) of - Nothing -> traceError "Failed to parse ScriptContext" + Nothing -> traceError "Failed to parse ScriptContext" Just ctx -> check $ typedValidator $ trace "Parsed ScriptContext" ctx validatorCode :: CompiledCode (BuiltinData -> BuiltinUnit) diff --git a/plutus-benchmark/linear-vesting/test/Main.hs b/plutus-benchmark/linear-vesting/test/Main.hs index bdec9328ed9..224ef030075 100644 --- a/plutus-benchmark/linear-vesting/test/Main.hs +++ b/plutus-benchmark/linear-vesting/test/Main.hs @@ -7,15 +7,13 @@ import PlutusTx.Test (goldenBundle') import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc) - main :: IO () main = defaultMain $ do - testGroup "linear-vesting" - [ - runTestGhc [goldenBundle' "main" validatorCodeFullyApplied] + testGroup + "linear-vesting" + [ runTestGhc [goldenBundle' "main" validatorCodeFullyApplied] ] - runTestGhc :: [TestNested] -> TestTree runTestGhc = runTestNested ["linear-vesting", "test"] . pure . testNestedGhc diff --git a/plutus-benchmark/lists/bench/Bench.hs b/plutus-benchmark/lists/bench/Bench.hs index b3adc290d76..a53d8df565c 100644 --- a/plutus-benchmark/lists/bench/Bench.hs +++ b/plutus-benchmark/lists/bench/Bench.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} -{- | Plutus benchmarks for some simple list algorithms. See README.md for more information. -} - +-- | Plutus benchmarks for some simple list algorithms. See README.md for more information. module Main (main) where import Criterion.Main @@ -17,38 +16,44 @@ import Data.Functor benchmarks :: EvaluationContext -> [Benchmark] benchmarks ctx = - [ bgroup "sort" - [ mkBMsForSort "ghcSort" Sort.mkWorstCaseGhcSortTerm + [ bgroup + "sort" + [ mkBMsForSort "ghcSort" Sort.mkWorstCaseGhcSortTerm , mkBMsForSort "insertionSort" Sort.mkWorstCaseInsertionSortTerm - , mkBMsForSort "mergeSort" Sort.mkWorstCaseMergeSortTerm - , mkBMsForSort "quickSort" Sort.mkWorstCaseQuickSortTerm + , mkBMsForSort "mergeSort" Sort.mkWorstCaseMergeSortTerm + , mkBMsForSort "quickSort" Sort.mkWorstCaseQuickSortTerm ] - , bgroup "sum" - [ bgroup "compiled-from-Haskell" - [ mkBMsForSum "sum-right-builtin" Sum.Compiled.mkSumRightBuiltinTerm - , mkBMsForSum "sum-right-Scott" Sum.Compiled.mkSumRightScottTerm - , mkBMsForSum "sum-right-data" Sum.Compiled.mkSumRightDataTerm - , mkBMsForSum "sum-left-builtin" Sum.Compiled.mkSumLeftBuiltinTerm - , mkBMsForSum "sum-left-Scott" Sum.Compiled.mkSumLeftScottTerm - , mkBMsForSum "sum-left-data" Sum.Compiled.mkSumLeftDataTerm - ] - , bgroup "hand-written-PLC" - [ mkBMsForSum "sum-right-builtin" Sum.HandWritten.mkSumRightBuiltinTerm - , mkBMsForSum "sum-right-Scott" Sum.HandWritten.mkSumRightScottTerm - , mkBMsForSum "sum-left-builtin" Sum.HandWritten.mkSumLeftBuiltinTerm - , mkBMsForSum "sum-left-Scott" Sum.HandWritten.mkSumLeftScottTerm - ] + , bgroup + "sum" + [ bgroup + "compiled-from-Haskell" + [ mkBMsForSum "sum-right-builtin" Sum.Compiled.mkSumRightBuiltinTerm + , mkBMsForSum "sum-right-Scott" Sum.Compiled.mkSumRightScottTerm + , mkBMsForSum "sum-right-data" Sum.Compiled.mkSumRightDataTerm + , mkBMsForSum "sum-left-builtin" Sum.Compiled.mkSumLeftBuiltinTerm + , mkBMsForSum "sum-left-Scott" Sum.Compiled.mkSumLeftScottTerm + , mkBMsForSum "sum-left-data" Sum.Compiled.mkSumLeftDataTerm + ] + , bgroup + "hand-written-PLC" + [ mkBMsForSum "sum-right-builtin" Sum.HandWritten.mkSumRightBuiltinTerm + , mkBMsForSum "sum-right-Scott" Sum.HandWritten.mkSumRightScottTerm + , mkBMsForSum "sum-left-builtin" Sum.HandWritten.mkSumLeftBuiltinTerm + , mkBMsForSum "sum-left-Scott" Sum.HandWritten.mkSumLeftScottTerm + ] ] - ] - where - mkBMsForSort name f = - bgroup name $ sizesForSort <&> \n -> + ] + where + mkBMsForSort name f = + bgroup name $ + sizesForSort <&> \n -> bench (show n) $ benchTermCek ctx (f n) - sizesForSort = [50, 100..300] - mkBMsForSum name f = - bgroup name $ sizesForSum <&> \n -> - bench (show n) $ benchTermCek ctx (f [1..n]) - sizesForSum = [100, 500, 1000, 2500, 5000] + sizesForSort = [50, 100 .. 300] + mkBMsForSum name f = + bgroup name $ + sizesForSum <&> \n -> + bench (show n) $ benchTermCek ctx (f [1 .. n]) + sizesForSum = [100, 500, 1000, 2500, 5000] main :: IO () main = do diff --git a/plutus-benchmark/lists/exe/Main.hs b/plutus-benchmark/lists/exe/Main.hs index 62fc545d8a0..12dfe919ff5 100644 --- a/plutus-benchmark/lists/exe/Main.hs +++ b/plutus-benchmark/lists/exe/Main.hs @@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{- | This compiles several list-sorting algorithms to Plutus Core and runs them on - worst-case inputs, reporting the CPU cost in ExUnits. -} - +-- | This compiles several list-sorting algorithms to Plutus Core and runs them on +-- worst-case inputs, reporting the CPU cost in ExUnits. module Main where import Data.HashMap.Monoidal qualified as H @@ -20,57 +19,64 @@ import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek getBudgetUsage :: Term -> Maybe Integer getBudgetUsage term = - case (\(Cek.CekReport fstT sndT _) -> (Cek.cekResultToEither fstT, sndT)) $ - Cek.runCekDeBruijn PLC.defaultCekParametersForTesting Cek.counting Cek.noEmitter term - of - (Left _, _) -> Nothing - (Right _, Cek.CountingSt c) -> - let ExCPU cpu = exBudgetCPU c in Just $ fromSatInt cpu + case (\(Cek.CekReport fstT sndT _) -> (Cek.cekResultToEither fstT, sndT)) $ + Cek.runCekDeBruijn PLC.defaultCekParametersForTesting Cek.counting Cek.noEmitter term of + (Left _, _) -> Nothing + (Right _, Cek.CountingSt c) -> + let ExCPU cpu = exBudgetCPU c in Just $ fromSatInt cpu getCekSteps :: Term -> Maybe Integer getCekSteps term = - case (\(Cek.CekReport fstT sndT _) -> (Cek.cekResultToEither fstT, sndT)) $ - Cek.runCekDeBruijn PLC.unitCekParameters Cek.tallying Cek.noEmitter term - of - (Left _, _) -> Nothing - (Right _, Cek.TallyingSt (Cek.CekExTally counts) _) -> - let getCount k = - case H.lookup k counts of - Just v -> let ExCPU n = exBudgetCPU v in fromSatInt n - Nothing -> 0 - allNodeTags = - fmap - Cek.BStep - [Cek.BConst, Cek.BVar, Cek.BLamAbs, Cek.BApply, Cek.BDelay, Cek.BForce, - Cek.BBuiltin] - totalComputeSteps = sum $ map getCount allNodeTags - in Just totalComputeSteps + case (\(Cek.CekReport fstT sndT _) -> (Cek.cekResultToEither fstT, sndT)) $ + Cek.runCekDeBruijn PLC.unitCekParameters Cek.tallying Cek.noEmitter term of + (Left _, _) -> Nothing + (Right _, Cek.TallyingSt (Cek.CekExTally counts) _) -> + let getCount k = + case H.lookup k counts of + Just v -> let ExCPU n = exBudgetCPU v in fromSatInt n + Nothing -> 0 + allNodeTags = + fmap + Cek.BStep + [ Cek.BConst + , Cek.BVar + , Cek.BLamAbs + , Cek.BApply + , Cek.BDelay + , Cek.BForce + , Cek.BBuiltin + ] + totalComputeSteps = sum $ map getCount allNodeTags + in Just totalComputeSteps getInfo :: Term -> Maybe (Integer, Integer) getInfo term = - case (getBudgetUsage term, getCekSteps term) of - (Just c, Just n) -> Just (c,n) - _ -> Nothing + case (getBudgetUsage term, getCekSteps term) of + (Just c, Just n) -> Just (c, n) + _ -> Nothing -- Create a term sorting a list of length n and execute it in counting mode then -- tallying mode and print out the cost and the number of CEK compute steps. printSortStatistics :: (Integer -> Term) -> Integer -> IO () printSortStatistics termMaker n = - let term = termMaker n - in case getInfo term of - Nothing -> putStrLn "Error during execution" - Just (cpu, steps) -> - putStr $ printf "%-4d %5s ms %16s %14s\n" - n - (PLC.show $ cpu`div` 1000000000) - ("(" ++ PLC.show cpu ++ ")") - (PLC.show steps) + let term = termMaker n + in case getInfo term of + Nothing -> putStrLn "Error during execution" + Just (cpu, steps) -> + putStr $ + printf + "%-4d %5s ms %16s %14s\n" + n + (PLC.show $ cpu `div` 1000000000) + ("(" ++ PLC.show cpu ++ ")") + (PLC.show steps) main :: IO () main = do - let inputLengths = [10,20..500] - header = "Length Cost (ms) Cost (ps) CEK steps\n" - ++ "------------------------------------------------" + let inputLengths = [10, 20 .. 500] + header = + "Length Cost (ms) Cost (ps) CEK steps\n" + ++ "------------------------------------------------" putStrLn "GHC sort" putStrLn "" putStrLn header diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Lookup/Compiled.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Lookup/Compiled.hs index 8653b7f8ca8..d11ddee456c 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Lookup/Compiled.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Lookup/Compiled.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} + module PlutusBenchmark.Lists.Lookup.Compiled where import PlutusTx qualified as Tx @@ -29,11 +30,12 @@ type Workload f = (f Integer, f Integer, f Integer, f Integer) workloadOfSize :: Integer -> Workload [] workloadOfSize sz = let - lixs = [0 .. (sz-1)] + lixs = [0 .. (sz - 1)] rixs = reverse lixs - ls = take (fromIntegral sz) [1,3 ..] - rs = take (fromIntegral sz) [1,2..] - in (lixs, rixs, ls, rs) + ls = take (fromIntegral sz) [1, 3 ..] + rs = take (fromIntegral sz) [1, 2 ..] + in + (lixs, rixs, ls, rs) workloadLToBl :: Workload [] -> Workload BI.BuiltinList workloadLToBl (lixs, rixs, ls, rs) = @@ -42,12 +44,12 @@ workloadLToBl (lixs, rixs, ls, rs) = matchWithLists :: Workload [] -> Integer matchWithLists (lixs, rixs, ls, rs) = go lixs rixs 0 where - go (lix:lrest) (rix:rrest) acc = + go (lix : lrest) (rix : rrest) acc = go lrest rrest ((ls L.!! lix) `B.addInteger` (rs L.!! rix) `B.addInteger` acc) go _ _ acc = acc mkMatchWithListsCode :: Workload [] -> Tx.CompiledCode Integer -mkMatchWithListsCode l = $$(Tx.compile [|| matchWithLists ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l +mkMatchWithListsCode l = $$(Tx.compile [||matchWithLists||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l matchWithBuiltinLists :: Workload BI.BuiltinList -> Integer matchWithBuiltinLists (lixs, rixs, ls, rs) = go lixs rixs 0 @@ -56,9 +58,17 @@ matchWithBuiltinLists (lixs, rixs, ls, rs) = go lixs rixs 0 B.matchList' ltodo acc - (\lix lrest -> B.matchList' rtodo acc - (\rix rrest -> go lrest rrest - ((ls !! lix) `B.addInteger` (rs !! rix) `B.addInteger` acc))) + ( \lix lrest -> + B.matchList' + rtodo + acc + ( \rix rrest -> + go + lrest + rrest + ((ls !! lix) `B.addInteger` (rs !! rix) `B.addInteger` acc) + ) + ) l !! ix = B.matchList' l @@ -68,4 +78,4 @@ matchWithBuiltinLists (lixs, rixs, ls, rs) = go lixs rixs 0 mkMatchWithBuiltinListsCode :: Workload [] -> Tx.CompiledCode Integer mkMatchWithBuiltinListsCode l = - $$(Tx.compile [|| matchWithBuiltinLists ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (workloadLToBl l) + $$(Tx.compile [||matchWithBuiltinLists||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (workloadLToBl l) diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort.hs index 6591ac35022..e7a9c82a76e 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort.hs @@ -4,4 +4,3 @@ import PlutusBenchmark.Lists.Sort.GhcSort as Export import PlutusBenchmark.Lists.Sort.InsertionSort as Export import PlutusBenchmark.Lists.Sort.MergeSort as Export import PlutusBenchmark.Lists.Sort.QuickSort as Export - diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/GhcSort.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/GhcSort.hs index 810e8eb4d45..0396a7f6d42 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/GhcSort.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/GhcSort.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{- | Merge sort implementation based on GHC's 'sort' function -} +-- | Merge sort implementation based on GHC's 'sort' function module PlutusBenchmark.Lists.Sort.GhcSort where import PlutusBenchmark.Common (Term, compiledCodeToTerm) @@ -13,48 +13,50 @@ import PlutusTx qualified as Tx import PlutusTx.Plugin () import PlutusTx.Prelude as Tx -{- | GHC's 'sort' algorithm specialised to Integer. - See https://hackage.haskell.org/package/base-4.15.0.0/docs/src/Data-OldList.html#sortBy --} +-- | GHC's 'sort' algorithm specialised to Integer. +-- See https://hackage.haskell.org/package/base-4.15.0.0/docs/src/Data-OldList.html#sortBy ghcSort :: [Integer] -> [Integer] ghcSort = mergeAll . sequences where - sequences (a:b:xs) - | a > b = descending b [a] xs - | otherwise = ascending b (a:) xs + sequences (a : b : xs) + | a > b = descending b [a] xs + | otherwise = ascending b (a :) xs sequences xs = [xs] {- This detects ascending and descending subsequences of a list, reverses the descending ones, and accumulates the results in a list. For example, [1,2,9,5,4,7,2,8] -> [[1,2,9],[4,5],[2,7],[8]]. -} - descending a as (b:bs) - | a > b = descending b (a:as) bs - descending a as bs = (a:as): sequences bs + descending a as (b : bs) + | a > b = descending b (a : as) bs + descending a as bs = (a : as) : sequences bs - ascending a as (b:bs) - | a <= b = ascending b (\ys -> as (a:ys)) bs - ascending a as bs = let !x = as [a] - in x : sequences bs + ascending a as (b : bs) + | a <= b = ascending b (\ys -> as (a : ys)) bs + ascending a as bs = + let !x = as [a] + in x : sequences bs mergeAll [x] = x - mergeAll xs = mergeAll (mergePairs xs) + mergeAll xs = mergeAll (mergePairs xs) - mergePairs (a:b:xs) = let !x = merge a b - in x : mergePairs xs - mergePairs xs = xs + mergePairs (a : b : xs) = + let !x = merge a b + in x : mergePairs xs + mergePairs xs = xs {- Merge adjoining pairs of ordered lists to get a new list of ordered lists then recurse on that; we're doing a kind of binary tree of merges, and I think that this (maybe along with some benefits from laziness when we're running this in Haskell) is what makes this algorithm faster than standard mergesort. -} - merge as@(a:as') bs@(b:bs') = -- Same as in mergeSort - if a <= b - then a:(merge as' bs) - else b:(merge as bs') + merge as@(a : as') bs@(b : bs') = + -- Same as in mergeSort + if a <= b + then a : (merge as' bs) + else b : (merge as bs') merge [] bs = bs merge as [] = as -{-# INLINABLE ghcSort #-} +{-# INLINEABLE ghcSort #-} {- I think the worst case input should be about the same as for mergesort. The worst case for 'sequences' is when we start with a list of alternately @@ -73,8 +75,7 @@ ghcSortWorstCase = mergeSortWorstCase mkGhcSortTerm :: [Integer] -> Term mkGhcSortTerm l = - compiledCodeToTerm $ $$(Tx.compile [|| ghcSort ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l + compiledCodeToTerm $ $$(Tx.compile [||ghcSort||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l mkWorstCaseGhcSortTerm :: Integer -> Term mkWorstCaseGhcSortTerm = mkGhcSortTerm . ghcSortWorstCase - diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/InsertionSort.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/InsertionSort.hs index 304815e0c42..6e9d0a32f38 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/InsertionSort.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/InsertionSort.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{- | Simple insertion sort implementation -} +-- | Simple insertion sort implementation module PlutusBenchmark.Lists.Sort.InsertionSort where import PlutusBenchmark.Common (Term, compiledCodeToTerm) @@ -13,24 +13,26 @@ import PlutusTx.Prelude insertionSort :: [Integer] -> [Integer] insertionSort l0 = sort l0 [] - where sort [] r = r - sort (n:ns) r = sort ns (insert n r) - insert n acc = - case acc of - [] -> [n] - m:ms -> if n <= m - then n:acc - else m:(insert n ms) -{-# INLINABLE insertionSort #-} + where + sort [] r = r + sort (n : ns) r = sort ns (insert n r) + insert n acc = + case acc of + [] -> [n] + m : ms -> + if n <= m + then n : acc + else m : (insert n ms) +{-# INLINEABLE insertionSort #-} {- The worst case should be when the list is already sorted, since then whenever we insert a new element in the accumulator it'll have to go at the very end. -} insertionSortWorstCase :: Integer -> [Integer] -insertionSortWorstCase n = [1..n] +insertionSortWorstCase n = [1 .. n] mkInsertionSortTerm :: [Integer] -> Term mkInsertionSortTerm l = - compiledCodeToTerm $ $$(Tx.compile [|| insertionSort ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l + compiledCodeToTerm $ $$(Tx.compile [||insertionSort||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l mkWorstCaseInsertionSortTerm :: Integer -> Term mkWorstCaseInsertionSortTerm = mkInsertionSortTerm . insertionSortWorstCase diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/MergeSort.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/MergeSort.hs index 88bd794251d..6e734c6db8f 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/MergeSort.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/MergeSort.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} - {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -{- | Simple merge sort implementation -} +-- | Simple merge sort implementation module PlutusBenchmark.Lists.Sort.MergeSort where import PlutusBenchmark.Common (Term, compiledCodeToTerm) @@ -15,22 +14,23 @@ import PlutusTx.Plugin () import PlutusTx.Prelude as Tx merge :: [Integer] -> [Integer] -> [Integer] -merge as@(a:as') bs@(b:bs') = - if a <= b - then a:(merge as' bs) - else b:(merge as bs') +merge as@(a : as') bs@(b : bs') = + if a <= b + then a : (merge as' bs) + else b : (merge as bs') merge [] bs = bs merge as [] = as -{-# INLINABLE merge #-} +{-# INLINEABLE merge #-} mergeSort :: [Integer] -> [Integer] mergeSort xs = - let n = length xs - in if n > 1 - then let n2 = n `divide` 2 - in merge (mergeSort (take n2 xs)) (mergeSort (drop n2 xs)) - else xs -{-# INLINABLE mergeSort #-} + let n = length xs + in if n > 1 + then + let n2 = n `divide` 2 + in merge (mergeSort (take n2 xs)) (mergeSort (drop n2 xs)) + else xs +{-# INLINEABLE mergeSort #-} {- I think this is approximately the worst case. A lot of the work happens in merge and this should make sure that the maximal amount of interleaving is @@ -39,22 +39,23 @@ mergeSort xs = [1,5,3,7,2,6,4,8], which leads to merge [1,3,5,7] [2,4,6,8], and we have to go all the way to 1:2:3:4:5:6:7:(merge [] [8]) to merge those. -} mergeSortWorstCase :: Integer -> [Integer] -mergeSortWorstCase n = f [1..n] - where f ls = - let (left, right) = unzip2 ls [] [] - in case (left, right) of - ([],_) -> right - (_,[]) -> left - _ -> f left ++ f right - unzip2 l lacc racc = - case l of - [] -> (reverse lacc, reverse racc) - [a] -> (reverse(a:lacc), reverse racc) - (a:b:rest) -> unzip2 rest (a:lacc) (b:racc) +mergeSortWorstCase n = f [1 .. n] + where + f ls = + let (left, right) = unzip2 ls [] [] + in case (left, right) of + ([], _) -> right + (_, []) -> left + _ -> f left ++ f right + unzip2 l lacc racc = + case l of + [] -> (reverse lacc, reverse racc) + [a] -> (reverse (a : lacc), reverse racc) + (a : b : rest) -> unzip2 rest (a : lacc) (b : racc) mkMergeSortTerm :: [Integer] -> Term mkMergeSortTerm l = - compiledCodeToTerm $ $$(Tx.compile [|| mergeSort ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l + compiledCodeToTerm $ $$(Tx.compile [||mergeSort||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l mkWorstCaseMergeSortTerm :: Integer -> Term mkWorstCaseMergeSortTerm = mkMergeSortTerm . mergeSortWorstCase diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/QuickSort.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/QuickSort.hs index 89f4d0731ba..130c6233a05 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/QuickSort.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sort/QuickSort.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{- | Simple quicksort implementation. -} +-- | Simple quicksort implementation. module PlutusBenchmark.Lists.Sort.QuickSort where import PlutusBenchmark.Common (Term, compiledCodeToTerm) @@ -13,17 +13,20 @@ import PlutusTx.Plugin () import PlutusTx.Prelude as Tx quickSort :: [Integer] -> [Integer] -quickSort [] = [] -quickSort (n:ns) = (quickSort $ before n ns []) ++ (n:(quickSort $ after n ns [])) - where before _ [] r = r -- Elements < x - before x (y:ys) r = if y < x - then before x ys (y:r) - else before x ys r - after _ [] r = r - after x (y:ys) r = if y >= x -- Elements >= x - then after x ys (y:r) - else after x ys r -{-# INLINABLE quickSort #-} +quickSort [] = [] +quickSort (n : ns) = (quickSort $ before n ns []) ++ (n : (quickSort $ after n ns [])) + where + before _ [] r = r -- Elements < x + before x (y : ys) r = + if y < x + then before x ys (y : r) + else before x ys r + after _ [] r = r + after x (y : ys) r = + if y >= x -- Elements >= x + then after x ys (y : r) + else after x ys r +{-# INLINEABLE quickSort #-} {- The worst case is when the list is already sorted (or reverse sorted) because then if the list has n elements you have to recurse n times, scanning a list @@ -32,11 +35,11 @@ quickSort (n:ns) = (quickSort $ before n ns []) ++ (n:(quickSort $ after n ns [] then four of length (n-3)/4, and so on. For this version a reverse-sorted input seems to be marginally slower than a properly-sorted input. -} quickSortWorstCase :: Integer -> [Integer] -quickSortWorstCase n = reverse [1..n] +quickSortWorstCase n = reverse [1 .. n] mkQuickSortTerm :: [Integer] -> Term mkQuickSortTerm l = - compiledCodeToTerm $ $$(Tx.compile [|| quickSort ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l + compiledCodeToTerm $ $$(Tx.compile [||quickSort||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l mkWorstCaseQuickSortTerm :: Integer -> Term mkWorstCaseQuickSortTerm = mkQuickSortTerm . quickSortWorstCase diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/Compiled.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/Compiled.hs index 8f650d83755..84912895314 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/Compiled.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/Compiled.hs @@ -1,5 +1,5 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} @@ -15,37 +15,36 @@ import PlutusTx.Prelude import Prelude (($!)) - ---------------- Folding over Scott lists ---------------- foldLeftScott :: (b -> a -> b) -> b -> [a] -> b -foldLeftScott _ z [] = z -foldLeftScott f z (x:xs) = foldLeftScott f (f z x) xs -{-# INLINABLE foldLeftScott #-} +foldLeftScott _ z [] = z +foldLeftScott f z (x : xs) = foldLeftScott f (f z x) xs +{-# INLINEABLE foldLeftScott #-} sumLeftScott :: [Integer] -> Integer sumLeftScott l = foldLeftScott (+) 0 l -{-# INLINABLE sumLeftScott #-} +{-# INLINEABLE sumLeftScott #-} foldRightScott :: (a -> b -> b) -> b -> [a] -> b -foldRightScott _ z [] = z -foldRightScott f z (x:xs) = f x $! (foldRightScott f z xs) -{-# INLINABLE foldRightScott #-} +foldRightScott _ z [] = z +foldRightScott f z (x : xs) = f x $! (foldRightScott f z xs) +{-# INLINEABLE foldRightScott #-} sumRightScott :: [Integer] -> Integer sumRightScott l = foldRightScott (+) 0 l -{-# INLINABLE sumRightScott #-} +{-# INLINEABLE sumRightScott #-} -- Compiling to PLC terms mkSumLeftScottCode :: [Integer] -> Tx.CompiledCode Integer -mkSumLeftScottCode l = $$(Tx.compile [|| sumLeftScott ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l +mkSumLeftScottCode l = $$(Tx.compile [||sumLeftScott||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l -mkSumLeftScottTerm :: [Integer] -> Term +mkSumLeftScottTerm :: [Integer] -> Term mkSumLeftScottTerm l = compiledCodeToTerm $ mkSumLeftScottCode l mkSumRightScottCode :: [Integer] -> Tx.CompiledCode Integer -mkSumRightScottCode l = $$(Tx.compile [|| sumRightScott ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l +mkSumRightScottCode l = $$(Tx.compile [||sumRightScott||]) `Tx.unsafeApplyCode` Tx.liftCodeDef l mkSumRightScottTerm :: [Integer] -> Term mkSumRightScottTerm l = compiledCodeToTerm $ mkSumRightScottCode l @@ -54,30 +53,30 @@ mkSumRightScottTerm l = compiledCodeToTerm $ mkSumRightScottCode l foldLeftBuiltin :: (b -> a -> b) -> b -> BuiltinList a -> b foldLeftBuiltin f z l = B.matchList' l z (\x xs -> (foldLeftBuiltin f (f z x) xs)) -{-# INLINABLE foldLeftBuiltin #-} +{-# INLINEABLE foldLeftBuiltin #-} sumLeftBuiltin :: BuiltinList Integer -> Integer sumLeftBuiltin l = foldLeftBuiltin B.addInteger 0 l -{-# INLINABLE sumLeftBuiltin #-} +{-# INLINEABLE sumLeftBuiltin #-} foldRightBuiltin :: (a -> b -> b) -> b -> BuiltinList a -> b foldRightBuiltin f z l = B.matchList' l z (\x xs -> f x $! (foldRightBuiltin f z xs)) -{-# INLINABLE foldRightBuiltin #-} +{-# INLINEABLE foldRightBuiltin #-} sumRightBuiltin :: BuiltinList Integer -> Integer sumRightBuiltin l = foldRightBuiltin B.addInteger 0 l -{-# INLINABLE sumRightBuiltin #-} +{-# INLINEABLE sumRightBuiltin #-} -- Compiling to PLC terms mkSumRightBuiltinCode :: [Integer] -> Tx.CompiledCode Integer -mkSumRightBuiltinCode l = $$(Tx.compile [|| sumRightBuiltin ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (BI.BuiltinList l) +mkSumRightBuiltinCode l = $$(Tx.compile [||sumRightBuiltin||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (BI.BuiltinList l) mkSumRightBuiltinTerm :: [Integer] -> Term mkSumRightBuiltinTerm l = compiledCodeToTerm $ mkSumRightBuiltinCode l mkSumLeftBuiltinCode :: [Integer] -> Tx.CompiledCode Integer -mkSumLeftBuiltinCode l = $$(Tx.compile [|| sumLeftBuiltin ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (BI.BuiltinList l) +mkSumLeftBuiltinCode l = $$(Tx.compile [||sumLeftBuiltin||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (BI.BuiltinList l) mkSumLeftBuiltinTerm :: [Integer] -> Term mkSumLeftBuiltinTerm l = compiledCodeToTerm $ mkSumLeftBuiltinCode l @@ -90,7 +89,7 @@ That is, rather than relying on the PIR compiler or explicit Scott encoding, we use the Constr constructor of Data. This is a slightly odd way to do things, but is apparently how Aiken encodes -*all* structured data, so it's instructive to benchmark it against other approaches. +\*all* structured data, so it's instructive to benchmark it against other approaches. Data lists don't perform that well, unsurprisingly, since constructing/deconstructing a list encoded in this way requires several builtin operations to get through the @@ -99,7 +98,7 @@ a list encoded in this way requires several builtin operations to get through th type DataList = BuiltinData -matchDataList :: forall r . DataList -> r -> (BuiltinData -> DataList -> r) -> r +matchDataList :: forall r. DataList -> r -> (BuiltinData -> DataList -> r) -> r matchDataList l nilCase consCase = B.matchData' l @@ -110,42 +109,45 @@ matchDataList l nilCase consCase = (\_ -> error ()) where handleConstr tag values = - if tag == 0 then nilCase - else if tag == 1 then B.matchList values error (\h t -> consCase h (BI.head t)) - else error () + if tag == 0 + then nilCase + else + if tag == 1 + then B.matchList values error (\h t -> consCase h (BI.head t)) + else error () foldLeftData :: (b -> BuiltinData -> b) -> b -> DataList -> b foldLeftData f z l = matchDataList l z (\x xs -> (foldLeftData f (f z x) xs)) -{-# INLINABLE foldLeftData #-} +{-# INLINEABLE foldLeftData #-} sumLeftData :: DataList -> Integer sumLeftData l = foldLeftData (\acc d -> B.addInteger acc (BI.unsafeDataAsI d)) 0 l -{-# INLINABLE sumLeftData #-} +{-# INLINEABLE sumLeftData #-} foldRightData :: (BuiltinData -> b -> b) -> b -> DataList -> b foldRightData f z l = matchDataList l z (\x xs -> f x $! (foldRightData f z xs)) -{-# INLINABLE foldRightData #-} +{-# INLINEABLE foldRightData #-} sumRightData :: DataList -> Integer sumRightData l = foldRightData (\d acc -> B.addInteger (BI.unsafeDataAsI d) acc) 0 l -{-# INLINABLE sumRightData #-} +{-# INLINEABLE sumRightData #-} -- Compiling to PLC terms listToDataList :: [Integer] -> DataList listToDataList l = Tx.dataToBuiltinData (go l) where - go [] = Tx.Constr 0 [] - go (x:xs) = Tx.Constr 1 [Tx.I x, go xs] + go [] = Tx.Constr 0 [] + go (x : xs) = Tx.Constr 1 [Tx.I x, go xs] mkSumRightDataCode :: [Integer] -> Tx.CompiledCode Integer -mkSumRightDataCode l = $$(Tx.compile [|| sumRightData ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (listToDataList l) +mkSumRightDataCode l = $$(Tx.compile [||sumRightData||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (listToDataList l) mkSumRightDataTerm :: [Integer] -> Term mkSumRightDataTerm l = compiledCodeToTerm $ mkSumRightDataCode l mkSumLeftDataCode :: [Integer] -> Tx.CompiledCode Integer -mkSumLeftDataCode l = $$(Tx.compile [|| sumLeftData ||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (listToDataList l) +mkSumLeftDataCode l = $$(Tx.compile [||sumLeftData||]) `Tx.unsafeApplyCode` Tx.liftCodeDef (listToDataList l) mkSumLeftDataTerm :: [Integer] -> Term mkSumLeftDataTerm l = compiledCodeToTerm $ mkSumLeftDataCode l diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs index 398910c8330..f92500b25ee 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs @@ -15,7 +15,6 @@ import PlutusTx qualified as Tx import PlutusTx.Builtins.Internal qualified as BI import UntypedPlutusCore qualified as UPLC - ---------------- Hand-written folds, using stuff from PlutusCore.StdLib.Data ---------------- mkBuiltinList :: [Integer] -> Term @@ -23,11 +22,11 @@ mkBuiltinList l = compiledCodeToTerm (Tx.liftCodeDef $ BI.BuiltinList l) mkSumLeftBuiltinTerm :: [Integer] -> Term mkSumLeftBuiltinTerm l = - UPLC.Apply () (debruijnTermUnsafe $ eraseTerm (BuiltinList.sum UseChoose)) (mkBuiltinList l) + UPLC.Apply () (debruijnTermUnsafe $ eraseTerm (BuiltinList.sum UseChoose)) (mkBuiltinList l) mkSumRightBuiltinTerm :: [Integer] -> Term mkSumRightBuiltinTerm l = - UPLC.Apply () (debruijnTermUnsafe $ eraseTerm (BuiltinList.sumr UseChoose)) (mkBuiltinList l) + UPLC.Apply () (debruijnTermUnsafe $ eraseTerm (BuiltinList.sumr UseChoose)) (mkBuiltinList l) mkScottList :: [Integer] -> Term mkScottList l = compiledCodeToTerm (Tx.liftCode PLC.plcVersion100 l) @@ -37,10 +36,10 @@ mkSumLeftScottTerm l = UPLC.Apply () (debruijnTermUnsafe $ eraseTerm ScottList.s mkSumRightScottTerm :: [Integer] -> Term mkSumRightScottTerm l = - UPLC.Apply () (debruijnTermUnsafe $ eraseTerm ScottList.sumr) (mkScottList l) - + UPLC.Apply () (debruijnTermUnsafe $ eraseTerm ScottList.sumr) (mkScottList l) -debruijnTermUnsafe :: UPLC.Term UPLC.Name uni fun ann - -> UPLC.Term UPLC.NamedDeBruijn uni fun ann +debruijnTermUnsafe :: + UPLC.Term UPLC.Name uni fun ann -> + UPLC.Term UPLC.NamedDeBruijn uni fun ann debruijnTermUnsafe = - fromRight (error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm + fromRight (error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm diff --git a/plutus-benchmark/lists/test/Lookup/Spec.hs b/plutus-benchmark/lists/test/Lookup/Spec.hs index e02edf33f2c..39c48cbe348 100644 --- a/plutus-benchmark/lists/test/Lookup/Spec.hs +++ b/plutus-benchmark/lists/test/Lookup/Spec.hs @@ -17,9 +17,9 @@ tests = runTestGhc ["Lookup"] $ flip concatMap sizes $ \sz -> [ Tx.goldenEvalCekCatchBudget ("match-scott-list-" ++ show sz) $ - Compiled.mkMatchWithListsCode (Compiled.workloadOfSize sz) + Compiled.mkMatchWithListsCode (Compiled.workloadOfSize sz) , Tx.goldenEvalCekCatchBudget ("match-builtin-list-" ++ show sz) $ - Compiled.mkMatchWithBuiltinListsCode (Compiled.workloadOfSize sz) + Compiled.mkMatchWithBuiltinListsCode (Compiled.workloadOfSize sz) ] where sizes = [5, 10, 50, 100] diff --git a/plutus-benchmark/lists/test/Sort/Spec.hs b/plutus-benchmark/lists/test/Sort/Spec.hs index cde75dc1a50..a623e580018 100644 --- a/plutus-benchmark/lists/test/Sort/Spec.hs +++ b/plutus-benchmark/lists/test/Sort/Spec.hs @@ -8,9 +8,9 @@ import PlutusBenchmark.Common (Term, cekResultMatchesHaskellValue) import PlutusBenchmark.Lists.Sort qualified as Sort isSorted :: Ord a => [a] -> Bool -isSorted [] = True -isSorted [_] = True -isSorted (a:b:cs) = a <= b && isSorted (b:cs) +isSorted [] = True +isSorted [_] = True +isSorted (a : b : cs) = a <= b && isSorted (b : cs) -- | Check that a Haskell implementation of a sorting function really does sort -- its input. @@ -24,14 +24,15 @@ prop_PlutusOK sort termMaker l = cekResultMatchesHaskellValue (termMaker l) (=== tests :: TestTree tests = - testGroup "plutus-benchmark list-sort tests" - [ testProperty "GHC sort (Haskell)" $ prop_HaskellOK Sort.ghcSort - , testProperty "GHC sort (Plutus)" $ prop_PlutusOK Sort.ghcSort Sort.mkGhcSortTerm + testGroup + "plutus-benchmark list-sort tests" + [ testProperty "GHC sort (Haskell)" $ prop_HaskellOK Sort.ghcSort + , testProperty "GHC sort (Plutus)" $ prop_PlutusOK Sort.ghcSort Sort.mkGhcSortTerm , testProperty "insertion sort (Haskell)" $ prop_HaskellOK Sort.insertionSort - , testProperty "insertion sort (Plutus)" $ - prop_PlutusOK Sort.insertionSort Sort.mkInsertionSortTerm - , testProperty "merge sort (Haskell)" $ prop_HaskellOK Sort.mergeSort - , testProperty "merge sort (Plutus)" $ prop_PlutusOK Sort.mergeSort Sort.mkMergeSortTerm - , testProperty "quicksort (Haskell)" $ prop_HaskellOK Sort.quickSort - , testProperty "quicksort (Plutus)" $ prop_PlutusOK Sort.quickSort Sort.mkQuickSortTerm + , testProperty "insertion sort (Plutus)" $ + prop_PlutusOK Sort.insertionSort Sort.mkInsertionSortTerm + , testProperty "merge sort (Haskell)" $ prop_HaskellOK Sort.mergeSort + , testProperty "merge sort (Plutus)" $ prop_PlutusOK Sort.mergeSort Sort.mkMergeSortTerm + , testProperty "quicksort (Haskell)" $ prop_HaskellOK Sort.quickSort + , testProperty "quicksort (Plutus)" $ prop_PlutusOK Sort.quickSort Sort.mkQuickSortTerm ] diff --git a/plutus-benchmark/lists/test/Spec.hs b/plutus-benchmark/lists/test/Spec.hs index 005669a1895..4a8b7fcf7b6 100644 --- a/plutus-benchmark/lists/test/Spec.hs +++ b/plutus-benchmark/lists/test/Spec.hs @@ -1,7 +1,6 @@ -{- | Tests for the sorting and summation functions. We're benchmarking PLC - programs which are compiled from Haskell or are hand-written, so let's make - sure that they do what they're supposed to. -} - +-- | Tests for the sorting and summation functions. We're benchmarking PLC +-- programs which are compiled from Haskell or are hand-written, so let's make +-- sure that they do what they're supposed to. module Main (main) where import Test.Tasty @@ -12,7 +11,8 @@ import Sum.Spec qualified as Sum allTests :: TestTree allTests = - testGroup "plutus-benchmark list tests" + testGroup + "plutus-benchmark list tests" [ Sort.tests , Sum.tests , Lookup.tests diff --git a/plutus-benchmark/lists/test/Sum/Spec.hs b/plutus-benchmark/lists/test/Sum/Spec.hs index 6c989fef2dd..48021084c6a 100644 --- a/plutus-benchmark/lists/test/Sum/Spec.hs +++ b/plutus-benchmark/lists/test/Sum/Spec.hs @@ -18,32 +18,35 @@ runTestGhc :: [FilePath] -> [TestNested] -> TestTree runTestGhc path = runTestNested (["lists", "test"] ++ path) . pure . testNestedGhc -- | Check that the various summation functions all give the same result as 'sum' - prop_sum :: ([Integer] -> Term) -> [Integer] -> Property prop_sum termMaker l = cekResultMatchesHaskellValue (termMaker l) (===) (sum l) tests :: TestTree tests = - testGroup "plutus-benchmark list-sum tests" - [ testGroup "correct evaluation" - [ testProperty "Handwritten right fold (Scott lists)" $ prop_sum HandWritten.mkSumRightScottTerm - , testProperty "Handwritten right fold (built-in lists)" $ prop_sum HandWritten.mkSumRightBuiltinTerm - , testProperty "Compiled right fold (Scott lists)" $ prop_sum Compiled.mkSumRightScottTerm - , testProperty "Compiled right fold (built-in lists)" $ prop_sum Compiled.mkSumRightBuiltinTerm - , testProperty "Compiled right fold (data lists)" $ prop_sum Compiled.mkSumRightDataTerm - , testProperty "Handwritten left fold (Scott lists)" $ prop_sum HandWritten.mkSumLeftScottTerm - , testProperty "Handwritten left fold (built-in lists)" $ prop_sum HandWritten.mkSumLeftBuiltinTerm - , testProperty "Compiled left fold (Scott lists)" $ prop_sum Compiled.mkSumLeftScottTerm - , testProperty "Compiled left fold (built-in lists)" $ prop_sum Compiled.mkSumLeftBuiltinTerm - , testProperty "Compiled left fold (data lists)" $ prop_sum Compiled.mkSumLeftDataTerm - ] - , runTestGhc ["Sum"] - [ Tx.goldenEvalCekCatchBudget "right-fold-scott" $ Compiled.mkSumRightScottCode input - , Tx.goldenEvalCekCatchBudget "right-fold-built-in" $ Compiled.mkSumRightBuiltinCode input - , Tx.goldenEvalCekCatchBudget "right-fold-data" $ Compiled.mkSumRightDataCode input - , Tx.goldenEvalCekCatchBudget "left-fold-scott" $ Compiled.mkSumLeftScottCode input - , Tx.goldenEvalCekCatchBudget "left-fold-built-in" $ Compiled.mkSumLeftBuiltinCode input - , Tx.goldenEvalCekCatchBudget "left-fold-data" $ Compiled.mkSumLeftDataCode input - ] + testGroup + "plutus-benchmark list-sum tests" + [ testGroup + "correct evaluation" + [ testProperty "Handwritten right fold (Scott lists)" $ prop_sum HandWritten.mkSumRightScottTerm + , testProperty "Handwritten right fold (built-in lists)" $ prop_sum HandWritten.mkSumRightBuiltinTerm + , testProperty "Compiled right fold (Scott lists)" $ prop_sum Compiled.mkSumRightScottTerm + , testProperty "Compiled right fold (built-in lists)" $ prop_sum Compiled.mkSumRightBuiltinTerm + , testProperty "Compiled right fold (data lists)" $ prop_sum Compiled.mkSumRightDataTerm + , testProperty "Handwritten left fold (Scott lists)" $ prop_sum HandWritten.mkSumLeftScottTerm + , testProperty "Handwritten left fold (built-in lists)" $ prop_sum HandWritten.mkSumLeftBuiltinTerm + , testProperty "Compiled left fold (Scott lists)" $ prop_sum Compiled.mkSumLeftScottTerm + , testProperty "Compiled left fold (built-in lists)" $ prop_sum Compiled.mkSumLeftBuiltinTerm + , testProperty "Compiled left fold (data lists)" $ prop_sum Compiled.mkSumLeftDataTerm + ] + , runTestGhc + ["Sum"] + [ Tx.goldenEvalCekCatchBudget "right-fold-scott" $ Compiled.mkSumRightScottCode input + , Tx.goldenEvalCekCatchBudget "right-fold-built-in" $ Compiled.mkSumRightBuiltinCode input + , Tx.goldenEvalCekCatchBudget "right-fold-data" $ Compiled.mkSumRightDataCode input + , Tx.goldenEvalCekCatchBudget "left-fold-scott" $ Compiled.mkSumLeftScottCode input + , Tx.goldenEvalCekCatchBudget "left-fold-built-in" $ Compiled.mkSumLeftBuiltinCode input + , Tx.goldenEvalCekCatchBudget "left-fold-data" $ Compiled.mkSumLeftDataCode input + ] ] - where input = [1..100] + where + input = [1 .. 100] diff --git a/plutus-benchmark/marlowe/bench/Shared.hs b/plutus-benchmark/marlowe/bench/Shared.hs index 1e7c6c99f13..be23801d0c0 100644 --- a/plutus-benchmark/marlowe/bench/Shared.hs +++ b/plutus-benchmark/marlowe/bench/Shared.hs @@ -4,20 +4,23 @@ module Shared where import Criterion.Main (Benchmark, Benchmarkable, bench, bgroup, defaultMainWith) import PlutusBenchmark.Common (Program, getConfig) -import PlutusBenchmark.Marlowe.BenchUtil (benchmarkToUPLC, rolePayoutBenchmarks, - semanticsBenchmarks) +import PlutusBenchmark.Marlowe.BenchUtil ( + benchmarkToUPLC, + rolePayoutBenchmarks, + semanticsBenchmarks, + ) import PlutusBenchmark.Marlowe.Scripts.RolePayout (rolePayoutValidator) import PlutusBenchmark.Marlowe.Scripts.Semantics (marloweValidator) import PlutusBenchmark.Marlowe.Types qualified as M import PlutusLedgerApi.V2 (scriptContextTxInfo, txInfoId) import PlutusTx.Code (CompiledCode) -mkBenchmarkable - :: (Program -> Benchmarkable) - -> CompiledCode a - -> M.Benchmark - -> (String, Benchmarkable) -mkBenchmarkable benchmarker validator bm@M.Benchmark{..} = +mkBenchmarkable :: + (Program -> Benchmarkable) -> + CompiledCode a -> + M.Benchmark -> + (String, Benchmarkable) +mkBenchmarkable benchmarker validator bm@M.Benchmark {..} = let benchName = show $ txInfoId $ scriptContextTxInfo bScriptContext in (benchName, benchmarker $ benchmarkToUPLC validator bm) diff --git a/plutus-benchmark/marlowe/exe/Main.hs b/plutus-benchmark/marlowe/exe/Main.hs index 643b352bdea..b38b09966ce 100644 --- a/plutus-benchmark/marlowe/exe/Main.hs +++ b/plutus-benchmark/marlowe/exe/Main.hs @@ -7,16 +7,19 @@ import Data.ByteString qualified as BS (writeFile) import Data.ByteString.Base16 qualified as B16 (encode) import Data.List (intercalate) import PlutusBenchmark.Common (getDataDir) -import PlutusBenchmark.Marlowe.BenchUtil (rolePayoutBenchmarks, semanticsBenchmarks, - tabulateResults, writeFlatUPLCs) +import PlutusBenchmark.Marlowe.BenchUtil ( + rolePayoutBenchmarks, + semanticsBenchmarks, + tabulateResults, + writeFlatUPLCs, + ) import PlutusBenchmark.Marlowe.RolePayout qualified as RolePayout import PlutusBenchmark.Marlowe.Semantics qualified as Semantics import PlutusLedgerApi.V2 (ScriptHash, SerialisedScript) import System.FilePath (normalise, ()) -{-| Run the benchmarks and export information about -the validators and the benchmarking results. --} +-- | Run the benchmarks and export information about +-- the validators and the benchmarking results. main :: IO () main = do dir <- normalise <$> getDataDir @@ -72,19 +75,18 @@ main = do RolePayout.validatorBytes -- | Print information about a validator. -printValidator - :: String - -- ^ The name of the validator. - -> FilePath - -- ^ The base file path for exported files. - -> ScriptHash - -- ^ The hash of the validator script. - -> SerialisedScript - -- ^ The serialised validator. - -> IO () - {- ^ Action to print the information about the benchmarking, - and write the files. - -} +printValidator :: + -- | The name of the validator. + String -> + -- | The base file path for exported files. + FilePath -> + -- | The hash of the validator script. + ScriptHash -> + -- | The serialised validator. + SerialisedScript -> + -- | Action to print the information about the benchmarking, + -- and write the files. + IO () printValidator name file hash validator = do putStrLn $ name <> ":" putStrLn $ " Validator hash: " <> show hash diff --git a/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/RolePayout.hs b/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/RolePayout.hs index 868024a1e2e..1355d01f474 100644 --- a/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/RolePayout.hs +++ b/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/RolePayout.hs @@ -10,17 +10,36 @@ module PlutusBenchmark.Marlowe.RolePayout ( import Data.Bifunctor (second) import PlutusBenchmark.Marlowe.BenchUtil (readBenchmarks, updateScriptHash, writeFlatUPLC) -import PlutusBenchmark.Marlowe.Scripts.RolePayout (rolePayoutValidator, rolePayoutValidatorBytes, - rolePayoutValidatorHash) +import PlutusBenchmark.Marlowe.Scripts.RolePayout ( + rolePayoutValidator, + rolePayoutValidatorBytes, + rolePayoutValidatorHash, + ) import PlutusBenchmark.Marlowe.Types (Benchmark (..), makeBenchmark) -import PlutusBenchmark.Marlowe.Util (lovelace, makeBuiltinData, makeDatumMap, makeInput, makeOutput, - makeRedeemerMap) -import PlutusLedgerApi.V2 (Credential (PubKeyCredential, ScriptCredential), CurrencySymbol (..), - ExBudget (ExBudget), Extended (NegInf, PosInf), Interval (Interval), - LowerBound (LowerBound), - ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), - ScriptHash, ScriptPurpose (Spending), SerialisedScript, TxInfo (..), - TxOutRef (TxOutRef), UpperBound (UpperBound), singleton) +import PlutusBenchmark.Marlowe.Util ( + lovelace, + makeBuiltinData, + makeDatumMap, + makeInput, + makeOutput, + makeRedeemerMap, + ) +import PlutusLedgerApi.V2 ( + Credential (PubKeyCredential, ScriptCredential), + CurrencySymbol (..), + ExBudget (ExBudget), + Extended (NegInf, PosInf), + Interval (Interval), + LowerBound (LowerBound), + ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), + ScriptHash, + ScriptPurpose (Spending), + SerialisedScript, + TxInfo (..), + TxOutRef (TxOutRef), + UpperBound (UpperBound), + singleton, + ) import PlutusLedgerApi.V1.Value (TokenName (TokenName)) import PlutusTx.AssocMap qualified as AM (empty) @@ -44,7 +63,7 @@ benchmarks = -- | Revise the validator hashes in the benchmark's script context. rescript :: Benchmark -> Benchmark -rescript benchmark@Benchmark{..} = +rescript benchmark@Benchmark {..} = benchmark { bScriptContext = updateScriptHash @@ -125,7 +144,7 @@ exampleBenchmark = "95de9e2c3bface3de5739c0bd5197f0864315c1819c52783afb9b2ce075215f5" "d8799f581cd768a767450e9ffa2d68ae61e8476fb6267884e0477d7fd19703f9d84653656c6c6572ff" txInfoId = "4e16f03a5533f22adbc5097a07077f3b708b1bf74b42e6b2938dd2d4156207f0" - scriptContextTxInfo = TxInfo{..} + scriptContextTxInfo = TxInfo {..} scriptContextPurpose = Spending $ TxOutRef "ef6a9ef1b84bef3dad5e12d9bf128765595be4a92da45bda2599dc7fae7e2397" 1 in @@ -134,5 +153,5 @@ exampleBenchmark = "d8799f581cd768a767450e9ffa2d68ae61e8476fb6267884e0477d7fd19703f9d84653656c6c6572ff" ) (makeBuiltinData "d87980") - ScriptContext{..} + ScriptContext {..} (Just $ ExBudget 477988519 1726844) diff --git a/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Semantics.hs b/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Semantics.hs index 42aed6bebcd..05c6839615b 100644 --- a/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Semantics.hs +++ b/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Semantics.hs @@ -9,19 +9,37 @@ module PlutusBenchmark.Marlowe.Semantics ( ) where import PlutusBenchmark.Marlowe.BenchUtil (writeFlatUPLC) -import PlutusBenchmark.Marlowe.Scripts.Semantics (marloweValidator, marloweValidatorBytes, - marloweValidatorHash) +import PlutusBenchmark.Marlowe.Scripts.Semantics ( + marloweValidator, + marloweValidatorBytes, + marloweValidatorHash, + ) import PlutusBenchmark.Marlowe.Types (Benchmark (..), makeBenchmark) -import PlutusBenchmark.Marlowe.Util (lovelace, makeBuiltinData, makeDatumMap, makeInput, makeOutput, - makeRedeemerMap) +import PlutusBenchmark.Marlowe.Util ( + lovelace, + makeBuiltinData, + makeDatumMap, + makeInput, + makeOutput, + makeRedeemerMap, + ) import PlutusLedgerApi.V1.Value (TokenName (TokenName)) -import PlutusLedgerApi.V2 (Credential (PubKeyCredential, ScriptCredential), CurrencySymbol (..), - ExBudget (ExBudget), Extended (..), Interval (Interval), - LowerBound (LowerBound), - ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), - ScriptHash, ScriptPurpose (Spending), SerialisedScript, - TxInfo (TxInfo, txInfoDCert, txInfoData, txInfoFee, txInfoId, txInfoInputs, txInfoMint, txInfoOutputs, txInfoRedeemers, txInfoReferenceInputs, txInfoSignatories, txInfoValidRange, txInfoWdrl), - TxOutRef (TxOutRef), UpperBound (UpperBound), singleton) +import PlutusLedgerApi.V2 ( + Credential (PubKeyCredential, ScriptCredential), + CurrencySymbol (..), + ExBudget (ExBudget), + Extended (..), + Interval (Interval), + LowerBound (LowerBound), + ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), + ScriptHash, + ScriptPurpose (Spending), + SerialisedScript, + TxInfo (TxInfo, txInfoDCert, txInfoData, txInfoFee, txInfoId, txInfoInputs, txInfoMint, txInfoOutputs, txInfoRedeemers, txInfoReferenceInputs, txInfoSignatories, txInfoValidRange, txInfoWdrl), + TxOutRef (TxOutRef), + UpperBound (UpperBound), + singleton, + ) import PlutusTx.AssocMap qualified as AM (empty, unionWith) -- | The serialised Marlowe semantics validator. @@ -33,10 +51,10 @@ validatorHash :: ScriptHash validatorHash = marloweValidatorHash -- | Write flat UPLC for a benchmark. -writeUPLC - :: FilePath - -> Benchmark - -> IO () +writeUPLC :: + FilePath -> + Benchmark -> + IO () writeUPLC = writeFlatUPLC marloweValidator {-# DEPRECATED exampleBenchmark "Experimental, not thoroughly tested." #-} @@ -121,7 +139,7 @@ exampleBenchmark = "d8799fd8799f581c8bb3b343d8e404472337966a722150048c768d0a92a9813596c5338dffd8799fa1d8799fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd8799f4040ffff1a047868c0a1d8799f51466f756e6420476c6f626520546f6b656ed87a9f45476c6f6265ffff00a01b000001883109fc30ffd87c9f9fd8799fd87a9fd8799f50466f756e64205377616e20546f6b656ed87a9f445377616effff9fd8799f0000ffffffd87c9f9fd8799fd87a9fd8799f56466f756e64204265617247617264656e20546f6b656ed87a9f4a4265617247617264656effff9fd8799f0000ffffffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f45476c6f6265ffffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f445377616effffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f4a4265617247617264656effffd8799f4040ffd87a9f1a017d7840ffd87980ffffffffff1b0000018831ac75f0d87980ffffff1b0000018831758770d87980ffff" ) txInfoId = "b5b18fb63795bada186cc4b3876cb9a924467f0d64984c84886b58f7a907f8db" - scriptContextTxInfo = TxInfo{..} + scriptContextTxInfo = TxInfo {..} scriptContextPurpose = Spending $ TxOutRef "04688f43cf473ddcc27aeef0c9ccae1d7efb97d83a1dfc946d2ab36ba91a91b9" 1 in @@ -132,5 +150,5 @@ exampleBenchmark = ( makeBuiltinData "9fd8799fd87a9fd8799f51466f756e6420476c6f626520546f6b656ed87a9f45476c6f6265ffff00ffffff" ) - ScriptContext{..} + ScriptContext {..} (Just $ ExBudget 4808532 1297175159) diff --git a/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Util.hs b/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Util.hs index e5ef07f717f..76cd56c278b 100644 --- a/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Util.hs +++ b/plutus-benchmark/marlowe/exe/PlutusBenchmark/Marlowe/Util.hs @@ -10,12 +10,28 @@ module PlutusBenchmark.Marlowe.Util ( ) where import Codec.Serialise (deserialise) -import PlutusLedgerApi.V2 (Address (Address), BuiltinData, Credential (..), Datum (Datum), - DatumHash, LedgerBytes (getLedgerBytes), - OutputDatum (NoOutputDatum, OutputDatumHash), Redeemer (Redeemer), - ScriptHash, ScriptPurpose, TxId, TxInInfo (..), TxOut (..), - TxOutRef (TxOutRef), Value, adaSymbol, adaToken, dataToBuiltinData, - fromBuiltin, singleton) +import PlutusLedgerApi.V2 ( + Address (Address), + BuiltinData, + Credential (..), + Datum (Datum), + DatumHash, + LedgerBytes (getLedgerBytes), + OutputDatum (NoOutputDatum, OutputDatumHash), + Redeemer (Redeemer), + ScriptHash, + ScriptPurpose, + TxId, + TxInInfo (..), + TxOut (..), + TxOutRef (TxOutRef), + Value, + adaSymbol, + adaToken, + dataToBuiltinData, + fromBuiltin, + singleton, + ) import Data.ByteString.Lazy qualified as LBS (fromStrict) import PlutusTx.AssocMap qualified as AM (Map, singleton) @@ -25,35 +41,35 @@ lovelace :: Integer -> Value lovelace = singleton adaSymbol adaToken -- Construct a `TxInInfo`. -makeInput - :: TxId - -> Integer - -> Credential - -> Value - -> Maybe DatumHash - -> Maybe ScriptHash - -> TxInInfo +makeInput :: + TxId -> + Integer -> + Credential -> + Value -> + Maybe DatumHash -> + Maybe ScriptHash -> + TxInInfo makeInput txId txIx credential value datum script = TxInInfo (TxOutRef txId txIx) (makeOutput credential value datum script) -- Construct a `TxOut`. -makeOutput - :: Credential - -> Value - -> Maybe DatumHash - -> Maybe ScriptHash - -> TxOut +makeOutput :: + Credential -> + Value -> + Maybe DatumHash -> + Maybe ScriptHash -> + TxOut makeOutput credential value = TxOut (Address credential Nothing) value . maybe NoOutputDatum OutputDatumHash -- Construct a map of redeemers. -makeRedeemerMap - :: ScriptPurpose - -> LedgerBytes - -> AM.Map ScriptPurpose Redeemer +makeRedeemerMap :: + ScriptPurpose -> + LedgerBytes -> + AM.Map ScriptPurpose Redeemer makeRedeemerMap = (. (Redeemer . makeBuiltinData)) . AM.singleton -- Construct a map of datum hashes to datums. diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs index fcc73d4818f..0c90bf3ca75 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs @@ -35,8 +35,13 @@ import PlutusBenchmark.Marlowe.Types qualified as M import PlutusCore.Default qualified as PLC import PlutusCore.Executable.AstIO (fromNamedDeBruijnUPLC) import PlutusCore.Executable.Common (writeProgram) -import PlutusCore.Executable.Types (AstNameType (NamedDeBruijn), Format (Flat), Output (FileOutput), - PrintMode (Readable), UplcProg) +import PlutusCore.Executable.Types ( + AstNameType (NamedDeBruijn), + Format (Flat), + Output (FileOutput), + PrintMode (Readable), + UplcProg, + ) import PlutusCore.MkPlc (mkConstant) import PlutusLedgerApi.Common.Versions import PlutusLedgerApi.V2 @@ -48,24 +53,23 @@ import UntypedPlutusCore (NamedDeBruijn, Program (..), applyProgram) import UntypedPlutusCore.Core.Type qualified as UPLC -- | Turn a `PlutusBenchmark.Marlowe.Types.Benchmark` to a UPLC program. -benchmarkToUPLC - :: CompiledCode a - -- ^ semantics or role payout validator. - -> M.Benchmark - {- ^ `PlutusBenchmark.Marlowe.Types.Benchmark`, benchmarking type used by - the executable, it includes benchmarking results along with script info. - -} - -> UPLC.Program NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () - -- ^ A named DeBruijn program, for turning to `Benchmarkable`. -benchmarkToUPLC validator M.Benchmark{..} = +benchmarkToUPLC :: + -- | semantics or role payout validator. + CompiledCode a -> + -- | `PlutusBenchmark.Marlowe.Types.Benchmark`, benchmarking type used by + -- the executable, it includes benchmarking results along with script info. + M.Benchmark -> + -- | A named DeBruijn program, for turning to `Benchmarkable`. + UPLC.Program NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () +benchmarkToUPLC validator M.Benchmark {..} = foldl1 (unsafeFromEither .* applyProgram) $ void prog : [datum, redeemer, context] - where - wrap = UPLC.Program () (UPLC.Version 1 0 0) - datum = wrap $ mkConstant () bDatum - redeemer = wrap $ mkConstant () bRedeemer - context = wrap $ mkConstant () $ toData bScriptContext - prog = getPlc validator + where + wrap = UPLC.Program () (UPLC.Version 1 0 0) + datum = wrap $ mkConstant () bDatum + redeemer = wrap $ mkConstant () bRedeemer + context = wrap $ mkConstant () $ toData bScriptContext + prog = getPlc validator -- | Read all of the benchmarking cases for a particular validator. readBenchmarks :: FilePath -> IO (Either String [Benchmark]) @@ -92,28 +96,28 @@ readBenchmark filename = do ExBudget (fromInteger cpu) (fromInteger memory) - pure Benchmark{..} + pure Benchmark {..} _ -> Left "Failed deserializing benchmark file." -- Rewrite all of a particular script hash in the script context. updateScriptHash :: ScriptHash -> ScriptHash -> ScriptContext -> ScriptContext updateScriptHash oldHash newHash scriptContext = - scriptContext{scriptContextTxInfo = txInfo'} - where - updateAddress address@(Address (ScriptCredential hash) stakeCredential) - | hash == oldHash = Address (ScriptCredential newHash) stakeCredential - | otherwise = address - updateAddress address = address - updateTxOut txOut@TxOut{..} = - txOut{txOutAddress = updateAddress txOutAddress} - updateTxInInfo txInInfo@TxInInfo{..} = - txInInfo{txInInfoResolved = updateTxOut txInInfoResolved} - txInfo@TxInfo{..} = scriptContextTxInfo scriptContext - txInfo' = - txInfo - { txInfoInputs = updateTxInInfo <$> txInfoInputs - , txInfoOutputs = updateTxOut <$> txInfoOutputs - } + scriptContext {scriptContextTxInfo = txInfo'} + where + updateAddress address@(Address (ScriptCredential hash) stakeCredential) + | hash == oldHash = Address (ScriptCredential newHash) stakeCredential + | otherwise = address + updateAddress address = address + updateTxOut txOut@TxOut {..} = + txOut {txOutAddress = updateAddress txOutAddress} + updateTxInInfo txInInfo@TxInInfo {..} = + txInInfo {txInInfoResolved = updateTxOut txInInfoResolved} + txInfo@TxInfo {..} = scriptContextTxInfo scriptContext + txInfo' = + txInfo + { txInfoInputs = updateTxInInfo <$> txInfoInputs + , txInfoOutputs = updateTxOut <$> txInfoOutputs + } {- | Revise the validator hashes in the benchmark's script context. Reasons: @@ -128,7 +132,7 @@ it checking for another Marlowe script running in the same transaction. Thus, the script context needs editing here, too. -} rescript :: Benchmark -> Benchmark -rescript benchmark@Benchmark{..} = +rescript benchmark@Benchmark {..} = benchmark { bScriptContext = updateScriptHash @@ -150,7 +154,7 @@ rolePayoutBenchmarks = second (rescript <$>) <$> readBenchmarks "marlowe/scripts -- | Print a benchmarking case. printBenchmark :: Benchmark -> IO () -printBenchmark Benchmark{..} = do +printBenchmark Benchmark {..} = do putStrLn "*** DATUM ***" print (fromData bDatum :: Maybe MarloweData) putStrLn "*** REDEEMER ***" @@ -161,13 +165,13 @@ printBenchmark Benchmark{..} = do print bReferenceCost -- | Run and print the results of benchmarking. -printResult - :: SerialisedScript - -- ^ The serialised validator. - -> Benchmark - -- ^ The benchmarking case. - -> IO () - -- ^ The action to run and print the results. +printResult :: + -- | The serialised validator. + SerialisedScript -> + -- | The benchmarking case. + Benchmark -> + -- | The action to run and print the results. + IO () printResult validator benchmark = case executeBenchmark validator benchmark of Right (_, Right budget) -> @@ -181,17 +185,17 @@ printResult validator benchmark = Left msg -> print msg -- | Run multiple benchmarks and organize their results in a table. -tabulateResults - :: String - -- ^ The name of the validator. - -> ScriptHash - -- ^ The hash of the validator script. - -> SerialisedScript - -- ^ The serialisation of the validator script. - -> [Benchmark] - -- ^ The benchmarking cases. - -> [[String]] - -- ^ A table of results, with a header in the first line. +tabulateResults :: + -- | The name of the validator. + String -> + -- | The hash of the validator script. + ScriptHash -> + -- | The serialisation of the validator script. + SerialisedScript -> + -- | The benchmarking cases. + [Benchmark] -> + -- | A table of results, with a header in the first line. + [[String]] tabulateResults name hash validator benchmarks = let na = "NA" @@ -222,7 +226,7 @@ tabulateResults name hash validator benchmarks = , show (logs, msg) ] Left msg -> [na, na, cpuRef, memoryRef, show msg] - | benchmark@Benchmark{..} <- benchmarks + | benchmark@Benchmark {..} <- benchmarks , let txId = txInfoId $ scriptContextTxInfo bScriptContext cpuRef = maybe na (show . unExCPU . exBudgetCPU) bReferenceCost @@ -231,21 +235,21 @@ tabulateResults name hash validator benchmarks = ] -- | Write flat UPLC files for benchmarks. -writeFlatUPLCs - :: (FilePath -> Benchmark -> IO ()) - -> [Benchmark] - -> FilePath - -> IO () +writeFlatUPLCs :: + (FilePath -> Benchmark -> IO ()) -> + [Benchmark] -> + FilePath -> + IO () writeFlatUPLCs writer benchmarks folder = sequence_ [ writer (folder show txId <> "-uplc" <.> "flat") benchmark - | benchmark@Benchmark{..} <- benchmarks + | benchmark@Benchmark {..} <- benchmarks , let txId = txInfoId $ scriptContextTxInfo bScriptContext ] -- | Write a flat UPLC file for a benchmark. writeFlatUPLC :: CompiledCode a -> FilePath -> Benchmark -> IO () -writeFlatUPLC validator filename Benchmark{..} = +writeFlatUPLC validator filename Benchmark {..} = let wrap = Program () (Version 1 0 0) datum = wrap $ mkConstant () bDatum :: UplcProg () @@ -259,14 +263,14 @@ writeFlatUPLC validator filename Benchmark{..} = writeProgram (FileOutput filename) (Flat NamedDeBruijn) Readable applied -- | Run a benchmark case. -executeBenchmark - :: SerialisedScript - -- ^ The serialised validator. - -> Benchmark - -- ^ The benchmarking case. - -> Either String (LogOutput, Either EvaluationError ExBudget) - -- ^ An error or the cost. -executeBenchmark serialisedValidator Benchmark{..} = +executeBenchmark :: + -- | The serialised validator. + SerialisedScript -> + -- | The benchmarking case. + Benchmark -> + -- | An error or the cost. + Either String (LogOutput, Either EvaluationError ExBudget) +executeBenchmark serialisedValidator Benchmark {..} = case evaluationContext of Left message -> Left message Right ec -> diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics.hs index efa5396d53a..62d7e4d79e9 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics.hs @@ -1,12 +1,12 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -O0 #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -18,27 +18,26 @@ {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-| = Marlowe: financial contracts domain specific language for blockchain - - Here we present a reference implementation of Marlowe, domain-specific - language targeted at the execution of financial contracts in the style - of Peyton Jones et al on Cardano. - - This is the Haskell implementation of Marlowe semantics for Cardano. - - == Semantics - - Semantics is based on - - - Marlowe Contract execution is a chain of transactions, - where remaining contract and its state is passed through /Datum/, - and actions (i.e. /Choices/) are passed as - /Redeemer Script/ - - /Validation Script/ is always the same Marlowe interpreter implementation, - available below. --} +-- | = Marlowe: financial contracts domain specific language for blockchain +-- +-- Here we present a reference implementation of Marlowe, domain-specific +-- language targeted at the execution of financial contracts in the style +-- of Peyton Jones et al on Cardano. +-- +-- This is the Haskell implementation of Marlowe semantics for Cardano. +-- +-- == Semantics +-- +-- Semantics is based on +-- +-- +-- Marlowe Contract execution is a chain of transactions, +-- where remaining contract and its state is passed through /Datum/, +-- and actions (i.e. /Choices/) are passed as +-- /Redeemer Script/ +-- +-- /Validation Script/ is always the same Marlowe interpreter implementation, +-- available below. module PlutusBenchmark.Marlowe.Core.V1.Semantics ( -- * Semantics MarloweData (MarloweData, marloweParams, marloweState, marloweContract), @@ -99,19 +98,32 @@ import PlutusTx.Foldable (foldMap) import PlutusTx.IsData (makeIsDataIndexed) import PlutusTx.Lift (makeLift) import PlutusTx.List -import PlutusTx.Prelude (AdditiveGroup ((-)), AdditiveSemigroup ((+)), Bool (..), Eq (..), Integer, - Maybe (..), MultiplicativeSemigroup ((*)), - Ord (max, min, (<), (<=), (>), (>=)), fst, negate, not, otherwise, snd, - ($), (&&), (||)) +import PlutusTx.Prelude ( + AdditiveGroup ((-)), + AdditiveSemigroup ((+)), + Bool (..), + Eq (..), + Integer, + Maybe (..), + MultiplicativeSemigroup ((*)), + Ord (max, min, (<), (<=), (>), (>=)), + fst, + negate, + not, + otherwise, + snd, + ($), + (&&), + (||), + ) import PlutusLedgerApi.V2 qualified as Val import PlutusTx.AssocMap qualified as Map import PlutusTx.Builtins qualified as Builtins import Prelude qualified as Haskell -{-| Payment occurs during 'Pay' contract evaluation, and - when positive balances are payed out on contract closure. --} +-- | Payment occurs during 'Pay' contract evaluation, and +-- when positive balances are payed out on contract closure. data Payment = Payment AccountId Payee Token Integer deriving stock (Haskell.Eq, Haskell.Show, Data) @@ -193,7 +205,7 @@ data TransactionError -- | Marlowe transaction input. data TransactionInput = TransactionInput { txInterval :: TimeInterval - , txInputs :: [Input] + , txInputs :: [Input] } deriving stock (Haskell.Show, Haskell.Eq, Data) @@ -202,7 +214,7 @@ data TransactionOutput = TransactionOutput { txOutWarnings :: [TransactionWarning] , txOutPayments :: [Payment] - , txOutState :: State + , txOutState :: State , txOutContract :: Contract } | Error TransactionError @@ -248,8 +260,8 @@ fixInterval interval state = newLow = max low curMinTime -- We know high is greater or equal than newLow (prove) curInterval = (newLow, high) - env = Environment{timeInterval = curInterval} - newState = state{minTime = newLow} + env = Environment {timeInterval = curInterval} + newState = state {minTime = newLow} in if high < curMinTime then IntervalError (IntervalInPastError curMinTime interval) @@ -281,7 +293,7 @@ evalValue env state value = -- the initial state's `choices` in Isabelle was sorted and -- did not contain duplicate entries. case Map.lookup choiceId (choices state) of - Just x -> x + Just x -> x Nothing -> 0 TimeIntervalStart -> getPOSIXTime (fst (timeInterval env)) TimeIntervalEnd -> getPOSIXTime (snd (timeInterval env)) @@ -292,7 +304,7 @@ evalValue env state value = -- the initial state's `boundValues` in Isabelle was sorted -- and did not contain duplicate entries. case Map.lookup valId (boundValues state) of - Just x -> x + Just x -> x Nothing -> 0 Cond cond thn els -> if evalObservation env state cond @@ -307,22 +319,22 @@ evalObservation env state obs = evalVal = evalValue env state in case obs of - AndObs lhs rhs -> evalObs lhs && evalObs rhs - OrObs lhs rhs -> evalObs lhs || evalObs rhs - NotObs subObs -> not (evalObs subObs) + AndObs lhs rhs -> evalObs lhs && evalObs rhs + OrObs lhs rhs -> evalObs lhs || evalObs rhs + NotObs subObs -> not (evalObs subObs) -- SCP-5126: Given the precondition that `choices` contains no -- duplicate entries, this membership test behaves identically -- to Marlowe's Isabelle semantics given the precondition that -- the initial state's `choices` in Isabelle was sorted and did -- not contain duplicate entries. ChoseSomething choiceId -> choiceId `Map.member` choices state - ValueGE lhs rhs -> evalVal lhs >= evalVal rhs - ValueGT lhs rhs -> evalVal lhs > evalVal rhs - ValueLT lhs rhs -> evalVal lhs < evalVal rhs - ValueLE lhs rhs -> evalVal lhs <= evalVal rhs - ValueEQ lhs rhs -> evalVal lhs == evalVal rhs - TrueObs -> True - FalseObs -> False + ValueGE lhs rhs -> evalVal lhs >= evalVal rhs + ValueGT lhs rhs -> evalVal lhs > evalVal rhs + ValueLT lhs rhs -> evalVal lhs < evalVal rhs + ValueLE lhs rhs -> evalVal lhs <= evalVal rhs + ValueEQ lhs rhs -> evalVal lhs == evalVal rhs + TrueObs -> True + FalseObs -> False -- | Pick the first account with money in it. refundOne :: Accounts -> Maybe ((Party, Token, Integer), Accounts) @@ -348,7 +360,7 @@ moneyInAccount accId token accounts = -- the initial state's `accounts` in Isabelle was sorted and -- did not contain duplicate entries. case Map.lookup (accId, token) accounts of - Just x -> x + Just x -> x Nothing -> 0 -- | Sets the amount of money available in an account. @@ -364,9 +376,8 @@ updateMoneyInAccount accId token amount = then Map.delete (accId, token) else Map.insert (accId, token) amount -{-| Add the given amount of money to an account (only if it is positive). - Return the updated Map. --} +-- | Add the given amount of money to an account (only if it is positive). +-- Return the updated Map. addMoneyToAccount :: AccountId -> Token -> Integer -> Accounts -> Accounts addMoneyToAccount accId token amount accounts = let @@ -377,20 +388,19 @@ addMoneyToAccount accId token amount accounts = then accounts else updateMoneyInAccount accId token newBalance accounts -{-| Gives the given amount of money to the given payee. - Returns the appropriate effect and updated accounts. --} -giveMoney - :: AccountId - -> Payee - -> Token - -> Integer - -> Accounts - -> (ReduceEffect, Accounts) +-- | Gives the given amount of money to the given payee. +-- Returns the appropriate effect and updated accounts. +giveMoney :: + AccountId -> + Payee -> + Token -> + Integer -> + Accounts -> + (ReduceEffect, Accounts) giveMoney accountId payee token amount accounts = let newAccounts = case payee of - Party _ -> accounts + Party _ -> accounts Account accId -> addMoneyToAccount accId token amount accounts in (ReduceWithPayment (Payment accountId payee token amount), newAccounts) @@ -409,7 +419,7 @@ reduceContractStep env state contract = case contract of Close -> case refundOne (accounts state) of Just ((party, token, amount), newAccounts) -> let - newState = state{accounts = newAccounts} + newState = state {accounts = newAccounts} in Reduced ReduceNoWarning @@ -438,7 +448,7 @@ reduceContractStep env state contract = case contract of then ReducePartialPay accId payee tok paidAmount amountToPay else ReduceNoWarning (payment, finalAccs) = giveMoney accId payee tok paidAmount newAccs - newState = state{accounts = finalAccs} + newState = state {accounts = finalAccs} in Reduced warning payment newState cont If obs cont1 cont2 -> @@ -468,7 +478,7 @@ reduceContractStep env state contract = case contract of -- (aside from internal ordering) to Marlowe's Isabelle semantics -- given the precondition that the initial state's `boundValues` -- in Isabelle was sorted and did not contain duplicate entries. - newState = state{boundValues = Map.insert valId evaluatedValue boundVals} + newState = state {boundValues = Map.insert valId evaluatedValue boundVals} -- SCP-5126: Given the precondition that `boundValues` contains -- no duplicate entries, this lookup behaves identically to -- Marlowe's Isabelle semantics given the precondition that the @@ -476,7 +486,7 @@ reduceContractStep env state contract = case contract of -- not contain duplicate entries. warn = case Map.lookup valId boundVals of Just oldVal -> ReduceShadowing valId oldVal evaluatedValue - Nothing -> ReduceNoWarning + Nothing -> ReduceNoWarning in Reduced warn ReduceNoPayment newState cont Assert obs cont -> @@ -489,31 +499,31 @@ reduceContractStep env state contract = case contract of Reduced warning ReduceNoPayment state cont -- | Reduce a contract until it cannot be reduced more. -reduceContractUntilQuiescent - :: Environment - -> State - -> Contract - -> ReduceResult +reduceContractUntilQuiescent :: + Environment -> + State -> + Contract -> + ReduceResult reduceContractUntilQuiescent env state contract = let - reductionLoop - :: Bool - -> Environment - -> State - -> Contract - -> [ReduceWarning] - -> [Payment] - -> ReduceResult + reductionLoop :: + Bool -> + Environment -> + State -> + Contract -> + [ReduceWarning] -> + [Payment] -> + ReduceResult reductionLoop reduced env state contract warnings payments = case reduceContractStep env state contract of Reduced warning effect newState cont -> let newWarnings = case warning of ReduceNoWarning -> warnings - _ -> warning : warnings + _ -> warning : warnings newPayments = case effect of ReduceWithPayment payment -> payment : payments - ReduceNoPayment -> payments + ReduceNoPayment -> payments in reductionLoop True env newState cont newWarnings newPayments AmbiguousTimeIntervalReductionError -> RRAmbiguousTimeIntervalError @@ -555,7 +565,7 @@ applyAction then ApplyNoWarning else ApplyNonPositiveDeposit party2 accId2 tok2 amount newAccounts = addMoneyToAccount accId1 tok1 amount (accounts state) - newState = state{accounts = newAccounts} + newState = state {accounts = newAccounts} in AppliedAction warning newState else NotAppliedAction applyAction _ state (IChoice choId1 choice) (Choice choId2 bounds) = @@ -566,7 +576,7 @@ applyAction _ state (IChoice choId1 choice) (Choice choId2 bounds) = -- given the precondition that the initial state's `choices` -- in Isabelle was sorted and did not contain duplicate entries. then - let newState = state{choices = Map.insert choId1 choice (choices state)} + let newState = state {choices = Map.insert choId1 choice (choices state)} in AppliedAction ApplyNoWarning newState else NotAppliedAction applyAction env state INotify (Notify obs) @@ -596,14 +606,14 @@ applyCases env state input (headCase : tailCases) = -- the Cardano semantics includes merkleization. case maybeContinuation of Just continuation -> Applied warning newState continuation - Nothing -> ApplyHashMismatch + Nothing -> ApplyHashMismatch NotAppliedAction -> applyCases env state input tailCases applyCases _ _ _ [] = ApplyNoMatchError -- | Apply a single @Input@ to a current contract. applyInput :: Environment -> State -> Input -> Contract -> ApplyResult applyInput env state input (When cases _ _) = applyCases env state input cases -applyInput _ _ _ _ = ApplyNoMatchError +applyInput _ _ _ _ = ApplyNoMatchError -- | Propagate 'ReduceWarning' to 'TransactionWarning'. convertReduceWarnings :: [ReduceWarning] -> [TransactionWarning] @@ -628,15 +638,15 @@ convertReduceWarnings = applyAllInputs :: Environment -> State -> Contract -> [Input] -> ApplyAllResult applyAllInputs env state contract inputs = let - applyAllLoop - :: Bool - -> Environment - -> State - -> Contract - -> [Input] - -> [TransactionWarning] - -> [Payment] - -> ApplyAllResult + applyAllLoop :: + Bool -> + Environment -> + State -> + Contract -> + [Input] -> + [TransactionWarning] -> + [Payment] -> + ApplyAllResult applyAllLoop contractChanged env state contract inputs warnings payments = case reduceContractUntilQuiescent env state contract of RRAmbiguousTimeIntervalError -> ApplyAllAmbiguousTimeIntervalError @@ -667,32 +677,31 @@ applyAllInputs env state contract inputs = ApplyHashMismatch -> ApplyAllHashMismatch in applyAllLoop False env state contract inputs [] [] - where - convertApplyWarning :: ApplyWarning -> [TransactionWarning] - convertApplyWarning warn = - case warn of - ApplyNoWarning -> [] - ApplyNonPositiveDeposit party accId tok amount -> - [TransactionNonPositiveDeposit party accId tok amount] + where + convertApplyWarning :: ApplyWarning -> [TransactionWarning] + convertApplyWarning warn = + case warn of + ApplyNoWarning -> [] + ApplyNonPositiveDeposit party accId tok amount -> + [TransactionNonPositiveDeposit party accId tok amount] -- | Check if a contract is just @Close@. isClose :: Contract -> Bool isClose Close = True -isClose _ = False +isClose _ = False -- | Check if a contract is not just @Close@. notClose :: Contract -> Bool notClose Close = False -notClose _ = True - -{-| Try to compute outputs of a transaction given its inputs, -a contract, and it's @State@ --} -computeTransaction - :: TransactionInput - -> State - -> Contract - -> TransactionOutput +notClose _ = True + +-- | Try to compute outputs of a transaction given its inputs, +-- a contract, and it's @State@ +computeTransaction :: + TransactionInput -> + State -> + Contract -> + TransactionOutput computeTransaction tx state contract = let inputs = txInputs tx @@ -718,9 +727,8 @@ computeTransaction tx state contract = Error TEHashMismatch IntervalError error -> Error (TEIntervalError error) -{-| Run a set of inputs starting from the results of a transaction, -reporting the new result. --} +-- | Run a set of inputs starting from the results of a transaction, +-- reporting the new result. playTraceAux :: TransactionOutput -> [TransactionInput] -> TransactionOutput playTraceAux res [] = res playTraceAux @@ -733,7 +741,7 @@ playTraceAux (h : t) = let transRes = computeTransaction h state cont in case transRes of - TransactionOutput{..} -> + TransactionOutput {..} -> playTraceAux TransactionOutput { txOutPayments = payments ++ txOutPayments @@ -745,9 +753,8 @@ playTraceAux Error _ -> transRes playTraceAux err@(Error _) _ = err -{-| Run a set of inputs starting from a contract and empty state, -reporting the result. --} +-- | Run a set of inputs starting from a contract and empty state, +-- reporting the result. playTrace :: POSIXTime -> Contract -> [TransactionInput] -> TransactionOutput playTrace minTime c = playTraceAux @@ -758,9 +765,8 @@ playTrace minTime c = , txOutContract = c } -{-| Calculates an upper bound for the maximum lifespan of a contract -(assuming is not merkleized) --} +-- | Calculates an upper bound for the maximum lifespan of a contract +-- (assuming is not merkleized) contractLifespanUpperBound :: Contract -> POSIXTime contractLifespanUpperBound contract = case contract of Close -> 0 @@ -790,7 +796,7 @@ totalBalance accounts = -- | Check that all accounts have positive balance. allBalancesArePositive :: State -> Bool -allBalancesArePositive State{..} = +allBalancesArePositive State {..} = all (\(_, balance) -> balance > 0) (Map.toList accounts) instance Eq Payment where @@ -804,22 +810,22 @@ instance Eq ReduceWarning where ReduceNoWarning == _ = False ReduceNonPositivePay acc1 p1 tn1 a1 == ReduceNonPositivePay acc2 p2 tn2 a2 = acc1 == acc2 && p1 == p2 && tn1 == tn2 && a1 == a2 - ReduceNonPositivePay{} == _ = False + ReduceNonPositivePay {} == _ = False ReducePartialPay acc1 p1 tn1 a1 e1 == ReducePartialPay acc2 p2 tn2 a2 e2 = acc1 == acc2 && p1 == p2 && tn1 == tn2 && a1 == a2 && e1 == e2 - ReducePartialPay{} == _ = False + ReducePartialPay {} == _ = False ReduceShadowing v1 old1 new1 == ReduceShadowing v2 old2 new2 = v1 == v2 && old1 == old2 && new1 == new2 - ReduceShadowing{} == _ = False + ReduceShadowing {} == _ = False ReduceAssertionFailed == ReduceAssertionFailed = True ReduceAssertionFailed == _ = False instance Eq ReduceEffect where {-# INLINEABLE (==) #-} - ReduceNoPayment == ReduceNoPayment = True - ReduceNoPayment == _ = False + ReduceNoPayment == ReduceNoPayment = True + ReduceNoPayment == _ = False ReduceWithPayment p1 == ReduceWithPayment p2 = p1 == p2 - ReduceWithPayment _ == _ = False + ReduceWithPayment _ == _ = False -- Functions that used in Plutus Core must be inlineable, -- so their code is available for PlutusTx compiler. diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics/Types.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics/Types.hs index 873708572bd..48be07e8abc 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics/Types.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics/Types.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- Probably could use a more specific flag but not sure what, need -- to stop GHC inserting a clever recursive go function with no unfolding {-# OPTIONS_GHC -O0 #-} @@ -27,8 +27,13 @@ import GHC.Generics (Generic) import PlutusBenchmark.Marlowe.Core.V1.Semantics.Types.Address (Network) import PlutusLedgerApi.V1.Value qualified as Val import PlutusLedgerApi.V2 (CurrencySymbol, POSIXTime (..), TokenName) -import PlutusLedgerApi.V2 qualified as Ledger (Address (..), Credential (..), PubKeyHash (..), - ScriptHash (..), StakingCredential (..)) +import PlutusLedgerApi.V2 qualified as Ledger ( + Address (..), + Credential (..), + PubKeyHash (..), + ScriptHash (..), + StakingCredential (..), + ) import PlutusTx.AsData (asData) import PlutusTx.AssocMap (Map) import PlutusTx.AssocMap qualified as Map @@ -80,9 +85,8 @@ type ChoiceName = BuiltinByteString -- | A numeric choice in a contract. type ChosenNum = Integer -{-| The time validity range for a Marlowe transaction, -inclusive of both endpoints. --} +-- | The time validity range for a Marlowe transaction, +-- inclusive of both endpoints. type TimeInterval = (POSIXTime, POSIXTime) asData @@ -122,9 +126,8 @@ asData -- | The accounts in a contract. type Accounts = Map (AccountId, Token) Integer -{-| Values, as defined using Let ar e identified by name, - and can be used by 'UseValue' construct. --} +-- | Values, as defined using Let ar e identified by name, +-- and can be used by 'UseValue' construct. newtype ValueId = ValueId BuiltinByteString deriving (Haskell.Show) via TokenName deriving stock (Haskell.Eq, Haskell.Ord, Generic, Data) @@ -133,13 +136,12 @@ newtype ValueId = ValueId BuiltinByteString makeIsDataIndexed ''ValueId [('ValueId, 0)] -{-| Values include some quantities that change with time, - including “the time interval”, “the current balance of an account”, - and any choices that have already been made. - - Values can also be scaled, and combined using addition, subtraction, - and negation. --} +-- | Values include some quantities that change with time, +-- including “the time interval”, “the current balance of an account”, +-- and any choices that have already been made. +-- +-- Values can also be scaled, and combined using addition, subtraction, +-- and negation. data Value a = AvailableMoney AccountId Token | Constant Integer @@ -156,43 +158,42 @@ data Value a deriving stock (Generic, Data) deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show) -instance (Eq a) => Eq (Value a) where +instance Eq a => Eq (Value a) where {-# INLINEABLE (==) #-} AvailableMoney acc1 tok1 == AvailableMoney acc2 tok2 = acc1 == acc2 && tok1 == tok2 AvailableMoney _ _ == _ = False Constant i1 == Constant i2 = i1 == i2 - Constant{} == _ = False + Constant {} == _ = False NegValue val1 == NegValue val2 = val1 == val2 - NegValue{} == _ = False + NegValue {} == _ = False AddValue val1 val2 == AddValue val3 val4 = val1 == val3 && val2 == val4 - AddValue{} == _ = False + AddValue {} == _ = False SubValue val1 val2 == SubValue val3 val4 = val1 == val3 && val2 == val4 - SubValue{} == _ = False + SubValue {} == _ = False MulValue val1 val2 == MulValue val3 val4 = val1 == val3 && val2 == val4 - MulValue{} == _ = False + MulValue {} == _ = False DivValue val1 val2 == DivValue val3 val4 = val1 == val3 && val2 == val4 - DivValue{} == _ = False + DivValue {} == _ = False ChoiceValue cid1 == ChoiceValue cid2 = cid1 == cid2 - ChoiceValue{} == _ = False + ChoiceValue {} == _ = False TimeIntervalStart == TimeIntervalStart = True TimeIntervalStart == _ = False TimeIntervalEnd == TimeIntervalEnd = True TimeIntervalEnd == _ = False UseValue val1 == UseValue val2 = val1 == val2 - UseValue{} == _ = False + UseValue {} == _ = False Cond obs1 thn1 els1 == Cond obs2 thn2 els2 = obs1 == obs2 && thn1 == thn2 && els1 == els2 - Cond{} == _ = False + Cond {} == _ = False unstableMakeIsData ''Value -{-| Observations are Boolean values derived by comparing values, - and can be combined using the standard Boolean operators. - - It is also possible to observe whether any choice has been made - (for a particular identified choice). --} +-- | Observations are Boolean values derived by comparing values, +-- and can be combined using the standard Boolean operators. +-- +-- It is also possible to observe whether any choice has been made +-- (for a particular identified choice). data Observation = AndObs Observation Observation | OrObs Observation Observation @@ -210,28 +211,28 @@ data Observation instance Eq Observation where {-# INLINEABLE (==) #-} - AndObs o1l o2l == AndObs o1r o2r = o1l == o1r && o2l == o2r - AndObs{} == _ = False - OrObs o1l o2l == OrObs o1r o2r = o1l == o1r && o2l == o2r - OrObs{} == _ = False - NotObs ol == NotObs or = ol == or - NotObs{} == _ = False + AndObs o1l o2l == AndObs o1r o2r = o1l == o1r && o2l == o2r + AndObs {} == _ = False + OrObs o1l o2l == OrObs o1r o2r = o1l == o1r && o2l == o2r + OrObs {} == _ = False + NotObs ol == NotObs or = ol == or + NotObs {} == _ = False ChoseSomething cid1 == ChoseSomething cid2 = cid1 == cid2 - ChoseSomething _ == _ = False - ValueGE v1l v2l == ValueGE v1r v2r = v1l == v1r && v2l == v2r - ValueGE{} == _ = False - ValueGT v1l v2l == ValueGT v1r v2r = v1l == v1r && v2l == v2r - ValueGT{} == _ = False - ValueLT v1l v2l == ValueLT v1r v2r = v1l == v1r && v2l == v2r - ValueLT{} == _ = False - ValueLE v1l v2l == ValueLE v1r v2r = v1l == v1r && v2l == v2r - ValueLE{} == _ = False - ValueEQ v1l v2l == ValueEQ v1r v2r = v1l == v1r && v2l == v2r - ValueEQ{} == _ = False - TrueObs == TrueObs = True - TrueObs == _ = False - FalseObs == FalseObs = True - FalseObs == _ = False + ChoseSomething _ == _ = False + ValueGE v1l v2l == ValueGE v1r v2r = v1l == v1r && v2l == v2r + ValueGE {} == _ = False + ValueGT v1l v2l == ValueGT v1r v2r = v1l == v1r && v2l == v2r + ValueGT {} == _ = False + ValueLT v1l v2l == ValueLT v1r v2r = v1l == v1r && v2l == v2r + ValueLT {} == _ = False + ValueLE v1l v2l == ValueLE v1r v2r = v1l == v1r && v2l == v2r + ValueLE {} == _ = False + ValueEQ v1l v2l == ValueEQ v1r v2r = v1l == v1r && v2l == v2r + ValueEQ {} == _ = False + TrueObs == TrueObs = True + TrueObs == _ = False + FalseObs == FalseObs = True + FalseObs == _ = False unstableMakeIsData ''Observation @@ -327,7 +328,7 @@ asData -- | Extract the @Action@ from a @Case@. getAction :: (ToData a, UnsafeFromData a) => Case a -> Action -getAction (Case action _) = action +getAction (Case action _) = action getAction (MerkleizedCase action _) = action {-# INLINEABLE getAction #-} @@ -431,17 +432,16 @@ asData -- | Extract the content of input. getInputContent :: Input -> InputContent -getInputContent (NormalInput inputContent) = inputContent +getInputContent (NormalInput inputContent) = inputContent getInputContent (MerkleizedInput inputContent _ _) = inputContent {-# INLINEABLE getInputContent #-} -{-| Time interval errors. - 'InvalidInterval' means @slotStart > slotEnd@, and - 'IntervalInPastError' means time interval is in the past, - relative to the contract. - - These errors should never occur, but we are always prepared. --} +-- | Time interval errors. +-- 'InvalidInterval' means @slotStart > slotEnd@, and +-- 'IntervalInPastError' means time interval is in the past, +-- relative to the contract. +-- +-- These errors should never occur, but we are always prepared. data IntervalError = InvalidInterval TimeInterval | IntervalInPastError POSIXTime TimeInterval diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/RolePayout.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/RolePayout.hs index aead88c0cec..b08c778a3a1 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/RolePayout.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/RolePayout.hs @@ -1,7 +1,4 @@ - -- editorconfig-checker-disable-file - - ----------------------------------------------------------------------------- -- -- Module : $Headers @@ -10,39 +7,45 @@ -- Stability : Experimental -- Portability : Portable -- --- | Marlowe validators. --- ----------------------------------------------------------------------------- - - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - - -module PlutusBenchmark.Marlowe.Scripts.Data.RolePayout - (-- * Payout Validator - rolePayoutValidatorHash - , rolePayoutValidatorBytes - , rolePayoutValidator - , mkRolePayoutValidator - ) where +-- | Marlowe validators. +module PlutusBenchmark.Marlowe.Scripts.Data.RolePayout ( + -- * Payout Validator + rolePayoutValidatorHash, + rolePayoutValidatorBytes, + rolePayoutValidator, + mkRolePayoutValidator, +) where import PlutusLedgerApi.Data.V2 qualified as Data -import PlutusLedgerApi.V2 (CurrencySymbol, ScriptHash (..), SerialisedScript, TokenName, - serialiseCompiledCode) +import PlutusLedgerApi.V2 ( + CurrencySymbol, + ScriptHash (..), + SerialisedScript, + TokenName, + serialiseCompiledCode, + ) import PlutusLedgerApi.V2.Data.Contexts qualified as Data import PlutusTx (CompiledCode, unsafeFromBuiltinData) import PlutusTx.Plugin () -import PlutusTx.Prelude as PlutusTxPrelude (Bool (..), BuiltinData, BuiltinUnit, check, toBuiltin, - ($), (.)) +import PlutusTx.Prelude as PlutusTxPrelude ( + Bool (..), + BuiltinData, + BuiltinUnit, + check, + toBuiltin, + ($), + (.), + ) import Cardano.Crypto.Hash qualified as Hash import Data.ByteString qualified as BS @@ -50,26 +53,29 @@ import Data.ByteString.Short qualified as SBS import PlutusLedgerApi.V1.Value qualified as Val import PlutusTx qualified - -- | Tag for the Marlowe payout validator. data TypedRolePayoutValidator - -- | The Marlowe payout validator. -mkRolePayoutValidator :: (CurrencySymbol, TokenName) -- ^ The datum is the currency symbol and role name for the payout. - -> () -- ^ No redeemer is required. - -> Data.ScriptContext -- ^ The script context. - -> Bool -- ^ Whether the transaction validated. +mkRolePayoutValidator :: + -- | The datum is the currency symbol and role name for the payout. + (CurrencySymbol, TokenName) -> + -- | No redeemer is required. + () -> + -- | The script context. + Data.ScriptContext -> + -- | Whether the transaction validated. + Bool mkRolePayoutValidator (currency, role) _ ctx = let spent = - PlutusTx.unsafeFromBuiltinData + PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.valueSpent . Data.scriptContextTxInfo $ ctx - -- The role token for the correct currency must be present. - -- [Marlowe-Cardano Specification: "17. Payment authorized".] - in Val.singleton currency role 1 `Val.leq` spent + in -- The role token for the correct currency must be present. + -- [Marlowe-Cardano Specification: "17. Payment authorized".] + Val.singleton currency role 1 `Val.leq` spent -- | Compute the hash of a script. hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit) -> ScriptHash @@ -78,31 +84,28 @@ hashScript = ScriptHash . toBuiltin . (Hash.hashToBytes :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString -> BS.ByteString) - . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. + . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. . serialiseCompiledCode - -{-# INLINABLE rolePayoutValidator #-} +{-# INLINEABLE rolePayoutValidator #-} -- | The Marlowe payout validator. rolePayoutValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit) rolePayoutValidator = - $$(PlutusTx.compile [|| rolePayoutValidator' ||]) - where - rolePayoutValidator' :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit - rolePayoutValidator' d r p = - check - $ mkRolePayoutValidator - (unsafeFromBuiltinData d) - (unsafeFromBuiltinData r) - (unsafeFromBuiltinData p) - + $$(PlutusTx.compile [||rolePayoutValidator'||]) + where + rolePayoutValidator' :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit + rolePayoutValidator' d r p = + check + $ mkRolePayoutValidator + (unsafeFromBuiltinData d) + (unsafeFromBuiltinData r) + (unsafeFromBuiltinData p) -- | The serialisation of the Marlowe payout validator. rolePayoutValidatorBytes :: SerialisedScript rolePayoutValidatorBytes = serialiseCompiledCode rolePayoutValidator - -- | The hash of the Marlowe payout validator. rolePayoutValidatorHash :: ScriptHash rolePayoutValidatorHash = hashScript rolePayoutValidator diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/Semantics.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/Semantics.hs index 74938baa46e..51285fbcfa0 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/Semantics.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Data/Semantics.hs @@ -1,7 +1,4 @@ - -- editorconfig-checker-disable-file - - ----------------------------------------------------------------------------- -- -- Module : $Headers @@ -10,64 +7,94 @@ -- Stability : Experimental -- Portability : Portable -- --- | Marlowe validators. --- ----------------------------------------------------------------------------- - - -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} - -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} -module PlutusBenchmark.Marlowe.Scripts.Data.Semantics - ( -- * Types - MarloweInput - , MarloweTxInput(..) - -- * Semantics Validator - , marloweValidatorHash - , marloweValidatorBytes - , marloweValidator - , mkMarloweValidator - -- * Utilities - , marloweTxInputsFromInputs - ) where +-- | Marlowe validators. +module PlutusBenchmark.Marlowe.Scripts.Data.Semantics ( + -- * Types + MarloweInput, + MarloweTxInput (..), + + -- * Semantics Validator + marloweValidatorHash, + marloweValidatorBytes, + marloweValidator, + mkMarloweValidator, + + -- * Utilities + marloweTxInputsFromInputs, +) where import GHC.Generics (Generic) -import PlutusBenchmark.Marlowe.Core.V1.Semantics as Semantics (MarloweData (..), - MarloweParams (MarloweParams, rolesCurrency), - Payment (..), - TransactionError (TEAmbiguousTimeIntervalError, TEApplyNoMatchError, TEHashMismatch, TEIntervalError, TEUselessTransaction), - TransactionInput (TransactionInput, txInputs, txInterval), - TransactionOutput (Error, TransactionOutput, txOutContract, txOutPayments, txOutState), - computeTransaction, totalBalance) +import PlutusBenchmark.Marlowe.Core.V1.Semantics as Semantics ( + MarloweData (..), + MarloweParams (MarloweParams, rolesCurrency), + Payment (..), + TransactionError (TEAmbiguousTimeIntervalError, TEApplyNoMatchError, TEHashMismatch, TEIntervalError, TEUselessTransaction), + TransactionInput (TransactionInput, txInputs, txInterval), + TransactionOutput (Error, TransactionOutput, txOutContract, txOutPayments, txOutState), + computeTransaction, + totalBalance, + ) import PlutusBenchmark.Marlowe.Core.V1.Semantics.Types import PlutusBenchmark.Marlowe.Scripts.RolePayout (rolePayoutValidatorHash) import PlutusLedgerApi.Data.V2 qualified as Data -import PlutusLedgerApi.V2 (Datum (Datum), DatumHash (DatumHash), Extended (..), Interval (..), - LowerBound (..), POSIXTime (..), POSIXTimeRange, ScriptHash (..), - SerialisedScript, UpperBound (..), serialiseCompiledCode) +import PlutusLedgerApi.V2 ( + Datum (Datum), + DatumHash (DatumHash), + Extended (..), + Interval (..), + LowerBound (..), + POSIXTime (..), + POSIXTimeRange, + ScriptHash (..), + SerialisedScript, + UpperBound (..), + serialiseCompiledCode, + ) import PlutusLedgerApi.V2.Data.Contexts qualified as Data import PlutusTx (CompiledCode, makeIsDataIndexed, makeLift, unsafeFromBuiltinData) import PlutusTx.Foldable (foldMap) import PlutusTx.List (all, elem, null) import PlutusTx.Plugin () -import PlutusTx.Prelude as PlutusTxPrelude (AdditiveGroup ((-)), AdditiveMonoid (zero), - AdditiveSemigroup ((+)), Bool (..), BuiltinByteString, - BuiltinData, BuiltinString, BuiltinUnit, - Enum (fromEnum), Eq (..), Functor (fmap), Integer, - Maybe (..), Ord ((>)), Semigroup ((<>)), check, - otherwise, snd, toBuiltin, ($), (&&), (.), (/=), (||)) +import PlutusTx.Prelude as PlutusTxPrelude ( + AdditiveGroup ((-)), + AdditiveMonoid (zero), + AdditiveSemigroup ((+)), + Bool (..), + BuiltinByteString, + BuiltinData, + BuiltinString, + BuiltinUnit, + Enum (fromEnum), + Eq (..), + Functor (fmap), + Integer, + Maybe (..), + Ord ((>)), + Semigroup ((<>)), + check, + otherwise, + snd, + toBuiltin, + ($), + (&&), + (.), + (/=), + (||), + ) import Cardano.Crypto.Hash qualified as Hash import Data.ByteString qualified as BS @@ -84,58 +111,57 @@ import PlutusTx.Data.List qualified as Data.List import PlutusTx.Trace (traceError, traceIfFalse) import Prelude qualified as Haskell - -- | Input to a Marlowe transaction. type MarloweInput = [MarloweTxInput] - -- | Tag for the Marlowe semantics validator. data TypedMarloweValidator - -- | A single input applied in the Marlowe semantics validator. -data MarloweTxInput = Input InputContent - | MerkleizedTxInput InputContent BuiltinByteString - deriving stock (Haskell.Show,Haskell.Eq,Generic) - +data MarloweTxInput + = Input InputContent + | MerkleizedTxInput InputContent BuiltinByteString + deriving stock (Haskell.Show, Haskell.Eq, Generic) -- | Convert a Plutus POSIX time range into the closed interval needed by Marlowe semantics. closeInterval :: POSIXTimeRange -> Maybe (POSIXTime, POSIXTime) closeInterval (Interval (LowerBound (Finite (POSIXTime l)) lc) (UpperBound (Finite (POSIXTime h)) hc)) = Just - ( - POSIXTime $ l + 1 - fromEnum lc -- Add one millisecond if the interval was open. - , POSIXTime $ h - 1 + fromEnum hc -- Subtract one millisecond if the interval was open. + ( POSIXTime $ l + 1 - fromEnum lc -- Add one millisecond if the interval was open. + , POSIXTime $ h - 1 + fromEnum hc -- Subtract one millisecond if the interval was open. ) closeInterval _ = Nothing -{-# INLINABLE closeInterval #-} - +{-# INLINEABLE closeInterval #-} -- | The Marlowe semantics validator. +mkMarloweValidator :: + -- | The hash of the corresponding Marlowe payout validator. + ScriptHash -> + -- | The datum is the Marlowe parameters, state, and contract. + MarloweData -> + -- | The redeemer is the list of inputs applied to the contract. + MarloweInput -> + -- | The script context. + Data.ScriptContext -> + -- | Whether the transaction validated. + Bool mkMarloweValidator - :: ScriptHash -- ^ The hash of the corresponding Marlowe payout validator. - -> MarloweData -- ^ The datum is the Marlowe parameters, state, and contract. - -> MarloweInput -- ^ The redeemer is the list of inputs applied to the contract. - -> Data.ScriptContext -- ^ The script context. - -> Bool -- ^ Whether the transaction validated. -mkMarloweValidator - rolePayoutValidatorHash - MarloweData{..} - marloweTxInputs - ctx@Data.ScriptContext{scriptContextTxInfo} = do - + rolePayoutValidatorHash + MarloweData {..} + marloweTxInputs + ctx@Data.ScriptContext {scriptContextTxInfo} = do let scriptInValue = case ownInput of - Data.TxInInfo { txInInfoResolved = Data.TxOut { txOutValue }} -> + Data.TxInInfo {txInInfoResolved = Data.TxOut {txOutValue}} -> -- Data.Value -> Val.Value PlutusTx.unsafeFromBuiltinData @Val.Value . PlutusTx.toBuiltinData $ txOutValue -- let scriptInValue = PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txOutValue . Data.txInInfoResolved $ ownInput let interval = - -- Marlowe semantics require a closed interval, so we might adjust by one millisecond. - case closeInterval . PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txInfoValidRange $ scriptContextTxInfo of - Just interval' -> interval' - Nothing -> traceError "a" + -- Marlowe semantics require a closed interval, so we might adjust by one millisecond. + case closeInterval . PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txInfoValidRange $ scriptContextTxInfo of + Just interval' -> interval' + Nothing -> traceError "a" -- Find Contract continuation in TxInfo datums by hash or fail with error. let inputs = fmap marloweTxInputToInput marloweTxInputs @@ -160,9 +186,11 @@ mkMarloweValidator -- [Marlowe-Cardano Specification: "Constraint 0. Input to semantics".] -- Package the inputs to be applied in the semantics. - let txInput = TransactionInput { - txInterval = interval, - txInputs = inputs } + let txInput = + TransactionInput + { txInterval = interval + , txInputs = inputs + } -- [Marlowe-Cardano Specification: "Constraint 7. Input state".] -- [Marlowe-Cardano Specification: "Constraint 8. Input contract".] @@ -170,267 +198,269 @@ mkMarloweValidator -- the incoming datum. let computedResult = computeTransaction txInput marloweState marloweContract case computedResult of - TransactionOutput {txOutPayments, txOutState, txOutContract} -> do - - -- [Marlowe-Cardano Specification: "Constraint 9. Marlowe parameters".] - -- [Marlowe-Cardano Specification: "Constraint 10. Output state".] - -- [Marlowe-Cardano Specification: "Constraint 11. Output contract."] - -- The output datum maintains the parameters and uses the state - -- and contract resulting from the semantics computation. - let marloweData = MarloweData { - marloweParams = marloweParams, - marloweContract = txOutContract, - marloweState = txOutState } - - -- Each party must receive as least as much value as the semantics specify. - -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient payment."] - payoutsByParty = AssocMap.toList $ foldMap payoutByParty txOutPayments - payoutsOk = payoutConstraints payoutsByParty - - checkContinuation = case txOutContract of - -- [Marlowe-Cardano Specification: "Constraint 4. No output to script on close".] - Close -> traceIfFalse "c" hasNoOutputToOwnScript - _ -> let - totalIncome = foldMap collectDeposits inputContents - totalPayouts = foldMap snd payoutsByParty - finalBalance = scriptInValue + totalIncome - totalPayouts - in - -- [Marlowe-Cardano Specification: "Constraint 3. Single Marlowe output".] - -- [Marlowe-Cardano Specification: "Constraint 6. Output value to script."] - -- Check that the single Marlowe output has the correct datum and value. - checkOwnOutputConstraint marloweData finalBalance - -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] - -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] - -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] - -- Check that the final state obeys the Semantic's invariants. - && checkState "o" finalBalance txOutState - preconditionsOk && inputsOk && payoutsOk && checkContinuation - -- [Marlowe-Cardano Specification: "20. Single satsifaction".] - -- Either there must be no payouts, or there must be no other validators. - && traceIfFalse "z" (null payoutsByParty || noOthers) - Error TEAmbiguousTimeIntervalError -> traceError "i" - Error TEApplyNoMatchError -> traceError "n" - Error (TEIntervalError (InvalidInterval _)) -> traceError "j" - Error (TEIntervalError (IntervalInPastError _ _)) -> traceError "k" - Error TEUselessTransaction -> traceError "u" - Error TEHashMismatch -> traceError "m" - - where - - -- The roles currency is in the Marlowe parameters. - MarloweParams{ rolesCurrency } = marloweParams - - -- Find the input being spent by a script. - findOwnInput :: Data.ScriptContext -> Maybe Data.TxInInfo - findOwnInput Data.ScriptContext{scriptContextTxInfo=Data.TxInfo{txInfoInputs}, scriptContextPurpose=Data.Spending txOutRef} = - Data.List.find (\Data.TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs - findOwnInput _ = Nothing - - -- [Marlowe-Cardano Specification: "2. Single Marlowe script input".] - -- The inputs being spent by this script, and whether other validators are present. - ownInput :: Data.TxInInfo - noOthers :: Bool - (ownInput@Data.TxInInfo{txInInfoResolved=Data.TxOut{txOutAddress=ownAddress}}, noOthers) = + TransactionOutput {txOutPayments, txOutState, txOutContract} -> do + -- [Marlowe-Cardano Specification: "Constraint 9. Marlowe parameters".] + -- [Marlowe-Cardano Specification: "Constraint 10. Output state".] + -- [Marlowe-Cardano Specification: "Constraint 11. Output contract."] + -- The output datum maintains the parameters and uses the state + -- and contract resulting from the semantics computation. + let marloweData = + MarloweData + { marloweParams = marloweParams + , marloweContract = txOutContract + , marloweState = txOutState + } + + -- Each party must receive as least as much value as the semantics specify. + -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient payment."] + payoutsByParty = AssocMap.toList $ foldMap payoutByParty txOutPayments + payoutsOk = payoutConstraints payoutsByParty + + checkContinuation = case txOutContract of + -- [Marlowe-Cardano Specification: "Constraint 4. No output to script on close".] + Close -> traceIfFalse "c" hasNoOutputToOwnScript + _ -> + let + totalIncome = foldMap collectDeposits inputContents + totalPayouts = foldMap snd payoutsByParty + finalBalance = scriptInValue + totalIncome - totalPayouts + in + -- [Marlowe-Cardano Specification: "Constraint 3. Single Marlowe output".] + -- [Marlowe-Cardano Specification: "Constraint 6. Output value to script."] + -- Check that the single Marlowe output has the correct datum and value. + checkOwnOutputConstraint marloweData finalBalance + -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + -- Check that the final state obeys the Semantic's invariants. + && checkState "o" finalBalance txOutState + preconditionsOk + && inputsOk + && payoutsOk + && checkContinuation + -- [Marlowe-Cardano Specification: "20. Single satsifaction".] + -- Either there must be no payouts, or there must be no other validators. + && traceIfFalse "z" (null payoutsByParty || noOthers) + Error TEAmbiguousTimeIntervalError -> traceError "i" + Error TEApplyNoMatchError -> traceError "n" + Error (TEIntervalError (InvalidInterval _)) -> traceError "j" + Error (TEIntervalError (IntervalInPastError _ _)) -> traceError "k" + Error TEUselessTransaction -> traceError "u" + Error TEHashMismatch -> traceError "m" + where + -- The roles currency is in the Marlowe parameters. + MarloweParams {rolesCurrency} = marloweParams + + -- Find the input being spent by a script. + findOwnInput :: Data.ScriptContext -> Maybe Data.TxInInfo + findOwnInput Data.ScriptContext {scriptContextTxInfo = Data.TxInfo {txInfoInputs}, scriptContextPurpose = Data.Spending txOutRef} = + Data.List.find (\Data.TxInInfo {txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs + findOwnInput _ = Nothing + + -- [Marlowe-Cardano Specification: "2. Single Marlowe script input".] + -- The inputs being spent by this script, and whether other validators are present. + ownInput :: Data.TxInInfo + noOthers :: Bool + (ownInput@Data.TxInInfo {txInInfoResolved = Data.TxOut {txOutAddress = ownAddress}}, noOthers) = case findOwnInput ctx of - Just ownTxInInfo -> - examineScripts (sameValidatorHash ownTxInInfo) Nothing True (Data.txInfoInputs scriptContextTxInfo) - _ -> traceError "x" -- Input to be validated was not found. - - -- Check for the presence of multiple Marlowe validators or other Plutus validators. - examineScripts - :: (ScriptHash -> Bool) -- Test for this validator. - -> Maybe Data.TxInInfo -- The input for this validator, if found so far. - -> Bool -- Whether no other validator has been found so far. - -> Data.List Data.TxInInfo -- The inputs remaining to be examined. - -> (Data.TxInInfo, Bool) -- The input for this validator and whehter no other validators are present. - examineScripts check mTxInInfo valWasFound (Data.List.toBuiltinList -> inputs) = - go check mTxInInfo valWasFound inputs - where - go f mSelf noOthers = - B.caseList - (\() -> - case mSelf of - Just self -> (self, noOthers) - Nothing -> traceError "examineScripts: empty list of inputs" - ) - (\hd tl -> - case (mSelf, noOthers) of - (Just self, False) -> (self, False) - _ -> - let hd' = unsafeFromBuiltinData hd - in - case hd' of - Data.TxInInfo{txInInfoResolved=Data.TxOut{txOutAddress=Data.Address (Data.ScriptCredential vh) _}} -> - if f vh - then - case mSelf of - Nothing -> go f (Just hd') noOthers tl - Just _ -> traceError "w" - else go f mSelf False tl - _ -> go f mSelf noOthers tl - ) - - -- Check if inputs are being spent from the same script. - sameValidatorHash:: Data.TxInInfo -> ScriptHash -> Bool - sameValidatorHash Data.TxInInfo{txInInfoResolved=Data.TxOut{txOutAddress=Data.Address (Data.ScriptCredential vh1) _}} vh2 = vh1 == vh2 - sameValidatorHash _ _ = False - - -- Check a state for the correct value, positive accounts, and no duplicates. - checkState :: BuiltinString -> Val.Value -> State -> Bool - checkState tag expected State{..} = - let - positiveBalance :: (a, Integer) -> Bool - positiveBalance (_, balance) = balance > 0 - noDuplicates :: Eq k => AssocMap.Map k v -> Bool - noDuplicates am = - let - test [] = True -- An empty list has no duplicates. - test (x : xs) -- Look for a duplicate of the head in the tail. - | elem x xs = False -- A duplicate is present. - | otherwise = test xs -- Continue searching for a duplicate. - in - test $ AssocMap.keys am - in - -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] - -- and/or - -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] - traceIfFalse ("v" <> tag) (totalBalance accounts == expected) - -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] - && traceIfFalse ("b" <> tag) (all positiveBalance $ AssocMap.toList accounts) - -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] - && traceIfFalse ("ea" <> tag) (noDuplicates accounts) - && traceIfFalse ("ec" <> tag) (noDuplicates choices) - && traceIfFalse ("eb" <> tag) (noDuplicates boundValues) - - -- Look up the Datum hash for specific data. - findDatumHash' :: PlutusTx.ToData o => o -> Maybe DatumHash - findDatumHash' datum = Data.findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo - - -- Check that the correct datum and value is being output to the script. - checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool - checkOwnOutputConstraint ocDatum ocValue = + Just ownTxInInfo -> + examineScripts (sameValidatorHash ownTxInInfo) Nothing True (Data.txInfoInputs scriptContextTxInfo) + _ -> traceError "x" -- Input to be validated was not found. + + -- Check for the presence of multiple Marlowe validators or other Plutus validators. + examineScripts :: + (ScriptHash -> Bool) -> -- Test for this validator. + Maybe Data.TxInInfo -> -- The input for this validator, if found so far. + Bool -> -- Whether no other validator has been found so far. + Data.List Data.TxInInfo -> -- The inputs remaining to be examined. + (Data.TxInInfo, Bool) -- The input for this validator and whehter no other validators are present. + examineScripts check mTxInInfo valWasFound (Data.List.toBuiltinList -> inputs) = + go check mTxInInfo valWasFound inputs + where + go f mSelf noOthers = + B.caseList + ( \() -> + case mSelf of + Just self -> (self, noOthers) + Nothing -> traceError "examineScripts: empty list of inputs" + ) + ( \hd tl -> + case (mSelf, noOthers) of + (Just self, False) -> (self, False) + _ -> + let hd' = unsafeFromBuiltinData hd + in case hd' of + Data.TxInInfo {txInInfoResolved = Data.TxOut {txOutAddress = Data.Address (Data.ScriptCredential vh) _}} -> + if f vh + then case mSelf of + Nothing -> go f (Just hd') noOthers tl + Just _ -> traceError "w" + else go f mSelf False tl + _ -> go f mSelf noOthers tl + ) + + -- Check if inputs are being spent from the same script. + sameValidatorHash :: Data.TxInInfo -> ScriptHash -> Bool + sameValidatorHash Data.TxInInfo {txInInfoResolved = Data.TxOut {txOutAddress = Data.Address (Data.ScriptCredential vh1) _}} vh2 = vh1 == vh2 + sameValidatorHash _ _ = False + + -- Check a state for the correct value, positive accounts, and no duplicates. + checkState :: BuiltinString -> Val.Value -> State -> Bool + checkState tag expected State {..} = + let + positiveBalance :: (a, Integer) -> Bool + positiveBalance (_, balance) = balance > 0 + noDuplicates :: Eq k => AssocMap.Map k v -> Bool + noDuplicates am = + let + test [] = True -- An empty list has no duplicates. + test (x : xs) -- Look for a duplicate of the head in the tail. + | elem x xs = False -- A duplicate is present. + | otherwise = test xs -- Continue searching for a duplicate. + in + test $ AssocMap.keys am + in + -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] + -- and/or + -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] + traceIfFalse ("v" <> tag) (totalBalance accounts == expected) + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + && traceIfFalse ("b" <> tag) (all positiveBalance $ AssocMap.toList accounts) + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + && traceIfFalse ("ea" <> tag) (noDuplicates accounts) + && traceIfFalse ("ec" <> tag) (noDuplicates choices) + && traceIfFalse ("eb" <> tag) (noDuplicates boundValues) + + -- Look up the Datum hash for specific data. + findDatumHash' :: PlutusTx.ToData o => o -> Maybe DatumHash + findDatumHash' datum = Data.findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo + + -- Check that the correct datum and value is being output to the script. + checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool + checkOwnOutputConstraint ocDatum ocValue = let hsh = findDatumHash' ocDatum - in traceIfFalse "d" -- "Output constraint" - $ checkScriptOutput (==) (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ ownAddress) hsh ocValue getContinuingOutput - - getContinuingOutput :: Data.TxOut - ~getContinuingOutput = - let result = - Data.List.toBuiltinList - $ Data.List.filter (\Data.TxOut{txOutAddress} -> ownAddress == txOutAddress) allOutputs - in - B.caseList - (\() -> - traceError "o" - ) -- No continuation or multiple Marlowe contract outputs is forbidden. - (\hd tl -> - B.caseList' - (PlutusTx.unsafeFromBuiltinData hd) - (\_ _ -> traceError "o") -- No continuation or multiple Marlowe contract outputs is forbidden. - tl - ) - result - - -- Check that address, value, and datum match the specified. - checkScriptOutput :: (Val.Value -> Val.Value -> Bool) -> Ledger.Address -> Maybe DatumHash -> Val.Value -> Data.TxOut -> Bool - checkScriptOutput comparison addr hsh value Data.TxOut{txOutAddress, txOutValue, txOutDatum=Data.OutputDatumHash svh} = - (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ txOutValue) `comparison` value && hsh == Just svh && (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ txOutAddress) == addr - checkScriptOutput _ _ _ _ _ = False - - -- Check for any output to the script address. - hasNoOutputToOwnScript :: Bool - hasNoOutputToOwnScript = Data.List.all ((/= ownAddress) . PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txOutAddress) allOutputs - - -- All of the script outputs. - allOutputs :: Data.List Data.TxOut - allOutputs = Data.txInfoOutputs scriptContextTxInfo - - -- Check mekleization and transform transaction input to semantics input. - marloweTxInputToInput :: MarloweTxInput -> Input - marloweTxInputToInput (MerkleizedTxInput input hash) = + in traceIfFalse "d" -- "Output constraint" + $ checkScriptOutput (==) (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ ownAddress) hsh ocValue getContinuingOutput + + getContinuingOutput :: Data.TxOut + ~getContinuingOutput = + let result = + Data.List.toBuiltinList + $ Data.List.filter (\Data.TxOut {txOutAddress} -> ownAddress == txOutAddress) allOutputs + in B.caseList + ( \() -> + traceError "o" + ) -- No continuation or multiple Marlowe contract outputs is forbidden. + ( \hd tl -> + B.caseList' + (PlutusTx.unsafeFromBuiltinData hd) + (\_ _ -> traceError "o") -- No continuation or multiple Marlowe contract outputs is forbidden. + tl + ) + result + + -- Check that address, value, and datum match the specified. + checkScriptOutput :: (Val.Value -> Val.Value -> Bool) -> Ledger.Address -> Maybe DatumHash -> Val.Value -> Data.TxOut -> Bool + checkScriptOutput comparison addr hsh value Data.TxOut {txOutAddress, txOutValue, txOutDatum = Data.OutputDatumHash svh} = + (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ txOutValue) `comparison` value && hsh == Just svh && (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ txOutAddress) == addr + checkScriptOutput _ _ _ _ _ = False + + -- Check for any output to the script address. + hasNoOutputToOwnScript :: Bool + hasNoOutputToOwnScript = Data.List.all ((/= ownAddress) . PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txOutAddress) allOutputs + + -- All of the script outputs. + allOutputs :: Data.List Data.TxOut + allOutputs = Data.txInfoOutputs scriptContextTxInfo + + -- Check mekleization and transform transaction input to semantics input. + marloweTxInputToInput :: MarloweTxInput -> Input + marloweTxInputToInput (MerkleizedTxInput input hash) = case Data.findDatum (DatumHash hash) scriptContextTxInfo of - Just (Datum d) -> let - continuation = PlutusTx.unsafeFromBuiltinData d - in MerkleizedInput input hash continuation - Nothing -> traceError "h" - marloweTxInputToInput (Input input) = NormalInput input - - -- Check that inputs are authorized. - allInputsAreAuthorized :: [InputContent] -> Bool - allInputsAreAuthorized = all validateInputWitness - where - validateInputWitness :: InputContent -> Bool - validateInputWitness input = + Just (Datum d) -> + let + continuation = PlutusTx.unsafeFromBuiltinData d + in + MerkleizedInput input hash continuation + Nothing -> traceError "h" + marloweTxInputToInput (Input input) = NormalInput input + + -- Check that inputs are authorized. + allInputsAreAuthorized :: [InputContent] -> Bool + allInputsAreAuthorized = all validateInputWitness + where + validateInputWitness :: InputContent -> Bool + validateInputWitness input = case input of - IDeposit _ party _ _ -> validatePartyWitness party -- The party must witness a deposit. - IChoice (ChoiceId _ party) _ -> validatePartyWitness party -- The party must witness a choice. - INotify -> True -- No witness is needed for a notify. - where - validatePartyWitness :: Party -> Bool - validatePartyWitness (Address _ address) = traceIfFalse "s" $ txSignedByAddress (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ address) -- The key must have signed. - validatePartyWitness (Role role) = traceIfFalse "t" -- The role token must be present. - $ Val.singleton rolesCurrency role 1 `Val.leq` (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ Data.valueSpent scriptContextTxInfo) - - -- Tally the deposits in the input. - collectDeposits :: InputContent -> Val.Value - collectDeposits (IDeposit _ _ (Token cur tok) amount) - | amount > 0 = Val.singleton cur tok amount -- SCP-5123: Semantically negative deposits - | otherwise = zero -- do not remove funds from the script's UTxO. - collectDeposits _ = zero - - -- Extract the payout to a party. - payoutByParty :: Payment -> AssocMap.Map Party Val.Value - payoutByParty (Payment _ (Party party) (Token cur tok) amount) - | amount > 0 = AssocMap.singleton party $ Val.singleton cur tok amount - | otherwise = AssocMap.empty -- NOTE: Perhaps required because semantics may make zero payments - -- (though this passes the test suite), but removing this function's - -- guard reduces the validator size by 20 bytes. - payoutByParty (Payment _ (Account _) _ _ ) = AssocMap.empty - - -- Check outgoing payments. - payoutConstraints :: [(Party, Val.Value)] -> Bool - payoutConstraints = all payoutToTxOut - where - payoutToTxOut :: (Party, Val.Value) -> Bool - payoutToTxOut (party, value) = case party of + IDeposit _ party _ _ -> validatePartyWitness party -- The party must witness a deposit. + IChoice (ChoiceId _ party) _ -> validatePartyWitness party -- The party must witness a choice. + INotify -> True -- No witness is needed for a notify. + where + validatePartyWitness :: Party -> Bool + validatePartyWitness (Address _ address) = traceIfFalse "s" $ txSignedByAddress (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ address) -- The key must have signed. + validatePartyWitness (Role role) = + traceIfFalse "t" -- The role token must be present. + $ Val.singleton rolesCurrency role 1 + `Val.leq` (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData $ Data.valueSpent scriptContextTxInfo) + + -- Tally the deposits in the input. + collectDeposits :: InputContent -> Val.Value + collectDeposits (IDeposit _ _ (Token cur tok) amount) + | amount > 0 = Val.singleton cur tok amount -- SCP-5123: Semantically negative deposits + | otherwise = zero -- do not remove funds from the script's UTxO. + collectDeposits _ = zero + + -- Extract the payout to a party. + payoutByParty :: Payment -> AssocMap.Map Party Val.Value + payoutByParty (Payment _ (Party party) (Token cur tok) amount) + | amount > 0 = AssocMap.singleton party $ Val.singleton cur tok amount + | otherwise = AssocMap.empty -- NOTE: Perhaps required because semantics may make zero payments + -- (though this passes the test suite), but removing this function's + -- guard reduces the validator size by 20 bytes. + payoutByParty (Payment _ (Account _) _ _) = AssocMap.empty + + -- Check outgoing payments. + payoutConstraints :: [(Party, Val.Value)] -> Bool + payoutConstraints = all payoutToTxOut + where + payoutToTxOut :: (Party, Val.Value) -> Bool + payoutToTxOut (party, value) = case party of -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient Payment".] -- SCP-5128: Note that the payment to an address may be split into several outputs but the payment to a role must be -- a single output. The flexibily of multiple outputs accommodates wallet-related practicalities such as the change and -- the return of the role token being in separate UTxOs in situations where a contract is also paying to the address -- where that change and that role token are sent. - Address _ address -> traceIfFalse "p" $ value `Val.leq` valuePaidToAddress address -- At least sufficient value paid. - Role role -> let + Address _ address -> traceIfFalse "p" $ value `Val.leq` valuePaidToAddress address -- At least sufficient value paid. + Role role -> + let hsh = findDatumHash' (rolesCurrency, role) addr = Address.scriptHashAddress rolePayoutValidatorHash + in -- Some output must have the correct value and datum to the role-payout address. - in traceIfFalse "r" $ Data.List.any (checkScriptOutput Val.geq addr hsh value) allOutputs + traceIfFalse "r" $ Data.List.any (checkScriptOutput Val.geq addr hsh value) allOutputs - -- The key for the address must have signed. - txSignedByAddress :: Data.Address -> Bool - txSignedByAddress (Data.Address (Data.PubKeyCredential pkh) _) = scriptContextTxInfo `Data.txSignedBy` pkh - txSignedByAddress _ = False - - -- Tally the value paid to an address. - valuePaidToAddress :: Ledger.Address -> Val.Value - valuePaidToAddress address = Data.List.foldMap (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txOutValue) $ Data.List.filter ((== address) . PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txOutAddress) allOutputs -{-# INLINABLE mkMarloweValidator #-} + -- The key for the address must have signed. + txSignedByAddress :: Data.Address -> Bool + txSignedByAddress (Data.Address (Data.PubKeyCredential pkh) _) = scriptContextTxInfo `Data.txSignedBy` pkh + txSignedByAddress _ = False + -- Tally the value paid to an address. + valuePaidToAddress :: Ledger.Address -> Val.Value + valuePaidToAddress address = Data.List.foldMap (PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txOutValue) $ Data.List.filter ((== address) . PlutusTx.unsafeFromBuiltinData . PlutusTx.toBuiltinData . Data.txOutAddress) allOutputs +{-# INLINEABLE mkMarloweValidator #-} -- | Convert semantics input to transaction input. marloweTxInputFromInput :: Input -> MarloweTxInput -marloweTxInputFromInput (NormalInput i) = Input i +marloweTxInputFromInput (NormalInput i) = Input i marloweTxInputFromInput (MerkleizedInput i h _) = MerkleizedTxInput i h - -- | Convert semantics inputs to transaction inputs. marloweTxInputsFromInputs :: [Input] -> [MarloweTxInput] marloweTxInputsFromInputs = fmap marloweTxInputFromInput - -- Lifting data types to Plutus Core makeLift ''MarloweTxInput -makeIsDataIndexed ''MarloweTxInput [('Input,0),('MerkleizedTxInput,1)] - +makeIsDataIndexed ''MarloweTxInput [('Input, 0), ('MerkleizedTxInput, 1)] -- | Compute the hash of a script. hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit) -> ScriptHash @@ -439,10 +469,9 @@ hashScript = ScriptHash . toBuiltin . (Hash.hashToBytes :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString -> BS.ByteString) - . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. + . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. . serialiseCompiledCode - -- | The validator for Marlowe semantics. marloweValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit) marloweValidator = @@ -450,27 +479,27 @@ marloweValidator = marloweValidator' :: ScriptHash -> BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit marloweValidator' rpvh d r p = check - $ mkMarloweValidator rpvh - (unsafeFromBuiltinData d) - (unsafeFromBuiltinData r) - (unsafeFromBuiltinData p) + $ mkMarloweValidator + rpvh + (unsafeFromBuiltinData d) + (unsafeFromBuiltinData r) + (unsafeFromBuiltinData p) errorOrApplied = - $$(PlutusTx.compile [|| marloweValidator' ||]) + $$(PlutusTx.compile [||marloweValidator'||]) `PlutusTx.applyCode` PlutusTx.liftCode plcVersion100 rolePayoutValidatorHash - in + in case errorOrApplied of Haskell.Left err -> - Haskell.error $ "Application of role-payout validator hash to marlowe validator failed." + Haskell.error + $ "Application of role-payout validator hash to marlowe validator failed." <> err Haskell.Right applied -> applied - -- | The serialisation of the Marlowe semantics validator. marloweValidatorBytes :: SerialisedScript marloweValidatorBytes = serialiseCompiledCode marloweValidator - -- | The hash of the Marlowe semantics validator. marloweValidatorHash :: ScriptHash marloweValidatorHash = hashScript marloweValidator diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs index 725432dabc2..ddc357f6e52 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} @@ -19,50 +19,63 @@ import Cardano.Crypto.Hash qualified as Hash import Data.ByteString qualified as BS import Data.ByteString.Short qualified as SBS import PlutusLedgerApi.V1.Value qualified as Val -import PlutusLedgerApi.V2 (CurrencySymbol, ScriptContext (scriptContextTxInfo), ScriptHash (..), - SerialisedScript, TokenName, serialiseCompiledCode) +import PlutusLedgerApi.V2 ( + CurrencySymbol, + ScriptContext (scriptContextTxInfo), + ScriptHash (..), + SerialisedScript, + TokenName, + serialiseCompiledCode, + ) import PlutusLedgerApi.V2.Contexts (valueSpent) import PlutusTx (CompiledCode, unsafeFromBuiltinData) import PlutusTx qualified import PlutusTx.Plugin () -import PlutusTx.Prelude as PlutusTxPrelude (Bool (..), BuiltinData, BuiltinUnit, check, toBuiltin, - ($), (.)) +import PlutusTx.Prelude as PlutusTxPrelude ( + Bool (..), + BuiltinData, + BuiltinUnit, + check, + toBuiltin, + ($), + (.), + ) -- | Tag for the Marlowe payout validator. data TypedRolePayoutValidator -- | The Marlowe payout validator. -mkRolePayoutValidator - :: (CurrencySymbol, TokenName) - -- ^ The datum is the currency symbol and role name for the payout. - -> () - -- ^ No redeemer is required. - -> ScriptContext - -- ^ The script context. - -> Bool - -- ^ Whether the transaction validated. +mkRolePayoutValidator :: + -- | The datum is the currency symbol and role name for the payout. + (CurrencySymbol, TokenName) -> + -- | No redeemer is required. + () -> + -- | The script context. + ScriptContext -> + -- | Whether the transaction validated. + Bool mkRolePayoutValidator (currency, role) _ ctx = -- The role token for the correct currency must be present. -- [Marlowe-Cardano Specification: "17. Payment authorized".] Val.singleton currency role 1 `Val.leq` valueSpent (scriptContextTxInfo ctx) -- | Compute the hash of a script. -hashScript - :: CompiledCode - ( BuiltinData - -> BuiltinData - -> BuiltinData - -> BuiltinUnit - ) - -> ScriptHash +hashScript :: + CompiledCode + ( BuiltinData -> + BuiltinData -> + BuiltinData -> + BuiltinUnit + ) -> + ScriptHash hashScript = -- FIXME: Apparently this is the wrong recipe, since its hash disagrees with -- `cardano-cli`. ScriptHash . toBuiltin - . ( Hash.hashToBytes - :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString - -> BS.ByteString + . ( Hash.hashToBytes :: + Hash.Hash Hash.Blake2b_224 SBS.ShortByteString -> + BS.ByteString ) . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. . serialiseCompiledCode @@ -70,26 +83,26 @@ hashScript = {-# INLINEABLE rolePayoutValidator #-} -- | The Marlowe payout validator. -rolePayoutValidator - :: CompiledCode - ( BuiltinData - -> BuiltinData - -> BuiltinData - -> BuiltinUnit - ) +rolePayoutValidator :: + CompiledCode + ( BuiltinData -> + BuiltinData -> + BuiltinData -> + BuiltinUnit + ) rolePayoutValidator = $$(PlutusTx.compile [||rolePayoutValidator'||]) - where - rolePayoutValidator' - :: BuiltinData - -> BuiltinData - -> BuiltinData - -> BuiltinUnit - rolePayoutValidator' d r p = - check - $ mkRolePayoutValidator - (unsafeFromBuiltinData d) - (unsafeFromBuiltinData r) - (unsafeFromBuiltinData p) + where + rolePayoutValidator' :: + BuiltinData -> + BuiltinData -> + BuiltinData -> + BuiltinUnit + rolePayoutValidator' d r p = + check + $ mkRolePayoutValidator + (unsafeFromBuiltinData d) + (unsafeFromBuiltinData r) + (unsafeFromBuiltinData p) -- | The serialisation of the Marlowe payout validator. rolePayoutValidatorBytes :: SerialisedScript diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs index 1b88aeecbf6..421b9fd47d0 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs @@ -1,15 +1,15 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-preserve-logging #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-preserve-logging #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} module PlutusBenchmark.Marlowe.Scripts.Semantics ( @@ -28,34 +28,71 @@ module PlutusBenchmark.Marlowe.Scripts.Semantics ( ) where import GHC.Generics (Generic) -import PlutusBenchmark.Marlowe.Core.V1.Semantics as Semantics (MarloweData (..), - MarloweParams (MarloweParams, rolesCurrency), - Payment (..), TransactionError (..), - TransactionInput (TransactionInput, txInputs, txInterval), - TransactionOutput (..), - computeTransaction, totalBalance) +import PlutusBenchmark.Marlowe.Core.V1.Semantics as Semantics ( + MarloweData (..), + MarloweParams (MarloweParams, rolesCurrency), + Payment (..), + TransactionError (..), + TransactionInput (TransactionInput, txInputs, txInterval), + TransactionOutput (..), + computeTransaction, + totalBalance, + ) import PlutusBenchmark.Marlowe.Core.V1.Semantics.Types import PlutusBenchmark.Marlowe.Scripts.RolePayout (rolePayoutValidatorHash) -import PlutusLedgerApi.V2 (Credential (..), Datum (Datum), DatumHash (DatumHash), Extended (..), - Interval (..), LowerBound (..), POSIXTime (..), POSIXTimeRange, - ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), - ScriptHash (..), ScriptPurpose (Spending), SerialisedScript, - TxInInfo (TxInInfo, txInInfoOutRef, txInInfoResolved), - TxInfo (TxInfo, txInfoInputs, txInfoOutputs, txInfoValidRange), - UpperBound (..), serialiseCompiledCode) +import PlutusLedgerApi.V2 ( + Credential (..), + Datum (Datum), + DatumHash (DatumHash), + Extended (..), + Interval (..), + LowerBound (..), + POSIXTime (..), + POSIXTimeRange, + ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), + ScriptHash (..), + ScriptPurpose (Spending), + SerialisedScript, + TxInInfo (TxInInfo, txInInfoOutRef, txInInfoResolved), + TxInfo (TxInfo, txInfoInputs, txInfoOutputs, txInfoValidRange), + UpperBound (..), + serialiseCompiledCode, + ) import PlutusLedgerApi.V2.Contexts (findDatum, findDatumHash, txSignedBy, valueSpent) -import PlutusLedgerApi.V2.Tx (OutputDatum (OutputDatumHash), - TxOut (TxOut, txOutAddress, txOutDatum, txOutValue)) +import PlutusLedgerApi.V2.Tx ( + OutputDatum (OutputDatumHash), + TxOut (TxOut, txOutAddress, txOutDatum, txOutValue), + ) import PlutusTx (CompiledCode, makeIsDataIndexed, makeLift, unsafeFromBuiltinData) import PlutusTx.Foldable (foldMap) import PlutusTx.List (all, any, elem, filter, find, null) import PlutusTx.Plugin () -import PlutusTx.Prelude as PlutusTxPrelude (AdditiveGroup ((-)), AdditiveMonoid (zero), - AdditiveSemigroup ((+)), Bool (..), BuiltinByteString, - BuiltinData, BuiltinString, BuiltinUnit, - Enum (fromEnum), Eq (..), Functor (fmap), Integer, - Maybe (..), Ord ((>)), Semigroup ((<>)), check, - otherwise, snd, toBuiltin, ($), (&&), (.), (/=), (||)) +import PlutusTx.Prelude as PlutusTxPrelude ( + AdditiveGroup ((-)), + AdditiveMonoid (zero), + AdditiveSemigroup ((+)), + Bool (..), + BuiltinByteString, + BuiltinData, + BuiltinString, + BuiltinUnit, + Enum (fromEnum), + Eq (..), + Functor (fmap), + Integer, + Maybe (..), + Ord ((>)), + Semigroup ((<>)), + check, + otherwise, + snd, + toBuiltin, + ($), + (&&), + (.), + (/=), + (||), + ) import Cardano.Crypto.Hash qualified as Hash import Data.ByteString qualified as BS @@ -81,9 +118,8 @@ data MarloweTxInput | MerkleizedTxInput InputContent BuiltinByteString deriving stock (Haskell.Show, Haskell.Eq, Generic) -{-| Convert a Plutus POSIX time range into the closed interval -needed by Marlowe semantics. --} +-- | Convert a Plutus POSIX time range into the closed interval +-- needed by Marlowe semantics. closeInterval :: POSIXTimeRange -> Maybe (POSIXTime, POSIXTime) closeInterval ( Interval @@ -100,29 +136,29 @@ closeInterval _ = Nothing {-# INLINEABLE closeInterval #-} -- | The Marlowe semantics validator. -mkMarloweValidator - :: ScriptHash - -- ^ The hash of the corresponding Marlowe payout validator. - -> MarloweData - -- ^ The datum is the Marlowe parameters, state, and contract. - -> MarloweInput - -- ^ The redeemer is the list of inputs applied to the contract. - -> ScriptContext - -- ^ The script context. - -> Bool - -- ^ Whether the transaction validated. +mkMarloweValidator :: + -- | The hash of the corresponding Marlowe payout validator. + ScriptHash -> + -- | The datum is the Marlowe parameters, state, and contract. + MarloweData -> + -- | The redeemer is the list of inputs applied to the contract. + MarloweInput -> + -- | The script context. + ScriptContext -> + -- | Whether the transaction validated. + Bool mkMarloweValidator rolePayoutValidatorHash - MarloweData{..} + MarloweData {..} marloweTxInputs - ctx@ScriptContext{scriptContextTxInfo} = do + ctx@ScriptContext {scriptContextTxInfo} = do let scriptInValue = txOutValue $ txInInfoResolved ownInput let interval = -- Marlowe semantics require a closed interval, -- so we might adjust by one millisecond. case closeInterval $ txInfoValidRange scriptContextTxInfo of Just interval' -> interval' - Nothing -> traceError "a" + Nothing -> traceError "a" -- Find Contract continuation in TxInfo datums by hash or fail with error. let inputs = fmap marloweTxInputToInput marloweTxInputs @@ -159,7 +195,7 @@ mkMarloweValidator -- the incoming datum. let computedResult = computeTransaction txInput marloweState marloweContract case computedResult of - TransactionOutput{txOutPayments, txOutState, txOutContract} -> do + TransactionOutput {txOutPayments, txOutState, txOutContract} -> do -- [Marlowe-Cardano Specification: "Constraint 9. Marlowe parameters".] -- [Marlowe-Cardano Specification: "Constraint 10. Output state".] -- [Marlowe-Cardano Specification: "Constraint 11. Output contract."] @@ -208,256 +244,256 @@ mkMarloweValidator Error (TEIntervalError (IntervalInPastError _ _)) -> traceError "k" Error TEUselessTransaction -> traceError "u" Error TEHashMismatch -> traceError "m" - where - -- The roles currency is in the Marlowe parameters. - MarloweParams{rolesCurrency} = marloweParams - - -- Find the input being spent by a script. - findOwnInput :: ScriptContext -> Maybe TxInInfo - findOwnInput - ScriptContext - { scriptContextTxInfo = TxInfo{txInfoInputs} - , scriptContextPurpose = Spending txOutRef - } = - find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) - txInfoInputs - findOwnInput _ = Nothing - - -- [Marlowe-Cardano Specification: "2. Single Marlowe script input".] - -- The inputs being spent by this script, and whether other validators are present. - ownInput :: TxInInfo - noOthers :: Bool - (ownInput@TxInInfo{txInInfoResolved = TxOut{txOutAddress = ownAddress}}, noOthers) = - case findOwnInput ctx of - Just ownTxInInfo -> - examineScripts - (sameValidatorHash ownTxInInfo) - Nothing - True - (txInfoInputs scriptContextTxInfo) - _ -> traceError "x" -- Input to be validated was not found. - - -- Check for the presence of multiple Marlowe validators or other Plutus validators. - examineScripts - :: (ScriptHash -> Bool) - -- \^ Test for this validator. - -> Maybe TxInInfo - -- \^ The input for this validator, if found so far. - -> Bool - -- \^ Whether no other validator has been found so far. - -> [TxInInfo] - -- \^ The inputs remaining to be examined. - -> (TxInInfo, Bool) - -- \^ The input for this validator and whether no other validators are present. - - -- This validator has not been found. - examineScripts _ Nothing _ [] = traceError "x" - -- This validator has been found, and other validators may have been found. - examineScripts _ (Just self) noOthers [] = (self, noOthers) - -- Found both this validator and another script, so we short-cut. - examineScripts _ (Just self) False _ = (self, False) - -- Found one script. - examineScripts - f - mSelf - noOthers - ( tx@TxInInfo + where + -- The roles currency is in the Marlowe parameters. + MarloweParams {rolesCurrency} = marloweParams + + -- Find the input being spent by a script. + findOwnInput :: ScriptContext -> Maybe TxInInfo + findOwnInput + ScriptContext + { scriptContextTxInfo = TxInfo {txInfoInputs} + , scriptContextPurpose = Spending txOutRef + } = + find + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == txOutRef) + txInfoInputs + findOwnInput _ = Nothing + + -- [Marlowe-Cardano Specification: "2. Single Marlowe script input".] + -- The inputs being spent by this script, and whether other validators are present. + ownInput :: TxInInfo + noOthers :: Bool + (ownInput@TxInInfo {txInInfoResolved = TxOut {txOutAddress = ownAddress}}, noOthers) = + case findOwnInput ctx of + Just ownTxInInfo -> + examineScripts + (sameValidatorHash ownTxInInfo) + Nothing + True + (txInfoInputs scriptContextTxInfo) + _ -> traceError "x" -- Input to be validated was not found. + + -- Check for the presence of multiple Marlowe validators or other Plutus validators. + examineScripts :: + (ScriptHash -> Bool) -> + -- \^ Test for this validator. + Maybe TxInInfo -> + -- \^ The input for this validator, if found so far. + Bool -> + -- \^ Whether no other validator has been found so far. + [TxInInfo] -> + -- \^ The inputs remaining to be examined. + (TxInInfo, Bool) + -- \^ The input for this validator and whether no other validators are present. + + -- This validator has not been found. + examineScripts _ Nothing _ [] = traceError "x" + -- This validator has been found, and other validators may have been found. + examineScripts _ (Just self) noOthers [] = (self, noOthers) + -- Found both this validator and another script, so we short-cut. + examineScripts _ (Just self) False _ = (self, False) + -- Found one script. + examineScripts + f + mSelf + noOthers + ( tx@TxInInfo + { txInInfoResolved = + TxOut + { txOutAddress = Ledger.Address (ScriptCredential vh) _ + } + } + : txs + ) + -- The script is this validator. + | f vh = case mSelf of + -- We hadn't found it before, so we save it in `mSelf`. + Nothing -> examineScripts f (Just tx) noOthers txs + -- We already had found this validator before + Just _ -> traceError "w" + -- The script is something else, so we set `noOther` to `False`. + | otherwise = examineScripts f mSelf False txs + -- An input without a validator is encountered. + examineScripts f self others (_ : txs) = examineScripts f self others txs + + -- Check if inputs are being spent from the same script. + sameValidatorHash :: TxInInfo -> ScriptHash -> Bool + sameValidatorHash + TxInInfo { txInInfoResolved = TxOut - { txOutAddress = Ledger.Address (ScriptCredential vh) _ + { txOutAddress = + Ledger.Address (ScriptCredential vh1) _ } } - : txs - ) - -- The script is this validator. - | f vh = case mSelf of - -- We hadn't found it before, so we save it in `mSelf`. - Nothing -> examineScripts f (Just tx) noOthers txs - -- We already had found this validator before - Just _ -> traceError "w" - -- The script is something else, so we set `noOther` to `False`. - | otherwise = examineScripts f mSelf False txs - -- An input without a validator is encountered. - examineScripts f self others (_ : txs) = examineScripts f self others txs - - -- Check if inputs are being spent from the same script. - sameValidatorHash :: TxInInfo -> ScriptHash -> Bool - sameValidatorHash - TxInInfo - { txInInfoResolved = - TxOut - { txOutAddress = - Ledger.Address (ScriptCredential vh1) _ - } - } - vh2 = vh1 == vh2 - sameValidatorHash _ _ = False - - -- Check a state for the correct value, positive accounts, and no duplicates. - checkState :: BuiltinString -> Val.Value -> State -> Bool - checkState tag expected State{..} = - let - positiveBalance :: (a, Integer) -> Bool - positiveBalance (_, balance) = balance > 0 - noDuplicates :: (Eq k) => AssocMap.Map k v -> Bool - noDuplicates am = - let - test [] = True -- An empty list has no duplicates. - test (x : xs) -- Look for a duplicate of the head in the tail. - | elem x xs = False -- A duplicate is present. - | otherwise = test xs -- Continue searching for a duplicate. - in - test $ AssocMap.keys am - in - -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] - -- and/or - -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] - traceIfFalse ("v" <> tag) (totalBalance accounts == expected) - -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] - && traceIfFalse ("b" <> tag) (all positiveBalance $ AssocMap.toList accounts) - -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] - && traceIfFalse ("ea" <> tag) (noDuplicates accounts) - && traceIfFalse ("ec" <> tag) (noDuplicates choices) - && traceIfFalse ("eb" <> tag) (noDuplicates boundValues) - - -- Look up the Datum hash for specific data. - findDatumHash' :: (PlutusTx.ToData o) => o -> Maybe DatumHash - findDatumHash' datum = findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo - - -- Check that the correct datum and value is being output to the script. - checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool - checkOwnOutputConstraint ocDatum ocValue = - let hsh = findDatumHash' ocDatum - in traceIfFalse "d" -- "Output constraint" - $ checkScriptOutput (==) ownAddress hsh ocValue getContinuingOutput - - getContinuingOutput :: TxOut - ~getContinuingOutput = - case filter (\TxOut{txOutAddress} -> ownAddress == txOutAddress) allOutputs of - [out] -> out - _ -> traceError "o" -- No continuation or multiple Marlowe contract outputs is forbidden. - - -- Check that address, value, and datum match the specified. - checkScriptOutput - :: (Val.Value -> Val.Value -> Bool) - -> Ledger.Address - -> Maybe DatumHash - -> Val.Value - -> TxOut - -> Bool - checkScriptOutput - comparison - addr - hsh - value - TxOut - { txOutAddress - , txOutValue - , txOutDatum = OutputDatumHash svh - } = - txOutValue `comparison` value && hsh == Just svh && txOutAddress == addr - checkScriptOutput _ _ _ _ _ = False - - -- Check for any output to the script address. - hasNoOutputToOwnScript :: Bool - hasNoOutputToOwnScript = all ((/= ownAddress) . txOutAddress) allOutputs - - -- All of the script outputs. - allOutputs :: [TxOut] - allOutputs = txInfoOutputs scriptContextTxInfo - - -- Check mekleization and transform transaction input to semantics input. - marloweTxInputToInput :: MarloweTxInput -> Input - marloweTxInputToInput (MerkleizedTxInput input hash) = - case findDatum (DatumHash hash) scriptContextTxInfo of - Just (Datum d) -> - let - continuation = PlutusTx.unsafeFromBuiltinData d - in - MerkleizedInput input hash continuation - Nothing -> traceError "h" - marloweTxInputToInput (Input input) = NormalInput input - - -- Check that inputs are authorized. - allInputsAreAuthorized :: [InputContent] -> Bool - allInputsAreAuthorized = all validateInputWitness - where - validateInputWitness :: InputContent -> Bool - validateInputWitness input = - case input of - IDeposit _ party _ _ -> - validatePartyWitness party -- The party must witness a deposit. - IChoice (ChoiceId _ party) _ -> - validatePartyWitness party -- The party must witness a choice. - INotify -> True -- No witness is needed for a notify. - where - validatePartyWitness :: Party -> Bool - validatePartyWitness (Address _ address) = - traceIfFalse "s" $ txSignedByAddress address -- The key must have signed. - validatePartyWitness (Role role) = - traceIfFalse "t" -- The role token must be present. - $ Val.singleton rolesCurrency role 1 - `Val.leq` valueSpent scriptContextTxInfo - - -- Tally the deposits in the input. - collectDeposits :: InputContent -> Val.Value - collectDeposits (IDeposit _ _ (Token cur tok) amount) - | amount > 0 = Val.singleton cur tok amount -- SCP-5123: Semantically negative deposits - | otherwise = zero -- do not remove funds from the script's UTxO. - collectDeposits _ = zero - - -- Extract the payout to a party. - payoutByParty :: Payment -> AssocMap.Map Party Val.Value - payoutByParty (Payment _ (Party party) (Token cur tok) amount) - | amount > 0 = AssocMap.singleton party $ Val.singleton cur tok amount - | otherwise = - AssocMap.empty - -- NOTE: Perhaps required because semantics may make zero payments - -- (though this passes the test suite), but removing this function's - -- guard reduces the validator size by 20 bytes. - payoutByParty (Payment _ (Account _) _ _) = AssocMap.empty - - -- Check outgoing payments. - payoutConstraints :: [(Party, Val.Value)] -> Bool - payoutConstraints = all payoutToTxOut - where - payoutToTxOut :: (Party, Val.Value) -> Bool - payoutToTxOut (party, value) = case party of - -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient Payment".] - -- SCP-5128: Note that the payment to an address may be split into - -- several outputs but the payment to a role must be a single output. - -- The flexibily of multiple outputs accommodates wallet-related - -- practicalities such as the change and the return of the role token - -- being in separate UTxOs in situations where a contract is also paying - -- to the address where that change and that role token are sent. - Address _ address -> - -- At least sufficient value paid. - traceIfFalse "p" $ value `Val.leq` valuePaidToAddress address - Role role -> - let - hsh = findDatumHash' (rolesCurrency, role) - addr = Address.scriptHashAddress rolePayoutValidatorHash - in - -- Some output must have the correct value and datum to the role-payout address. - traceIfFalse "r" - $ any (checkScriptOutput Val.geq addr hsh value) allOutputs - - -- The key for the address must have signed. - txSignedByAddress :: Ledger.Address -> Bool - txSignedByAddress (Ledger.Address (PubKeyCredential pkh) _) = - scriptContextTxInfo `txSignedBy` pkh - txSignedByAddress _ = False - - -- Tally the value paid to an address. - valuePaidToAddress :: Ledger.Address -> Val.Value - valuePaidToAddress address = - foldMap txOutValue $ filter ((== address) . txOutAddress) allOutputs + vh2 = vh1 == vh2 + sameValidatorHash _ _ = False + + -- Check a state for the correct value, positive accounts, and no duplicates. + checkState :: BuiltinString -> Val.Value -> State -> Bool + checkState tag expected State {..} = + let + positiveBalance :: (a, Integer) -> Bool + positiveBalance (_, balance) = balance > 0 + noDuplicates :: Eq k => AssocMap.Map k v -> Bool + noDuplicates am = + let + test [] = True -- An empty list has no duplicates. + test (x : xs) -- Look for a duplicate of the head in the tail. + | elem x xs = False -- A duplicate is present. + | otherwise = test xs -- Continue searching for a duplicate. + in + test $ AssocMap.keys am + in + -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] + -- and/or + -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] + traceIfFalse ("v" <> tag) (totalBalance accounts == expected) + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + && traceIfFalse ("b" <> tag) (all positiveBalance $ AssocMap.toList accounts) + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + && traceIfFalse ("ea" <> tag) (noDuplicates accounts) + && traceIfFalse ("ec" <> tag) (noDuplicates choices) + && traceIfFalse ("eb" <> tag) (noDuplicates boundValues) + + -- Look up the Datum hash for specific data. + findDatumHash' :: PlutusTx.ToData o => o -> Maybe DatumHash + findDatumHash' datum = findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo + + -- Check that the correct datum and value is being output to the script. + checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool + checkOwnOutputConstraint ocDatum ocValue = + let hsh = findDatumHash' ocDatum + in traceIfFalse "d" -- "Output constraint" + $ checkScriptOutput (==) ownAddress hsh ocValue getContinuingOutput + + getContinuingOutput :: TxOut + ~getContinuingOutput = + case filter (\TxOut {txOutAddress} -> ownAddress == txOutAddress) allOutputs of + [out] -> out + _ -> traceError "o" -- No continuation or multiple Marlowe contract outputs is forbidden. + + -- Check that address, value, and datum match the specified. + checkScriptOutput :: + (Val.Value -> Val.Value -> Bool) -> + Ledger.Address -> + Maybe DatumHash -> + Val.Value -> + TxOut -> + Bool + checkScriptOutput + comparison + addr + hsh + value + TxOut + { txOutAddress + , txOutValue + , txOutDatum = OutputDatumHash svh + } = + txOutValue `comparison` value && hsh == Just svh && txOutAddress == addr + checkScriptOutput _ _ _ _ _ = False + + -- Check for any output to the script address. + hasNoOutputToOwnScript :: Bool + hasNoOutputToOwnScript = all ((/= ownAddress) . txOutAddress) allOutputs + + -- All of the script outputs. + allOutputs :: [TxOut] + allOutputs = txInfoOutputs scriptContextTxInfo + + -- Check mekleization and transform transaction input to semantics input. + marloweTxInputToInput :: MarloweTxInput -> Input + marloweTxInputToInput (MerkleizedTxInput input hash) = + case findDatum (DatumHash hash) scriptContextTxInfo of + Just (Datum d) -> + let + continuation = PlutusTx.unsafeFromBuiltinData d + in + MerkleizedInput input hash continuation + Nothing -> traceError "h" + marloweTxInputToInput (Input input) = NormalInput input + + -- Check that inputs are authorized. + allInputsAreAuthorized :: [InputContent] -> Bool + allInputsAreAuthorized = all validateInputWitness + where + validateInputWitness :: InputContent -> Bool + validateInputWitness input = + case input of + IDeposit _ party _ _ -> + validatePartyWitness party -- The party must witness a deposit. + IChoice (ChoiceId _ party) _ -> + validatePartyWitness party -- The party must witness a choice. + INotify -> True -- No witness is needed for a notify. + where + validatePartyWitness :: Party -> Bool + validatePartyWitness (Address _ address) = + traceIfFalse "s" $ txSignedByAddress address -- The key must have signed. + validatePartyWitness (Role role) = + traceIfFalse "t" -- The role token must be present. + $ Val.singleton rolesCurrency role 1 + `Val.leq` valueSpent scriptContextTxInfo + + -- Tally the deposits in the input. + collectDeposits :: InputContent -> Val.Value + collectDeposits (IDeposit _ _ (Token cur tok) amount) + | amount > 0 = Val.singleton cur tok amount -- SCP-5123: Semantically negative deposits + | otherwise = zero -- do not remove funds from the script's UTxO. + collectDeposits _ = zero + + -- Extract the payout to a party. + payoutByParty :: Payment -> AssocMap.Map Party Val.Value + payoutByParty (Payment _ (Party party) (Token cur tok) amount) + | amount > 0 = AssocMap.singleton party $ Val.singleton cur tok amount + | otherwise = + AssocMap.empty + -- NOTE: Perhaps required because semantics may make zero payments + -- (though this passes the test suite), but removing this function's + -- guard reduces the validator size by 20 bytes. + payoutByParty (Payment _ (Account _) _ _) = AssocMap.empty + + -- Check outgoing payments. + payoutConstraints :: [(Party, Val.Value)] -> Bool + payoutConstraints = all payoutToTxOut + where + payoutToTxOut :: (Party, Val.Value) -> Bool + payoutToTxOut (party, value) = case party of + -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient Payment".] + -- SCP-5128: Note that the payment to an address may be split into + -- several outputs but the payment to a role must be a single output. + -- The flexibily of multiple outputs accommodates wallet-related + -- practicalities such as the change and the return of the role token + -- being in separate UTxOs in situations where a contract is also paying + -- to the address where that change and that role token are sent. + Address _ address -> + -- At least sufficient value paid. + traceIfFalse "p" $ value `Val.leq` valuePaidToAddress address + Role role -> + let + hsh = findDatumHash' (rolesCurrency, role) + addr = Address.scriptHashAddress rolePayoutValidatorHash + in + -- Some output must have the correct value and datum to the role-payout address. + traceIfFalse "r" + $ any (checkScriptOutput Val.geq addr hsh value) allOutputs + + -- The key for the address must have signed. + txSignedByAddress :: Ledger.Address -> Bool + txSignedByAddress (Ledger.Address (PubKeyCredential pkh) _) = + scriptContextTxInfo `txSignedBy` pkh + txSignedByAddress _ = False + + -- Tally the value paid to an address. + valuePaidToAddress :: Ledger.Address -> Val.Value + valuePaidToAddress address = + foldMap txOutValue $ filter ((== address) . txOutAddress) allOutputs {-# INLINEABLE mkMarloweValidator #-} -- | Convert semantics input to transaction input. marloweTxInputFromInput :: Input -> MarloweTxInput -marloweTxInputFromInput (NormalInput i) = Input i +marloweTxInputFromInput (NormalInput i) = Input i marloweTxInputFromInput (MerkleizedInput i h _) = MerkleizedTxInput i h -- | Convert semantics inputs to transaction inputs. @@ -469,42 +505,42 @@ makeLift ''MarloweTxInput makeIsDataIndexed ''MarloweTxInput [('Input, 0), ('MerkleizedTxInput, 1)] -- | Compute the hash of a script. -hashScript - :: CompiledCode - ( BuiltinData - -> BuiltinData - -> BuiltinData - -> BuiltinUnit - ) - -> ScriptHash +hashScript :: + CompiledCode + ( BuiltinData -> + BuiltinData -> + BuiltinData -> + BuiltinUnit + ) -> + ScriptHash hashScript = -- FIXME: Apparently this is the wrong recipe, -- since its hash disagrees with `cardano-cli`. ScriptHash . toBuiltin - . ( Hash.hashToBytes - :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString - -> BS.ByteString + . ( Hash.hashToBytes :: + Hash.Hash Hash.Blake2b_224 SBS.ShortByteString -> + BS.ByteString ) . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. . serialiseCompiledCode -- | The validator for Marlowe semantics. -marloweValidator - :: CompiledCode - ( BuiltinData - -> BuiltinData - -> BuiltinData - -> BuiltinUnit - ) +marloweValidator :: + CompiledCode + ( BuiltinData -> + BuiltinData -> + BuiltinData -> + BuiltinUnit + ) marloweValidator = let - marloweValidator' - :: ScriptHash - -> BuiltinData - -> BuiltinData - -> BuiltinData - -> BuiltinUnit + marloweValidator' :: + ScriptHash -> + BuiltinData -> + BuiltinData -> + BuiltinData -> + BuiltinUnit marloweValidator' rpvh d r p = check $ mkMarloweValidator diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Types.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Types.hs index d11d0d460a4..461c712fba4 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Types.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Types.hs @@ -8,26 +8,25 @@ import PlutusLedgerApi.V2 (Data, ExBudget, ScriptContext, ToData, toData) -- | A benchmarking case. data Benchmark = Benchmark - { bDatum :: Data + { bDatum :: Data -- ^ The datum. - , bRedeemer :: Data + , bRedeemer :: Data -- ^ The redeemer. , bScriptContext :: ScriptContext -- ^ The script context. , bReferenceCost :: Maybe ExBudget - {- ^ The previously measured execution costs in production, - which uses the Plutus version on August 18 2022 - (commit 6ed578b592f46afc0e77f4d19e5955a6eb439ba4). - -} + -- ^ The previously measured execution costs in production, + -- which uses the Plutus version on August 18 2022 + -- (commit 6ed578b592f46afc0e77f4d19e5955a6eb439ba4). } deriving stock (Show) -- | Construct a benchmarking case. -makeBenchmark - :: (ToData d, ToData r) - => d - -> r - -> ScriptContext - -> Maybe ExBudget - -> Benchmark +makeBenchmark :: + (ToData d, ToData r) => + d -> + r -> + ScriptContext -> + Maybe ExBudget -> + Benchmark makeBenchmark datum redeemer = Benchmark (toData datum) (toData redeemer) diff --git a/plutus-benchmark/marlowe/test/Lib.hs b/plutus-benchmark/marlowe/test/Lib.hs index 559d3258301..20896eb35c7 100644 --- a/plutus-benchmark/marlowe/test/Lib.hs +++ b/plutus-benchmark/marlowe/test/Lib.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Lib where @@ -23,35 +23,33 @@ import Text.Read (readMaybe) import Text.Tabular (Header (..), Properties (NoLine, SingleLine), Table (Table)) import Text.Tabular.AsciiArt qualified as Tabular import UntypedPlutusCore (NamedDeBruijn) -import UntypedPlutusCore.Core.Type qualified as UPLC import UntypedPlutusCore.AstSize qualified as UPLC +import UntypedPlutusCore.Core.Type qualified as UPLC -- | Measure the given program's execution budget and size. -measureProgram - :: UPLC.Program NamedDeBruijn DefaultUni DefaultFun () - -> IO (ExCPU, ExMemory, UPLC.AstSize) +measureProgram :: + UPLC.Program NamedDeBruijn DefaultUni DefaultFun () -> + IO (ExCPU, ExMemory, UPLC.AstSize) measureProgram program = runExceptT (runUPlcFull [program]) >>= \case Left err -> fail $ "Error evaluating UPLC program: " <> show err Right (_term, ExBudget exCpu exMem, _logs) -> pure (exCpu, exMem, UPLC.programAstSize program) -{-| Compare the output file's contents against the golden file's contents -after the given action has created the output file. --} -goldenUplcMeasurements - :: TestName - -- ^ test name - -> FilePath - -- ^ path to the «golden» file (the file that contains correct output) - -> FilePath - -- ^ path to the output file - -> (Handle -> IO ()) - -- ^ Given a file handle, action that writes measurements to it. - -> TestTree - {- ^ the test verifies that the output file contents is the same as - the golden file contents - -} +-- | Compare the output file's contents against the golden file's contents +-- after the given action has created the output file. +goldenUplcMeasurements :: + -- | test name + TestName -> + -- | path to the «golden» file (the file that contains correct output) + FilePath -> + -- | path to the output file + FilePath -> + -- | Given a file handle, action that writes measurements to it. + (Handle -> IO ()) -> + -- | the test verifies that the output file contents is the same as + -- the golden file contents + TestTree goldenUplcMeasurements name goldenPath outputPath act = goldenTest2 name @@ -60,70 +58,70 @@ goldenUplcMeasurements name goldenPath outputPath act = reportDifference (createDirectoriesAndWriteFile goldenPath) (removeFile outputPath) - where - reportDifference :: Text -> Text -> IO (Maybe String) - reportDifference expected actual = do - let parse = traverse parseLine . Text.lines - expectedResults <- parse expected - actualResults <- parse actual - if expectedResults == actualResults - then pure Nothing - else do - let (cpu0, mem0, size0) = aggregateResults expectedResults - (cpu1, mem1, size1) = aggregateResults actualResults + where + reportDifference :: Text -> Text -> IO (Maybe String) + reportDifference expected actual = do + let parse = traverse parseLine . Text.lines + expectedResults <- parse expected + actualResults <- parse actual + if expectedResults == actualResults + then pure Nothing + else do + let (cpu0, mem0, size0) = aggregateResults expectedResults + (cpu1, mem1, size1) = aggregateResults actualResults - pure . Just $ - "Actual execution budgets and sizes differ from expected ones:\n" - <> Tabular.render - id - id - Text.unpack - ( Table - ( Group - NoLine - [ Header "Baseline (average)" - , Header "Actual (average)" - , Header "Delta" - ] - ) - ( Group - SingleLine - [ Header "CPU units" - , Header "Memory units" - , Header "AST Size" + pure . Just $ + "Actual execution budgets and sizes differ from expected ones:\n" + <> Tabular.render + id + id + Text.unpack + ( Table + ( Group + NoLine + [ Header "Baseline (average)" + , Header "Actual (average)" + , Header "Delta" + ] + ) + ( Group + SingleLine + [ Header "CPU units" + , Header "Memory units" + , Header "AST Size" + ] + ) + [ [formatUnits cpu0, formatUnits mem0, formatUnits size0] + , [formatUnits cpu1, formatUnits mem1, formatUnits size1] + , + [ formatDelta cpu1 cpu0 + , formatDelta mem1 mem0 + , formatDelta size1 size0 ] - ) - [ [formatUnits cpu0, formatUnits mem0, formatUnits size0] - , [formatUnits cpu1, formatUnits mem1, formatUnits size1] - , - [ formatDelta cpu1 cpu0 - , formatDelta mem1 mem0 - , formatDelta size1 size0 ] - ] - ) + ) -aggregateResults - :: [(ExCPU, ExMemory, UPLC.AstSize)] - -> (Integer, Integer, Integer) +aggregateResults :: + [(ExCPU, ExMemory, UPLC.AstSize)] -> + (Integer, Integer, Integer) aggregateResults results = ( average (map (\(ExCPU i) -> fromSatInt i) cpus) , average (map (\(ExMemory m) -> fromSatInt m) mems) , average (map UPLC.unAstSize sizes) ) - where - (cpus, mems, sizes) = unzip3 results - average xs - | null xs = 0 - | otherwise = sum xs `div` fromIntegral (length xs) + where + (cpus, mems, sizes) = unzip3 results + average xs + | null xs = 0 + | otherwise = sum xs `div` fromIntegral (length xs) formatDelta :: Integer -> Integer -> Text formatDelta a b = F.sformat (F.fixed 2 F.% "%") (delta b a) - where - delta :: Integer -> Integer -> Double - delta x y - | x > 0 = (fromIntegral (y - x) * 100) / fromIntegral x - | otherwise = 0 + where + delta :: Integer -> Integer -> Double + delta x y + | x > 0 = (fromIntegral (y - x) * 100) / fromIntegral x + | otherwise = 0 formatUnits :: Integer -> Text formatUnits = F.sformat (F.groupInt 3 ' ') @@ -146,24 +144,24 @@ parseLine ln = <*> readMem mem <*> readAstSize size _ -> throwIO . userError $ "Can't parse line: " <> show ln - where - readCpu :: Text -> IO ExCPU - readCpu t = - case readMaybe (Text.unpack t) of - Just (cpu :: CostingInteger) -> pure (ExCPU cpu) - Nothing -> - throwIO . userError $ "Can't parse CPU exec units: " <> show t + where + readCpu :: Text -> IO ExCPU + readCpu t = + case readMaybe (Text.unpack t) of + Just (cpu :: CostingInteger) -> pure (ExCPU cpu) + Nothing -> + throwIO . userError $ "Can't parse CPU exec units: " <> show t - readMem :: Text -> IO ExMemory - readMem t = - case readMaybe (Text.unpack t) of - Just (mem :: CostingInteger) -> pure (ExMemory mem) - Nothing -> - throwIO . userError $ "Can't parse Memory exec units: " <> show t + readMem :: Text -> IO ExMemory + readMem t = + case readMaybe (Text.unpack t) of + Just (mem :: CostingInteger) -> pure (ExMemory mem) + Nothing -> + throwIO . userError $ "Can't parse Memory exec units: " <> show t - readAstSize :: Text -> IO UPLC.AstSize - readAstSize t = - case readMaybe (Text.unpack t) of - Just (size :: Integer) -> pure (UPLC.AstSize size) - Nothing -> - throwIO . userError $ "Can't parse program size: " <> show t + readAstSize :: Text -> IO UPLC.AstSize + readAstSize t = + case readMaybe (Text.unpack t) of + Just (size :: Integer) -> pure (UPLC.AstSize size) + Nothing -> + throwIO . userError $ "Can't parse program size: " <> show t diff --git a/plutus-benchmark/marlowe/test/Spec.hs b/plutus-benchmark/marlowe/test/Spec.hs index 97b7214d4b3..5e41e670e71 100644 --- a/plutus-benchmark/marlowe/test/Spec.hs +++ b/plutus-benchmark/marlowe/test/Spec.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where @@ -9,8 +9,11 @@ import Data.List qualified as List import Lib qualified import Main.Utf8 (withUtf8) import PlutusBenchmark.Common (checkGoldenFileExists) -import PlutusBenchmark.Marlowe.BenchUtil (benchmarkToUPLC, rolePayoutBenchmarks, - semanticsBenchmarks) +import PlutusBenchmark.Marlowe.BenchUtil ( + benchmarkToUPLC, + rolePayoutBenchmarks, + semanticsBenchmarks, + ) import PlutusBenchmark.Marlowe.Scripts.Data.RolePayout qualified as Data (rolePayoutValidator) import PlutusBenchmark.Marlowe.Scripts.Data.Semantics qualified as Data (marloweValidator) import PlutusBenchmark.Marlowe.Scripts.RolePayout qualified as SOP (rolePayoutValidator) @@ -23,7 +26,6 @@ import UntypedPlutusCore.AstSize qualified as UPLC main :: IO () main = withUtf8 $ do - let dir = "marlowe" "test" goldenFile = dir "budgets.golden.tsv" goldenFileData = dir "data.budgets.golden.tsv" @@ -66,18 +68,19 @@ main = withUtf8 $ do [benchmarkToUPLC Data.rolePayoutValidator bench | bench <- rolePayout] -- Write the measures to the actual file - defaultMain - $ testGroup "Marlowe" - [ Lib.goldenUplcMeasurements "budgets" goldenFile actualFile \writeHandle -> - for_ - (semanticsMeasures <> rolePayoutMeasures) - \(ExCPU cpu, ExMemory mem, UPLC.AstSize size) -> - hPutStrLn writeHandle $ - List.intercalate "\t" [show cpu, show mem, show size] - , Lib.goldenUplcMeasurements "data-budgets" goldenFileData actualFileData \writeHandle -> - for_ - (dataSemanticsMeasures <> dataRolePayoutMeasures) - \(ExCPU cpu, ExMemory mem, UPLC.AstSize size) -> - hPutStrLn writeHandle $ - List.intercalate "\t" [show cpu, show mem, show size] - ] + defaultMain $ + testGroup + "Marlowe" + [ Lib.goldenUplcMeasurements "budgets" goldenFile actualFile \writeHandle -> + for_ + (semanticsMeasures <> rolePayoutMeasures) + \(ExCPU cpu, ExMemory mem, UPLC.AstSize size) -> + hPutStrLn writeHandle $ + List.intercalate "\t" [show cpu, show mem, show size] + , Lib.goldenUplcMeasurements "data-budgets" goldenFileData actualFileData \writeHandle -> + for_ + (dataSemanticsMeasures <> dataRolePayoutMeasures) + \(ExCPU cpu, ExMemory mem, UPLC.AstSize size) -> + hPutStrLn writeHandle $ + List.intercalate "\t" [show cpu, show mem, show size] + ] diff --git a/plutus-benchmark/nofib/bench/BenchAgdaCek.hs b/plutus-benchmark/nofib/bench/BenchAgdaCek.hs index 7192e42d6db..32298a07ad0 100644 --- a/plutus-benchmark/nofib/bench/BenchAgdaCek.hs +++ b/plutus-benchmark/nofib/bench/BenchAgdaCek.hs @@ -1,5 +1,4 @@ -{- | Plutus benchmarks for the Agda CEK machine based on some nofib examples. -} - +-- | Plutus benchmarks for the Agda CEK machine based on some nofib examples. module Main where import PlutusBenchmark.Agda.Common (benchTermAgdaCek) diff --git a/plutus-benchmark/nofib/bench/BenchCek.hs b/plutus-benchmark/nofib/bench/BenchCek.hs index 4ea23a143fa..df6a0bb47f9 100644 --- a/plutus-benchmark/nofib/bench/BenchCek.hs +++ b/plutus-benchmark/nofib/bench/BenchCek.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -{- | Plutus benchmarks for the CEK machine based on some nofib examples. -} +-- | Plutus benchmarks for the CEK machine based on some nofib examples. module Main where import PlutusBenchmark.Common (mkMostRecentEvalCtx) diff --git a/plutus-benchmark/nofib/bench/BenchHaskell.hs b/plutus-benchmark/nofib/bench/BenchHaskell.hs index 3c6231287cf..658435d04c5 100644 --- a/plutus-benchmark/nofib/bench/BenchHaskell.hs +++ b/plutus-benchmark/nofib/bench/BenchHaskell.hs @@ -1,4 +1,4 @@ -{- | Benchmarking for the Haskell versions of the Plutus nofib benchmarks. -} +-- | Benchmarking for the Haskell versions of the Plutus nofib benchmarks. module Main (main) where import Shared (mkBenchMarks) @@ -27,5 +27,5 @@ benchQueens sz alg = nf (Queens.runQueens sz) alg main :: IO () main = do let runners = (benchClausify, benchKnights, benchPrime, benchQueens) - config <- getConfig 5.0 -- Run each benchmark for at least five seconds + config <- getConfig 5.0 -- Run each benchmark for at least five seconds defaultMainWith config $ mkBenchMarks runners diff --git a/plutus-benchmark/nofib/bench/Shared.hs b/plutus-benchmark/nofib/bench/Shared.hs index 2aead8a3059..d38f892b4e9 100644 --- a/plutus-benchmark/nofib/bench/Shared.hs +++ b/plutus-benchmark/nofib/bench/Shared.hs @@ -1,9 +1,9 @@ -{- | Shared code for benchmarking Plutus and Haskell versions of the Plutus nofib examples -} +-- | Shared code for benchmarking Plutus and Haskell versions of the Plutus nofib examples module Shared ( - benchWith - , mkBenchMarks - , benchTermCek - ) where + benchWith, + mkBenchMarks, + benchTermCek, +) where import PlutusBenchmark.Common (Term, benchTermCek, getConfig) @@ -14,51 +14,59 @@ import PlutusBenchmark.NoFib.Queens qualified as Queens import Criterion.Main - -{- | Package together functions to create benchmarks for each program given suitable inputs. -} +-- | Package together functions to create benchmarks for each program given suitable inputs. type BenchmarkRunners = - ( Clausify.StaticFormula -> Benchmarkable - , Integer -> Integer -> Benchmarkable - , Prime.PrimeID -> Benchmarkable - , Integer -> Queens.Algorithm -> Benchmarkable - ) - -{- | Make a benchmarks with a number of different inputs. The input values have - been chosen to complete in a reasonable time. -} + ( Clausify.StaticFormula -> Benchmarkable + , Integer -> Integer -> Benchmarkable + , Prime.PrimeID -> Benchmarkable + , Integer -> Queens.Algorithm -> Benchmarkable + ) + +-- | Make a benchmarks with a number of different inputs. The input values have +-- been chosen to complete in a reasonable time. mkBenchMarks :: BenchmarkRunners -> [Benchmark] -mkBenchMarks (benchClausify, benchKnights, benchPrime, benchQueens) = [ - bgroup "clausify" [ bench "formula1" $ benchClausify Clausify.F1 - , bench "formula2" $ benchClausify Clausify.F2 - , bench "formula3" $ benchClausify Clausify.F3 - , bench "formula4" $ benchClausify Clausify.F4 - , bench "formula5" $ benchClausify Clausify.F5 - ] - , bgroup "knights" [ bench "4x4" $ benchKnights 100 4 - , bench "6x6" $ benchKnights 100 6 - , bench "8x8" $ benchKnights 100 8 - ] - , bgroup "primetest" [ bench "05digits" $ benchPrime Prime.P5 - , bench "10digits" $ benchPrime Prime.P10 - , bench "30digits" $ benchPrime Prime.P30 - , bench "50digits" $ benchPrime Prime.P50 - -- Larger primes are available in Primes.hs, but may take a long time. - ] - , bgroup "queens4x4" [ -- N-queens problem on a 4x4 board - bench "bt" $ benchQueens 4 Queens.Bt - , bench "bm" $ benchQueens 4 Queens.Bm - , bench "bjbt1" $ benchQueens 4 Queens.Bjbt1 - , bench "bjbt2" $ benchQueens 4 Queens.Bjbt2 - , bench "fc" $ benchQueens 4 Queens.Fc - ] - , bgroup "queens5x5" [ -- N-queens problem on a 5x5 board - bench "bt" $ benchQueens 5 Queens.Bt - , bench "bm" $ benchQueens 5 Queens.Bm - , bench "bjbt1" $ benchQueens 5 Queens.Bjbt1 - , bench "bjbt2" $ benchQueens 5 Queens.Bjbt2 - , bench "fc" $ benchQueens 5 Queens.Fc - ] - ] - +mkBenchMarks (benchClausify, benchKnights, benchPrime, benchQueens) = + [ bgroup + "clausify" + [ bench "formula1" $ benchClausify Clausify.F1 + , bench "formula2" $ benchClausify Clausify.F2 + , bench "formula3" $ benchClausify Clausify.F3 + , bench "formula4" $ benchClausify Clausify.F4 + , bench "formula5" $ benchClausify Clausify.F5 + ] + , bgroup + "knights" + [ bench "4x4" $ benchKnights 100 4 + , bench "6x6" $ benchKnights 100 6 + , bench "8x8" $ benchKnights 100 8 + ] + , bgroup + "primetest" + [ bench "05digits" $ benchPrime Prime.P5 + , bench "10digits" $ benchPrime Prime.P10 + , bench "30digits" $ benchPrime Prime.P30 + , bench "50digits" $ benchPrime Prime.P50 + -- Larger primes are available in Primes.hs, but may take a long time. + ] + , bgroup + "queens4x4" + [ -- N-queens problem on a 4x4 board + bench "bt" $ benchQueens 4 Queens.Bt + , bench "bm" $ benchQueens 4 Queens.Bm + , bench "bjbt1" $ benchQueens 4 Queens.Bjbt1 + , bench "bjbt2" $ benchQueens 4 Queens.Bjbt2 + , bench "fc" $ benchQueens 4 Queens.Fc + ] + , bgroup + "queens5x5" + [ -- N-queens problem on a 5x5 board + bench "bt" $ benchQueens 5 Queens.Bt + , bench "bm" $ benchQueens 5 Queens.Bm + , bench "bjbt1" $ benchQueens 5 Queens.Bjbt1 + , bench "bjbt2" $ benchQueens 5 Queens.Bjbt2 + , bench "fc" $ benchQueens 5 Queens.Fc + ] + ] ---------------- Create a benchmark with given inputs ---------------- @@ -95,13 +103,16 @@ benchKnightsWith benchmarker depth sz = benchmarker $ Knights.mkKnightsTerm dept -} - -- Given a function (involving some evaluator) which constructs a Benchmarkable -- from a Term, use it to construct and run all of the benchmarks benchWith :: (Term -> Benchmarkable) -> IO () benchWith benchmarker = do - let runners = ( benchClausifyWith benchmarker, benchKnightsWith benchmarker - , benchPrimeWith benchmarker, benchQueensWith benchmarker) + let runners = + ( benchClausifyWith benchmarker + , benchKnightsWith benchmarker + , benchPrimeWith benchmarker + , benchQueensWith benchmarker + ) -- Run each benchmark for at least one minute. Change this with -L or --timeout. config <- getConfig 60.0 defaultMainWith config $ mkBenchMarks runners diff --git a/plutus-benchmark/nofib/exe/Main.hs b/plutus-benchmark/nofib/exe/Main.hs index feb1099da4a..f15592dc92b 100644 --- a/plutus-benchmark/nofib/exe/Main.hs +++ b/plutus-benchmark/nofib/exe/Main.hs @@ -1,5 +1,5 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module Main where @@ -47,25 +47,23 @@ import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC failWithMsg :: Hs.String -> IO a failWithMsg s = hPutStrLn stderr s >> exitFailure - -- | A program together with its arguments -data ProgAndArgs = - Clausify Clausify.StaticFormula - | Queens Hs.Integer Queens.Algorithm - | Knights Hs.Integer Hs.Integer +data ProgAndArgs + = Clausify Clausify.StaticFormula + | Queens Hs.Integer Queens.Algorithm + | Knights Hs.Integer Hs.Integer | LastPiece - | Prime Prime.PrimeID + | Prime Prime.PrimeID | Primetest Integer -- | The actions this program can perform data Options - = RunPLC ProgAndArgs - | RunHaskell ProgAndArgs - | DumpPLC ProgAndArgs - | DumpFlatNamed ProgAndArgs - | DumpFlatDeBruijn ProgAndArgs - | SizesAndBudgets - + = RunPLC ProgAndArgs + | RunHaskell ProgAndArgs + | DumpPLC ProgAndArgs + | DumpFlatNamed ProgAndArgs + | DumpFlatDeBruijn ProgAndArgs + | SizesAndBudgets -- Clausify options -- @@ -80,56 +78,65 @@ clausifyFormulaReader "F4" = Right Clausify.F4 clausifyFormulaReader "F5" = Right Clausify.F5 clausifyFormulaReader "F6" = Right Clausify.F6 clausifyFormulaReader "F7" = Right Clausify.F7 -clausifyFormulaReader f = Left $ "Cannot parse `" <> f <> "`. Expected " ++ knownFormulae ++ "." +clausifyFormulaReader f = Left $ "Cannot parse `" <> f <> "`. Expected " ++ knownFormulae ++ "." clausifyOptions :: Parser ProgAndArgs clausifyOptions = - Clausify <$> argument (eitherReader clausifyFormulaReader) - (metavar "FORMULA" <> - help ("Formula to use for benchmarking: " ++ knownFormulae ++ ".")) - + Clausify + <$> argument + (eitherReader clausifyFormulaReader) + ( metavar "FORMULA" + <> help ("Formula to use for benchmarking: " ++ knownFormulae ++ ".") + ) -- Knights options -- knightsOptions :: Parser ProgAndArgs knightsOptions = - Knights <$> argument auto (metavar "DEPTH" <> - help "Maximum search depth.") - <*> argument auto (metavar "BOARD-SIZE" <> - help "Board size (NxN)") - + Knights + <$> argument + auto + ( metavar "DEPTH" + <> help "Maximum search depth." + ) + <*> argument + auto + ( metavar "BOARD-SIZE" + <> help "Board size (NxN)" + ) -- Lastpiece options -- lastpieceOptions :: Parser ProgAndArgs lastpieceOptions = Hs.pure LastPiece - -- Primes options -- knownPrimes :: Hs.String knownPrimes = "P05, P08, P10, P20, P30, P40, P50, P60, P100, P150, or P200 (a prime with the indicated number of digits)" primeIdReader :: Hs.String -> Either Hs.String Prime.PrimeID -primeIdReader "P05" = Right Prime.P5 -primeIdReader "P08" = Right Prime.P8 -primeIdReader "P10" = Right Prime.P10 -primeIdReader "P20" = Right Prime.P20 -primeIdReader "P30" = Right Prime.P30 -primeIdReader "P40" = Right Prime.P40 -primeIdReader "P50" = Right Prime.P50 -primeIdReader "P60" = Right Prime.P60 +primeIdReader "P05" = Right Prime.P5 +primeIdReader "P08" = Right Prime.P8 +primeIdReader "P10" = Right Prime.P10 +primeIdReader "P20" = Right Prime.P20 +primeIdReader "P30" = Right Prime.P30 +primeIdReader "P40" = Right Prime.P40 +primeIdReader "P50" = Right Prime.P50 +primeIdReader "P60" = Right Prime.P60 primeIdReader "P100" = Right Prime.P100 primeIdReader "P150" = Right Prime.P150 primeIdReader "P200" = Right Prime.P200 -primeIdReader f = Left $ "Cannot parse `" <> f <> "`. Possible values are " ++ knownPrimes ++"." +primeIdReader f = Left $ "Cannot parse `" <> f <> "`. Possible values are " ++ knownPrimes ++ "." -- | Apply the primality test to one of the built-in primes primeOptions :: Parser ProgAndArgs primeOptions = - Prime <$> (argument (eitherReader primeIdReader) - (metavar "ID" <> help ("Identifier for known prime: " ++ knownPrimes))) - + Prime + <$> ( argument + (eitherReader primeIdReader) + (metavar "ID" <> help ("Identifier for known prime: " ++ knownPrimes)) + ) -- Primetest options -- @@ -138,94 +145,126 @@ primetestOptions :: Parser ProgAndArgs primetestOptions = Primetest <$> (argument auto (metavar "N" <> help "a positive integer")) - -- Queens options -- knownAlgorithms :: Hs.String knownAlgorithms = "bt, bm, bjbt1, bjbt2, fc" queensAlgorithmReader :: Hs.String -> Either Hs.String Queens.Algorithm -queensAlgorithmReader "bt" = Right Queens.Bt -queensAlgorithmReader "bm" = Right Queens.Bm +queensAlgorithmReader "bt" = Right Queens.Bt +queensAlgorithmReader "bm" = Right Queens.Bm queensAlgorithmReader "bjbt1" = Right Queens.Bjbt1 queensAlgorithmReader "bjbt2" = Right Queens.Bjbt2 -queensAlgorithmReader "fc" = Right Queens.Fc -queensAlgorithmReader alg = Left $ "Unknown algorithm: " <> alg <> ". Options are " ++ knownAlgorithms +queensAlgorithmReader "fc" = Right Queens.Fc +queensAlgorithmReader alg = Left $ "Unknown algorithm: " <> alg <> ". Options are " ++ knownAlgorithms queensOptions :: Parser ProgAndArgs queensOptions = - Queens <$> argument auto (metavar "BOARD-SIZE" <> - help "Size of the playing board NxN") - <*> (argument (eitherReader queensAlgorithmReader) - (metavar "ALGORITHM" <> - help ("Algorithm to use for constraint solving. One of: " ++ knownAlgorithms))) + Queens + <$> argument + auto + ( metavar "BOARD-SIZE" + <> help "Size of the playing board NxN" + ) + <*> ( argument + (eitherReader queensAlgorithmReader) + ( metavar "ALGORITHM" + <> help ("Algorithm to use for constraint solving. One of: " ++ knownAlgorithms) + ) + ) -- Main parsers -- progAndArgs :: Parser ProgAndArgs -progAndArgs = hsubparser - ( command "clausify" (info clausifyOptions (progDesc "Run the Clausify benchmark.")) - <> command "queens" (info queensOptions (progDesc "Run the Queens benchmark.")) - <> command "knights" (info knightsOptions (progDesc "Run the Knights benchmark")) - <> command "lastpiece" (info lastpieceOptions (progDesc "Run the Lastpiece benchmark")) - <> command "prime" (info primeOptions (progDesc "Run the Prime benchmark on a known prime (see help)")) - <> command "primetest" (info primetestOptions (progDesc "Run the Prime benchmark on a positive integer N")) ) - +progAndArgs = + hsubparser + ( command "clausify" (info clausifyOptions (progDesc "Run the Clausify benchmark.")) + <> command "queens" (info queensOptions (progDesc "Run the Queens benchmark.")) + <> command "knights" (info knightsOptions (progDesc "Run the Knights benchmark")) + <> command "lastpiece" (info lastpieceOptions (progDesc "Run the Lastpiece benchmark")) + <> command "prime" (info primeOptions (progDesc "Run the Prime benchmark on a known prime (see help)")) + <> command "primetest" (info primetestOptions (progDesc "Run the Prime benchmark on a positive integer N")) + ) options :: Parser Options -options = hsubparser - ( command "run" - (info (RunPLC <$> progAndArgs) - (progDesc "same as run-plc")) - <> command "run-plc" - (info (RunPLC <$> progAndArgs) - (progDesc "compile the program to Plutus Core and evaluate it using the CEK machine")) - <> command "run-hs" - (info (RunHaskell <$> progAndArgs) - (progDesc "run the program directly as Hs")) - <> command "dump-uplc" - (info (DumpPLC <$> progAndArgs) - (progDesc "print the program (applied to arguments) as Plutus Core source on standard output")) - <> command "dump-flat-named" - (info (DumpFlatNamed <$> progAndArgs) - (progDesc "dump the AST as Flat, preserving names")) - <> command "dump-flat" - (info (DumpFlatDeBruijn <$> progAndArgs) - (progDesc "same as dump-flat-deBruijn, but easier to type")) - <> command "dump-flat-deBruijn" - (info (DumpFlatDeBruijn <$> progAndArgs) - (progDesc "dump the AST as Flat, with names replaced by de Bruijn indices")) - <> command "sizes-and-budgets" - (info (Hs.pure SizesAndBudgets) - (progDesc "Print the size and cpu/memory budgets of each program")) - ) - +options = + hsubparser + ( command + "run" + ( info + (RunPLC <$> progAndArgs) + (progDesc "same as run-plc") + ) + <> command + "run-plc" + ( info + (RunPLC <$> progAndArgs) + (progDesc "compile the program to Plutus Core and evaluate it using the CEK machine") + ) + <> command + "run-hs" + ( info + (RunHaskell <$> progAndArgs) + (progDesc "run the program directly as Hs") + ) + <> command + "dump-uplc" + ( info + (DumpPLC <$> progAndArgs) + (progDesc "print the program (applied to arguments) as Plutus Core source on standard output") + ) + <> command + "dump-flat-named" + ( info + (DumpFlatNamed <$> progAndArgs) + (progDesc "dump the AST as Flat, preserving names") + ) + <> command + "dump-flat" + ( info + (DumpFlatDeBruijn <$> progAndArgs) + (progDesc "same as dump-flat-deBruijn, but easier to type") + ) + <> command + "dump-flat-deBruijn" + ( info + (DumpFlatDeBruijn <$> progAndArgs) + (progDesc "dump the AST as Flat, with names replaced by de Bruijn indices") + ) + <> command + "sizes-and-budgets" + ( info + (Hs.pure SizesAndBudgets) + (progDesc "Print the size and cpu/memory budgets of each program") + ) + ) ---------------- Evaluation ---------------- -evaluateWithCek - :: UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.EvaluationResult (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) +evaluateWithCek :: + UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () -> + UPLC.EvaluationResult (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) evaluateWithCek = UPLC.unsafeSplitStructuralOperational - . UPLC.cekResultToEither - . UPLC._cekReportResult - . UPLC.runCekDeBruijn PLC.defaultCekParametersForTesting UPLC.restrictingEnormous UPLC.noEmitter + . UPLC.cekResultToEither + . UPLC._cekReportResult + . UPLC.runCekDeBruijn PLC.defaultCekParametersForTesting UPLC.restrictingEnormous UPLC.noEmitter writeFlatNamed :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () -> IO () writeFlatNamed prog = BS.putStr . Flat.flat . UPLC.UnrestrictedProgram $ prog -writeFlatDeBruijn ::UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -> IO () -writeFlatDeBruijn prog = BS.putStr . Flat.flat . UPLC.UnrestrictedProgram $ prog +writeFlatDeBruijn :: UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -> IO () +writeFlatDeBruijn prog = BS.putStr . Flat.flat . UPLC.UnrestrictedProgram $ prog description :: Hs.String -description = "This program provides operations on a number of Plutus programs " - ++ "ported from the nofib Hs test suite. " - ++ "The programs are written in Hs and can be run directly " - ++ "or compiled into Plutus Core and run on the CEK machine. " - ++ "Compiled programs can also be output in a number of formats." - -knownProgs :: [Doc ann ] +description = + "This program provides operations on a number of Plutus programs " + ++ "ported from the nofib Hs test suite. " + ++ "The programs are written in Hs and can be run directly " + ++ "or compiled into Plutus Core and run on the CEK machine. " + ++ "Compiled programs can also be output in a number of formats." + +knownProgs :: [Doc ann] knownProgs = map fromString ["clausify", "knights", "lastpiece", "prime", "primetest", "queens"] -- Extra information about the available programs. We need a Doc because if you @@ -233,75 +272,88 @@ knownProgs = map fromString ["clausify", "knights", "lastpiece", "prime", "prime -- manual formatting in here because the text doesn't wrap as expected, presumably -- due to what optparse-applicative is doing internally. footerInfo :: Doc ann -footerInfo = fromString "Most commands take the name of a program and a (possbily empty) list of arguments." - <> line <> line - <> fromString "The available programs are: " - <> line - <> indent 2 (vsep knownProgs) - <> line <> line - <> fromString ("See 'nofib-exe run --help' for information about the arguments\n" - ++ "for a particular program.") - <> line <> line - <> fromString ("The 'dump' commands construct a Plutus Core term applying the program to its\n" - ++ "arguments and prints the result to the terminal in the specified format.\n" - ++ "You'll probably want to redirect the output to a file.") - +footerInfo = + fromString "Most commands take the name of a program and a (possbily empty) list of arguments." + <> line + <> line + <> fromString "The available programs are: " + <> line + <> indent 2 (vsep knownProgs) + <> line + <> line + <> fromString + ( "See 'nofib-exe run --help' for information about the arguments\n" + ++ "for a particular program." + ) + <> line + <> line + <> fromString + ( "The 'dump' commands construct a Plutus Core term applying the program to its\n" + ++ "arguments and prints the result to the terminal in the specified format.\n" + ++ "You'll probably want to redirect the output to a file." + ) -- Copied pretty much directly from plutus-tx/testlib/PlutusTx/Test.hs measureBudget :: CompiledCode a -> (Integer, Integer) measureBudget compiledCode = - let programE = PLC.runQuote - $ runExceptT @PLC.FreeVariableError - $ traverseOf UPLC.progTerm UPLC.unDeBruijnTerm - $ getPlcNoAnn compiledCode + let programE = + PLC.runQuote + $ runExceptT @PLC.FreeVariableError + $ traverseOf UPLC.progTerm UPLC.unDeBruijnTerm + $ getPlcNoAnn compiledCode in case programE of - Left _ -> (-1,-1) -- Something has gone wrong but I don't care. + Left _ -> (-1, -1) -- Something has gone wrong but I don't care. Right program -> let (_, UPLC.TallyingSt _ budget) = UPLC.runCekNoEmit PLC.defaultCekParametersForTesting UPLC.tallying $ program ^. UPLC.progTerm ExCPU cpu = exBudgetCPU budget ExMemory mem = exBudgetMemory budget - in (fromSatInt cpu, fromSatInt mem) + in (fromSatInt cpu, fromSatInt mem) getInfo :: (Hs.String, CompiledCode a) -> (Hs.String, Integer, Integer, Integer) getInfo (name, code) = - let size = countAstNodes code - (cpu, mem) = measureBudget code - in (name, size, cpu, mem) + let size = countAstNodes code + (cpu, mem) = measureBudget code + in (name, size, cpu, mem) printSizesAndBudgets :: IO () printSizesAndBudgets = do -- The applied programs to measure, which are the same as the ones in the benchmarks. - -- We can't put all of these in one list because the 'a's in 'CompiledCode a' are different - let clausify = [ ("clausify/F1", Clausify.mkClausifyCode Clausify.F1) - , ("clausify/F2", Clausify.mkClausifyCode Clausify.F2) - , ("clausify/F3", Clausify.mkClausifyCode Clausify.F3) - , ("clausify/F4", Clausify.mkClausifyCode Clausify.F4) - , ("clausify/F5", Clausify.mkClausifyCode Clausify.F5) - ] - knights = [ ( "knights/4x4", Knights.mkKnightsCode 100 4) - , ( "knights/6x6", Knights.mkKnightsCode 100 6) - , ( "knights/8x8", Knights.mkKnightsCode 100 8) - ] - primetest = [ ("primes/05digits", Prime.mkPrimalityCode Prime.P5) - , ("primes/08digits", Prime.mkPrimalityCode Prime.P8) - , ("primes/10digits", Prime.mkPrimalityCode Prime.P10) - , ("primes/20digits", Prime.mkPrimalityCode Prime.P20) - , ("primes/30digits", Prime.mkPrimalityCode Prime.P30) - , ("primes/40digits", Prime.mkPrimalityCode Prime.P40) - , ("primes/50digits", Prime.mkPrimalityCode Prime.P50) - ] - queens4x4 = [ ("queens4x4/bt", Queens.mkQueensCode 4 Queens.Bt) - , ("queens4x4/bm", Queens.mkQueensCode 4 Queens.Bm) - , ("queens4x4/bjbt1", Queens.mkQueensCode 4 Queens.Bjbt1) - , ("queens4x4/bjbt2", Queens.mkQueensCode 4 Queens.Bjbt2) - , ("queens4x4/fc", Queens.mkQueensCode 4 Queens.Fc) - ] - queens5x5 = [ ("queens5x5/bt" ,Queens.mkQueensCode 5 Queens.Bt) - , ("queens5x5/bm" ,Queens.mkQueensCode 5 Queens.Bm) - , ("queens5x5/bjbt1" ,Queens.mkQueensCode 5 Queens.Bjbt1) - , ("queens5x5/bjbt2" ,Queens.mkQueensCode 5 Queens.Bjbt2) - , ("queens5x5/fc" ,Queens.mkQueensCode 5 Queens.Fc) - ] + -- We can't put all of these in one list because the 'a's in 'CompiledCode a' are different + let clausify = + [ ("clausify/F1", Clausify.mkClausifyCode Clausify.F1) + , ("clausify/F2", Clausify.mkClausifyCode Clausify.F2) + , ("clausify/F3", Clausify.mkClausifyCode Clausify.F3) + , ("clausify/F4", Clausify.mkClausifyCode Clausify.F4) + , ("clausify/F5", Clausify.mkClausifyCode Clausify.F5) + ] + knights = + [ ("knights/4x4", Knights.mkKnightsCode 100 4) + , ("knights/6x6", Knights.mkKnightsCode 100 6) + , ("knights/8x8", Knights.mkKnightsCode 100 8) + ] + primetest = + [ ("primes/05digits", Prime.mkPrimalityCode Prime.P5) + , ("primes/08digits", Prime.mkPrimalityCode Prime.P8) + , ("primes/10digits", Prime.mkPrimalityCode Prime.P10) + , ("primes/20digits", Prime.mkPrimalityCode Prime.P20) + , ("primes/30digits", Prime.mkPrimalityCode Prime.P30) + , ("primes/40digits", Prime.mkPrimalityCode Prime.P40) + , ("primes/50digits", Prime.mkPrimalityCode Prime.P50) + ] + queens4x4 = + [ ("queens4x4/bt", Queens.mkQueensCode 4 Queens.Bt) + , ("queens4x4/bm", Queens.mkQueensCode 4 Queens.Bm) + , ("queens4x4/bjbt1", Queens.mkQueensCode 4 Queens.Bjbt1) + , ("queens4x4/bjbt2", Queens.mkQueensCode 4 Queens.Bjbt2) + , ("queens4x4/fc", Queens.mkQueensCode 4 Queens.Fc) + ] + queens5x5 = + [ ("queens5x5/bt", Queens.mkQueensCode 5 Queens.Bt) + , ("queens5x5/bm", Queens.mkQueensCode 5 Queens.Bm) + , ("queens5x5/bjbt1", Queens.mkQueensCode 5 Queens.Bjbt1) + , ("queens5x5/bjbt2", Queens.mkQueensCode 5 Queens.Bjbt2) + , ("queens5x5/fc", Queens.mkQueensCode 5 Queens.Fc) + ] statistics = map getInfo clausify ++ map getInfo knights ++ map getInfo primetest ++ map getInfo queens4x4 ++ map getInfo queens5x5 formatInfo (name, size, cpu, mem) = printf "%-20s %10d %15d %15d\n" name size cpu mem @@ -309,48 +361,57 @@ printSizesAndBudgets = do putStrLn "-----------------------------------------------------------------" traverse_ (putStr . formatInfo) statistics - main :: IO () main = do execParser (info (helper <*> options) (fullDesc <> progDesc description <> footerDoc (Just footerInfo))) >>= \case RunPLC pa -> - print . prettyPlc . fmap fromNamedDeBruijnUPLC . evaluateWithCek . getTerm $ pa + print . prettyPlc . fmap fromNamedDeBruijnUPLC . evaluateWithCek . getTerm $ pa RunHaskell pa -> - case pa of - Clausify formula -> print $ Clausify.runClausify formula - Knights depth boardSize -> print $ Knights.runKnights depth boardSize - LastPiece -> print $ LastPiece.runLastPiece - Queens boardSize alg -> print $ Queens.runQueens boardSize alg - Prime input -> print $ Prime.runFixedPrimalityTest input - Primetest n -> if n < 0 - then Hs.error "Positive number expected" - else print $ Prime.runPrimalityTest n + case pa of + Clausify formula -> print $ Clausify.runClausify formula + Knights depth boardSize -> print $ Knights.runKnights depth boardSize + LastPiece -> print $ LastPiece.runLastPiece + Queens boardSize alg -> print $ Queens.runQueens boardSize alg + Prime input -> print $ Prime.runFixedPrimalityTest input + Primetest n -> + if n < 0 + then Hs.error "Positive number expected" + else print $ Prime.runPrimalityTest n DumpPLC pa -> - traverse_ putStrLn - $ unindent . prettyPlc - . UPLC.Program () PLC.latestVersion . fromNamedDeBruijnUPLC . getTerm $ pa - -- These are big programs and with indentation the output is > 90% whitespace - where unindent d = map (dropWhile isSpace) $ (Hs.lines . Hs.show $ d) + traverse_ putStrLn + $ unindent + . prettyPlc + . UPLC.Program () PLC.latestVersion + . fromNamedDeBruijnUPLC + . getTerm + $ pa + where + -- These are big programs and with indentation the output is > 90% whitespace + unindent d = map (dropWhile isSpace) $ (Hs.lines . Hs.show $ d) DumpFlatNamed pa -> - writeFlatNamed . UPLC.Program () PLC.latestVersion . getTerm $ pa + writeFlatNamed . UPLC.Program () PLC.latestVersion . getTerm $ pa DumpFlatDeBruijn pa -> - writeFlatDeBruijn . UPLC.Program () PLC.latestVersion . toAnonDeBruijnTerm . getTerm $ pa - SizesAndBudgets - -> printSizesAndBudgets + writeFlatDeBruijn . UPLC.Program () PLC.latestVersion . toAnonDeBruijnTerm . getTerm $ pa + SizesAndBudgets -> + printSizesAndBudgets + where -- Write the output to stdout and let the user deal with redirecting it. - where getTerm :: ProgAndArgs -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () - getTerm = - \case - Clausify formula -> Clausify.mkClausifyTerm formula - Queens boardSize alg -> Queens.mkQueensTerm boardSize alg - Knights depth boardSize -> Knights.mkKnightsTerm depth boardSize - LastPiece -> LastPiece.mkLastPieceTerm - Prime input -> Prime.mkPrimalityBenchTerm input - Primetest n -> if n<0 then Hs.error "Positive number expected" - else Prime.mkPrimalityTestTerm n - fromNamedDeBruijnUPLC - :: UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.Term UPLC.Name DefaultUni DefaultFun () - fromNamedDeBruijnUPLC = - unsafeFromRight @PLC.FreeVariableError - . PLC.runQuoteT . UPLC.unDeBruijnTerm + getTerm :: ProgAndArgs -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () + getTerm = + \case + Clausify formula -> Clausify.mkClausifyTerm formula + Queens boardSize alg -> Queens.mkQueensTerm boardSize alg + Knights depth boardSize -> Knights.mkKnightsTerm depth boardSize + LastPiece -> LastPiece.mkLastPieceTerm + Prime input -> Prime.mkPrimalityBenchTerm input + Primetest n -> + if n < 0 + then Hs.error "Positive number expected" + else Prime.mkPrimalityTestTerm n + fromNamedDeBruijnUPLC :: + UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () -> + UPLC.Term UPLC.Name DefaultUni DefaultFun () + fromNamedDeBruijnUPLC = + unsafeFromRight @PLC.FreeVariableError + . PLC.runQuoteT + . UPLC.unDeBruijnTerm diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Clausify.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Clausify.hs index cfd5dbea9e4..174cb8df61d 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Clausify.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Clausify.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.NoFib.Clausify where @@ -23,177 +22,206 @@ type Var = Integer type LRVars = ([Var], [Var]) -- % Lists of variables in lhs and rhs of formula -data Formula = - Sym Var | -- % Was Char, but that doesn't work well with PLC - Not Formula | - Dis Formula Formula | - Con Formula Formula | - Imp Formula Formula | - Eqv Formula Formula - deriving stock (Haskell.Show) +data Formula + = Sym Var -- % Was Char, but that doesn't work well with PLC + | Not Formula + | Dis Formula Formula + | Con Formula Formula + | Imp Formula Formula + | Eqv Formula Formula + deriving stock (Haskell.Show) Tx.makeLift ''Formula -- separate positive and negative literals, eliminating duplicates clause :: Formula -> LRVars -clause p = clause' p ([] , []) - where - clause' (Dis p q) x = clause' p (clause' q x) - clause' (Sym s) (c,a) = (insert s c , a) - clause' (Not (Sym s)) (c,a) = (c , insert s a) -{-# INLINABLE clause #-} +clause p = clause' p ([], []) + where + clause' (Dis p q) x = clause' p (clause' q x) + clause' (Sym s) (c, a) = (insert s c, a) + clause' (Not (Sym s)) (c, a) = (c, insert s a) +{-# INLINEABLE clause #-} -- the main pipeline from propositional formulae to a list of clauses clauses :: Formula -> [LRVars] clauses = unicl . split . disin . negin . elim -{-# INLINABLE clauses #-} +{-# INLINEABLE clauses #-} conjunct :: Formula -> Bool conjunct (Con _ _) = True -conjunct _ = False -{-# INLINABLE conjunct #-} +conjunct _ = False +{-# INLINEABLE conjunct #-} -- shift disjunction within conjunction disin :: Formula -> Formula disin (Dis p (Con q r)) = Con (disin (Dis p q)) (disin (Dis p r)) disin (Dis (Con p q) r) = Con (disin (Dis p r)) (disin (Dis q r)) disin (Dis p q) = - if conjunct dp || conjunct dq then disin (Dis dp dq) - else (Dis dp dq) + if conjunct dp || conjunct dq + then disin (Dis dp dq) + else (Dis dp dq) where - dp = disin p - dq = disin q + dp = disin p + dq = disin q disin (Con p q) = Con (disin p) (disin q) disin p = p -{-# INLINABLE disin #-} +{-# INLINEABLE disin #-} -- split conjunctive proposition into a list of conjuncts split :: Formula -> [Formula] split p = split' p [] - where - split' (Con p q) a = split' p (split' q a) - split' p a = p : a -{-# INLINABLE split #-} + where + split' (Con p q) a = split' p (split' q a) + split' p a = p : a +{-# INLINEABLE split #-} -- eliminate connectives other than not, disjunction and conjunction elim :: Formula -> Formula -elim (Sym s) = Sym s -elim (Not p) = Not (elim p) -elim (Dis p q) = Dis (elim p) (elim q) -elim (Con p q) = Con (elim p) (elim q) -elim (Imp p q) = Dis (Not (elim p)) (elim q) +elim (Sym s) = Sym s +elim (Not p) = Not (elim p) +elim (Dis p q) = Dis (elim p) (elim q) +elim (Con p q) = Con (elim p) (elim q) +elim (Imp p q) = Dis (Not (elim p)) (elim q) elim (Eqv f f') = Con (elim (Imp f f')) (elim (Imp f' f)) -{-# INLINABLE elim #-} +{-# INLINEABLE elim #-} -- insertion of an item into an ordered list -- Note: this is a corrected version from Colin (94/05/03 WDP) -insert :: (Ord t) => t -> [t] -> [t] +insert :: Ord t => t -> [t] -> [t] insert x [] = [x] -insert x p@(y:ys) = - if x < y then x : p - else if x > y then y : insert x ys - else p -{-# INLINABLE insert #-} +insert x p@(y : ys) = + if x < y + then x : p + else + if x > y + then y : insert x ys + else p +{-# INLINEABLE insert #-} -- shift negation to innermost positions negin :: Formula -> Formula -negin (Not (Not p)) = negin p +negin (Not (Not p)) = negin p negin (Not (Con p q)) = Dis (negin (Not p)) (negin (Not q)) negin (Not (Dis p q)) = Con (negin (Not p)) (negin (Not q)) -negin (Dis p q) = Dis (negin p) (negin q) -negin (Con p q) = Con (negin p) (negin q) -negin p = p -{-# INLINABLE negin #-} +negin (Dis p q) = Dis (negin p) (negin q) +negin (Con p q) = Con (negin p) (negin q) +negin p = p +{-# INLINEABLE negin #-} -- does any symbol appear in both consequent and antecedent of clause tautclause :: LRVars -> Bool -tautclause (c,a) = [x | x <- c, x `List.elem` a] /= [] -{-# INLINABLE tautclause #-} +tautclause (c, a) = [x | x <- c, x `List.elem` a] /= [] +{-# INLINEABLE tautclause #-} -- form unique clausal axioms excluding tautologies unicl :: [Formula] -> [LRVars] unicl a = List.foldr unicl' [] a - where - unicl' p x = if tautclause cp then x else insert cp x - where - cp = clause p :: LRVars -{-# INLINABLE unicl #-} + where + unicl' p x = if tautclause cp then x else insert cp x + where + cp = clause p :: LRVars +{-# INLINEABLE unicl #-} while :: (t -> Bool) -> (t -> t) -> t -> t while p f x = if p x then while p f (f x) else x -{-# INLINABLE while #-} - -formula1 :: Formula -- % (a = a) = (a = a) = (a = a) -formula1 = Eqv (Eqv (Sym 1) (Sym 1)) - (Eqv (Eqv (Sym 1) (Sym 1)) - (Eqv (Sym 1) (Sym 1))) -{-# INLINABLE formula1 #-} +{-# INLINEABLE while #-} + +formula1 :: Formula -- % (a = a) = (a = a) = (a = a) +formula1 = + Eqv + (Eqv (Sym 1) (Sym 1)) + ( Eqv + (Eqv (Sym 1) (Sym 1)) + (Eqv (Sym 1) (Sym 1)) + ) +{-# INLINEABLE formula1 #-} -- % One execution takes about 0.35s and 300 MB -formula2 :: Formula -- (a = a = a) = (a = a = a) -formula2 = Eqv (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) - (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) -{-# INLINABLE formula2 #-} +formula2 :: Formula -- (a = a = a) = (a = a = a) +formula2 = + Eqv + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) +{-# INLINEABLE formula2 #-} -- % One execution takes about 1.5s and 660 MB -formula3 :: Formula -- (a = a = a) = (a = a) = (a = a) -formula3 = Eqv (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) - (Eqv (Eqv (Sym 1) (Sym 1)) - (Eqv (Sym 1) (Sym 1))) -{-# INLINABLE formula3 #-} +formula3 :: Formula -- (a = a = a) = (a = a) = (a = a) +formula3 = + Eqv + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) + ( Eqv + (Eqv (Sym 1) (Sym 1)) + (Eqv (Sym 1) (Sym 1)) + ) +{-# INLINEABLE formula3 #-} -- % One execution takes about 2s and 1 GB -formula4 :: Formula -- (a = b = c) = (d = e) = (f = g) -formula4 = Eqv (Eqv (Sym 1) (Eqv (Sym 2) (Sym 3))) - (Eqv (Eqv (Sym 4) (Sym 5)) - (Eqv (Sym 6) (Sym 7))) -{-# INLINABLE formula4 #-} +formula4 :: Formula -- (a = b = c) = (d = e) = (f = g) +formula4 = + Eqv + (Eqv (Sym 1) (Eqv (Sym 2) (Sym 3))) + ( Eqv + (Eqv (Sym 4) (Sym 5)) + (Eqv (Sym 6) (Sym 7)) + ) +{-# INLINEABLE formula4 #-} -- % One execution takes about 11s and 5 GB -formula5 :: Formula -- (a = a = a) = (a = a = a) = (a = a) -formula5 = Eqv (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) - (Eqv (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) - (Eqv (Sym 1) (Sym 1))) -{-# INLINABLE formula5 #-} +formula5 :: Formula -- (a = a = a) = (a = a = a) = (a = a) +formula5 = + Eqv + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) + ( Eqv + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) + (Eqv (Sym 1) (Sym 1)) + ) +{-# INLINEABLE formula5 #-} -- % Overflow -formula6 :: Formula -- (a = a = a) = (a = a = a) = (a = a = a) -formula6 = Eqv (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) - (Eqv (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) - (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1)))) -{-# INLINABLE formula6 #-} +formula6 :: Formula -- (a = a = a) = (a = a = a) = (a = a = a) +formula6 = + Eqv + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) + ( Eqv + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) + (Eqv (Sym 1) (Eqv (Sym 1) (Sym 1))) + ) +{-# INLINEABLE formula6 #-} -- % Overflow formula7 :: Formula -- (a = b = c) = (d = e = f) = (g = h = i) -formula7 = Eqv (Eqv (Sym 1) (Eqv (Sym 2) (Sym 3))) - (Eqv (Eqv (Sym 4) (Eqv (Sym 5) (Sym 6))) - (Eqv (Sym 7) (Eqv (Sym 8) (Sym 9)))) -{-# INLINABLE formula7 #-} +formula7 = + Eqv + (Eqv (Sym 1) (Eqv (Sym 2) (Sym 3))) + ( Eqv + (Eqv (Sym 4) (Eqv (Sym 5) (Sym 6))) + (Eqv (Sym 7) (Eqv (Sym 8) (Sym 9))) + ) +{-# INLINEABLE formula7 #-} data StaticFormula = F1 | F2 | F3 | F4 | F5 | F6 | F7 Tx.makeLift ''StaticFormula getFormula :: StaticFormula -> Formula getFormula = - \case - F1 -> formula1 - F2 -> formula2 - F3 -> formula3 - F4 -> formula4 - F5 -> formula5 - F6 -> formula6 - F7 -> formula7 -{-# INLINABLE getFormula #-} + \case + F1 -> formula1 + F2 -> formula2 + F3 -> formula3 + F4 -> formula4 + F5 -> formula5 + F6 -> formula6 + F7 -> formula7 +{-# INLINEABLE getFormula #-} -- % Haskell entry point for testing runClausify :: StaticFormula -> [LRVars] runClausify = clauses . getFormula -{-# INLINABLE runClausify #-} +{-# INLINEABLE runClausify #-} mkClausifyCode :: StaticFormula -> Tx.CompiledCode [LRVars] mkClausifyCode formula = - $$(Tx.compile [|| runClausify ||]) - `Tx.unsafeApplyCode` - Tx.liftCodeDef formula + $$(Tx.compile [||runClausify||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef formula mkClausifyTerm :: StaticFormula -> Term mkClausifyTerm formula = compiledCodeToTerm $ mkClausifyCode formula diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights.hs index 0d3ad684f78..9baaefe07af 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} @@ -23,34 +22,35 @@ import PlutusTx.Plugin () import PlutusTx.Prelude as Tx import Prelude qualified as Haskell -zipConst :: a -> [b] -> [(a,b)] +zipConst :: a -> [b] -> [(a, b)] zipConst a = map ((,) a) -{-# INLINABLE zipConst #-} +{-# INLINEABLE zipConst #-} -grow :: (Integer,ChessSet) -> [(Integer,ChessSet)] -grow (x,y) = zipConst (x+1) (descendents y) -{-# INLINABLE grow #-} +grow :: (Integer, ChessSet) -> [(Integer, ChessSet)] +grow (x, y) = zipConst (x + 1) (descendents y) +{-# INLINEABLE grow #-} -isFinished :: (Integer,ChessSet) -> Bool -isFinished (_,y) = tourFinished y -{-# INLINABLE isFinished #-} +isFinished :: (Integer, ChessSet) -> Bool +isFinished (_, y) = tourFinished y +{-# INLINEABLE isFinished #-} interval :: Integer -> Integer -> [Integer] -interval a0 b = go a0 where +interval a0 b = go a0 + where go a = if a > b then [] else a : go (a + 1) -{-# INLINABLE interval #-} +{-# INLINEABLE interval #-} -- % Original version used infinite lists. mkStarts :: Integer -> [(Integer, ChessSet)] mkStarts sze = - let l = [startTour (x,y) sze | x <- interval 1 sze, y <- interval 1 sze] - numStarts = List.length l -- = sze*sze - in List.zip (replicate numStarts (1-numStarts)) l -{-# INLINABLE mkStarts #-} + let l = [startTour (x, y) sze | x <- interval 1 sze, y <- interval 1 sze] + numStarts = List.length l -- = sze*sze + in List.zip (replicate numStarts (1 - numStarts)) l +{-# INLINEABLE mkStarts #-} root :: Integer -> Queue (Integer, ChessSet) root sze = addAllFront (mkStarts sze) createQueue -{-# INLINABLE root #-} +{-# INLINEABLE root #-} {-% Original version root sze = addAllFront @@ -65,34 +65,38 @@ root sze = addAllFront type Solution = (Integer, ChessSet) -- % Added a depth parameter to stop things getting out of hand in the strict world. -depthSearch :: (Eq a) => Integer -> Queue a -> (a -> [a]) -> (a -> Bool) -> Queue a +depthSearch :: Eq a => Integer -> Queue a -> (a -> [a]) -> (a -> Bool) -> Queue a depthSearch depth q growFn finFn - | depth == 0 = [] - | emptyQueue q = [] - | finFn (inquireFront q) = (inquireFront q): - (depthSearch (depth-1) (removeFront q) growFn finFn) - | otherwise = depthSearch (depth-1) - (addAllFront (growFn (inquireFront q)) - (removeFront q)) - growFn - finFn -{-# INLINABLE depthSearch #-} + | depth == 0 = [] + | emptyQueue q = [] + | finFn (inquireFront q) = + (inquireFront q) + : (depthSearch (depth - 1) (removeFront q) growFn finFn) + | otherwise = + depthSearch + (depth - 1) + ( addAllFront + (growFn (inquireFront q)) + (removeFront q) + ) + growFn + finFn +{-# INLINEABLE depthSearch #-} -- % Only for textual output of PLC scripts unindent :: PLC.Doc ann -> [Haskell.String] unindent d = map (Haskell.dropWhile isSpace) $ (Haskell.lines . Haskell.show $ d) - -- % Haskell entry point for testing runKnights :: Integer -> Integer -> [Solution] runKnights depth boardSize = depthSearch depth (root boardSize) grow isFinished -{-# INLINABLE runKnights #-} +{-# INLINEABLE runKnights #-} mkKnightsCode :: Integer -> Integer -> Tx.CompiledCode [Solution] mkKnightsCode depth boardSize = - $$(Tx.compile [|| runKnights ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef depth - `Tx.unsafeApplyCode` Tx.liftCodeDef boardSize + $$(Tx.compile [||runKnights||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef depth + `Tx.unsafeApplyCode` Tx.liftCodeDef boardSize mkKnightsTerm :: Integer -> Integer -> Term mkKnightsTerm depth boardSize = compiledCodeToTerm $ mkKnightsCode depth boardSize diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/ChessSetList.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/ChessSetList.hs index b7cc607fafb..de99f26d338 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/ChessSetList.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/ChessSetList.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-} -- Turning this off makes things fail, should investigate why {-# OPTIONS_GHC -fno-strictness #-} -module PlutusBenchmark.NoFib.Knights.ChessSetList - ( Tile, - ChessSet (..), - createBoard, - sizeBoard, - addPiece, - deleteFirst, - noPieces, - positionPiece, - lastPiece, - firstPiece, - pieceAtTile, - isSquareFree - ) where +module PlutusBenchmark.NoFib.Knights.ChessSetList ( + Tile, + ChessSet (..), + createBoard, + sizeBoard, + addPiece, + deleteFirst, + noPieces, + positionPiece, + lastPiece, + firstPiece, + pieceAtTile, + isSquareFree, +) where import Control.DeepSeq (NFData) import GHC.Generics @@ -30,54 +30,53 @@ import PlutusTx.Prelude as Tx import Prelude qualified as Haskell - -type Tile = (Integer,Integer) - -data ChessSet = Board - Integer -- % Size of board (along edge) - Integer -- % Current move number - (Maybe Tile) -- % Initial square: see Note (deleteFirst) below - [Tile] -- % All squares visited (in reverse: the last element is the initial - -- square). - deriving stock (Generic) - deriving anyclass (NFData) +type Tile = (Integer, Integer) + +data ChessSet + = Board + Integer -- % Size of board (along edge) + Integer -- % Current move number + (Maybe Tile) -- % Initial square: see Note (deleteFirst) below + [Tile] -- % All squares visited (in reverse: the last element is the initial + -- square). + deriving stock (Generic) + deriving anyclass (NFData) instance Tx.Eq ChessSet where - _ == _ = True + _ == _ = True instance Tx.Ord ChessSet where - _ <= _ = True + _ <= _ = True createBoard :: Integer -> Tile -> ChessSet createBoard x t = Board x 1 (Just t) [t] -{-# INLINABLE createBoard #-} +{-# INLINEABLE createBoard #-} sizeBoard :: ChessSet -> Integer sizeBoard (Board s _ _ _) = s -{-# INLINABLE sizeBoard #-} +{-# INLINEABLE sizeBoard #-} noPieces :: ChessSet -> Integer noPieces (Board _ n _ _) = n -{-# INLINABLE noPieces #-} +{-# INLINEABLE noPieces #-} addPiece :: Tile -> ChessSet -> ChessSet -addPiece t (Board s n f ts) = Board s (n+1) f (t:ts) -{-# INLINABLE addPiece #-} +addPiece t (Board s n f ts) = Board s (n + 1) f (t : ts) +{-# INLINEABLE addPiece #-} -- % Remove the last element from a list init :: [a] -> [a] init l = case reverse l of - _:as -> reverse as - [] -> Tx.error () -{-# INLINABLE init #-} + _ : as -> reverse as + [] -> Tx.error () +{-# INLINEABLE init #-} secondLast :: [a] -> Maybe a secondLast l = - case reverse l of - [] -> Tx.error () - [_] -> Nothing - _:a:_ -> Just a -{-# INLINABLE secondLast #-} - + case reverse l of + [] -> Tx.error () + [_] -> Nothing + _ : a : _ -> Just a +{-# INLINEABLE secondLast #-} {-% Note (deleteFirst). deleteFirst removes the first position from the tour. @@ -93,79 +92,82 @@ secondLast l = deleteFirst :: ChessSet -> ChessSet deleteFirst (Board s n _ ts) = - Board s (n-1) f' ts' - where ts' = init ts - f' = secondLast ts -{-# INLINABLE deleteFirst #-} + Board s (n - 1) f' ts' + where + ts' = init ts + f' = secondLast ts +{-# INLINEABLE deleteFirst #-} positionPiece :: Integer -> ChessSet -> Tile positionPiece x (Board _ n _ ts) = ts List.!! (n - x) -{-# INLINABLE positionPiece #-} +{-# INLINEABLE positionPiece #-} lastPiece :: ChessSet -> Tile -lastPiece (Board _ _ _ (t:_)) = t -lastPiece _ = Tx.error () -{-# INLINABLE lastPiece #-} +lastPiece (Board _ _ _ (t : _)) = t +lastPiece _ = Tx.error () +{-# INLINEABLE lastPiece #-} firstPiece :: ChessSet -> Tile firstPiece (Board _ _ f _) = - case f of Just tile -> tile - Nothing -> Tx.error () -{-# INLINABLE firstPiece #-} + case f of + Just tile -> tile + Nothing -> Tx.error () +{-# INLINEABLE firstPiece #-} pieceAtTile :: Tile -> ChessSet -> Integer -pieceAtTile x0 (Board _ _ _ ts) - = findPiece x0 ts - where - findPiece _ [] = Tx.error () - findPiece x (y:xs) - | x == y = 1 + List.length xs - | otherwise = findPiece x xs -{-# INLINABLE pieceAtTile #-} - - -notIn :: Eq a => a -> [a] -> Bool -notIn _ [] = True -notIn x (a:as) = (x /= a) && (notIn x as) -{-# INLINABLE notIn #-} +pieceAtTile x0 (Board _ _ _ ts) = + findPiece x0 ts + where + findPiece _ [] = Tx.error () + findPiece x (y : xs) + | x == y = 1 + List.length xs + | otherwise = findPiece x xs +{-# INLINEABLE pieceAtTile #-} + +notIn :: Eq a => a -> [a] -> Bool +notIn _ [] = True +notIn x (a : as) = (x /= a) && (notIn x as) +{-# INLINEABLE notIn #-} isSquareFree :: Tile -> ChessSet -> Bool isSquareFree x (Board _ _ _ ts) = notIn x ts -{-# INLINABLE isSquareFree #-} - +{-# INLINEABLE isSquareFree #-} -- % Everything below here is only needed for printing boards. -- % This is useful for debugging. instance Haskell.Show ChessSet where - showsPrec _ (Board sze n _ ts) - = Haskell.showString (printBoard sze sortedTrail 1) - where sortedTrail = quickSort (assignMoveNo ts sze n) + showsPrec _ (Board sze n _ ts) = + Haskell.showString (printBoard sze sortedTrail 1) + where + sortedTrail = quickSort (assignMoveNo ts sze n) assignMoveNo :: [Tile] -> Integer -> Integer -> [Tile] -assignMoveNo [] _ _ - = [] -assignMoveNo ((x,y):t) size z - = (((y-1)*size)+x,z):assignMoveNo t size (z-1) +assignMoveNo [] _ _ = + [] +assignMoveNo ((x, y) : t) size z = + (((y - 1) * size) + x, z) : assignMoveNo t size (z - 1) printBoard :: Integer -> [Tile] -> Integer -> Haskell.String printBoard s [] n - | (n > (s*s)) = "" - | ((n `Haskell.mod` s) /=0)= "*"++(spaces (s*s) 1) ++(printBoard s [] (n+1)) - | ((n `Haskell.mod` s) ==0)= "*\n" ++(printBoard s [] (n+1)) -printBoard s trail@((i,j):xs) n - | (i==n) && - ((n `Haskell.mod` s) ==0) = (Haskell.show j)++"\n"++(printBoard s xs (n+1)) - | (i==n) && - ((n `Haskell.mod` s) /=0)= (Haskell.show j)++(spaces (s*s) j)++(printBoard s xs (n+1)) - | ((n `Haskell.mod` s) /=0)= "*" ++(spaces (s*s) 1)++(printBoard s trail (n+1)) - | ((n `Haskell.mod` s) ==0)= "*\n" ++(printBoard s trail (n+1)) + | (n > (s * s)) = "" + | ((n `Haskell.mod` s) /= 0) = "*" ++ (spaces (s * s) 1) ++ (printBoard s [] (n + 1)) + | ((n `Haskell.mod` s) == 0) = "*\n" ++ (printBoard s [] (n + 1)) +printBoard s trail@((i, j) : xs) n + | (i == n) + && ((n `Haskell.mod` s) == 0) = + (Haskell.show j) ++ "\n" ++ (printBoard s xs (n + 1)) + | (i == n) + && ((n `Haskell.mod` s) /= 0) = + (Haskell.show j) ++ (spaces (s * s) j) ++ (printBoard s xs (n + 1)) + | ((n `Haskell.mod` s) /= 0) = "*" ++ (spaces (s * s) 1) ++ (printBoard s trail (n + 1)) + | ((n `Haskell.mod` s) == 0) = "*\n" ++ (printBoard s trail (n + 1)) printBoard _ _ _ = "?" spaces :: Integer -> Integer -> Haskell.String spaces s y = - take' ((logTen s) - (logTen y) + 1) [' ',' '..] - where - logTen :: Integer -> Integer - logTen 0 = 0 - logTen x = 1 + logTen (x `Haskell.div` 10) + take' ((logTen s) - (logTen y) + 1) [' ', ' ' ..] + where + logTen :: Integer -> Integer + logTen 0 = 0 + logTen x = 1 + logTen (x `Haskell.div` 10) diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/KnightHeuristic.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/KnightHeuristic.hs index c332834b743..afe1a830f4c 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/KnightHeuristic.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/KnightHeuristic.hs @@ -1,11 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} -module PlutusBenchmark.NoFib.Knights.KnightHeuristic - ( ChessSet, - startTour, - descendents, - tourFinished - ) where +module PlutusBenchmark.NoFib.Knights.KnightHeuristic ( + ChessSet, + startTour, + descendents, + tourFinished, +) where import PlutusBenchmark.NoFib.Knights.ChessSetList import PlutusBenchmark.NoFib.Knights.Sort (quickSort) @@ -13,89 +13,93 @@ import PlutusBenchmark.NoFib.Knights.Sort (quickSort) import PlutusTx.List as List import PlutusTx.Prelude as Tx -data Direction = UL | UR | DL |DR | LU | LD | RU | RD +data Direction = UL | UR | DL | DR | LU | LD | RU | RD move :: Direction -> Tile -> Tile -move UL (x,y) = (x-1,y-2) -move UR (x,y) = (x+1,y-2) -move DL (x,y) = (x-1,y+2) -move DR (x,y) = (x+1,y+2) -move LU (x,y) = (x-2,y-1) -move LD (x,y) = (x-2,y+1) -move RU (x,y) = (x+2,y-1) -move RD (x,y) = (x+2,y+1) -{-# INLINABLE move #-} +move UL (x, y) = (x - 1, y - 2) +move UR (x, y) = (x + 1, y - 2) +move DL (x, y) = (x - 1, y + 2) +move DR (x, y) = (x + 1, y + 2) +move LU (x, y) = (x - 2, y - 1) +move LD (x, y) = (x - 2, y + 1) +move RU (x, y) = (x + 2, y - 1) +move RD (x, y) = (x + 2, y + 1) +{-# INLINEABLE move #-} startTour :: Tile -> Integer -> ChessSet startTour st size - | (size `Tx.remainder` 2) == 0 = createBoard size st - | otherwise = {-Tx.trace "startTour" $ -} Tx.error () -{-# INLINABLE startTour #-} + | (size `Tx.remainder` 2) == 0 = createBoard size st + | otherwise {-Tx.trace "startTour" $ -} = Tx.error () +{-# INLINEABLE startTour #-} moveKnight :: ChessSet -> Direction -> ChessSet -moveKnight board dir - = addPiece (move dir (lastPiece board)) board -{-# INLINABLE moveKnight #-} +moveKnight board dir = + addPiece (move dir (lastPiece board)) board +{-# INLINEABLE moveKnight #-} canMove :: ChessSet -> Direction -> Bool -canMove board dir - = canMoveTo (move dir (lastPiece board)) board -{-# INLINABLE canMove #-} +canMove board dir = + canMoveTo (move dir (lastPiece board)) board +{-# INLINEABLE canMove #-} canMoveTo :: Tile -> ChessSet -> Bool -canMoveTo t@(x,y) board - = (x Tx.>= 1) && (x Tx.<= sze) && - (y Tx.>= 1) && (y Tx.<= sze) && - isSquareFree t board - where - sze = sizeBoard board -{-# INLINABLE canMoveTo #-} +canMoveTo t@(x, y) board = + (x Tx.>= 1) + && (x Tx.<= sze) + && (y Tx.>= 1) + && (y Tx.<= sze) + && isSquareFree t board + where + sze = sizeBoard board +{-# INLINEABLE canMoveTo #-} descendents :: ChessSet -> [ChessSet] descendents board = if (canJumpFirst board) && (deadEnd (addPiece (firstPiece board) board)) - then [] - else - let l = List.length singles in - if l == 0 then map snd (quickSort (descAndNo board)) - else if l == 1 then singles - else [] -- Going to be dead end - where - singles = singleDescend board -{-# INLINABLE descendents #-} - + then [] + else + let l = List.length singles + in if l == 0 + then map snd (quickSort (descAndNo board)) + else + if l == 1 + then singles + else [] -- Going to be dead end + where + singles = singleDescend board +{-# INLINEABLE descendents #-} singleDescend :: ChessSet -> [ChessSet] -singleDescend board =[x | (y,x) <- descAndNo board, y==1] -{-# INLINABLE singleDescend #-} +singleDescend board = [x | (y, x) <- descAndNo board, y == 1] +{-# INLINEABLE singleDescend #-} -descAndNo :: ChessSet -> [(Integer,ChessSet)] -descAndNo board - = [(List.length (possibleMoves (deleteFirst x)),x) | x <- allDescend board] -{-# INLINABLE descAndNo #-} +descAndNo :: ChessSet -> [(Integer, ChessSet)] +descAndNo board = + [(List.length (possibleMoves (deleteFirst x)), x) | x <- allDescend board] +{-# INLINEABLE descAndNo #-} allDescend :: ChessSet -> [ChessSet] -allDescend board - = map (moveKnight board) (possibleMoves board) -{-# INLINABLE allDescend #-} +allDescend board = + map (moveKnight board) (possibleMoves board) +{-# INLINEABLE allDescend #-} possibleMoves :: ChessSet -> [Direction] -possibleMoves board - =[x | x <- [UL,UR,DL,DR,LU,LD,RU,RD], (canMove board x)] -{-# INLINABLE possibleMoves #-} +possibleMoves board = + [x | x <- [UL, UR, DL, DR, LU, LD, RU, RD], (canMove board x)] +{-# INLINEABLE possibleMoves #-} deadEnd :: ChessSet -> Bool deadEnd board = List.length (possibleMoves board) == 0 -{-# INLINABLE deadEnd #-} +{-# INLINEABLE deadEnd #-} canJumpFirst :: ChessSet -> Bool -canJumpFirst board - = canMoveTo (firstPiece board) (deleteFirst board) -{-# INLINABLE canJumpFirst #-} +canJumpFirst board = + canMoveTo (firstPiece board) (deleteFirst board) +{-# INLINEABLE canJumpFirst #-} tourFinished :: ChessSet -> Bool -tourFinished board - = (noPieces board == (sze*sze)) && (canJumpFirst board) - where - sze = sizeBoard board -{-# INLINABLE tourFinished #-} +tourFinished board = + (noPieces board == (sze * sze)) && (canJumpFirst board) + where + sze = sizeBoard board +{-# INLINEABLE tourFinished #-} diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Queue.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Queue.hs index 1ebcd870961..c60696c888c 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Queue.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Queue.hs @@ -1,9 +1,16 @@ -module PlutusBenchmark.NoFib.Knights.Queue - ( Queue, createQueue, addFront, addBack, - addAllFront, addAllBack, inquireFront, - inquireBack, removeFront, removeBack, - emptyQueue - ) where +module PlutusBenchmark.NoFib.Knights.Queue ( + Queue, + createQueue, + addFront, + addBack, + addAllFront, + addAllBack, + inquireFront, + inquireBack, + removeFront, + removeBack, + emptyQueue, +) where import PlutusTx.List qualified as List import PlutusTx.Prelude as Tx @@ -12,50 +19,50 @@ type Queue a = [a] createQueue :: Queue a createQueue = [] -{-# INLINABLE createQueue #-} +{-# INLINEABLE createQueue #-} addFront :: a -> Queue a -> Queue a -addFront x q = x:q -{-# INLINABLE addFront #-} +addFront x q = x : q +{-# INLINEABLE addFront #-} addBack :: a -> Queue a -> Queue a addBack x q = q List.++ [x] -{-# INLINABLE addBack #-} +{-# INLINEABLE addBack #-} addAllFront :: [a] -> Queue a -> Queue a addAllFront list q = list List.++ q -{-# INLINABLE addAllFront #-} +{-# INLINEABLE addAllFront #-} addAllBack :: [a] -> Queue a -> Queue a addAllBack list q = q List.++ list -{-# INLINABLE addAllBack #-} +{-# INLINEABLE addAllBack #-} inquireFront :: Queue a -> a -inquireFront [] = Tx.error () -inquireFront (h:_) = h -{-# INLINABLE inquireFront #-} +inquireFront [] = Tx.error () +inquireFront (h : _) = h +{-# INLINEABLE inquireFront #-} inquireBack :: Queue a -> a -inquireBack [] = Tx.error () -inquireBack [x] = x -inquireBack (_:xs) = inquireBack xs -{-# INLINABLE inquireBack #-} +inquireBack [] = Tx.error () +inquireBack [x] = x +inquireBack (_ : xs) = inquireBack xs +{-# INLINEABLE inquireBack #-} removeFront :: Queue a -> Queue a -removeFront [] = Tx.error () -removeFront (_:t) = t -{-# INLINABLE removeFront #-} +removeFront [] = Tx.error () +removeFront (_ : t) = t +{-# INLINEABLE removeFront #-} removeBack :: Queue a -> Queue a -removeBack [] = Tx.error () -removeBack [_] = [] -removeBack (x:xs) = x:(removeBack xs) -{-# INLINABLE removeBack #-} +removeBack [] = Tx.error () +removeBack [_] = [] +removeBack (x : xs) = x : (removeBack xs) +{-# INLINEABLE removeBack #-} emptyQueue :: Queue a -> Bool emptyQueue [] = True -emptyQueue _ = False -{-# INLINABLE emptyQueue #-} +emptyQueue _ = False +{-# INLINEABLE emptyQueue #-} {- sizeQueue :: Queue b -> Integer diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs index bbb1dd106f9..db72f0f23c5 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs @@ -1,48 +1,52 @@ {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -module PlutusBenchmark.NoFib.Knights.Sort - ( insertSort, - mergeSort, - quickSort - ) where +module PlutusBenchmark.NoFib.Knights.Sort ( + insertSort, + mergeSort, + quickSort, +) where import PlutusTx.Prelude qualified as Tx -insertSort :: (Tx.Ord a) => [a] -> [a] +insertSort :: Tx.Ord a => [a] -> [a] insertSort xs = foldr insertion [] xs -{-# INLINABLE insertSort #-} +{-# INLINEABLE insertSort #-} -insertion :: (Tx.Ord a) => a -> [a] -> [a] +insertion :: Tx.Ord a => a -> [a] -> [a] insertion x [] = [x] -insertion x (y:ys) - | x Tx.<= y = x:y:ys - | otherwise = y:insertion x ys -{-# INLINABLE insertion #-} - -mergeSort :: (Tx.Ord a) => [a] -> [a] -mergeSort xs - = if (n <=1 ) then xs - else - (mergeList - ( mergeSort (take (n `div` 2) xs)) - ( mergeSort (drop (n `div` 2) xs))) - where - n = length xs -{-# INLINABLE mergeSort #-} - -mergeList :: (Tx.Ord a) => [a] -> [a] -> [a] -mergeList [] ys = ys -mergeList xs [] = xs -mergeList (x:xs) (y:ys) - | x Tx.<= y = x:mergeList xs (y:ys) - | otherwise = y:mergeList (x:xs) ys -{-# INLINABLE mergeList #-} - -quickSort :: (Tx.Ord a) => [a] -> [a] -quickSort [] = [] -quickSort (x:xs) = (quickSort [y | y<-xs, y Tx.< x]) ++ [x] ++ - (quickSort [y | y<-xs, y Tx.>= x]) -{-# INLINABLE quickSort #-} +insertion x (y : ys) + | x Tx.<= y = x : y : ys + | otherwise = y : insertion x ys +{-# INLINEABLE insertion #-} + +mergeSort :: Tx.Ord a => [a] -> [a] +mergeSort xs = + if (n <= 1) + then xs + else + ( mergeList + (mergeSort (take (n `div` 2) xs)) + (mergeSort (drop (n `div` 2) xs)) + ) + where + n = length xs +{-# INLINEABLE mergeSort #-} + +mergeList :: Tx.Ord a => [a] -> [a] -> [a] +mergeList [] ys = ys +mergeList xs [] = xs +mergeList (x : xs) (y : ys) + | x Tx.<= y = x : mergeList xs (y : ys) + | otherwise = y : mergeList (x : xs) ys +{-# INLINEABLE mergeList #-} + +quickSort :: Tx.Ord a => [a] -> [a] +quickSort [] = [] +quickSort (x : xs) = + (quickSort [y | y <- xs, y Tx.< x]) + ++ [x] + ++ (quickSort [y | y <- xs, y Tx.>= x]) +{-# INLINEABLE quickSort #-} {-% These don't work in Plutus, and aren't used in the original program. lazySortLe :: (a -> a -> Bool) -> [a] -> [a] @@ -94,43 +98,43 @@ rqpart le x (y:ys) rle rgt r = randomIntegers :: Integer -> Integer -> [Integer] randomIntegers s1 s2 = - if 1 <= s1 && s1 <= 2147483562 then - if 1 <= s2 && s2 <= 2147483398 then - rands s1 s2 + if 1 <= s1 && s1 <= 2147483562 + then + if 1 <= s2 && s2 <= 2147483398 + then + rands s1 s2 else - error "randomIntegers: Bad second seed." + error "randomIntegers: Bad second seed." else - error "randomIntegers: Bad first seed." -{-# INLINABLE randomIntegers #-} + error "randomIntegers: Bad first seed." +{-# INLINEABLE randomIntegers #-} rands :: Integer -> Integer -> [Integer] -rands s1 s2 - = if z < 1 then z + 2147483562 : rands s1'' s2'' - else - z : rands s1'' s2'' - where - k = s1 `div` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - - k' = s2 `div` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - - z = s1'' - s2'' -{-# INLINABLE rands #-} +rands s1 s2 = + if z < 1 + then z + 2147483562 : rands s1'' s2'' + else + z : rands s1'' s2'' + where + k = s1 `div` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' --- % These are from the original program. That's literate Haskell, and it --- % contains the results as latex. + k' = s2 `div` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' -test1,test2,test3,test4,test5,test6,test7::[Integer] + z = s1'' - s2'' +{-# INLINEABLE rands #-} -test1 = [1..10] -test2 = [10,9..1] -test3 = [1..500] -test4 = [500,499..1] +-- % These are from the original program. That's literate Haskell, and it +-- % contains the results as latex. -test5 = take 10 (randomIntegers 123213 342234) -test6 = take 100 (randomIntegers 123213 342234) +test1, test2, test3, test4, test5, test6, test7 :: [Integer] +test1 = [1 .. 10] +test2 = [10, 9 .. 1] +test3 = [1 .. 500] +test4 = [500, 499 .. 1] +test5 = take 10 (randomIntegers 123213 342234) +test6 = take 100 (randomIntegers 123213 342234) test7 = take 1000 (randomIntegers 123213 342234) - diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Utils.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Utils.hs index a50559e3aa9..d2b991cabce 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Utils.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Utils.hs @@ -5,6 +5,6 @@ module PlutusBenchmark.NoFib.Knights.Utils where import PlutusTx.Prelude take' :: Integer -> [a] -> [a] -take' _ [] = [] -take' n (a:as) = if n<=0 then [] else a:(take' (n-1) as) -{-# INLINABLE take' #-} +take' _ [] = [] +take' n (a : as) = if n <= 0 then [] else a : (take' (n - 1) as) +{-# INLINEABLE take' #-} diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/LastPiece.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/LastPiece.hs index 60349647fa3..fd922022a29 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/LastPiece.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/LastPiece.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-% Last piece puzzle, adapted from nofib/spectral/last-piece. This is a solver for a jigsaw problem: @@ -34,280 +34,345 @@ import Prelude qualified as Haskell ------------------------------------- -- Pieces -type Offset = (Integer, Integer) -type Square = (Integer, Integer) - -- (1,1) is bottom LH corner +type Offset = (Integer, Integer) +type Square = (Integer, Integer) + +-- (1,1) is bottom LH corner type PieceId = Tx.BuiltinString -type Board = [(Square, PieceId)] -- Was Map.Map Square PieceId +type Board = [(Square, PieceId)] -- Was Map.Map Square PieceId -data Piece = P PieceId - [[Offset]] -- Male in bottom LH - [[Offset]] -- Female in bottom LH - -- In both cases, the list of offset is all the - -- squares except the bottom LH one +data Piece + = P + PieceId + [[Offset]] -- Male in bottom LH + [[Offset]] -- Female in bottom LH + -- In both cases, the list of offset is all the + -- squares except the bottom LH one -data Solution = Soln Board - | Choose [Solution] -- Non-empty - | Fail -- Board Square - deriving stock (Haskell.Show) +data Solution + = Soln Board + | Choose [Solution] -- Non-empty + | Fail -- Board Square + deriving stock (Haskell.Show) data Sex = Male | Female - sumList :: [Integer] -> Integer -sumList [] = 0 -sumList (h:t) = h + sumList t -{-# INLINABLE sumList #-} +sumList [] = 0 +sumList (h : t) = h + sumList t +{-# INLINEABLE sumList #-} numSolutions :: Solution -> Integer -numSolutions (Soln _) = 1 +numSolutions (Soln _) = 1 numSolutions (Choose l) = sumList . List.map numSolutions $ l -numSolutions Fail = 0 -{-# INLINABLE numSolutions #-} +numSolutions Fail = 0 +{-# INLINEABLE numSolutions #-} sizeOfSolution :: Solution -> Integer -sizeOfSolution (Soln _) = 1 +sizeOfSolution (Soln _) = 1 sizeOfSolution (Choose l) = sumList . List.map sizeOfSolution $ l -sizeOfSolution Fail = 1 +sizeOfSolution Fail = 1 flipSex :: Sex -> Sex -flipSex Male = Female +flipSex Male = Female flipSex Female = Male -{-# INLINABLE flipSex #-} +{-# INLINEABLE flipSex #-} -- The main search -search :: Square -> Sex -- Square we are up to - -> Board -- Current board - -> [Piece] -- Remaining pieces - -> Solution -search _ _ board [] - = Soln board -- Finished -search (row,col) sex board ps -- Next row - | col == (maxCol+1) = search (row+1, 1) (flipSex sex) board ps -search square sex board ps -- Occupied square +search :: + Square -> + Sex -> -- Square we are up to + Board -> -- Current board + [Piece] -> -- Remaining pieces + Solution +search _ _ board [] = + Soln board -- Finished +search (row, col) sex board ps -- Next row + | col == (maxCol + 1) = search (row + 1, 1) (flipSex sex) board ps +search square sex board ps -- Occupied square | isJust (check board square) = search (next square) (flipSex sex) board ps -search square sex board ps - = case mapMaybe (try square sex board) choices of - [] -> Fail -- board square - ss -> prune ss -- discard failed paths - where - choices = [(pid, os, ps') | - (P pid ms fs, ps') <- pickOne ps, - let oss = case sex of - Male -> ms - Female -> fs, - os <- oss] -{-# INLINABLE search #-} +search square sex board ps = + case mapMaybe (try square sex board) choices of + [] -> Fail -- board square + ss -> prune ss -- discard failed paths + where + choices = + [ (pid, os, ps') + | (P pid ms fs, ps') <- pickOne ps + , let oss = case sex of + Male -> ms + Female -> fs + , os <- oss + ] +{-# INLINEABLE search #-} -- % An attempt to cut down on the size of the result (not in the original program) prune :: [Solution] -> Solution prune ss = - case List.filter nonFailure ss of - [] -> Fail - [Soln s] -> Soln s - l -> Choose l - where nonFailure Fail = False - nonFailure _ = True -{-# INLINABLE prune #-} - -try :: Square -> Sex -> Board -> (PieceId,[Offset],[Piece]) -> Maybe Solution -try square sex board (pid,os,ps) - = case fit board square pid os of - Just board' -> Just (search (next square) (flipSex sex) board' ps) - Nothing -> Nothing -{-# INLINABLE try #-} + case List.filter nonFailure ss of + [] -> Fail + [Soln s] -> Soln s + l -> Choose l + where + nonFailure Fail = False + nonFailure _ = True +{-# INLINEABLE prune #-} +try :: Square -> Sex -> Board -> (PieceId, [Offset], [Piece]) -> Maybe Solution +try square sex board (pid, os, ps) = + case fit board square pid os of + Just board' -> Just (search (next square) (flipSex sex) board' ps) + Nothing -> Nothing +{-# INLINEABLE try #-} fit :: Board -> Square -> PieceId -> [Offset] -> Maybe Board -fit board square pid [] = Just (extend board square pid) -fit board square pid (o:os) = - case extend_maybe board (square `add` o) pid of - Just board' -> fit board' square pid os - Nothing -> Nothing -{-# INLINABLE fit #-} - +fit board square pid [] = Just (extend board square pid) +fit board square pid (o : os) = + case extend_maybe board (square `add` o) pid of + Just board' -> fit board' square pid os + Nothing -> Nothing +{-# INLINEABLE fit #-} -------------------------- -- Offsets and squares add :: Square -> Offset -> Square -add (row,col) (orow, ocol) = (row + orow, col + ocol) -{-# INLINABLE add #-} +add (row, col) (orow, ocol) = (row + orow, col + ocol) +{-# INLINEABLE add #-} next :: Square -> Square -next (row,col) = (row,col+1) -{-# INLINABLE next #-} +next (row, col) = (row, col + 1) +{-# INLINEABLE next #-} -maxRow,maxCol :: Integer +maxRow, maxCol :: Integer maxRow = 8 maxCol = 8 -{-# INLINABLE maxRow #-} -{-# INLINABLE maxCol #-} - +{-# INLINEABLE maxRow #-} +{-# INLINEABLE maxCol #-} ------------------------ -- Boards emptyBoard :: Board emptyBoard = [] -- Map.empty -{-# INLINABLE emptyBoard #-} +{-# INLINEABLE emptyBoard #-} check :: Board -> Square -> Maybe PieceId -check board square = -- Map.lookup square board - case board of - [] -> Nothing - (square',pid):board' -> if square == square' then Just pid else check board' square -{-# INLINABLE check #-} +check board square = + -- Map.lookup square board + case board of + [] -> Nothing + (square', pid) : board' -> if square == square' then Just pid else check board' square +{-# INLINEABLE check #-} extend :: Board -> Square -> PieceId -> Board -extend board square pid = (square, pid): board -- Map.insert square pid board -{-# INLINABLE extend #-} +extend board square pid = (square, pid) : board -- Map.insert square pid board +{-# INLINEABLE extend #-} extend_maybe :: Board -> Square -> PieceId -> Maybe Board -extend_maybe board square@(row,col) pid - | row > maxRow || col < 1 || col > maxCol - = Nothing - | otherwise - = case check board square of - Just _ -> Nothing +extend_maybe board square@(row, col) pid + | row > maxRow || col < 1 || col > maxCol = + Nothing + | otherwise = + case check board square of + Just _ -> Nothing Nothing -> Just (extend board square pid) -{-# INLINABLE extend_maybe #-} - +{-# INLINEABLE extend_maybe #-} -------------------------- -- Utility -pickOne :: [a] -> [(a,[a])] +pickOne :: [a] -> [(a, [a])] pickOne = go id where - go _ [] = [] - go f (x:xs) = (x, f xs) : go ((x :) . f) xs -{-# INLINABLE pickOne #-} - + go _ [] = [] + go f (x : xs) = (x, f xs) : go ((x :) . f) xs +{-# INLINEABLE pickOne #-} ----------------------------------- -- The initial setup -- % Library functions is not inlinable fromJust :: Maybe a -> a -fromJust Nothing = Tx.error () +fromJust Nothing = Tx.error () fromJust (Just x) = x -{-# INLINABLE fromJust #-} +{-# INLINEABLE fromJust #-} initialBoard :: Board -initialBoard = fromJust (fit emptyBoard (1,1) "a" [(1,0),(1,1)]) -{-# INLINABLE initialBoard #-} +initialBoard = fromJust (fit emptyBoard (1, 1) "a" [(1, 0), (1, 1)]) +{-# INLINEABLE initialBoard #-} initialPieces :: [Piece] -initialPieces = [bPiece, cPiece, dPiece, ePiece, fPiece, - gPiece, hPiece, iPiece, jPiece, kPiece, - lPiece, mPiece, nPiece] -{-# INLINABLE initialPieces #-} +initialPieces = + [ bPiece + , cPiece + , dPiece + , ePiece + , fPiece + , gPiece + , hPiece + , iPiece + , jPiece + , kPiece + , lPiece + , mPiece + , nPiece + ] +{-# INLINEABLE initialPieces #-} nPiece :: Piece -nPiece = P "n" [ [(0,1),(1,1),(2,1),(2,2)], - [(1,0),(1,-1),(1,-2),(2,-2)] ] - [] -{-# INLINABLE nPiece #-} +nPiece = + P + "n" + [ [(0, 1), (1, 1), (2, 1), (2, 2)] + , [(1, 0), (1, -1), (1, -2), (2, -2)] + ] + [] +{-# INLINEABLE nPiece #-} mPiece :: Piece -mPiece = P "m" [ [(0,1),(1,0),(2,0),(3,0)] ] - [ [(0,1),(0,2),(0,3),(1,3)], - [(1,0),(2,0),(3,0),(3,-1)] ] -{-# INLINABLE mPiece #-} +mPiece = + P + "m" + [[(0, 1), (1, 0), (2, 0), (3, 0)]] + [ [(0, 1), (0, 2), (0, 3), (1, 3)] + , [(1, 0), (2, 0), (3, 0), (3, -1)] + ] +{-# INLINEABLE mPiece #-} lPiece :: Piece -lPiece = P "l" [ [(0,1),(0,2),(0,3),(1,2)], - [(1,0),(2,0),(3,0),(2,-1)] ] - [ [(1,-1),(1,0),(1,1),(1,2)], - [(1,0),(2,0),(3,0),(1,1)] ] -{-# INLINABLE lPiece #-} +lPiece = + P + "l" + [ [(0, 1), (0, 2), (0, 3), (1, 2)] + , [(1, 0), (2, 0), (3, 0), (2, -1)] + ] + [ [(1, -1), (1, 0), (1, 1), (1, 2)] + , [(1, 0), (2, 0), (3, 0), (1, 1)] + ] +{-# INLINEABLE lPiece #-} kPiece :: Piece -kPiece = P "k" [ [(0,1),(1,0),(2,0),(2,-1)] ] - [ [(1,0),(1,1),(1,2),(2,2)] ] -{-# INLINABLE kPiece #-} - +kPiece = + P + "k" + [[(0, 1), (1, 0), (2, 0), (2, -1)]] + [[(1, 0), (1, 1), (1, 2), (2, 2)]] +{-# INLINEABLE kPiece #-} jPiece :: Piece -jPiece = P "j" [ [(0,1),(0,2),(0,3),(1,1)], - [(1,0),(2,0),(3,0),(1,-1)], - [(1,-2),(1,-1),(1,0),(1,1)] ] - [ [(1,0),(2,0),(3,0),(2,2)] ] -{-# INLINABLE jPiece #-} +jPiece = + P + "j" + [ [(0, 1), (0, 2), (0, 3), (1, 1)] + , [(1, 0), (2, 0), (3, 0), (1, -1)] + , [(1, -2), (1, -1), (1, 0), (1, 1)] + ] + [[(1, 0), (2, 0), (3, 0), (2, 2)]] +{-# INLINEABLE jPiece #-} iPiece :: Piece -iPiece = P "i" [ [(1,0),(2,0),(2,1),(3,1)], - [(0,1),(0,2),(1,0),(1,-1)], - [(1,0),(1,1),(2,1),(3,1)] ] - [ [(0,1),(1,0),(1,-1),(1,-2)] ] -{-# INLINABLE iPiece #-} +iPiece = + P + "i" + [ [(1, 0), (2, 0), (2, 1), (3, 1)] + , [(0, 1), (0, 2), (1, 0), (1, -1)] + , [(1, 0), (1, 1), (2, 1), (3, 1)] + ] + [[(0, 1), (1, 0), (1, -1), (1, -2)]] +{-# INLINEABLE iPiece #-} hPiece :: Piece -hPiece = P "h" [ [(0,1),(1,1),(1,2),(2,2)], - [(1,0),(1,-1),(2,-1),(2,-2)], - [(1,0),(1,1),(2,1),(2,2)] ] - [ [(0,1),(1,0),(1,-1),(2,-1)] ] -{-# INLINABLE hPiece #-} - +hPiece = + P + "h" + [ [(0, 1), (1, 1), (1, 2), (2, 2)] + , [(1, 0), (1, -1), (2, -1), (2, -2)] + , [(1, 0), (1, 1), (2, 1), (2, 2)] + ] + [[(0, 1), (1, 0), (1, -1), (2, -1)]] +{-# INLINEABLE hPiece #-} gPiece :: Piece -gPiece = P "g" [ ] - [ [(0,1),(1,1),(1,2),(1,3)], - [(1,0),(1,-1),(2,-1),(3,-1)], - [(0,1),(0,2),(1,2),(1,3)], - [(1,0),(2,0),(2,-1),(3,-1)] ] -{-# INLINABLE gPiece #-} +gPiece = + P + "g" + [] + [ [(0, 1), (1, 1), (1, 2), (1, 3)] + , [(1, 0), (1, -1), (2, -1), (3, -1)] + , [(0, 1), (0, 2), (1, 2), (1, 3)] + , [(1, 0), (2, 0), (2, -1), (3, -1)] + ] +{-# INLINEABLE gPiece #-} fPiece :: Piece -fPiece = P "f" [ [(0,1),(1,1),(2,1),(3,1)], - [(1,0),(1,-1),(1,-2),(1,-3)], - [(1,0),(2,0),(3,0),(3,1)] ] - [ [(0,1),(0,2),(0,3),(1,0)] ] -{-# INLINABLE fPiece #-} - +fPiece = + P + "f" + [ [(0, 1), (1, 1), (2, 1), (3, 1)] + , [(1, 0), (1, -1), (1, -2), (1, -3)] + , [(1, 0), (2, 0), (3, 0), (3, 1)] + ] + [[(0, 1), (0, 2), (0, 3), (1, 0)]] +{-# INLINEABLE fPiece #-} ePiece :: Piece -ePiece = P "e" [ [(0,1),(1,1),(1,2)], - [(1,0),(1,-1),(2,-1)] ] - [ [(0,1),(1,1),(1,2)], - [(1,0),(1,-1),(2,-1)] ] -{-# INLINABLE ePiece #-} +ePiece = + P + "e" + [ [(0, 1), (1, 1), (1, 2)] + , [(1, 0), (1, -1), (2, -1)] + ] + [ [(0, 1), (1, 1), (1, 2)] + , [(1, 0), (1, -1), (2, -1)] + ] +{-# INLINEABLE ePiece #-} dPiece :: Piece -dPiece = P "d" [ [(0,1),(1,1),(2,1)], - [(1,0),(1,-1),(1,-2)] ] - [ [(1,0),(2,0),(2,1)] ] -{-# INLINABLE dPiece #-} - +dPiece = + P + "d" + [ [(0, 1), (1, 1), (2, 1)] + , [(1, 0), (1, -1), (1, -2)] + ] + [[(1, 0), (2, 0), (2, 1)]] +{-# INLINEABLE dPiece #-} cPiece :: Piece -cPiece = P "c" [ ] - [ [(0,1),(0,2),(1,1)], - [(1,0),(1,-1),(2,0)], - [(1,-1),(1,0),(1,1)], - [(1,0),(1,1),(2,0)] ] -{-# INLINABLE cPiece #-} +cPiece = + P + "c" + [] + [ [(0, 1), (0, 2), (1, 1)] + , [(1, 0), (1, -1), (2, 0)] + , [(1, -1), (1, 0), (1, 1)] + , [(1, 0), (1, 1), (2, 0)] + ] +{-# INLINEABLE cPiece #-} bPiece :: Piece -bPiece = P "b" [ [(0,1),(0,2),(1,2)], - [(1,0),(2,0),(2,-1)], - [(0,1),(1,0),(2,0)] ] - [ [(1,0),(1,1),(1,2)] ] -{-# INLINABLE bPiece #-} +bPiece = + P + "b" + [ [(0, 1), (0, 2), (1, 2)] + , [(1, 0), (2, 0), (2, -1)] + , [(0, 1), (1, 0), (2, 0)] + ] + [[(1, 0), (1, 1), (1, 2)]] +{-# INLINEABLE bPiece #-} unindent :: PLC.Doc ann -> [Haskell.String] unindent d = List.map (Haskell.dropWhile isSpace) (Haskell.lines . Haskell.show $ d) runLastPiece :: Solution -runLastPiece = search (1,2) Female initialBoard initialPieces +runLastPiece = search (1, 2) Female initialBoard initialPieces mkLastPieceTerm :: Term mkLastPieceTerm = - compiledCodeToTerm $ $$(compile [|| runLastPiece ||]) + compiledCodeToTerm $ $$(compile [||runLastPiece||]) -- -- Number of correct solutions: 3 -- -- Number including failures: 59491 diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Prime.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Prime.hs index 122d269d4df..33a313a4c2d 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Prime.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Prime.hs @@ -3,16 +3,14 @@ {-% Primality testing functions taken from nofib/spectral/primetest. Most of the literate Haskell stuff has been removed and everything's been put into one file for simplicity. %-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-identities #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -48,18 +46,19 @@ even n = (n `modInteger` 2) == 0 -- = x_0.@b@^n + x_1.@b@^{n-1} + \cdots + x_n.@b@^0\] makeNumber :: Integer -> [Integer] -> Integer makeNumber b = foldl f 0 where f a x = a * b + x -{-# INLINABLE makeNumber #-} +{-# INLINEABLE makeNumber #-} -- The (left and right) inverse of @makeNumber@ is @chop@. chop :: Integer -> Integer -> [Integer] chop b = chop' [] - where chop' a n = - if n == 0 - then a - else chop' (r:a) q - where (q,r) = n `divMod` b -{-# INLINABLE chop #-} - + where + chop' a n = + if n == 0 + then a + else chop' (r : a) q + where + (q, r) = n `divMod` b +{-# INLINEABLE chop #-} {- The following function @powerMod@ calculates @a^b `mod` m@. I suspect that this is the critical function in the benchmarking process, and @@ -69,14 +68,20 @@ chop b = chop' [] -} powerMod :: Integer -> Integer -> Integer -> Integer powerMod a b m = - if b == 0 then 1 - else f a' (b-1) a' - where a' = a `modInteger` m - f a b c = if b == 0 then c - else g a b where - g a b | even b = g ((a*a) `modInteger` m) (b `divideInteger` 2) - | otherwise = f a (b-1) ((a*c) `modInteger` m) -{-# INLINABLE powerMod #-} + if b == 0 + then 1 + else f a' (b - 1) a' + where + a' = a `modInteger` m + f a b c = + if b == 0 + then c + else g a b + where + g a b + | even b = g ((a * a) `modInteger` m) (b `divideInteger` 2) + | otherwise = f a (b - 1) ((a * c) `modInteger` m) +{-# INLINEABLE powerMod #-} {- The value $@y@=@cubeRoot x@$ is the integer cube root of @x@, {\it i.e.} $@y@ = \lfloor \sqrt[3]{@x@} \, \rfloor$. Given $@x@\geq 0$, @@ -91,19 +96,20 @@ powerMod a b m = -} cubeRoot :: Integer -> Integer cubeRoot x = until satisfy improve x - where satisfy y = y*y*y >= x && y'*y'*y' < x where y' = y-1 - improve y = (2*y*y*y+x) `ddiv` (3*y*y) - ddiv a b = if (r < (b `divideInteger` 2)) then q else q+1 - where (q, r) = a `divMod` b -{-# INLINABLE cubeRoot #-} + where + satisfy y = y * y * y >= x && y' * y' * y' < x where y' = y - 1 + improve y = (2 * y * y * y + x) `ddiv` (3 * y * y) + ddiv a b = if (r < (b `divideInteger` 2)) then q else q + 1 + where + (q, r) = a `divMod` b +{-# INLINEABLE cubeRoot #-} ---The $@log2@ n$ is the @Integer@ $m$ such that $m = \lfloor\log_2 -- n\rfloor$. log2 :: Integer -> Integer log2 = Haskell.fromIntegral . length . chop 2 -{-# INLINABLE log2 #-} - +{-# INLINEABLE log2 #-} ---------------- Random ---------------- @@ -119,122 +125,143 @@ data RNGstate = RNGstate Integer Integer initRNG :: Integer -> Integer -> RNGstate initRNG s1 s2 = - if 1 <= s1 && s1 <= 2147483562 then - if 1 <= s2 && s2 <= 2147483398 then RNGstate s1 s2 + if 1 <= s1 && s1 <= 2147483562 + then + if 1 <= s2 && s2 <= 2147483398 + then RNGstate s1 s2 -- error "randomInts: Bad second seed." else {-Tx.trace "randomInts: Bad second seed." $-} Tx.error () -- error "randomInts: Bad first seed." else {-Tx.trace "randomInts: Bad first seed." $-} Tx.error () -{-# INLINABLE initRNG #-} - +{-# INLINEABLE initRNG #-} -- % Make a single random integer, returning that and the updated state. In the -- original version this was an infinite list of random numbers, but that's not -- a good idea in the strict world. getRandom :: RNGstate -> (Integer, RNGstate) getRandom (RNGstate s1 s2) = - let - k = s1 `divideInteger` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - k' = s2 `divideInteger` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - z = s1'' - s2'' - newState = RNGstate s1'' s2'' - in if z < 1 then (z + 2147483562, newState) - else (z, newState) -{-# INLINABLE getRandom #-} + let + k = s1 `divideInteger` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' + k' = s2 `divideInteger` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' + z = s1'' - s2'' + newState = RNGstate s1'' s2'' + in + if z < 1 + then (z + 2147483562, newState) + else (z, newState) +{-# INLINEABLE getRandom #-} -- % Produce a list of n random numbers, also returning the updated RNG state. getRandoms :: Integer -> RNGstate -> ([Integer], RNGstate) getRandoms n r = getRandoms' n r [] - where getRandoms' n r acc = - if n <= 0 then (acc, r) -- We don't need to reverse the accumulator - else let (x, r') = getRandom r - in getRandoms' (n-1) r' (x:acc) - + where + getRandoms' n r acc = + if n <= 0 + then (acc, r) -- We don't need to reverse the accumulator + else + let (x, r') = getRandom r + in getRandoms' (n - 1) r' (x : acc) ---------------- Prime ---------------- -- Given a value @x@ we can test whether we have a witness to @n@'s -- compositeness using @singleTestX@. singleTestX :: Integer -> (Integer, Integer) -> Integer -> Bool -singleTestX n (k, q) x - = (t == 1) || (t == (n-1)) || witness ts - where (t:ts) = iterateN k square (powerMod x q n) - witness [] = False - witness (t:ts) = if t == (n-1) then True - else if t == 1 then False - else witness ts - square x = (x*x) `modInteger` n -{-# INLINABLE singleTestX #-} +singleTestX n (k, q) x = + (t == 1) || (t == (n - 1)) || witness ts + where + (t : ts) = iterateN k square (powerMod x q n) + witness [] = False + witness (t : ts) = + if t == (n - 1) + then True + else + if t == 1 + then False + else witness ts + square x = (x * x) `modInteger` n +{-# INLINEABLE singleTestX #-} -- The function @singleTest@ takes an odd, positive, @Integer@ @n@ and a -- pair of @Integer@'s derived from @n@ by the @findKQ@ function singleTest :: Integer -> (Integer, Integer) -> RNGstate -> (Bool, RNGstate) -singleTest n kq r = -- Tx.trace "singleTest" $ - (singleTestX n kq (2+x), r') - where (x, r') = boundedRandom (n-2) r -{-# INLINABLE singleTest #-} +singleTest n kq r = + -- Tx.trace "singleTest" $ + (singleTestX n kq (2 + x), r') + where + (x, r') = boundedRandom (n - 2) r +{-# INLINEABLE singleTest #-} + +-- The function @findKQ@ takes an odd integer $n$ and returns the tuple ---The function @findKQ@ takes an odd integer $n$ and returns the tuple -- $(k,q)$ such that $n = q2^k+1$. findKQ :: Integer -> (Integer, Integer) -findKQ n = f (0, (n-1)) - where f (k,q) = - if r == 0 - then f (k+1, d) - else (k, q) - where (d,r) = q `divMod` 2 -{-# INLINABLE findKQ #-} +findKQ n = f (0, (n - 1)) + where + f (k, q) = + if r == 0 + then f (k + 1, d) + else (k, q) + where + (d, r) = q `divMod` 2 +{-# INLINEABLE findKQ #-} -- % Perform k single tests on the integer n -multiTest :: Integer -> RNGstate-> Integer -> (Bool, RNGstate) -multiTest k r n = {-Tx.trace "* multiTest" $-} -- (True, r) - if (n <= 1 || even n) - then (n==2, r) +multiTest :: Integer -> RNGstate -> Integer -> (Bool, RNGstate) +multiTest k r n = + {-Tx.trace "* multiTest" $-} + -- (True, r) + if (n <= 1 || even n) + then (n == 2, r) else mTest k r - where mTest k r = - if k == 0 - then (True, r) - else case singleTest n (findKQ n) r - of (True, r') -> mTest (k-1) r' - x -> x -{-# INLINABLE multiTest #-} + where + mTest k r = + if k == 0 + then (True, r) + else case singleTest n (findKQ n) r of + (True, r') -> mTest (k - 1) r' + x -> x +{-# INLINEABLE multiTest #-} -- % Original version used `take k (iterate ...)` which doesn't terminate with strict evaluation. iterateN :: Integer -> (a -> a) -> a -> [a] iterateN k f x = - if k == 0 then [] - else x : iterateN (k-1) f (f x) -{-# INLINABLE iterateN #-} - + if k == 0 + then [] + else x : iterateN (k - 1) f (f x) +{-# INLINEABLE iterateN #-} -- % The @boundedRandom@ function takes a number @n@ and the state of a (pseudo-) RNG @r@ -- and returns a tuple consisting of an @Integer@ $x$ in the range $0 \leq x < -- @n@$, and the updated RNG state. boundedRandom :: Integer -> RNGstate -> (Integer, RNGstate) boundedRandom n r = (makeNumber 65536 (uniform ns rs), r') - where ns = chop 65536 n - (rs,r') = getRandoms (length ns) r -{-# INLINABLE boundedRandom #-} + where + ns = chop 65536 n + (rs, r') = getRandoms (length ns) r +{-# INLINEABLE boundedRandom #-} -- The @uniform@ function generates a sequence of @Integer@'s such that, -- when considered as a sequence of digits, we generate a number uniform -- in the range @0..ns@ from the random numbers @rs@. uniform :: [Integer] -> [Integer] -> [Integer] -uniform [n] [r] = [r `modInteger` n] -uniform (n:ns) (r:rs) = if t == n then t: uniform ns rs - else t: map ((`modInteger` 65536). Haskell.toInteger) rs - where t = Haskell.toInteger r `modInteger` (n+1) -{-# INLINABLE uniform #-} - +uniform [n] [r] = [r `modInteger` n] +uniform (n : ns) (r : rs) = + if t == n + then t : uniform ns rs + else t : map ((`modInteger` 65536) . Haskell.toInteger) rs + where + t = Haskell.toInteger r `modInteger` (n + 1) +{-# INLINEABLE uniform #-} ---------------- Main ---------------- data PrimeID = P5 | P8 | P10 | P20 | P30 | P40 | P50 | P60 | P100 | P150 | P200 - deriving stock (Haskell.Read, Haskell.Show) + deriving stock (Haskell.Read, Haskell.Show) Tx.makeLift ''PrimeID @@ -244,42 +271,41 @@ Tx.makeLift ''PrimeID getPrime :: PrimeID -> Integer getPrime = - \case - P5 -> 56123 - P8 -> 81241579 - P10 -> 9576890767 - P20 -> 40206835204840513073 - P30 -> 671998030559713968361666935769 - P40 -> 5991810554633396517767024967580894321153 - P50 -> 22953686867719691230002707821868552601124472329079 - P60 -> 511704374946917490638851104912462284144240813125071454126151 - P100 -> - 2193992993218604310884461864618001945131790925282531768679169054389241527895222169476723691605898517 - P150 -> - 533791764536500962982816454877600313815808544134584704665367971790938714376754987723404131641943766815146845004667377003395107827504566198008424339207 - P200 -> - 58021664585639791181184025950440248398226136069516938232493687505822471836536824298822733710342250697739996825938232641940670857624514103125986134050997697160127301547995788468137887651823707102007839 -{-# INLINABLE getPrime #-} - + \case + P5 -> 56123 + P8 -> 81241579 + P10 -> 9576890767 + P20 -> 40206835204840513073 + P30 -> 671998030559713968361666935769 + P40 -> 5991810554633396517767024967580894321153 + P50 -> 22953686867719691230002707821868552601124472329079 + P60 -> 511704374946917490638851104912462284144240813125071454126151 + P100 -> + 2193992993218604310884461864618001945131790925282531768679169054389241527895222169476723691605898517 + P150 -> + 533791764536500962982816454877600313815808544134584704665367971790938714376754987723404131641943766815146845004667377003395107827504566198008424339207 + P200 -> + 58021664585639791181184025950440248398226136069516938232493687505822471836536824298822733710342250697739996825938232641940670857624514103125986134050997697160127301547995788468137887651823707102007839 +{-# INLINEABLE getPrime #-} -- % Only for textual output of PLC scripts unindent :: PLC.Doc ann -> [Haskell.String] unindent d = map (Haskell.dropWhile isSpace) $ (Haskell.lines . Haskell.show $ d) - -- % Initialise the RNG initState :: RNGstate initState = initRNG 111 47 -{-# INLINABLE initState #-} +{-# INLINEABLE initState #-} -- % Parameter for multiTest: how many rounds of the main primality test do we want to perform? numTests :: Integer numTests = 100 -{-# INLINABLE numTests #-} +{-# INLINEABLE numTests #-} data Result = Composite | Prime - deriving stock (Haskell.Show, Haskell.Eq, Generic) - deriving anyclass (NFData) + deriving stock (Haskell.Show, Haskell.Eq, Generic) + deriving anyclass (NFData) + -- Haskell.Eq needed for comparing Haskell results in tests. Tx.makeLift ''Result @@ -288,44 +314,44 @@ Tx.makeLift ''Result -- % and produces a list of output results. processList :: [Integer] -> RNGstate -> [Result] processList input r = - case input of - [] -> [] - n:ns -> case multiTest numTests r n - of (True, r') -> Prime : processList ns r' - (False, r') -> Composite : processList ns r' -{-# INLINABLE processList #-} + case input of + [] -> [] + n : ns -> case multiTest numTests r n of + (True, r') -> Prime : processList ns r' + (False, r') -> Composite : processList ns r' +{-# INLINEABLE processList #-} -- % The @testInteger@ function takes a single input number and produces a single result. testInteger :: Integer -> RNGstate -> Result -testInteger n state = if fst $ multiTest numTests state n -- Discard the RNG state in the result - then Prime - else Composite -{-# INLINABLE testInteger #-} +testInteger n state = + if fst $ multiTest numTests state n -- Discard the RNG state in the result + then Prime + else Composite +{-# INLINEABLE testInteger #-} -- % Haskell entry point for testing runPrimalityTest :: Integer -> Result runPrimalityTest n = testInteger n initState -{-# INLINABLE runPrimalityTest #-} +{-# INLINEABLE runPrimalityTest #-} -- % Run the program on an arbitrary integer, for testing mkPrimalityTestTerm :: Integer -> Term mkPrimalityTestTerm n = - compiledCodeToTerm $ - $$(Tx.compile [|| runPrimalityTest ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef n + compiledCodeToTerm + $ $$(Tx.compile [||runPrimalityTest||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef n -- Run the program on one of the fixed primes listed above runFixedPrimalityTest :: PrimeID -> Result runFixedPrimalityTest pid = runPrimalityTest (getPrime pid) - mkPrimalityCode :: PrimeID -> Tx.CompiledCode Result mkPrimalityCode pid = - $$(Tx.compile [|| runFixedPrimalityTest ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef pid + $$(Tx.compile [||runFixedPrimalityTest||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef pid -- % Run the program on a number known to be prime, for benchmarking -- (primes take a long time, composite numbers generally don't). mkPrimalityBenchTerm :: PrimeID -> Term mkPrimalityBenchTerm pid = - compiledCodeToTerm $ mkPrimalityCode pid + compiledCodeToTerm $ mkPrimalityCode pid diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs index bc9f9c4fbc7..5b6eafbd52c 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs @@ -1,19 +1,18 @@ {-% nofib/spectral/constraints converted to Plutus. Renamed to avoid conflict with existing package. %-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.NoFib.Queens where @@ -24,8 +23,8 @@ import Control.DeepSeq (NFData) import Control.Monad (forM_) import Data.Char (isSpace) import GHC.Generics -import Prelude qualified as Haskell import System.Environment +import Prelude qualified as Haskell import PlutusBenchmark.Common (Term, compiledCodeToTerm) @@ -64,12 +63,13 @@ import PlutusTx.Prelude as TxPrelude hiding (abs) %-} -data Algorithm = Bt - | Bm - | Bjbt1 - | Bjbt2 - | Fc - deriving stock (Haskell.Show, Haskell.Read) +data Algorithm + = Bt + | Bm + | Bjbt1 + | Bjbt2 + | Fc + deriving stock (Haskell.Show, Haskell.Read) Tx.makeLift ''Algorithm @@ -80,48 +80,47 @@ allAlgorithms :: [Labeler] allAlgorithms = [bt, bm, bjbt, bjbt', fc] lookupAlgorithm :: Algorithm -> Labeler -lookupAlgorithm Bt = bt -lookupAlgorithm Bm = bm +lookupAlgorithm Bt = bt +lookupAlgorithm Bm = bm lookupAlgorithm Bjbt1 = bjbt -lookupAlgorithm Bjbt2 = bjbt' -- bjbt' problematic on command line -lookupAlgorithm Fc = fc -{-# INLINABLE lookupAlgorithm #-} +lookupAlgorithm Bjbt2 = bjbt' -- bjbt' problematic on command line +lookupAlgorithm Fc = fc +{-# INLINEABLE lookupAlgorithm #-} nqueens :: Integer -> Labeler -> [State] nqueens n algorithm = (search algorithm (queens n)) -{-# INLINABLE nqueens #-} +{-# INLINEABLE nqueens #-} -- % Haskell entry point for testing runQueens :: Integer -> Algorithm -> [State] runQueens n alg = nqueens n (lookupAlgorithm alg) -{-# INLINABLE runQueens #-} +{-# INLINEABLE runQueens #-} -- % Compile a Plutus Core term which runs nqueens on given arguments mkQueensCode :: Integer -> Algorithm -> Tx.CompiledCode [State] mkQueensCode sz alg = - $$(Tx.compile [|| runQueens ||]) - `Tx.unsafeApplyCode` Tx.liftCodeDef sz - `Tx.unsafeApplyCode` Tx.liftCodeDef alg + $$(Tx.compile [||runQueens||]) + `Tx.unsafeApplyCode` Tx.liftCodeDef sz + `Tx.unsafeApplyCode` Tx.liftCodeDef alg mkQueensTerm :: Integer -> Algorithm -> Term mkQueensTerm sz alg = compiledCodeToTerm $ mkQueensCode sz alg -main2 :: Haskell.IO () -- Haskell version +main2 :: Haskell.IO () -- Haskell version main2 = do args <- getArgs case args of [] -> Haskell.putStrLn "Integer parameter expected" - arg:_ -> do - let n = Haskell.read arg :: Integer - try algorithm = Haskell.print (nqueens n algorithm) - forM_ [1..240::Integer] $ const $ do - Haskell.sequence_ (map try allAlgorithms) + arg : _ -> do + let n = Haskell.read arg :: Integer + try algorithm = Haskell.print (nqueens n algorithm) + forM_ [1 .. 240 :: Integer] $ const $ do + Haskell.sequence_ (map try allAlgorithms) -- % Only for textual output of PLC scripts unindent :: PLC.Doc ann -> [Haskell.String] unindent d = map (dropWhile isSpace) $ (Haskell.lines . Haskell.show $ d) - ----------------------------------------------------------- -- % Various standard things reimplemented for Plutus ----------------------------------------------------------- @@ -129,68 +128,69 @@ unindent d = map (dropWhile isSpace) $ (Haskell.lines . Haskell.show $ d) -- % Replacement for `iterate`, which generates an infinite list iterateN :: Integer -> (a -> a) -> a -> [a] iterateN k f x = - if k == 0 then [] - else x : iterateN (k-1) f (f x) -{-# INLINABLE iterateN #-} + if k == 0 + then [] + else x : iterateN (k - 1) f (f x) +{-# INLINEABLE iterateN #-} -- % Replacement for [a..b] interval :: Integer -> Integer -> [Integer] interval a b = - if a > b then [] - else a : (interval (a+1) b) -{-# INLINABLE interval #-} + if a > b + then [] + else a : (interval (a + 1) b) +{-# INLINEABLE interval #-} abs :: Integer -> Integer -abs n = if n<0 then 0-n else n -{-# INLINABLE abs #-} +abs n = if n < 0 then 0 - n else n +{-# INLINEABLE abs #-} -- % Things needed for `union` deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] -deleteBy _ _ [] = [] -deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -{-# INLINABLE deleteBy #-} +deleteBy _ _ [] = [] +deleteBy eq x (y : ys) = if x `eq` y then ys else y : deleteBy eq x ys +{-# INLINEABLE deleteBy #-} unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] -unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (List.nubBy eq ys) xs -{-# INLINABLE unionBy #-} +unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (List.nubBy eq ys) xs +{-# INLINEABLE unionBy #-} -union :: (Eq a) => [a] -> [a] -> [a] -union = unionBy (==) -{-# INLINABLE union #-} +union :: Eq a => [a] -> [a] -> [a] +union = unionBy (==) +{-# INLINEABLE union #-} -- % Stolen from Data.List sortBy :: (a -> a -> Ordering) -> [a] -> [a] sortBy cmp = mergeAll . sequences where - sequences (a:b:xs) - | (a `cmp` b) == GT = descending b [a] xs - | otherwise = ascending b (a:) xs + sequences (a : b : xs) + | (a `cmp` b) == GT = descending b [a] xs + | otherwise = ascending b (a :) xs sequences xs = [xs] - descending a as (b:bs) - | (a `cmp` b) == GT = descending b (a:as) bs - descending a as bs = (a:as): sequences bs + descending a as (b : bs) + | (a `cmp` b) == GT = descending b (a : as) bs + descending a as bs = (a : as) : sequences bs - ascending a as (b:bs) - | (a `cmp` b) /= GT = ascending b (\ys -> as (a:ys)) bs - ascending a as bs = case as [a] -- Original used let !x = ... - of x -> x : sequences bs + ascending a as (b : bs) + | (a `cmp` b) /= GT = ascending b (\ys -> as (a : ys)) bs + ascending a as bs = case as [a] of -- Original used let !x = ... + x -> x : sequences bs mergeAll [x] = x - mergeAll xs = mergeAll (mergePairs xs) + mergeAll xs = mergeAll (mergePairs xs) - mergePairs (a:b:xs) = case merge a b -- Original used let !x = ... - of x -> x : mergePairs xs - mergePairs xs = xs - - merge as@(a:as') bs@(b:bs') - | a `cmp` b == GT = b:merge as bs' - | otherwise = a:merge as' bs - merge [] bs = bs - merge as [] = as -{-# INLINABLE sortBy #-} + mergePairs (a : b : xs) = case merge a b of -- Original used let !x = ... + x -> x : mergePairs xs + mergePairs xs = xs + merge as@(a : as') bs@(b : bs') + | a `cmp` b == GT = b : merge as bs' + | otherwise = a : merge as' bs + merge [] bs = bs + merge as [] = as +{-# INLINEABLE sortBy #-} ----------------------------- -- Figure 1. CSPs in Haskell. @@ -200,64 +200,67 @@ type Var = Integer type Value = Integer data Assign = Var := Value - deriving stock (Haskell.Show, Haskell.Eq, Haskell.Ord, Generic) - deriving anyclass (NFData) -instance TxPrelude.Eq Assign - where (a := b) == (a' := b') = a==a' && b==b' -instance TxPrelude.Ord Assign - where (a := b) < (a' := b') = (a Assign -> Bool -data CSP = CSP { vars, vals :: Integer, rel :: Relation } +data CSP = CSP {vars, vals :: Integer, rel :: Relation} type State = [Assign] level :: Assign -> Var level (var := val) = var -{-# INLINABLE level #-} +{-# INLINEABLE level #-} value :: Assign -> Value value (var := val) = val -{-# INLINABLE value #-} +{-# INLINEABLE value #-} maxLevel :: State -> Var -maxLevel [] = 0 -maxLevel ((var := val):_) = var -{-# INLINABLE maxLevel #-} +maxLevel [] = 0 +maxLevel ((var := val) : _) = var +{-# INLINEABLE maxLevel #-} complete :: CSP -> State -> Bool -complete CSP{vars=vars} s = maxLevel s == vars -{-# INLINABLE complete #-} +complete CSP {vars = vars} s = maxLevel s == vars +{-# INLINEABLE complete #-} generate :: CSP -> [State] -generate CSP{vals=vals,vars=vars} = g vars - where g 0 = [[]] - g var = [ (var := val):st | val <- interval 1 vals, st <- g (var-1) ] -{-# INLINABLE generate #-} +generate CSP {vals = vals, vars = vars} = g vars + where + g 0 = [[]] + g var = [(var := val) : st | val <- interval 1 vals, st <- g (var - 1)] +{-# INLINEABLE generate #-} -inconsistencies :: CSP -> State -> [(Var,Var)] -inconsistencies CSP{rel=rel} as = - [ (level a, level b) | a <- as, b <- reverse as, a > b, not (rel a b) ] -{-# INLINABLE inconsistencies #-} +inconsistencies :: CSP -> State -> [(Var, Var)] +inconsistencies CSP {rel = rel} as = + [(level a, level b) | a <- as, b <- reverse as, a > b, not (rel a b)] +{-# INLINEABLE inconsistencies #-} consistent :: CSP -> State -> Bool consistent csp = null . (inconsistencies csp) -{-# INLINABLE consistent #-} +{-# INLINEABLE consistent #-} test :: CSP -> [State] -> [State] test csp = filter (consistent csp) -{-# INLINABLE test #-} +{-# INLINEABLE test #-} solver :: CSP -> [State] -solver csp = test csp candidates - where candidates = generate csp -{-# INLINABLE solver #-} +solver csp = test csp candidates + where + candidates = generate csp +{-# INLINEABLE solver #-} queens :: Integer -> CSP queens n = CSP {vars = n, vals = n, rel = safe} - where safe (i := m) (j := n) = (m /= n) && abs (i - j) /= abs (m - n) -{-# INLINABLE queens #-} + where + safe (i := m) (j := n) = (m /= n) && abs (i - j) /= abs (m - n) +{-# INLINEABLE queens #-} ------------------------------- -- Figure 2. Trees in Haskell. @@ -270,61 +273,70 @@ label (Node lab _) = lab type Transform a b = Tree a -> Tree b -mapTree :: (a -> b) -> Transform a b +mapTree :: (a -> b) -> Transform a b mapTree f (Node a cs) = Node (f a) (map (mapTree f) cs) -{-# INLINABLE mapTree #-} +{-# INLINEABLE mapTree #-} foldTree :: (a -> [b] -> b) -> Tree a -> b foldTree f (Node a cs) = f a (map (foldTree f) cs) -{-# INLINABLE foldTree #-} +{-# INLINEABLE foldTree #-} filterTree :: (a -> Bool) -> Transform a a filterTree p = foldTree f - where f a cs = Node a (filter (p . label) cs) -{-# INLINABLE filterTree #-} + where + f a cs = Node a (filter (p . label) cs) +{-# INLINEABLE filterTree #-} prune :: (a -> Bool) -> Transform a a prune p = filterTree (not . p) -{-# INLINABLE prune #-} +{-# INLINEABLE prune #-} leaves :: Tree a -> [a] leaves (Node leaf []) = [leaf] -leaves (Node _ cs) = concat (map leaves cs) -{-# INLINABLE leaves #-} +leaves (Node _ cs) = concat (map leaves cs) +{-# INLINEABLE leaves #-} initTree :: (a -> [a]) -> a -> Tree a initTree f a = Node a (map (initTree f) (f a)) -{-# INLINABLE initTree #-} +{-# INLINEABLE initTree #-} -------------------------------------------------- -- Figure 3. Simple backtracking solver for CSPs. -------------------------------------------------- mkTree :: CSP -> Tree State -mkTree CSP{vars=vars,vals=vals} = initTree next [] - -- Removed [1..vals] - where next ss = [ ((maxLevel ss + 1) := j):ss | maxLevel ss < vars, j <- vallist ] - vallist = interval 1 vals -{-# INLINABLE mkTree #-} - -earliestInconsistency :: CSP -> State -> Maybe (Var,Var) -earliestInconsistency CSP{rel=rel} [] = Nothing -earliestInconsistency CSP{rel=rel} (a:as) = - case filter (not . rel a) (reverse as) of - [] -> Nothing - (b:_) -> Just (level a, level b) -{-# INLINABLE earliestInconsistency #-} - -labelInconsistencies :: CSP -> Transform State (State,Maybe (Var,Var)) +mkTree CSP {vars = vars, vals = vals} = initTree next [] + where + -- Removed [1..vals] + next ss = [((maxLevel ss + 1) := j) : ss | maxLevel ss < vars, j <- vallist] + vallist = interval 1 vals +{-# INLINEABLE mkTree #-} + +earliestInconsistency :: CSP -> State -> Maybe (Var, Var) +earliestInconsistency CSP {rel = rel} [] = Nothing +earliestInconsistency CSP {rel = rel} (a : as) = + case filter (not . rel a) (reverse as) of + [] -> Nothing + (b : _) -> Just (level a, level b) +{-# INLINEABLE earliestInconsistency #-} + +labelInconsistencies :: CSP -> Transform State (State, Maybe (Var, Var)) labelInconsistencies csp = mapTree f - where f s = (s,earliestInconsistency csp s) -{-# INLINABLE labelInconsistencies #-} + where + f s = (s, earliestInconsistency csp s) +{-# INLINEABLE labelInconsistencies #-} btsolver0 :: CSP -> [State] btsolver0 csp = - (filter (complete csp) . leaves . (mapTree fst) . prune ((/= Nothing) . snd) - . (labelInconsistencies csp) . mkTree) csp -{-# INLINABLE btsolver0 #-} + ( filter (complete csp) + . leaves + . (mapTree fst) + . prune ((/= Nothing) . snd) + . (labelInconsistencies csp) + . mkTree + ) + csp +{-# INLINEABLE btsolver0 #-} ----------------------------------------------- -- Figure 6. Conflict-directed solving of CSPs. @@ -332,46 +344,54 @@ btsolver0 csp = data ConflictSet = Known [Var] | Unknown instance TxPrelude.Eq ConflictSet where - Known v == Known w = v == w - Unknown == Unknown = True - _ == _ = False + Known v == Known w = v == w + Unknown == Unknown = True + _ == _ = False knownConflict :: ConflictSet -> Bool -knownConflict (Known (a:as)) = True -knownConflict _ = False -{-# INLINABLE knownConflict #-} +knownConflict (Known (a : as)) = True +knownConflict _ = False +{-# INLINEABLE knownConflict #-} knownSolution :: ConflictSet -> Bool knownSolution (Known []) = True -knownSolution _ = False -{-# INLINABLE knownSolution #-} +knownSolution _ = False +{-# INLINEABLE knownSolution #-} checkComplete :: CSP -> State -> ConflictSet checkComplete csp s = if complete csp s then Known [] else Unknown -{-# INLINABLE checkComplete #-} +{-# INLINEABLE checkComplete #-} type Labeler = CSP -> Transform State (State, ConflictSet) search :: Labeler -> CSP -> [State] search labeler csp = - (map - fst . - filter - (knownSolution . snd) . leaves . prune (knownConflict . snd) . labeler csp . mkTree) - csp -{-# INLINABLE search #-} + ( map + fst + . filter + (knownSolution . snd) + . leaves + . prune (knownConflict . snd) + . labeler csp + . mkTree + ) + csp +{-# INLINEABLE search #-} bt :: Labeler bt csp = mapTree f - where f s = (s, - case earliestInconsistency csp s of - Nothing -> checkComplete csp s - Just (a,b) -> Known [a,b]) -{-# INLINABLE bt #-} + where + f s = + ( s + , case earliestInconsistency csp s of + Nothing -> checkComplete csp s + Just (a, b) -> Known [a, b] + ) +{-# INLINEABLE bt #-} btsolver :: CSP -> [State] btsolver = search bt -{-# INLINABLE btsolver #-} +{-# INLINEABLE btsolver #-} ------------------------------------- -- Figure 7. Randomization heuristic. @@ -380,12 +400,13 @@ btsolver = search bt hrandom :: Integer -> Transform a a hrandom seed (Node a cs) = Node a (randomList seed' (zipWith hrandom (randoms (length cs) seed') cs)) - where seed' = random seed -{-# INLINABLE hrandom #-} + where + seed' = random seed +{-# INLINEABLE hrandom #-} btr :: Integer -> Labeler btr seed csp = bt csp . hrandom seed -{-# INLINABLE btr #-} +{-# INLINEABLE btr #-} --------------------------------------------- -- Support for random numbers (not in paper). @@ -393,61 +414,68 @@ btr seed csp = bt csp . hrandom seed random2 :: Integer -> Integer random2 n = if test > 0 then test else test + 2147483647 - where test = 16807 * lo - 2836 * hi - hi = n `Haskell.div` 127773 - lo = n `Haskell.rem` 127773 -{-# INLINABLE random2 #-} + where + test = 16807 * lo - 2836 * hi + hi = n `Haskell.div` 127773 + lo = n `Haskell.rem` 127773 +{-# INLINEABLE random2 #-} randoms :: Integer -> Integer -> [Integer] randoms k = iterateN k random2 -{-# INLINABLE randoms #-} +{-# INLINEABLE randoms #-} random :: Integer -> Integer random n = (a * n + c) -- mod m - where a = 994108973 - c = a -{-# INLINABLE random #-} + where + a = 994108973 + c = a +{-# INLINEABLE random #-} randomList :: Integer -> [a] -> [a] -randomList i as = map snd (sortBy (\(a,b) (c,d) -> compare a c) (zip (randoms (length as) i) as)) -{-# INLINABLE randomList #-} +randomList i as = map snd (sortBy (\(a, b) (c, d) -> compare a c) (zip (randoms (length as) i) as)) +{-# INLINEABLE randomList #-} ------------------------- -- Figure 8. Backmarking. ------------------------- -type Table = [Row] -- indexed by Var +type Table = [Row] -- indexed by Var type Row = [ConflictSet] -- indexed by Value bm :: Labeler bm csp = mapTree fst . lookupCache csp . cacheChecks csp (emptyTable csp) -{-# INLINABLE bm #-} +{-# INLINEABLE bm #-} emptyTable :: CSP -> Table -emptyTable CSP{vars=vars,vals=vals} = []:[[Unknown | m <- interval 1 vals] | n <- interval 1 vars] -{-# INLINABLE emptyTable #-} +emptyTable CSP {vars = vars, vals = vals} = [] : [[Unknown | m <- interval 1 vals] | n <- interval 1 vars] +{-# INLINEABLE emptyTable #-} cacheChecks :: CSP -> Table -> Transform State (State, Table) cacheChecks csp tbl (Node s cs) = Node (s, tbl) (map (cacheChecks csp (fillTable s csp (tail tbl))) cs) -{-# INLINABLE cacheChecks #-} +{-# INLINEABLE cacheChecks #-} fillTable :: State -> CSP -> Table -> Table fillTable [] csp tbl = tbl -fillTable ((var' := val'):as) CSP{vars=vars,vals=vals,rel=rel} tbl = - zipWith (zipWith f) tbl [[(var,val) | val <- interval 1 vals] | var <- interval (var'+1) vars] - where f cs (var,val) = if cs == Unknown && not (rel (var' := val') (var := val)) then - Known [var',var] - else cs -{-# INLINABLE fillTable #-} +fillTable ((var' := val') : as) CSP {vars = vars, vals = vals, rel = rel} tbl = + zipWith (zipWith f) tbl [[(var, val) | val <- interval 1 vals] | var <- interval (var' + 1) vars] + where + f cs (var, val) = + if cs == Unknown && not (rel (var' := val') (var := val)) + then + Known [var', var] + else cs +{-# INLINEABLE fillTable #-} lookupCache :: CSP -> Transform (State, Table) ((State, ConflictSet), Table) lookupCache csp t = mapTree f t - where f ([], tbl) = (([], Unknown), tbl) - f (s@(a:_), tbl) = ((s, cs), tbl) - where cs = if tableEntry == Unknown then checkComplete csp s else tableEntry - tableEntry = (head tbl)!!(value a-1) -{-# INLINABLE lookupCache #-} + where + f ([], tbl) = (([], Unknown), tbl) + f (s@(a : _), tbl) = ((s, cs), tbl) + where + cs = if tableEntry == Unknown then checkComplete csp s else tableEntry + tableEntry = (head tbl) !! (value a - 1) +{-# INLINEABLE lookupCache #-} -------------------------------------------- -- Figure 10. Conflict-directed backjumping. @@ -455,31 +483,35 @@ lookupCache csp t = mapTree f t bjbt :: Labeler bjbt csp = bj csp . bt csp -{-# INLINABLE bjbt #-} +{-# INLINEABLE bjbt #-} bjbt' :: Labeler bjbt' csp = bj' csp . bt csp -{-# INLINABLE bjbt' #-} +{-# INLINEABLE bjbt' #-} bj :: CSP -> Transform (State, ConflictSet) (State, ConflictSet) bj csp = foldTree f - where f (a, Known cs) chs = Node (a,Known cs) chs - f (a, Unknown) chs = Node (a,Known cs') chs - where cs' = combine (map label chs) [] -{-# INLINABLE bj #-} + where + f (a, Known cs) chs = Node (a, Known cs) chs + f (a, Unknown) chs = Node (a, Known cs') chs + where + cs' = combine (map label chs) [] +{-# INLINEABLE bj #-} combine :: [(State, ConflictSet)] -> [Var] -> [Var] -combine [] acc = acc -combine ((s, Known cs):css) acc = +combine [] acc = acc +combine ((s, Known cs) : css) acc = if maxLevel s `notElem` cs then cs else combine css (cs `union` acc) -{-# INLINABLE combine #-} +{-# INLINEABLE combine #-} bj' :: CSP -> Transform (State, ConflictSet) (State, ConflictSet) bj' csp = foldTree f - where f (a, Known cs) chs = Node (a,Known cs) chs - f (a, Unknown) chs = if knownConflict cs' then Node (a,cs') [] else Node (a,cs') chs - where cs' = Known (combine (map label chs) []) -{-# INLINABLE bj' #-} + where + f (a, Known cs) chs = Node (a, Known cs) chs + f (a, Unknown) chs = if knownConflict cs' then Node (a, cs') [] else Node (a, cs') chs + where + cs' = Known (combine (map label chs) []) +{-# INLINEABLE bj' #-} ------------------------------- -- Figure 11. Forward checking. @@ -487,18 +519,20 @@ bj' csp = foldTree f fc :: Labeler fc csp = domainWipeOut csp . lookupCache csp . cacheChecks csp (emptyTable csp) -{-# INLINABLE fc #-} +{-# INLINEABLE fc #-} collect :: [ConflictSet] -> [Var] -collect [] = [] -collect (Known cs:css) = cs `union` (collect css) -{-# INLINABLE collect #-} +collect [] = [] +collect (Known cs : css) = cs `union` (collect css) +{-# INLINEABLE collect #-} domainWipeOut :: CSP -> Transform ((State, ConflictSet), Table) (State, ConflictSet) -domainWipeOut CSP{vars=vars} t = mapTree f t - where f ((as, cs), tbl) = (as, cs') - where wipedDomains = ([vs | vs <- tbl, all (knownConflict) vs]) - cs' = if null wipedDomains then cs else Known (collect (head wipedDomains)) -{-# INLINABLE domainWipeOut #-} +domainWipeOut CSP {vars = vars} t = mapTree f t + where + f ((as, cs), tbl) = (as, cs') + where + wipedDomains = ([vs | vs <- tbl, all (knownConflict) vs]) + cs' = if null wipedDomains then cs else Known (collect (head wipedDomains)) +{-# INLINEABLE domainWipeOut #-} Tx.makeLift ''Assign diff --git a/plutus-benchmark/nofib/test/Spec.hs b/plutus-benchmark/nofib/test/Spec.hs index 261b7b0040d..3bdf7aab6d9 100644 --- a/plutus-benchmark/nofib/test/Spec.hs +++ b/plutus-benchmark/nofib/test/Spec.hs @@ -1,10 +1,9 @@ -{- | Tests for the Plutus nofib benchmarks, mostly comparing the result of Plutus -evaluation with the result of Haskell evaluation. Lastpiece is currently omitted -because its memory consumption as a Plutus program is too great to allow it to -run to completion. -} - {-# LANGUAGE FlexibleContexts #-} +-- | Tests for the Plutus nofib benchmarks, mostly comparing the result of Plutus +-- evaluation with the result of Haskell evaluation. Lastpiece is currently omitted +-- because its memory consumption as a Plutus program is too great to allow it to +-- run to completion. module Main where import Test.Tasty @@ -38,105 +37,121 @@ runAndCheck term = cekResultMatchesHaskellValue term (@?=) mkClausifyTest :: Clausify.StaticFormula -> IO () mkClausifyTest formula = - runAndCheck (Clausify.mkClausifyTerm formula) (Clausify.runClausify formula) + runAndCheck (Clausify.mkClausifyTerm formula) (Clausify.runClausify formula) testClausify :: TestTree -testClausify = testGroup "clausify" - [ testCase "formula1" $ mkClausifyTest Clausify.F1 - , testCase "formula2" $ mkClausifyTest Clausify.F2 - , testCase "formula3" $ mkClausifyTest Clausify.F3 - , testCase "formula4" $ mkClausifyTest Clausify.F4 - , testCase "formula5" $ mkClausifyTest Clausify.F5 - , runTestGhc - [ Tx.goldenPirReadable "clausify-F5" formula5example - , Tx.goldenEvalCekCatchBudget "clausify-F5" formula5example - ] - ] - where formula5example = Clausify.mkClausifyCode Clausify.F5 +testClausify = + testGroup + "clausify" + [ testCase "formula1" $ mkClausifyTest Clausify.F1 + , testCase "formula2" $ mkClausifyTest Clausify.F2 + , testCase "formula3" $ mkClausifyTest Clausify.F3 + , testCase "formula4" $ mkClausifyTest Clausify.F4 + , testCase "formula5" $ mkClausifyTest Clausify.F5 + , runTestGhc + [ Tx.goldenPirReadable "clausify-F5" formula5example + , Tx.goldenEvalCekCatchBudget "clausify-F5" formula5example + ] + ] + where + formula5example = Clausify.mkClausifyCode Clausify.F5 ---------------- Knights ---------------- mkKnightsTest :: Integer -> Integer -> IO () -mkKnightsTest depth sz = - runAndCheck (Knights.mkKnightsTerm depth sz) (Knights.runKnights depth sz) +mkKnightsTest depth sz = + runAndCheck (Knights.mkKnightsTerm depth sz) (Knights.runKnights depth sz) testKnights :: TestTree -testKnights = testGroup "knights" -- Odd sizes call "error" because there are no solutions - [ testCase "depth 10, 4x4" $ mkKnightsTest 10 4 - , testCase "depth 10, 6x6" $ mkKnightsTest 10 6 - , testCase "depth 10, 8x8" $ mkKnightsTest 10 8 - , testCase "depth 100, 4x4" $ mkKnightsTest 100 4 - , testCase "depth 100, 6x6" $ mkKnightsTest 100 6 - , testCase "depth 100, 8x8" $ mkKnightsTest 100 8 - , runTestGhc - [ Tx.goldenPirReadable "knights10-4x4" knightsExample - , Tx.goldenEvalCekCatchBudget "knights10-4x4" knightsExample - ] - ] - where knightsExample = Knights.mkKnightsCode 10 4 +testKnights = + testGroup + "knights" -- Odd sizes call "error" because there are no solutions + [ testCase "depth 10, 4x4" $ mkKnightsTest 10 4 + , testCase "depth 10, 6x6" $ mkKnightsTest 10 6 + , testCase "depth 10, 8x8" $ mkKnightsTest 10 8 + , testCase "depth 100, 4x4" $ mkKnightsTest 100 4 + , testCase "depth 100, 6x6" $ mkKnightsTest 100 6 + , testCase "depth 100, 8x8" $ mkKnightsTest 100 8 + , runTestGhc + [ Tx.goldenPirReadable "knights10-4x4" knightsExample + , Tx.goldenEvalCekCatchBudget "knights10-4x4" knightsExample + ] + ] + where + knightsExample = Knights.mkKnightsCode 10 4 ---------------- Queens ---------------- mkQueensTest :: Integer -> Queens.Algorithm -> IO () mkQueensTest sz alg = - runAndCheck (Queens.mkQueensTerm sz alg) (Queens.runQueens sz alg) + runAndCheck (Queens.mkQueensTerm sz alg) (Queens.runQueens sz alg) testQueens :: TestTree -testQueens = testGroup "queens" - [ testGroup "4x4" - [ testCase "Bt" $ mkQueensTest 4 Queens.Bt - , testCase "Bm" $ mkQueensTest 4 Queens.Bm - , testCase "Bjbt1" $ mkQueensTest 4 Queens.Bjbt1 - , testCase "Bjbt2" $ mkQueensTest 4 Queens.Bjbt2 - , testCase "Fc" $ mkQueensTest 4 Queens.Fc - , runTestGhc - [ Tx.goldenPirReadable "queens4-bt" queens4btExample - , Tx.goldenEvalCekCatchBudget "queens4-bt" queens4btExample - ] - ] - , testGroup "5x5" - [ testCase "Bt" $ mkQueensTest 5 Queens.Bt - , testCase "Bm" $ mkQueensTest 5 Queens.Bm - , testCase "Bjbt1" $ mkQueensTest 5 Queens.Bjbt1 - , testCase "Bjbt2" $ mkQueensTest 5 Queens.Bjbt2 - , testCase "Fc" $ mkQueensTest 5 Queens.Fc - , runTestGhc - [ Tx.goldenPirReadable "queens5-fc" queens5fcExample - , Tx.goldenEvalCekCatchBudget "queens5-fc" queens5fcExample - ] - ] - ] - where queens4btExample = Queens.mkQueensCode 4 Queens.Bt - queens5fcExample = Queens.mkQueensCode 5 Queens.Fc +testQueens = + testGroup + "queens" + [ testGroup + "4x4" + [ testCase "Bt" $ mkQueensTest 4 Queens.Bt + , testCase "Bm" $ mkQueensTest 4 Queens.Bm + , testCase "Bjbt1" $ mkQueensTest 4 Queens.Bjbt1 + , testCase "Bjbt2" $ mkQueensTest 4 Queens.Bjbt2 + , testCase "Fc" $ mkQueensTest 4 Queens.Fc + , runTestGhc + [ Tx.goldenPirReadable "queens4-bt" queens4btExample + , Tx.goldenEvalCekCatchBudget "queens4-bt" queens4btExample + ] + ] + , testGroup + "5x5" + [ testCase "Bt" $ mkQueensTest 5 Queens.Bt + , testCase "Bm" $ mkQueensTest 5 Queens.Bm + , testCase "Bjbt1" $ mkQueensTest 5 Queens.Bjbt1 + , testCase "Bjbt2" $ mkQueensTest 5 Queens.Bjbt2 + , testCase "Fc" $ mkQueensTest 5 Queens.Fc + , runTestGhc + [ Tx.goldenPirReadable "queens5-fc" queens5fcExample + , Tx.goldenEvalCekCatchBudget "queens5-fc" queens5fcExample + ] + ] + ] + where + queens4btExample = Queens.mkQueensCode 4 Queens.Bt + queens5fcExample = Queens.mkQueensCode 5 Queens.Fc ---------------- Primes ---------------- -- | Unit tests on some numbers which we know to be prime/composite, polymorphic -- over 'test' so that we can test both Haskell and Plutus evaluation. - -mkPrimalityTest :: String -> (Integer -> Prime.Result -> IO()) -> TestTree -mkPrimalityTest title test = testGroup title - [ testCase "56123" - $ test 56123 Prime - , testCase "81241579" - $ test 81241579 Prime - , testCase "56123*81241579" - $ test (56123*81241579) Composite - , testCase "81241579*81241579" - $ test (81241579*81241579) Composite - , testCase "894781389423478364713284623422222229" - $ test 894781389423478364713284623422222229 Composite - ] +mkPrimalityTest :: String -> (Integer -> Prime.Result -> IO ()) -> TestTree +mkPrimalityTest title test = + testGroup + title + [ testCase "56123" $ + test 56123 Prime + , testCase "81241579" $ + test 81241579 Prime + , testCase "56123*81241579" $ + test (56123 * 81241579) Composite + , testCase "81241579*81241579" $ + test (81241579 * 81241579) Composite + , testCase "894781389423478364713284623422222229" $ + test 894781389423478364713284623422222229 Composite + ] -- Check that the Haskell version gives the right results testPrimalityHs :: TestTree -testPrimalityHs = mkPrimalityTest "primality test (Haskell)" - (\n r -> Prime.runPrimalityTest n @?= r) +testPrimalityHs = + mkPrimalityTest + "primality test (Haskell)" + (\n r -> Prime.runPrimalityTest n @?= r) -- Check that the PLC version gives the right results testPrimalityPlc :: TestTree -testPrimalityPlc = mkPrimalityTest "primality test (Plutus Core)" - (\n r -> runAndCheck (Prime.mkPrimalityTestTerm n) r) +testPrimalityPlc = + mkPrimalityTest + "primality test (Plutus Core)" + (\n r -> runAndCheck (Prime.mkPrimalityTestTerm n) r) -- QuickCheck property tests on random six-digit numbers to make sure that the -- PLC and Haskell versions give the same result. @@ -145,8 +160,8 @@ sixDigits = choose (100000, 999999) prop_primalityTest :: Integer -> Property prop_primalityTest n = - n >= 2 ==> - cekResultMatchesHaskellValue (Prime.mkPrimalityTestTerm n) (===) (Prime.runPrimalityTest n) + n >= 2 ==> + cekResultMatchesHaskellValue (Prime.mkPrimalityTestTerm n) (===) (Prime.runPrimalityTest n) testPrimalityQC :: TestTree testPrimalityQC = testProperty "primality test (QuickCheck)" (forAll sixDigits prop_primalityTest) @@ -155,7 +170,8 @@ testPrimalityQC = testProperty "primality test (QuickCheck)" (forAll sixDigits p allTests :: TestTree allTests = - testGroup "plutus nofib tests" + testGroup + "plutus nofib tests" [ testClausify , testKnights , testPrimalityHs diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/Data/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/Data/ScriptContexts.hs index ba1f2a19ba0..7cdd10c1fbf 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/Data/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/Data/ScriptContexts.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.V1.Data.ScriptContexts where @@ -23,27 +23,28 @@ mkScriptContext i = (mkTxInfo i) (Spending (TxOutRef (TxId "") 0)) - mkTxInfo :: Integer -> TxInfo -mkTxInfo i = TxInfo { - txInfoInputs=mempty, - txInfoOutputs = Data.List.map mkTxOut (Data.List.fromSOP ([1 .. i] :: [Integer])), - txInfoFee=mempty, - txInfoMint=mempty, - txInfoDCert=mempty, - txInfoWdrl=mempty, - txInfoValidRange=always, - txInfoSignatories=mempty, - txInfoData=mempty, - txInfoId=TxId "" - } +mkTxInfo i = + TxInfo + { txInfoInputs = mempty + , txInfoOutputs = Data.List.map mkTxOut (Data.List.fromSOP ([1 .. i] :: [Integer])) + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = mempty + , txInfoWdrl = mempty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoData = mempty + , txInfoId = TxId "" + } mkTxOut :: Integer -> TxOut -mkTxOut i = TxOut { - txOutAddress=pubKeyHashAddress (PubKeyHash ""), - txOutValue=mkValue i, - txOutDatumHash=Nothing - } +mkTxOut i = + TxOut + { txOutAddress = pubKeyHashAddress (PubKeyHash "") + , txOutValue = mkValue i + , txOutDatumHash = Nothing + } mkValue :: Integer -> Value mkValue i = assetClassValue (assetClass adaSymbol adaToken) i @@ -57,20 +58,17 @@ checkScriptContext1 d = -- Bang pattern to ensure this is forced, probably not necesssary -- since we do use it later let !sc = PlutusTx.unsafeFromBuiltinData d - ScriptContext txi _ = sc - in - if Data.List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 - then () - else PlutusTx.traceError "Odd number of outputs" -{-# INLINABLE checkScriptContext1 #-} + ScriptContext txi _ = sc + in if Data.List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 + then () + else PlutusTx.traceError "Odd number of outputs" +{-# INLINEABLE checkScriptContext1 #-} mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext1Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext1 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext1||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example aims to *force* the decoding of the script context and then ignore it entirely. -- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces @@ -78,23 +76,21 @@ mkCheckScriptContext1Code sc = checkScriptContext2 :: PlutusTx.BuiltinData -> () checkScriptContext2 d = let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d - -- Just using a bang pattern was not enough to stop GHC from getting - -- rid of the dead binding before we even hit the plugin, this works - -- for now! - in case sc of - !_ -> - if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) - then () - else PlutusTx.traceError "Got my sums wrong" -{-# INLINABLE checkScriptContext2 #-} + in -- Just using a bang pattern was not enough to stop GHC from getting + -- rid of the dead binding before we even hit the plugin, this works + -- for now! + case sc of + !_ -> + if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) + then () + else PlutusTx.traceError "Got my sums wrong" +{-# INLINEABLE checkScriptContext2 #-} mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext2Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext2 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext2||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d {- Note [Redundant arguments to equality benchmarks] The arguments for the benchmarks are passed as terms created with `liftCodeDef`. @@ -114,26 +110,26 @@ scriptContextEqualityData :: ScriptContext -> PlutusTx.BuiltinData -> () -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityData _ d = if PlutusTx.equalsData d d - then () - else PlutusTx.traceError "The argument is not equal to itself" -{-# INLINABLE scriptContextEqualityData #-} + then () + else PlutusTx.traceError "The argument is not equal to itself" +{-# INLINEABLE scriptContextEqualityData #-} mkScriptContextEqualityDataCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityDataCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityData ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityData||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example is just the overhead from the previous two -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityOverhead :: ScriptContext -> PlutusTx.BuiltinData -> () scriptContextEqualityOverhead _ _ = () -{-# INLINABLE scriptContextEqualityOverhead #-} +{-# INLINEABLE scriptContextEqualityOverhead #-} mkScriptContextEqualityOverheadCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityOverheadCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityOverhead ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityOverhead||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/ScriptContexts.hs index 886e24fc686..4af218f26ff 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V1/ScriptContexts.hs @@ -1,13 +1,21 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.V1.ScriptContexts where -import PlutusLedgerApi.V1 (PubKeyHash (..), ScriptContext (..), ScriptPurpose (..), TxId (..), - TxInfo (..), TxOut (..), TxOutRef (..), always) +import PlutusLedgerApi.V1 ( + PubKeyHash (..), + ScriptContext (..), + ScriptPurpose (..), + TxId (..), + TxInfo (..), + TxOut (..), + TxOutRef (..), + always, + ) import PlutusLedgerApi.V1.Address import PlutusLedgerApi.V1.Value import PlutusTx qualified @@ -24,27 +32,28 @@ mkScriptContext i = (mkTxInfo i) (Spending (TxOutRef (TxId "") 0)) - mkTxInfo :: Int -> TxInfo -mkTxInfo i = TxInfo { - txInfoInputs=mempty, - txInfoOutputs=fmap mkTxOut [1..i], - txInfoFee=mempty, - txInfoMint=mempty, - txInfoDCert=mempty, - txInfoWdrl=mempty, - txInfoValidRange=always, - txInfoSignatories=mempty, - txInfoData=mempty, - txInfoId=TxId "" - } +mkTxInfo i = + TxInfo + { txInfoInputs = mempty + , txInfoOutputs = fmap mkTxOut [1 .. i] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = mempty + , txInfoWdrl = mempty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoData = mempty + , txInfoId = TxId "" + } mkTxOut :: Int -> TxOut -mkTxOut i = TxOut { - txOutAddress=pubKeyHashAddress (PubKeyHash ""), - txOutValue=mkValue i, - txOutDatumHash=Nothing - } +mkTxOut i = + TxOut + { txOutAddress = pubKeyHashAddress (PubKeyHash "") + , txOutValue = mkValue i + , txOutDatumHash = Nothing + } mkValue :: Int -> Value mkValue i = assetClassValue (assetClass adaSymbol adaToken) (fromIntegral i) @@ -58,20 +67,17 @@ checkScriptContext1 d = -- Bang pattern to ensure this is forced, probably not necesssary -- since we do use it later let !sc = PlutusTx.unsafeFromBuiltinData d - ScriptContext txi _ = sc - in - if List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 - then () - else PlutusTx.traceError "Odd number of outputs" -{-# INLINABLE checkScriptContext1 #-} + ScriptContext txi _ = sc + in if List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 + then () + else PlutusTx.traceError "Odd number of outputs" +{-# INLINEABLE checkScriptContext1 #-} mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext1Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext1 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext1||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example aims to *force* the decoding of the script context and then ignore it entirely. -- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces @@ -79,23 +85,21 @@ mkCheckScriptContext1Code sc = checkScriptContext2 :: PlutusTx.BuiltinData -> () checkScriptContext2 d = let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d - -- Just using a bang pattern was not enough to stop GHC from getting - -- rid of the dead binding before we even hit the plugin, this works - -- for now! - in case sc of - !_ -> - if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) - then () - else PlutusTx.traceError "Got my sums wrong" -{-# INLINABLE checkScriptContext2 #-} + in -- Just using a bang pattern was not enough to stop GHC from getting + -- rid of the dead binding before we even hit the plugin, this works + -- for now! + case sc of + !_ -> + if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) + then () + else PlutusTx.traceError "Got my sums wrong" +{-# INLINEABLE checkScriptContext2 #-} mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext2Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext2 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext2||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d {- Note [Redundant arguments to equality benchmarks] The arguments for the benchmarks are passed as terms created with `liftCodeDef`. @@ -115,26 +119,26 @@ scriptContextEqualityData :: ScriptContext -> PlutusTx.BuiltinData -> () -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityData _ d = if PlutusTx.equalsData d d - then () - else PlutusTx.traceError "The argument is not equal to itself" -{-# INLINABLE scriptContextEqualityData #-} + then () + else PlutusTx.traceError "The argument is not equal to itself" +{-# INLINEABLE scriptContextEqualityData #-} mkScriptContextEqualityDataCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityDataCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityData ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityData||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example is just the overhead from the previous two -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityOverhead :: ScriptContext -> PlutusTx.BuiltinData -> () scriptContextEqualityOverhead _ _ = () -{-# INLINABLE scriptContextEqualityOverhead #-} +{-# INLINEABLE scriptContextEqualityOverhead #-} mkScriptContextEqualityOverheadCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityOverheadCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityOverhead ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityOverhead||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs index 7fd7d22c344..40db19e44e7 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.V2.Data.ScriptContexts where @@ -29,81 +29,82 @@ mkScriptContext i = (mkTxInfo i) (Spending (TxOutRef (TxId "") 0)) -mkScriptContextWithStake - :: Integer - -> Integer - -> Maybe (StakingCredential, Int) - -> ScriptContext +mkScriptContextWithStake :: + Integer -> + Integer -> + Maybe (StakingCredential, Int) -> + ScriptContext mkScriptContextWithStake i j cred = ScriptContext (mkTxInfoWithStake i j cred) (Spending (TxOutRef (TxId "") 0)) mkTxInfo :: Integer -> TxInfo -mkTxInfo i = TxInfo { - txInfoInputs=mempty, - txInfoReferenceInputs=mempty, - txInfoOutputs=DataList.map mkTxOut (DataList.fromSOP ([1 .. i] :: [Integer])), - txInfoFee=mempty, - txInfoMint=mempty, - txInfoDCert=mempty, - txInfoWdrl=Map.empty, - txInfoValidRange=always, - txInfoSignatories=mempty, - txInfoRedeemers=Map.empty, - txInfoData=Map.empty, - txInfoId=TxId "" - } +mkTxInfo i = + TxInfo + { txInfoInputs = mempty + , txInfoReferenceInputs = mempty + , txInfoOutputs = DataList.map mkTxOut (DataList.fromSOP ([1 .. i] :: [Integer])) + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = mempty + , txInfoWdrl = Map.empty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoRedeemers = Map.empty + , txInfoData = Map.empty + , txInfoId = TxId "" + } -mkTxInfoWithStake - :: Integer - -> Integer - -> Maybe (StakingCredential, Int) - -> TxInfo +mkTxInfoWithStake :: + Integer -> + Integer -> + Maybe (StakingCredential, Int) -> + TxInfo mkTxInfoWithStake i j cred = - (mkTxInfo i) { txInfoWdrl = mkStakeMap j cred } + (mkTxInfo i) {txInfoWdrl = mkStakeMap j cred} -- | A very crude deterministic generator for maps of stake credentials with size -- approximately proportional to the input integer. If a specific credential is provided, it -- is inserted at the provided index. -mkStakeMap - :: Integer - -> Maybe (StakingCredential, Int) - -> Map.Map StakingCredential Integer +mkStakeMap :: + Integer -> + Maybe (StakingCredential, Int) -> + Map.Map StakingCredential Integer mkStakeMap j mCred = - Map.unsafeFromSOPList - $ case mCred of + Map.unsafeFromSOPList $ + case mCred of Just (cred, ix) -> insertAt cred ix genValues Nothing -> genValues where genValues = - (\i -> - ( mkStakingCredential ("testCred" <> show i) - , i - ) + ( \i -> + ( mkStakingCredential ("testCred" <> show i) + , i + ) ) - <$> [1..j] + <$> [1 .. j] insertAt x i xs = take i xs <> [(x, 1000)] <> drop i xs mkStakingCredential :: String -> StakingCredential mkStakingCredential str = StakingHash - . PubKeyCredential - . PubKeyHash - . stringToBuiltinByteString - $ str - + . PubKeyCredential + . PubKeyHash + . stringToBuiltinByteString + $ str mkTxOut :: Integer -> TxOut -mkTxOut i = TxOut { - txOutAddress=pubKeyHashAddress (PubKeyHash ""), - txOutValue=mkValue i, - txOutDatum=NoOutputDatum, - txOutReferenceScript=Nothing - } +mkTxOut i = + TxOut + { txOutAddress = pubKeyHashAddress (PubKeyHash "") + , txOutValue = mkValue i + , txOutDatum = NoOutputDatum + , txOutReferenceScript = Nothing + } mkValue :: Integer -> Value mkValue i = assetClassValue (assetClass adaSymbol adaToken) i @@ -118,19 +119,16 @@ checkScriptContext1 d = -- since we do use it later let !sc = PlutusTx.unsafeFromBuiltinData d ScriptContext txi _ = sc - in - if DataList.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 - then () - else PlutusTx.traceError "Odd number of outputs" -{-# INLINABLE checkScriptContext1 #-} + in if DataList.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 + then () + else PlutusTx.traceError "Odd number of outputs" +{-# INLINEABLE checkScriptContext1 #-} mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext1Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext1 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext1||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example aims to *force* the decoding of the script context and then ignore it entirely. -- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces @@ -138,23 +136,21 @@ mkCheckScriptContext1Code sc = checkScriptContext2 :: PlutusTx.BuiltinData -> () checkScriptContext2 d = let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d - -- Just using a bang pattern was not enough to stop GHC from getting - -- rid of the dead binding before we even hit the plugin, this works - -- for now! - in case sc of - !_ -> - if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) - then () - else PlutusTx.traceError "Got my sums wrong" -{-# INLINABLE checkScriptContext2 #-} + in -- Just using a bang pattern was not enough to stop GHC from getting + -- rid of the dead binding before we even hit the plugin, this works + -- for now! + case sc of + !_ -> + if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) + then () + else PlutusTx.traceError "Got my sums wrong" +{-# INLINEABLE checkScriptContext2 #-} mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext2Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext2 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext2||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d {- Note [Redundant arguments to equality benchmarks] The arguments for the benchmarks are passed as terms created with `liftCodeDef`. @@ -174,29 +170,29 @@ scriptContextEqualityData :: ScriptContext -> PlutusTx.BuiltinData -> () -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityData _ d = if PlutusTx.equalsData d d - then () - else PlutusTx.traceError "The argument is not equal to itself" -{-# INLINABLE scriptContextEqualityData #-} + then () + else PlutusTx.traceError "The argument is not equal to itself" +{-# INLINEABLE scriptContextEqualityData #-} mkScriptContextEqualityDataCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityDataCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityData ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityData||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example is just the overhead from the previous two -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityOverhead :: ScriptContext -> PlutusTx.BuiltinData -> () scriptContextEqualityOverhead _ _ = () -{-# INLINABLE scriptContextEqualityOverhead #-} +{-# INLINEABLE scriptContextEqualityOverhead #-} mkScriptContextEqualityOverheadCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityOverheadCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityOverhead ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityOverhead||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- The 'AsData' version of a script which validates that the stake credential is in -- the withdrawal map. @@ -205,31 +201,30 @@ mkScriptContextEqualityOverheadCode sc = forwardWithStakeTrick :: BuiltinData -> BuiltinData -> () forwardWithStakeTrick obsScriptCred ctx = case PlutusTx.unsafeFromBuiltinData ctx of - ScriptContext { scriptContextTxInfo = TxInfo { txInfoWdrl } } -> + ScriptContext {scriptContextTxInfo = TxInfo {txInfoWdrl}} -> let txInfoWdrl' = Map.toBuiltinList txInfoWdrl wdrlAtZero = BI.fst $ BI.head txInfoWdrl' rest = BI.tail txInfoWdrl' wdrlAtOne = BI.fst $ BI.head rest - in - if PlutusTx.equalsData obsScriptCred wdrlAtZero - || PlutusTx.equalsData obsScriptCred wdrlAtOne - then () - else - if BuiltinList.any (PlutusTx.equalsData obsScriptCred . BI.fst) rest - then () - else PlutusTx.traceError "not found" -{-# INLINABLE forwardWithStakeTrick #-} + in if PlutusTx.equalsData obsScriptCred wdrlAtZero + || PlutusTx.equalsData obsScriptCred wdrlAtOne + then () + else + if BuiltinList.any (PlutusTx.equalsData obsScriptCred . BI.fst) rest + then () + else PlutusTx.traceError "not found" +{-# INLINEABLE forwardWithStakeTrick #-} -mkForwardWithStakeTrickCode - :: StakingCredential - -> ScriptContext - -> PlutusTx.CompiledCode () +mkForwardWithStakeTrickCode :: + StakingCredential -> + ScriptContext -> + PlutusTx.CompiledCode () mkForwardWithStakeTrickCode cred ctx = let c = PlutusTx.toBuiltinData cred sc = PlutusTx.toBuiltinData ctx - in $$(PlutusTx.compile [|| forwardWithStakeTrick ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + in $$(PlutusTx.compile [||forwardWithStakeTrick||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc -- The manually optimised version of a script which validates that the stake -- credential is in the withdrawal map. @@ -241,10 +236,9 @@ forwardWithStakeTrickManual r_stake_cred r_ctx = wdrlAtZero = BI.fst $ BI.head wdrl rest = BI.tail wdrl wdrlAtOne = BI.fst $ BI.head $ rest - in if - ( PlutusTx.equalsData r_stake_cred wdrlAtZero - || PlutusTx.equalsData r_stake_cred wdrlAtOne - ) + in if ( PlutusTx.equalsData r_stake_cred wdrlAtZero + || PlutusTx.equalsData r_stake_cred wdrlAtOne + ) then () else lookForCred rest where @@ -252,35 +246,35 @@ forwardWithStakeTrickManual r_stake_cred r_ctx = lookForCred = PlutusTx.caseList (\() -> PlutusTx.traceError "not found") - (\p tl -> - if PlutusTx.equalsData r_stake_cred (BI.fst p) - then () - else lookForCred tl + ( \p tl -> + if PlutusTx.equalsData r_stake_cred (BI.fst p) + then () + else lookForCred tl ) getCtxWdrl :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) getCtxWdrl d_ctx = - BI.unsafeDataAsMap - $ BI.head - $ BI.tail - $ BI.tail - $ BI.tail - $ BI.tail - $ BI.tail - $ BI.tail - $ BI.snd - $ BI.unsafeDataAsConstr - $ BI.head - $ BI.snd - $ BI.unsafeDataAsConstr d_ctx -{-# INLINABLE forwardWithStakeTrickManual #-} + BI.unsafeDataAsMap $ + BI.head $ + BI.tail $ + BI.tail $ + BI.tail $ + BI.tail $ + BI.tail $ + BI.tail $ + BI.snd $ + BI.unsafeDataAsConstr $ + BI.head $ + BI.snd $ + BI.unsafeDataAsConstr d_ctx +{-# INLINEABLE forwardWithStakeTrickManual #-} -mkForwardWithStakeTrickManualCode - :: StakingCredential - -> ScriptContext - -> PlutusTx.CompiledCode () +mkForwardWithStakeTrickManualCode :: + StakingCredential -> + ScriptContext -> + PlutusTx.CompiledCode () mkForwardWithStakeTrickManualCode cred ctx = let c = PlutusTx.toBuiltinData cred sc = PlutusTx.toBuiltinData ctx - in $$(PlutusTx.compile [|| forwardWithStakeTrickManual ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + in $$(PlutusTx.compile [||forwardWithStakeTrickManual||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/ScriptContexts.hs index f26b0b338ec..839b65fb878 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/ScriptContexts.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.V2.ScriptContexts where @@ -26,81 +26,82 @@ mkScriptContext i = (mkTxInfo i) (Spending (TxOutRef (TxId "") 0)) -mkScriptContextWithStake - :: Int - -> Int - -> Maybe (StakingCredential, Int) - -> ScriptContext +mkScriptContextWithStake :: + Int -> + Int -> + Maybe (StakingCredential, Int) -> + ScriptContext mkScriptContextWithStake i j cred = ScriptContext (mkTxInfoWithStake i j cred) (Spending (TxOutRef (TxId "") 0)) - mkTxInfo :: Int -> TxInfo -mkTxInfo i = TxInfo { - txInfoInputs=mempty, - txInfoReferenceInputs=mempty, - txInfoOutputs=fmap mkTxOut [1..i], - txInfoFee=mempty, - txInfoMint=mempty, - txInfoDCert=mempty, - txInfoWdrl=Map.empty, - txInfoValidRange=always, - txInfoSignatories=mempty, - txInfoRedeemers=Map.empty, - txInfoData=Map.empty, - txInfoId=TxId "" - } - -mkTxInfoWithStake - :: Int - -> Int - -> Maybe (StakingCredential, Int) - -> TxInfo +mkTxInfo i = + TxInfo + { txInfoInputs = mempty + , txInfoReferenceInputs = mempty + , txInfoOutputs = fmap mkTxOut [1 .. i] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = mempty + , txInfoWdrl = Map.empty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoRedeemers = Map.empty + , txInfoData = Map.empty + , txInfoId = TxId "" + } + +mkTxInfoWithStake :: + Int -> + Int -> + Maybe (StakingCredential, Int) -> + TxInfo mkTxInfoWithStake i j cred = - (mkTxInfo i) { txInfoWdrl = mkStakeMap j cred } + (mkTxInfo i) {txInfoWdrl = mkStakeMap j cred} -- | A very crude deterministic generator for maps of stake credentials with size -- approximately proportional to the input integer. If a specific credential is provided, it -- is inserted at the provided index. -mkStakeMap - :: Int - -> Maybe (StakingCredential, Int) - -> Map.Map StakingCredential Integer +mkStakeMap :: + Int -> + Maybe (StakingCredential, Int) -> + Map.Map StakingCredential Integer mkStakeMap j mCred = - Map.unsafeFromList - $ case mCred of + Map.unsafeFromList $ + case mCred of Just (cred, ix) -> insertAt cred ix genValues Nothing -> genValues where genValues = - (\i -> - ( mkStakingCredential ("testCred" <> show i) - , fromIntegral i - ) + ( \i -> + ( mkStakingCredential ("testCred" <> show i) + , fromIntegral i + ) ) - <$> [1..j] + <$> [1 .. j] insertAt x i xs = take i xs <> [(x, 1000)] <> drop i xs mkStakingCredential :: String -> StakingCredential mkStakingCredential str = StakingHash - . PubKeyCredential - . PubKeyHash - . stringToBuiltinByteString - $ str + . PubKeyCredential + . PubKeyHash + . stringToBuiltinByteString + $ str mkTxOut :: Int -> TxOut -mkTxOut i = TxOut { - txOutAddress=pubKeyHashAddress (PubKeyHash ""), - txOutValue=mkValue i, - txOutDatum=NoOutputDatum, - txOutReferenceScript=Nothing - } +mkTxOut i = + TxOut + { txOutAddress = pubKeyHashAddress (PubKeyHash "") + , txOutValue = mkValue i + , txOutDatum = NoOutputDatum + , txOutReferenceScript = Nothing + } mkValue :: Int -> Value mkValue i = assetClassValue (assetClass adaSymbol adaToken) (fromIntegral i) @@ -115,19 +116,16 @@ checkScriptContext1 d = -- since we do use it later let !sc = PlutusTx.unsafeFromBuiltinData d ScriptContext txi _ = sc - in - if List.length (txInfoOutputs txi) `B.modInteger` 2 PlutusTx.== 0 - then () - else PlutusTx.traceError "Odd number of outputs" -{-# INLINABLE checkScriptContext1 #-} + in if List.length (txInfoOutputs txi) `B.modInteger` 2 PlutusTx.== 0 + then () + else PlutusTx.traceError "Odd number of outputs" +{-# INLINEABLE checkScriptContext1 #-} mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext1Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext1 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext1||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example aims to *force* the decoding of the script context and then ignore it entirely. -- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces @@ -135,23 +133,21 @@ mkCheckScriptContext1Code sc = checkScriptContext2 :: PlutusTx.BuiltinData -> () checkScriptContext2 d = let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d - -- Just using a bang pattern was not enough to stop GHC from getting - -- rid of the dead binding before we even hit the plugin, this works - -- for now! - in case sc of - !_ -> - if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) - then () - else PlutusTx.traceError "Got my sums wrong" -{-# INLINABLE checkScriptContext2 #-} + in -- Just using a bang pattern was not enough to stop GHC from getting + -- rid of the dead binding before we even hit the plugin, this works + -- for now! + case sc of + !_ -> + if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) + then () + else PlutusTx.traceError "Got my sums wrong" +{-# INLINEABLE checkScriptContext2 #-} mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext2Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext2 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext2||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d {- Note [Redundant arguments to equality benchmarks] The arguments for the benchmarks are passed as terms created with `liftCodeDef`. @@ -171,29 +167,29 @@ scriptContextEqualityData :: ScriptContext -> PlutusTx.BuiltinData -> () -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityData _ d = if B.equalsData d d - then () - else PlutusTx.traceError "The argument is not equal to itself" -{-# INLINABLE scriptContextEqualityData #-} + then () + else PlutusTx.traceError "The argument is not equal to itself" +{-# INLINEABLE scriptContextEqualityData #-} mkScriptContextEqualityDataCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityDataCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityData ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityData||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example is just the overhead from the previous two -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityOverhead :: ScriptContext -> PlutusTx.BuiltinData -> () scriptContextEqualityOverhead _ _ = () -{-# INLINABLE scriptContextEqualityOverhead #-} +{-# INLINEABLE scriptContextEqualityOverhead #-} mkScriptContextEqualityOverheadCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityOverheadCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityOverhead ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityOverhead||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- The SOP version of a script which validates that the stake credential is in -- the withdrawal map. @@ -202,29 +198,28 @@ mkScriptContextEqualityOverheadCode sc = forwardWithStakeTrick :: BuiltinData -> BuiltinData -> () forwardWithStakeTrick obsScriptCred ctx = case PlutusTx.unsafeFromBuiltinData ctx of - ScriptContext { scriptContextTxInfo = TxInfo { txInfoWdrl } } -> + ScriptContext {scriptContextTxInfo = TxInfo {txInfoWdrl}} -> let obsScriptCred' = PlutusTx.unsafeFromBuiltinData obsScriptCred txInfoWdrl' = Map.toList txInfoWdrl wdrlAtZero = PlutusTx.fst $ List.head txInfoWdrl' rest = List.tail txInfoWdrl' wdrlAtOne = PlutusTx.fst $ List.head $ rest - in - if obsScriptCred' PlutusTx.== wdrlAtZero - || obsScriptCred' PlutusTx.== wdrlAtOne - then () - else - if Map.member obsScriptCred' txInfoWdrl - then () - else PlutusTx.traceError "not found" -{-# INLINABLE forwardWithStakeTrick #-} - -mkForwardWithStakeTrickCode - :: StakingCredential - -> ScriptContext - -> PlutusTx.CompiledCode () + in if obsScriptCred' PlutusTx.== wdrlAtZero + || obsScriptCred' PlutusTx.== wdrlAtOne + then () + else + if Map.member obsScriptCred' txInfoWdrl + then () + else PlutusTx.traceError "not found" +{-# INLINEABLE forwardWithStakeTrick #-} + +mkForwardWithStakeTrickCode :: + StakingCredential -> + ScriptContext -> + PlutusTx.CompiledCode () mkForwardWithStakeTrickCode cred ctx = let c = PlutusTx.toBuiltinData cred sc = PlutusTx.toBuiltinData ctx - in $$(PlutusTx.compile [|| forwardWithStakeTrick ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + in $$(PlutusTx.compile [||forwardWithStakeTrick||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/Data/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/Data/ScriptContexts.hs index 2bb1f546004..3f94467a493 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/Data/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/Data/ScriptContexts.hs @@ -1,28 +1,58 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.V3.Data.ScriptContexts where import PlutusLedgerApi.Data.V1 qualified as PlutusTx -import PlutusLedgerApi.Data.V3 (PubKeyHash (..), Redeemer (..), ScriptContext, TxId (..), TxInfo, - TxOut, always, emptyMintValue, mintValueMinted, - pattern CertifyingScript, pattern MintingScript, - pattern NoOutputDatum, pattern ProposingScript, - pattern RewardingScript, pattern ScriptContext, - pattern SpendingScript, pattern TxInfo, pattern TxOut, - pattern TxOutRef, pattern VotingScript, txInInfoOutRef, - txInfoCurrentTreasuryAmount, txInfoData, txInfoFee, txInfoId, - txInfoInputs, txInfoMint, txInfoOutputs, txInfoProposalProcedures, - txInfoRedeemers, txInfoReferenceInputs, txInfoSignatories, - txInfoTreasuryDonation, txInfoTxCerts, txInfoValidRange, - txInfoVotes, txInfoWdrl, txOutAddress, txOutDatum, - txOutReferenceScript, txOutValue) +import PlutusLedgerApi.Data.V3 ( + PubKeyHash (..), + Redeemer (..), + ScriptContext, + TxId (..), + TxInfo, + TxOut, + always, + emptyMintValue, + mintValueMinted, + txInInfoOutRef, + txInfoCurrentTreasuryAmount, + txInfoData, + txInfoFee, + txInfoId, + txInfoInputs, + txInfoMint, + txInfoOutputs, + txInfoProposalProcedures, + txInfoRedeemers, + txInfoReferenceInputs, + txInfoSignatories, + txInfoTreasuryDonation, + txInfoTxCerts, + txInfoValidRange, + txInfoVotes, + txInfoWdrl, + txOutAddress, + txOutDatum, + txOutReferenceScript, + txOutValue, + pattern CertifyingScript, + pattern MintingScript, + pattern NoOutputDatum, + pattern ProposingScript, + pattern RewardingScript, + pattern ScriptContext, + pattern SpendingScript, + pattern TxInfo, + pattern TxOut, + pattern TxOutRef, + pattern VotingScript, + ) import PlutusLedgerApi.V1.Data.Address import PlutusLedgerApi.V1.Data.Value import PlutusLedgerApi.V3.Data.MintValue (MintValue (..)) @@ -33,9 +63,8 @@ import PlutusTx.Data.List qualified as List import PlutusTx.Plugin () import PlutusTx.Prelude qualified as PlutusTx -{-| A very crude deterministic generator for 'ScriptContext's with size -approximately proportional to the input integer. --} +-- | A very crude deterministic generator for 'ScriptContext's with size +-- approximately proportional to the input integer. mkScriptContext :: Integer -> ScriptContext mkScriptContext i = ScriptContext @@ -105,16 +134,18 @@ mkMintingTxInfo i = } mkMintValue :: Integer -> MintValue -mkMintValue n = listToMintValue - [(CurrencySymbol (toByteString i), [(TokenName (toByteString i), i)]) - | i <- [0..n]] +mkMintValue n = + listToMintValue + [ (CurrencySymbol (toByteString i), [(TokenName (toByteString i), i)]) + | i <- [0 .. n] + ] toByteString :: Integer -> PlutusTx.BuiltinByteString toByteString i = foldr (\_ -> PlutusTx.consByteString 48) PlutusTx.emptyByteString - [0..i] + [0 .. i] listToValue :: [(CurrencySymbol, [(TokenName, Integer)])] -> Value listToValue = Value . Map.unsafeFromSOPList . map (fmap Map.unsafeFromSOPList) diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/ScriptContexts.hs index 18786eec065..859e347fc2e 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V3/ScriptContexts.hs @@ -1,16 +1,26 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module PlutusBenchmark.V3.ScriptContexts where import PlutusLedgerApi.V1.Address import PlutusLedgerApi.V1.Value -import PlutusLedgerApi.V3 (OutputDatum (NoOutputDatum), PubKeyHash (..), Redeemer (..), - ScriptContext (..), ScriptInfo (SpendingScript), TxId (..), TxInfo (..), - TxOut (..), TxOutRef (..), always, emptyMintValue) +import PlutusLedgerApi.V3 ( + OutputDatum (NoOutputDatum), + PubKeyHash (..), + Redeemer (..), + ScriptContext (..), + ScriptInfo (SpendingScript), + TxId (..), + TxInfo (..), + TxOut (..), + TxOutRef (..), + always, + emptyMintValue, + ) import PlutusTx qualified import PlutusTx.AssocMap qualified as Map import PlutusTx.Builtins qualified as PlutusTx @@ -27,34 +37,35 @@ mkScriptContext i = (Redeemer (PlutusTx.toBuiltinData (1 :: Integer))) (SpendingScript (TxOutRef (TxId "") 0) Nothing) - mkTxInfo :: Int -> TxInfo -mkTxInfo i = TxInfo { - txInfoInputs=mempty, - txInfoReferenceInputs=mempty, - txInfoOutputs=fmap mkTxOut [1..i], - txInfoFee=10000, - txInfoMint=emptyMintValue, - txInfoTxCerts=mempty, - txInfoWdrl=Map.empty, - txInfoValidRange=always, - txInfoSignatories=mempty, - txInfoRedeemers=Map.empty, - txInfoData=Map.empty, - txInfoId=TxId "", - txInfoVotes=Map.empty, - txInfoProposalProcedures=mempty, - txInfoCurrentTreasuryAmount=Nothing, - txInfoTreasuryDonation=Nothing - } +mkTxInfo i = + TxInfo + { txInfoInputs = mempty + , txInfoReferenceInputs = mempty + , txInfoOutputs = fmap mkTxOut [1 .. i] + , txInfoFee = 10000 + , txInfoMint = emptyMintValue + , txInfoTxCerts = mempty + , txInfoWdrl = Map.empty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoRedeemers = Map.empty + , txInfoData = Map.empty + , txInfoId = TxId "" + , txInfoVotes = Map.empty + , txInfoProposalProcedures = mempty + , txInfoCurrentTreasuryAmount = Nothing + , txInfoTreasuryDonation = Nothing + } mkTxOut :: Int -> TxOut -mkTxOut i = TxOut { - txOutAddress=pubKeyHashAddress (PubKeyHash ""), - txOutValue=mkValue i, - txOutDatum=NoOutputDatum, - txOutReferenceScript=Nothing - } +mkTxOut i = + TxOut + { txOutAddress = pubKeyHashAddress (PubKeyHash "") + , txOutValue = mkValue i + , txOutDatum = NoOutputDatum + , txOutReferenceScript = Nothing + } mkValue :: Int -> Value mkValue i = assetClassValue (assetClass adaSymbol adaToken) (fromIntegral i) @@ -69,19 +80,16 @@ checkScriptContext1 d = -- since we do use it later let !sc = PlutusTx.unsafeFromBuiltinData d ScriptContext txi _ _ = sc - in - if List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 - then () - else PlutusTx.traceError "Odd number of outputs" -{-# INLINABLE checkScriptContext1 #-} + in if List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 + then () + else PlutusTx.traceError "Odd number of outputs" +{-# INLINEABLE checkScriptContext1 #-} mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext1Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext1 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext1||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example aims to *force* the decoding of the script context and then ignore it entirely. -- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces @@ -89,23 +97,21 @@ mkCheckScriptContext1Code sc = checkScriptContext2 :: PlutusTx.BuiltinData -> () checkScriptContext2 d = let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d - -- Just using a bang pattern was not enough to stop GHC from getting - -- rid of the dead binding before we even hit the plugin, this works - -- for now! - in case sc of - !_ -> - if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) - then () - else PlutusTx.traceError "Got my sums wrong" -{-# INLINABLE checkScriptContext2 #-} + in -- Just using a bang pattern was not enough to stop GHC from getting + -- rid of the dead binding before we even hit the plugin, this works + -- for now! + case sc of + !_ -> + if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) + then () + else PlutusTx.traceError "Got my sums wrong" +{-# INLINEABLE checkScriptContext2 #-} mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext2Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext2 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext2||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d {- Note [Redundant arguments to equality benchmarks] The arguments for the benchmarks are passed as terms created with `liftCodeDef`. @@ -125,26 +131,26 @@ scriptContextEqualityData :: ScriptContext -> PlutusTx.BuiltinData -> () -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityData _ d = if PlutusTx.equalsData d d - then () - else PlutusTx.traceError "The argument is not equal to itself" -{-# INLINABLE scriptContextEqualityData #-} + then () + else PlutusTx.traceError "The argument is not equal to itself" +{-# INLINEABLE scriptContextEqualityData #-} mkScriptContextEqualityDataCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityDataCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityData ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityData||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example is just the overhead from the previous two -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityOverhead :: ScriptContext -> PlutusTx.BuiltinData -> () scriptContextEqualityOverhead _ _ = () -{-# INLINABLE scriptContextEqualityOverhead #-} +{-# INLINEABLE scriptContextEqualityOverhead #-} mkScriptContextEqualityOverheadCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityOverheadCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityOverhead ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityOverhead||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d diff --git a/plutus-benchmark/script-contexts/test/Spec.hs b/plutus-benchmark/script-contexts/test/Spec.hs index ee293242773..1668ef5d317 100644 --- a/plutus-benchmark/script-contexts/test/Spec.hs +++ b/plutus-benchmark/script-contexts/test/Spec.hs @@ -8,8 +8,8 @@ import Test.Tasty main :: IO () main = - defaultMain - ( testGroup - "plutus-benchmark script-contexts tests" - [V1.allTests, V2.allTests, V3.allTests] - ) + defaultMain + ( testGroup + "plutus-benchmark script-contexts tests" + [V1.allTests, V2.allTests, V3.allTests] + ) diff --git a/plutus-benchmark/script-contexts/test/V1/Spec.hs b/plutus-benchmark/script-contexts/test/V1/Spec.hs index eee9eec7e1f..445e0616fd9 100644 --- a/plutus-benchmark/script-contexts/test/V1/Spec.hs +++ b/plutus-benchmark/script-contexts/test/V1/Spec.hs @@ -21,94 +21,113 @@ runTestGhcData :: [TestNested] -> TestTree runTestGhcData = runTestNested ["script-contexts", "test", "V1", "Data"] . pure . testNestedGhc testCheckSOPSc1 :: TestTree -testCheckSOPSc1 = testGroup "checkScriptContext1" +testCheckSOPSc1 = + testGroup + "checkScriptContext1" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 4) , testCase "fails on 5" . assertEvaluatesWithError $ SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 5) - , runTestGhcSOP [ Tx.goldenAstSize "checkScriptContext1" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext1" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 20) - ] + , runTestGhcSOP + [ Tx.goldenAstSize "checkScriptContext1" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext1" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 20) + ] ] testCheckDataSc1 :: TestTree -testCheckDataSc1 = testGroup "checkScriptContext1" +testCheckDataSc1 = + testGroup + "checkScriptContext1" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 4) , testCase "fails on 5" . assertEvaluatesWithError $ Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 5) - , runTestGhcData [ Tx.goldenAstSize "checkScriptContext1" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext1" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 20) - ] + , runTestGhcData + [ Tx.goldenAstSize "checkScriptContext1" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext1" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 20) + ] ] testCheckSOPSc2 :: TestTree -testCheckSOPSc2 = testGroup "checkScriptContext2" +testCheckSOPSc2 = + testGroup + "checkScriptContext2" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 4) , testCase "succeed on 5" . assertEvaluatesSuccessfully $ SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 5) - , runTestGhcSOP [ Tx.goldenAstSize "checkScriptContext2" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext2" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 20) - ] + , runTestGhcSOP + [ Tx.goldenAstSize "checkScriptContext2" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext2" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 20) + ] ] testCheckDataSc2 :: TestTree -testCheckDataSc2 = testGroup "checkScriptContext2" +testCheckDataSc2 = + testGroup + "checkScriptContext2" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 4) , testCase "succeed on 5" . assertEvaluatesSuccessfully $ Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 5) - , runTestGhcData [ Tx.goldenAstSize "checkScriptContext2" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext2" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 20) - ] + , runTestGhcData + [ Tx.goldenAstSize "checkScriptContext2" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext2" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 20) + ] ] testCheckSOPScEquality :: TestTree -testCheckSOPScEquality = testGroup "checkScriptContextEquality" - [ runTestGhcSOP [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ - SOP.SC.mkScriptContextEqualityDataCode (SOP.SC.mkScriptContext 20) - , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ - SOP.SC.mkScriptContextEqualityOverheadCode (SOP.SC.mkScriptContext 20) - ] +testCheckSOPScEquality = + testGroup + "checkScriptContextEquality" + [ runTestGhcSOP + [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ + SOP.SC.mkScriptContextEqualityDataCode (SOP.SC.mkScriptContext 20) + , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ + SOP.SC.mkScriptContextEqualityOverheadCode (SOP.SC.mkScriptContext 20) + ] ] testCheckDataScEquality :: TestTree -testCheckDataScEquality = testGroup "checkScriptContextEquality" - [ runTestGhcData [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ - Data.SC.mkScriptContextEqualityDataCode (Data.SC.mkScriptContext 20) - , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ - Data.SC.mkScriptContextEqualityOverheadCode (Data.SC.mkScriptContext 20) - ] +testCheckDataScEquality = + testGroup + "checkScriptContextEquality" + [ runTestGhcData + [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ + Data.SC.mkScriptContextEqualityDataCode (Data.SC.mkScriptContext 20) + , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ + Data.SC.mkScriptContextEqualityOverheadCode (Data.SC.mkScriptContext 20) + ] ] allTests :: TestTree allTests = - testGroup "plutus-benchmark script-contexts tests" + testGroup + "plutus-benchmark script-contexts tests" [ testCheckSOPSc1 , testCheckDataSc1 , testCheckSOPSc2 diff --git a/plutus-benchmark/script-contexts/test/V2/Spec.hs b/plutus-benchmark/script-contexts/test/V2/Spec.hs index b891f979bf6..00b2eca72f0 100644 --- a/plutus-benchmark/script-contexts/test/V2/Spec.hs +++ b/plutus-benchmark/script-contexts/test/V2/Spec.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module V2.Spec (allTests) where @@ -26,145 +26,164 @@ runTestGhcData :: [TestNested] -> TestTree runTestGhcData = runTestNested ["script-contexts", "test", "V2", "Data"] . pure . testNestedGhc testCheckSOPSc1 :: TestTree -testCheckSOPSc1 = testGroup "checkScriptContext1" +testCheckSOPSc1 = + testGroup + "checkScriptContext1" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 4) , testCase "fails on 5" . assertEvaluatesWithError $ SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 5) - , runTestGhcSOP [ Tx.goldenAstSize "checkScriptContext1" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext1" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ - SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 20) - ] + , runTestGhcSOP + [ Tx.goldenAstSize "checkScriptContext1" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext1" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ + SOP.SC.mkCheckScriptContext1Code (SOP.SC.mkScriptContext 20) + ] ] testCheckDataSc1 :: TestTree -testCheckDataSc1 = testGroup "checkScriptContext1" +testCheckDataSc1 = + testGroup + "checkScriptContext1" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 4) , testCase "fails on 5" . assertEvaluatesWithError $ Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 5) - , runTestGhcData [ Tx.goldenAstSize "checkScriptContext1" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext1" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ - Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 20) - ] + , runTestGhcData + [ Tx.goldenAstSize "checkScriptContext1" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext1" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-4" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext1-20" $ + Data.SC.mkCheckScriptContext1Code (Data.SC.mkScriptContext 20) + ] ] testCheckSOPSc2 :: TestTree -testCheckSOPSc2 = testGroup "checkScriptContext2" +testCheckSOPSc2 = + testGroup + "checkScriptContext2" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 4) + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 4) , testCase "succeed on 5" . assertEvaluatesSuccessfully $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 5) - , runTestGhcSOP [ Tx.goldenAstSize "checkScriptContext2" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext2" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ - SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 20) - ] + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 5) + , runTestGhcSOP + [ Tx.goldenAstSize "checkScriptContext2" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext2" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ + SOP.SC.mkCheckScriptContext2Code (SOP.SC.mkScriptContext 20) + ] ] testCheckDataSc2 :: TestTree -testCheckDataSc2 = testGroup "checkScriptContext2" +testCheckDataSc2 = + testGroup + "checkScriptContext2" [ testCase "succeed on 4" . assertEvaluatesSuccessfully $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 4) + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 4) , testCase "succeed on 5" . assertEvaluatesSuccessfully $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 5) - , runTestGhcData [ Tx.goldenAstSize "checkScriptContext2" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) - , Tx.goldenPirReadable "checkScriptContext2" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 4) - , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ - Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 20) - ] + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 5) + , runTestGhcData + [ Tx.goldenAstSize "checkScriptContext2" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) + , Tx.goldenPirReadable "checkScriptContext2" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 1) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-4" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 4) + , Tx.goldenEvalCekCatchBudget "checkScriptContext2-20" $ + Data.SC.mkCheckScriptContext2Code (Data.SC.mkScriptContext 20) + ] ] testCheckSOPScEquality :: TestTree -testCheckSOPScEquality = testGroup "checkScriptContextEquality" - [ runTestGhcSOP [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ - SOP.SC.mkScriptContextEqualityDataCode (SOP.SC.mkScriptContext 20) - , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ - SOP.SC.mkScriptContextEqualityOverheadCode (SOP.SC.mkScriptContext 20) - ] +testCheckSOPScEquality = + testGroup + "checkScriptContextEquality" + [ runTestGhcSOP + [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ + SOP.SC.mkScriptContextEqualityDataCode (SOP.SC.mkScriptContext 20) + , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ + SOP.SC.mkScriptContextEqualityOverheadCode (SOP.SC.mkScriptContext 20) + ] ] testCheckDataScEquality :: TestTree -testCheckDataScEquality = testGroup "checkScriptContextEquality" - [ runTestGhcData [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ - Data.SC.mkScriptContextEqualityDataCode (Data.SC.mkScriptContext 20) - , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ - Data.SC.mkScriptContextEqualityOverheadCode (Data.SC.mkScriptContext 20) - ] +testCheckDataScEquality = + testGroup + "checkScriptContextEquality" + [ runTestGhcData + [ Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityData-20" $ + Data.SC.mkScriptContextEqualityDataCode (Data.SC.mkScriptContext 20) + , Tx.goldenEvalCekCatchBudget "checkScriptContextEqualityOverhead-20" $ + Data.SC.mkScriptContextEqualityOverheadCode (Data.SC.mkScriptContext 20) + ] ] testSOPFwdStakeTrick :: TestTree testSOPFwdStakeTrick = - runTestGhcSOP - [ Tx.goldenPirReadable "sopFwdStakeTrick" testAbsCode - , Tx.goldenUPlcReadable "sopFwdStakeTrick" testAbsCode - , Tx.goldenEvalCekCatchBudget "sopFwdStakeTrick" testCode - ] + runTestGhcSOP + [ Tx.goldenPirReadable "sopFwdStakeTrick" testAbsCode + , Tx.goldenUPlcReadable "sopFwdStakeTrick" testAbsCode + , Tx.goldenEvalCekCatchBudget "sopFwdStakeTrick" testCode + ] where - testCredential = - SOP.SC.mkStakingCredential "someCredential" - testScriptContext = - SOP.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) - testAbsCode = - $$(PlutusTx.compile [|| SOP.SC.forwardWithStakeTrick ||]) - testCode = - SOP.SC.mkForwardWithStakeTrickCode testCredential testScriptContext + testCredential = + SOP.SC.mkStakingCredential "someCredential" + testScriptContext = + SOP.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) + testAbsCode = + $$(PlutusTx.compile [||SOP.SC.forwardWithStakeTrick||]) + testCode = + SOP.SC.mkForwardWithStakeTrickCode testCredential testScriptContext testDataFwdStakeTrick :: TestTree testDataFwdStakeTrick = - runTestGhcSOP - [ Tx.goldenPirReadable "dataFwdStakeTrick" testAbsCode - , Tx.goldenUPlcReadable "dataFwdStakeTrick" testAbsCode - , Tx.goldenEvalCekCatchBudget "dataFwdStakeTrick" testCode - ] + runTestGhcSOP + [ Tx.goldenPirReadable "dataFwdStakeTrick" testAbsCode + , Tx.goldenUPlcReadable "dataFwdStakeTrick" testAbsCode + , Tx.goldenEvalCekCatchBudget "dataFwdStakeTrick" testCode + ] where - testCredential = - Data.SC.mkStakingCredential "someCredential" - testScriptContext = - Data.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) - testAbsCode = - $$(PlutusTx.compile [|| Data.SC.forwardWithStakeTrick ||]) - testCode = - Data.SC.mkForwardWithStakeTrickCode testCredential testScriptContext + testCredential = + Data.SC.mkStakingCredential "someCredential" + testScriptContext = + Data.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) + testAbsCode = + $$(PlutusTx.compile [||Data.SC.forwardWithStakeTrick||]) + testCode = + Data.SC.mkForwardWithStakeTrickCode testCredential testScriptContext testDataFwdStakeTrickManual :: TestTree testDataFwdStakeTrickManual = - runTestGhcSOP - [ Tx.goldenPirReadable "dataFwdStakeTrickManual" testAbsCode - , Tx.goldenUPlcReadable "dataFwdStakeTrickManual" testAbsCode - , Tx.goldenEvalCekCatchBudget "dataFwdStakeTrickManual" testCode - ] + runTestGhcSOP + [ Tx.goldenPirReadable "dataFwdStakeTrickManual" testAbsCode + , Tx.goldenUPlcReadable "dataFwdStakeTrickManual" testAbsCode + , Tx.goldenEvalCekCatchBudget "dataFwdStakeTrickManual" testCode + ] where - testCredential = - Data.SC.mkStakingCredential "someCredential" - testScriptContext = - Data.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) - testAbsCode = - $$(PlutusTx.compile [|| Data.SC.forwardWithStakeTrickManual ||]) - testCode = - Data.SC.mkForwardWithStakeTrickManualCode testCredential testScriptContext + testCredential = + Data.SC.mkStakingCredential "someCredential" + testScriptContext = + Data.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) + testAbsCode = + $$(PlutusTx.compile [||Data.SC.forwardWithStakeTrickManual||]) + testCode = + Data.SC.mkForwardWithStakeTrickManualCode testCredential testScriptContext allTests :: TestTree allTests = - testGroup "V2" + testGroup + "V2" [ testCheckSOPSc1 , testCheckDataSc1 , testCheckSOPSc2 diff --git a/plutus-benchmark/validation/bench/BenchAgdaCek.hs b/plutus-benchmark/validation/bench/BenchAgdaCek.hs index 9b953b09db9..14d0dc1efe7 100644 --- a/plutus-benchmark/validation/bench/BenchAgdaCek.hs +++ b/plutus-benchmark/validation/bench/BenchAgdaCek.hs @@ -1,6 +1,6 @@ -{- | Validation benchmarks for the Agda CEK machine. -} - {-# LANGUAGE BangPatterns #-} + +-- | Validation benchmarks for the Agda CEK machine. module Main where import PlutusBenchmark.Agda.Common (benchTermAgdaCek) @@ -14,6 +14,6 @@ import Control.DeepSeq (force) main :: IO () main = do let mkAgdaCekBM file program = - let !benchTerm = force . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program - in benchTermAgdaCek benchTerm + let !benchTerm = force . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program + in benchTermAgdaCek benchTerm benchWith mkAgdaCekBM diff --git a/plutus-benchmark/validation/bench/BenchCek.hs b/plutus-benchmark/validation/bench/BenchCek.hs index 3c357ceb4ad..138ebb8084f 100644 --- a/plutus-benchmark/validation/bench/BenchCek.hs +++ b/plutus-benchmark/validation/bench/BenchCek.hs @@ -1,4 +1,4 @@ -{- | Validation benchmarks for the CEK machine. -} +-- | Validation benchmarks for the CEK machine. module Main where import Control.Exception (evaluate) @@ -8,19 +8,18 @@ import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariantA) import PlutusLedgerApi.Common (PlutusLedgerLanguage (PlutusV1)) import UntypedPlutusCore as UPLC -{-| - Benchmarks only for the CEK execution time of the data/*.flat validation scripts - - Run the benchmarks. You can run groups of benchmarks by typing things like - `stack bench -- plutus-benchmark:validation --ba crowdfunding` - or - `cabal bench -- plutus-benchmark:validation --benchmark-options crowdfunding`. --} +-- | +-- Benchmarks only for the CEK execution time of the data/*.flat validation scripts +-- +-- Run the benchmarks. You can run groups of benchmarks by typing things like +-- `stack bench -- plutus-benchmark:validation --ba crowdfunding` +-- or +-- `cabal bench -- plutus-benchmark:validation --benchmark-options crowdfunding`. main :: IO () main = do -- The validation benchmarks were all created with PlutusV1, so let's make -- sure that the evaluation context matches. evalCtx <- evaluate $ mkEvalCtx PlutusV1 DefaultFunSemanticsVariantA let mkCekBM file program = - benchTermCek evalCtx . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program + benchTermCek evalCtx . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program benchWith mkCekBM diff --git a/plutus-benchmark/validation/bench/BenchDec.hs b/plutus-benchmark/validation/bench/BenchDec.hs index 873fb3179c2..bb8c1c5fe4f 100644 --- a/plutus-benchmark/validation/bench/BenchDec.hs +++ b/plutus-benchmark/validation/bench/BenchDec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} + module Main where import PlutusLedgerApi.Common.Versions @@ -12,33 +13,33 @@ import Data.ByteString as BS import Data.Functor import PlutusBenchmark.Validation.Common -{-| -for each data/*.flat validation script, it benchmarks -the time taken to only flat-deserialize the script - - Run the benchmarks. You can run groups of benchmarks by typing things like - `stack bench -- plutus-benchmark:validation-decode --ba crowdfunding` - or - `cabal bench -- plutus-benchmark:validation-decode --benchmark-options crowdfunding`. --} +-- | +-- for each data/*.flat validation script, it benchmarks +-- the time taken to only flat-deserialize the script +-- +-- Run the benchmarks. You can run groups of benchmarks by typing things like +-- `stack bench -- plutus-benchmark:validation-decode --ba crowdfunding` +-- or +-- `cabal bench -- plutus-benchmark:validation-decode --benchmark-options crowdfunding`. main :: IO () main = benchWith mkDecBM where mkDecBM :: FilePath -> BS.ByteString -> Benchmarkable mkDecBM file bsFlat = - let - UPLC.Program _ v (fullyApplied :: Term) = unsafeUnflat file bsFlat - - -- script arguments are not 64-byte size limited, so we make - -- sure to remove them from the fully-applied script, and then decode back just the - -- "unsaturated" script - -- See Note [Deserialization size limits] - (unsaturated, _args) = peelDataArguments fullyApplied + let + UPLC.Program _ v (fullyApplied :: Term) = unsafeUnflat file bsFlat - -- we then have to re-encode and serialise it - !(benchScript :: SerialisedScript) = - force (serialiseUPLC $ UPLC.Program () v unsaturated) + -- script arguments are not 64-byte size limited, so we make + -- sure to remove them from the fully-applied script, and then decode back just the + -- "unsaturated" script + -- See Note [Deserialization size limits] + (unsaturated, _args) = peelDataArguments fullyApplied - -- Deserialize using 'FakeNamedDeBruijn' to get the fake names added - in whnf (either throw id . void . deserialiseScript futurePV - ) benchScript + -- we then have to re-encode and serialise it + !(benchScript :: SerialisedScript) = + force (serialiseUPLC $ UPLC.Program () v unsaturated) + in + -- Deserialize using 'FakeNamedDeBruijn' to get the fake names added + whnf + (either throw id . void . deserialiseScript futurePV) + benchScript diff --git a/plutus-benchmark/validation/bench/BenchFull.hs b/plutus-benchmark/validation/bench/BenchFull.hs index e99f8c129d2..d146d8b0ff1 100644 --- a/plutus-benchmark/validation/bench/BenchFull.hs +++ b/plutus-benchmark/validation/bench/BenchFull.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} + module Main where import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariantA)) @@ -13,15 +14,14 @@ import Criterion import Data.ByteString as BS import PlutusBenchmark.Validation.Common -{-| -for each data/*.flat validation script, it benchmarks -the whole time taken from script deserialization to script execution result. - - Run the benchmarks. You can run groups of benchmarks by typing things like - `stack bench -- plutus-benchmark:validation-full --ba crowdfunding` - or - `cabal bench -- plutus-benchmark:validation-full --benchmark-options crowdfunding`. --} +-- | +-- for each data/*.flat validation script, it benchmarks +-- the whole time taken from script deserialization to script execution result. +-- +-- Run the benchmarks. You can run groups of benchmarks by typing things like +-- `stack bench -- plutus-benchmark:validation-full --ba crowdfunding` +-- or +-- `cabal bench -- plutus-benchmark:validation-full --benchmark-options crowdfunding`. main :: IO () main = do -- The validation benchmarks were all created with PlutusV1, so let's make @@ -30,24 +30,25 @@ main = do let mkFullBM :: FilePath -> BS.ByteString -> Benchmarkable mkFullBM file bsFlat = let UPLC.Program () ver body = unsafeUnflat file bsFlat - -- We make some effort to mimic what happens on-chain, including the provision of - -- the script arguments. However, the inputs we have are *fully applied*. So we try - -- and reverse that by stripping off the arguments here. Conveniently, we know that - -- they will be Data constants. Annoyingly we can't just assume it's the first 3 - -- arguments, since some of them are policy scripts with only 2. + -- We make some effort to mimic what happens on-chain, including the provision of + -- the script arguments. However, the inputs we have are *fully applied*. So we try + -- and reverse that by stripping off the arguments here. Conveniently, we know that + -- they will be Data constants. Annoyingly we can't just assume it's the first 3 + -- arguments, since some of them are policy scripts with only 2. (term, args) = peelDataArguments body - -- strictify and "short" the result cbor to create a real `SerialisedScript` + -- strictify and "short" the result cbor to create a real `SerialisedScript` !benchScript = force . serialiseUPLC $ UPLC.Program () ver term eval script = - either (error . show) (\_ -> ()) . snd $ evaluateScriptRestricting - futurePV - -- no logs - Quiet - evalCtx - -- uses restricting(enormous) instead of counting to include the periodic - -- budget-overspent check - (unExRestrictingBudget enormousBudget) - (either (error . show) id $ deserialiseScript futurePV script) - args - in whnf eval benchScript + either (error . show) (\_ -> ()) . snd $ + evaluateScriptRestricting + futurePV + -- no logs + Quiet + evalCtx + -- uses restricting(enormous) instead of counting to include the periodic + -- budget-overspent check + (unExRestrictingBudget enormousBudget) + (either (error . show) id $ deserialiseScript futurePV script) + args + in whnf eval benchScript benchWith mkFullBM diff --git a/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs b/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs index 3a285f994ba..1780a70243e 100644 --- a/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs +++ b/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs @@ -1,14 +1,15 @@ -- editorconfig-checker-disable-file {-# LANGUAGE TypeApplications #-} + module PlutusBenchmark.Validation.Common ( - benchWith - , unsafeUnflat - , mkEvalCtx - , benchTermCek - , peelDataArguments - , Term - , getScriptDirectory - ) where + benchWith, + unsafeUnflat, + mkEvalCtx, + benchTermCek, + peelDataArguments, + Term, + getScriptDirectory, +) where import PlutusBenchmark.Common (benchTermCek, getConfig, getDataDir, mkEvalCtx) import PlutusBenchmark.NaturalSort @@ -28,32 +29,33 @@ import PlutusCore.Flat import System.Directory (listDirectory) import System.FilePath -{- | Benchmarks based on validations obtained using -plutus-use-cases:plutus-use-cases-scripts, which runs various contracts on the -blockchain simulator and dumps the applied validators as flat-encoded -scripts. Generating these scripts is a very lengthy process involving building a -lot of code, so the scripts were generated once and copied to the 'data' -directory here. Type 'cabal run plutus-use-cases:plutus-use-cases-scripts -plutus-benchmark/validation/data scripts' in the root directory of the Plutus -repository to regenerate them, but *be careful*. It's possible that the name of -the files may change and you could be left with old files that still get -benchmarked, so it might be a good idea to remove the old ones first (and -remember that these are all checked in to git). Also, the compiler output may -have changed since he scripts were last generated and so the builtins used and -so on could be different, which may confuse benchmark comparisons. We might -want to have two sets of benchmarks: one for a set of fixed scripts that let us -benchmark the evaluator independently of other factors, and another which is -generated anew every time to allow us to measure changes in the entire -compilation/execution pipeline. - -NB. Running these benchmarks with `stack bench` will use copies of the scripts -in `.stack_work` (and accessed via Paths_plutus_benchmark), and if a file in -`data` is removed and the benchmarks are re-run, the benchmarking code may still -be able to access the old copy in stack's files. --} - -{- | The name of the directory where the scripts are kept. This must match the - location of the files relative to the directory containing the cabal file. - IF THE DIRECTORY IS MOVED, THIS MUST BE UPDATED. -} +-- | Benchmarks based on validations obtained using +-- plutus-use-cases:plutus-use-cases-scripts, which runs various contracts on the +-- blockchain simulator and dumps the applied validators as flat-encoded +-- scripts. Generating these scripts is a very lengthy process involving building a +-- lot of code, so the scripts were generated once and copied to the 'data' +-- directory here. Type 'cabal run plutus-use-cases:plutus-use-cases-scripts +-- plutus-benchmark/validation/data scripts' in the root directory of the Plutus +-- repository to regenerate them, but *be careful*. It's possible that the name of +-- the files may change and you could be left with old files that still get +-- benchmarked, so it might be a good idea to remove the old ones first (and +-- remember that these are all checked in to git). Also, the compiler output may +-- have changed since he scripts were last generated and so the builtins used and +-- so on could be different, which may confuse benchmark comparisons. We might +-- want to have two sets of benchmarks: one for a set of fixed scripts that let us +-- benchmark the evaluator independently of other factors, and another which is +-- generated anew every time to allow us to measure changes in the entire +-- compilation/execution pipeline. +-- +-- NB. Running these benchmarks with `stack bench` will use copies of the scripts +-- in `.stack_work` (and accessed via Paths_plutus_benchmark), and if a file in +-- `data` is removed and the benchmarks are re-run, the benchmarking code may still +-- be able to access the old copy in stack's files. - + +-- | The name of the directory where the scripts are kept. This must match the +-- location of the files relative to the directory containing the cabal file. +-- IF THE DIRECTORY IS MOVED, THIS MUST BE UPDATED. + {- Note also that this directory (and any subdirectories) must be included in the "data-files" section of the cabal file to ensure that Paths_plutus_benchmark still works. -} @@ -65,66 +67,69 @@ getScriptDirectory = do -- | A small subset of the contracts for quick benchmarking quickPrefixes :: [String] quickPrefixes = - [ "crowdfunding-success" - , "prism" - , "token-account" - , "uniswap" - ] + [ "crowdfunding-success" + , "prism" + , "token-account" + , "uniswap" + ] -- Given two lists of strings l and ps, return the elements of l which have any -- element of ps as a prefix withAnyPrefixFrom :: [String] -> [String] -> [String] l `withAnyPrefixFrom` ps = - concatMap (\p -> filter (isPrefixOf p) l) ps + concatMap (\p -> filter (isPrefixOf p) l) ps unsafeUnflat :: String -> BS.ByteString -> UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () unsafeUnflat file contents = - case unflat contents of - Left e -> errorWithoutStackTrace $ "Flat deserialisation failure for " ++ file ++ ": " ++ show e - Right (UPLC.UnrestrictedProgram prog) -> prog + case unflat contents of + Left e -> errorWithoutStackTrace $ "Flat deserialisation failure for " ++ file ++ ": " ++ show e + Right (UPLC.UnrestrictedProgram prog) -> prog ----------------------- Main ----------------------- -- Extend the options to include `--quick`: see eg https://github.com/haskell/criterion/pull/206 data BenchOptions = BenchOptions - { quick :: Bool - , otherOptions :: Mode -- The standard options + { quick :: Bool + , otherOptions :: Mode -- The standard options } parseBenchOptions :: Config -> Parser BenchOptions -parseBenchOptions cfg = BenchOptions - <$> switch - ( short 'q' - <> long "quick" - <> help "Run only a small subset of the benchmarks") - <*> parseWith cfg +parseBenchOptions cfg = + BenchOptions + <$> switch + ( short 'q' + <> long "quick" + <> help "Run only a small subset of the benchmarks" + ) + <*> parseWith cfg parserInfo :: Config -> ParserInfo BenchOptions parserInfo cfg = - info (helper <*> parseBenchOptions cfg) $ header "Plutus Core validation benchmark suite" + info (helper <*> parseBenchOptions cfg) $ header "Plutus Core validation benchmark suite" benchWith :: (FilePath -> BS.ByteString -> Benchmarkable) -> IO () benchWith act = do - cfg <- getConfig 20.0 -- Run each benchmark for at least 20 seconds. Change this with -L or --timeout (longer is better). - options <- execParser $ parserInfo cfg - scriptDirectory <- getScriptDirectory - files0 <- listDirectory scriptDirectory -- Just the filenames, not the full paths - let -- naturalSort puts the filenames in a better order than Data.List.Sort - files1 = naturalSort $ filter (isExtensionOf ".flat") files0 -- Just in case there's anything else in the directory. - files = if quick options - then files1 `withAnyPrefixFrom` quickPrefixes - else files1 - runMode (otherOptions options) $ mkBMs scriptDirectory files - where - + cfg <- getConfig 20.0 -- Run each benchmark for at least 20 seconds. Change this with -L or --timeout (longer is better). + options <- execParser $ parserInfo cfg + scriptDirectory <- getScriptDirectory + files0 <- listDirectory scriptDirectory -- Just the filenames, not the full paths + let + -- naturalSort puts the filenames in a better order than Data.List.Sort + files1 = naturalSort $ filter (isExtensionOf ".flat") files0 -- Just in case there's anything else in the directory. + files = + if quick options + then files1 `withAnyPrefixFrom` quickPrefixes + else files1 + runMode (otherOptions options) $ mkBMs scriptDirectory files + where -- Make benchmarks for the given files in the directory mkBMs :: FilePath -> [FilePath] -> [Benchmark] mkBMs dir files = map (mkScriptBM dir) files mkScriptBM :: FilePath -> FilePath -> Benchmark mkScriptBM dir file = - env (BS.readFile $ dir file) $ \(~scriptBS) -> - bench (dropExtension file) $ act file scriptBS + env (BS.readFile $ dir file) $ \(~scriptBS) -> + bench (dropExtension file) $ act file scriptBS type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () @@ -132,8 +137,8 @@ type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () -- those arguments which are 'Data' constants. peelDataArguments :: Term -> (Term, [PLC.Data]) peelDataArguments = go [] - where - go acc t@(UPLC.Apply () t' arg) = case PLC.readKnown arg of - Left _ -> (t, acc) - Right d -> go (d:acc) t' - go acc t = (t, acc) + where + go acc t@(UPLC.Apply () t' arg) = case PLC.readKnown arg of + Left _ -> (t, acc) + Right d -> go (d : acc) t' + go acc t = (t, acc) diff --git a/plutus-conformance/agda/Spec.hs b/plutus-conformance/agda/Spec.hs index a0c21957634..989184da0da 100644 --- a/plutus-conformance/agda/Spec.hs +++ b/plutus-conformance/agda/Spec.hs @@ -11,14 +11,20 @@ import MAlonzo.Code.Evaluator.Term (runUAgda, runUCountingAgda) import PlutusConformance.Common (UplcEvaluator (..), runUplcEvalTests) import PlutusCore (Error (..)) import PlutusCore.Default (DefaultFun, DefaultUni) -import PlutusCore.Evaluation.Machine.CostModelInterface (CekMachineCosts, CostModelParams, - applyCostModelParams) +import PlutusCore.Evaluation.Machine.CostModelInterface ( + CekMachineCosts, + CostModelParams, + applyCostModelParams, + ) import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekCostModelForTesting) import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..)) -import PlutusCore.Evaluation.Machine.SimpleBuiltinCostModel (BuiltinCostKeyMap, BuiltinCostMap, - toSimpleBuiltinCostModel) +import PlutusCore.Evaluation.Machine.SimpleBuiltinCostModel ( + BuiltinCostKeyMap, + BuiltinCostMap, + toSimpleBuiltinCostModel, + ) import PlutusCore.Quote import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.DeBruijn @@ -44,12 +50,12 @@ toRawCostModel :: CostModelParams -> RawCostModel toRawCostModel params = let CostModel machineCosts builtinCosts = case applyCostModelParams defaultCekCostModelForTesting params of - Left e -> error $ show e + Left e -> error $ show e Right r -> r costKeyMap = case fromJSON @BuiltinCostKeyMap $ toJSON builtinCosts of - Error s -> error s + Error s -> error s Success m -> m in (machineCosts, toSimpleBuiltinCostModel costKeyMap) @@ -68,11 +74,11 @@ agdaEvalUplcProg WithCosting = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program () version tmU) -> let -- turn the body of the program into an untyped de Bruijn term - tmUDB - :: ExceptT - FreeVariableError - Quote - (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) + tmUDB :: + ExceptT + FreeVariableError + Quote + (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) tmUDB = deBruijnTerm tmU in case runQuote $ runExceptT $ withExceptT FreeVariableErrorE tmUDB of @@ -97,11 +103,11 @@ agdaEvalUplcProg WithCosting = in Just (UPLC.Program () version namedTerm, cost) agdaEvalUplcProg WithoutCosting = UplcEvaluatorWithoutCosting $ \(UPLC.Program () version tmU) -> - let tmUDB - :: ExceptT - FreeVariableError - Quote - (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) + let tmUDB :: + ExceptT + FreeVariableError + Quote + (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) tmUDB = deBruijnTerm tmU in case runQuote $ runExceptT $ withExceptT FreeVariableErrorE tmUDB of Left _ -> Nothing @@ -113,15 +119,14 @@ agdaEvalUplcProg WithoutCosting = runExceptT $ withExceptT FreeVariableErrorE $ unDeBruijnTerm tmEvaluated of - Left _ -> Nothing + Left _ -> Nothing Right namedTerm -> Just $ UPLC.Program () version namedTerm -{-| A list of evaluation tests which are currently expected to fail. Once a fix - for a test is pushed, the test will succeed and should be removed from the - list. The entries of the list are paths from the root of plutus-conformance to - the directory containing the test, eg - "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" --} +-- | A list of evaluation tests which are currently expected to fail. Once a fix +-- for a test is pushed, the test will succeed and should be removed from the +-- list. The entries of the list are paths from the root of plutus-conformance to +-- the directory containing the test, eg +-- "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" failingEvaluationTests :: [FilePath] failingEvaluationTests = [ -- These "constant casing" tests fail because Agda metatheory does not yet @@ -153,10 +158,9 @@ failingEvaluationTests = , "test-cases/uplc/evaluation/term/constant-case/unit/unit-01" , "test-cases/uplc/evaluation/term/constant-case/unit/unit-02" , "test-cases/uplc/evaluation/term/constant-case/unit/unit-03" - - -- The following are failing because the metatheory needs to be updated with - -- Value built-in functions - , "test-cases/uplc/evaluation/builtin/constant/value/duplicate-keys" + , -- The following are failing because the metatheory needs to be updated with + -- Value built-in functions + "test-cases/uplc/evaluation/builtin/constant/value/duplicate-keys" , "test-cases/uplc/evaluation/builtin/constant/value/empty-tokens" , "test-cases/uplc/evaluation/builtin/constant/value/empty" , "test-cases/uplc/evaluation/builtin/constant/value/ill-formed" @@ -211,12 +215,11 @@ failingEvaluationTests = , "test-cases/uplc/evaluation/builtin/semantics/scaleValue/no-underflow" ] -{-| A list of budget tests which are currently expected to fail. Once a fix for - a test is pushed, the test will succeed and should be removed from the list. - The entries of the list are paths from the root of plutus-conformance to the - directory containing the test, eg - "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" --} +-- | A list of budget tests which are currently expected to fail. Once a fix for +-- a test is pushed, the test will succeed and should be removed from the list. +-- The entries of the list are paths from the root of plutus-conformance to the +-- directory containing the test, eg +-- "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" failingBudgetTests :: [FilePath] failingBudgetTests = -- These currently fail because the Agda code doesn't know about the @@ -239,10 +242,10 @@ failingBudgetTests = , "test-cases/uplc/evaluation/builtin/semantics/dropList/dropList-14" , "test-cases/uplc/evaluation/builtin/semantics/dropList/dropList-15" , "test-cases/uplc/evaluation/builtin/semantics/dropList/dropList-16" - -- These "constant casing" tests fail because Agda metatheory does not yet - -- implement casing on constant values. - -- TODO: remove these tests once casing on constant is added to Agda metatheory. - , "test-cases/uplc/evaluation/term/constant-case/bool/bool-01" + , -- These "constant casing" tests fail because Agda metatheory does not yet + -- implement casing on constant values. + -- TODO: remove these tests once casing on constant is added to Agda metatheory. + "test-cases/uplc/evaluation/term/constant-case/bool/bool-01" , "test-cases/uplc/evaluation/term/constant-case/bool/bool-02" , "test-cases/uplc/evaluation/term/constant-case/bool/bool-03" , "test-cases/uplc/evaluation/term/constant-case/bool/bool-04" @@ -268,9 +271,9 @@ failingBudgetTests = , "test-cases/uplc/evaluation/term/constant-case/unit/unit-01" , "test-cases/uplc/evaluation/term/constant-case/unit/unit-02" , "test-cases/uplc/evaluation/term/constant-case/unit/unit-03" - -- The following are failing because the metatheory needs to be updated with - -- Value built-in functions - , "test-cases/uplc/evaluation/builtin/constant/value/duplicate-keys" + , -- The following are failing because the metatheory needs to be updated with + -- Value built-in functions + "test-cases/uplc/evaluation/builtin/constant/value/duplicate-keys" , "test-cases/uplc/evaluation/builtin/constant/value/empty-tokens" , "test-cases/uplc/evaluation/builtin/constant/value/empty" , "test-cases/uplc/evaluation/builtin/constant/value/ill-formed" diff --git a/plutus-conformance/haskell-steppable/Spec.hs b/plutus-conformance/haskell-steppable/Spec.hs index 5be979a008f..20c2aa5d120 100644 --- a/plutus-conformance/haskell-steppable/Spec.hs +++ b/plutus-conformance/haskell-steppable/Spec.hs @@ -10,21 +10,19 @@ import PlutusPrelude import UntypedPlutusCore as UPLC import UntypedPlutusCore.Evaluation.Machine.SteppableCek as SCek -{-| A list of evaluation tests which are currently expected to fail. Once a fix - for a test is pushed, the test will succeed and should be removed from the - list. The entries of the list are paths from the root of plutus-conformance to - the directory containing the test, eg - "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" --} +-- | A list of evaluation tests which are currently expected to fail. Once a fix +-- for a test is pushed, the test will succeed and should be removed from the +-- list. The entries of the list are paths from the root of plutus-conformance to +-- the directory containing the test, eg +-- "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" failingEvaluationTests :: [FilePath] failingEvaluationTests = [] -{-| A list of budget tests which are currently expected to fail. Once a fix for - a test is pushed, the test will succeed and should be removed from the list. - The entries of the list are paths from the root of plutus-conformance to the - directory containing the test, eg - "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" --} +-- | A list of budget tests which are currently expected to fail. Once a fix for +-- a test is pushed, the test will succeed and should be removed from the list. +-- The entries of the list are paths from the root of plutus-conformance to the +-- directory containing the test, eg +-- "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" failingBudgetTests :: [FilePath] failingBudgetTests = [] @@ -33,15 +31,15 @@ evalSteppableUplcProg :: UplcEvaluator evalSteppableUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do params <- case mkMachineVariantParametersFor [def] modelParams of - Left _ -> Nothing + Left _ -> Nothing Right machParamsList -> UPLC.MachineParameters def <$> lookup def machParamsList -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with -- free variables, that is why we manually check first for any free vars case UPLC.deBruijnTerm t of Left (_ :: UPLC.FreeVariableError) -> Nothing - Right _ -> Just () + Right _ -> Just () case SCek.runCekNoEmit params counting t of - (Left _, _) -> Nothing + (Left _, _) -> Nothing (Right t', CountingSt cost) -> Just (UPLC.Program a v t', cost) main :: IO () diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index 1ab98cb52bc..a2bae524f48 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/plutus-conformance/haskell/Spec.hs @@ -15,32 +15,30 @@ evalUplcProg :: UplcEvaluator evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do params <- case mkMachineVariantParametersFor [def] modelParams of - Left _ -> Nothing + Left _ -> Nothing Right machParamsList -> UPLC.MachineParameters def <$> lookup def machParamsList -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with -- free variables, that is why we manually check first for any free vars case UPLC.deBruijnTerm t of Left (_ :: UPLC.FreeVariableError) -> Nothing - Right _ -> Just () + Right _ -> Just () case runCekNoEmit params counting t of - (Left _, _) -> Nothing + (Left _, _) -> Nothing (Right prog, CountingSt cost) -> Just (UPLC.Program a v prog, cost) -{-| A list of evaluation tests which are currently expected to fail. Once a fix - for a test is pushed, the test will succeed and should be removed from the - list. The entries of the list are paths from the root of plutus-conformance to - the directory containing the test, eg - "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" --} +-- | A list of evaluation tests which are currently expected to fail. Once a fix +-- for a test is pushed, the test will succeed and should be removed from the +-- list. The entries of the list are paths from the root of plutus-conformance to +-- the directory containing the test, eg +-- "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" failingEvaluationTests :: [FilePath] failingEvaluationTests = [] -{-| A list of budget tests which are currently expected to fail. Once a fix for - a test is pushed, the test will succeed and should be removed from the list. - The entries of the list are paths from the root of plutus-conformance to the - directory containing the test, eg - "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" --} +-- | A list of budget tests which are currently expected to fail. Once a fix for +-- a test is pushed, the test will succeed and should be removed from the list. +-- The entries of the list are paths from the root of plutus-conformance to the +-- directory containing the test, eg +-- "test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger1" failingBudgetTests :: [FilePath] failingBudgetTests = [] diff --git a/plutus-conformance/src/PlutusConformance/Common.hs b/plutus-conformance/src/PlutusConformance/Common.hs index a7232422bbc..bd954475b67 100644 --- a/plutus-conformance/src/PlutusConformance/Common.hs +++ b/plutus-conformance/src/PlutusConformance/Common.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} -- | Plutus conformance test suite library. @@ -31,10 +31,9 @@ import Witherable (Witherable (wither)) -- Common functions for all tests -{-| The default shown text when a parse error occurs. -We don't want to show the detailed parse errors so that -users of the test suite can produce the expected output more easily. --} +-- | The default shown text when a parse error occurs. +-- We don't want to show the detailed parse errors so that +-- users of the test suite can produce the expected output more easily. shownParseError :: T.Text shownParseError = "parse error" @@ -43,9 +42,9 @@ shownEvaluationFailure :: T.Text shownEvaluationFailure = "evaluation failure" -- | The default parser to parse UPLC program inputs. -parseTxt - :: T.Text - -> Either ParserErrorBundle (UPLC.Program Name DefaultUni DefaultFun SrcSpan) +parseTxt :: + T.Text -> + Either ParserErrorBundle (UPLC.Program Name DefaultUni DefaultFun SrcSpan) parseTxt resTxt = runQuoteT $ UPLC.parseProgram resTxt -- | The input/output UPLC program type. @@ -64,126 +63,121 @@ type UplcEvaluatorFun res = UplcProg -> Maybe res data UplcEvaluator = -- | An evaluator that just produces an output program, or fails. UplcEvaluatorWithoutCosting (UplcEvaluatorFun UplcProg) - | {-| An evaluator that produces an output program along with the cost of - evaluating it, or fails. Note that nothing cares about the cost of failing - programs, so we don't test for conformance there. - -} + | -- | An evaluator that produces an output program along with the cost of + -- evaluating it, or fails. Note that nothing cares about the cost of failing + -- programs, so we don't test for conformance there. UplcEvaluatorWithCosting (CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget)) -{-| Walk a file tree, making test groups for directories with subdirectories, - and test cases for directories without. We expect every test directory to - contain a single `.uplc` file whose name matches that of the directory. For - example, the directory `modInteger-15` should contain `modInteger-15.uplc`, - and that file should contain a textual UPLC program. The directory should - also contain golden files `modInteger-15.uplc.expected`, containing the - expected output of the program, and `modInteger-15.uplc.budget.expected`, - containing the expected execution budget, although these will be created by - the testing machinery if they aren't already present. --} -discoverTests - :: UplcEvaluator - -- ^ The evaluator to be tested. - -> CostModelParams - -> (FilePath -> Bool) - {- ^ A function that takes a test directory and returns a Bool indicating - whether the evaluation test for the file in that directory is expected to - fail. - -} - -> (FilePath -> Bool) - {- ^ A function that takes a test directory and returns a Bool indicating - whether the budget test for the file in that directory is expected to fail. - -} - -> FilePath - -- ^ The directory to search for tests. - -> IO TestTree +-- | Walk a file tree, making test groups for directories with subdirectories, +-- and test cases for directories without. We expect every test directory to +-- contain a single `.uplc` file whose name matches that of the directory. For +-- example, the directory `modInteger-15` should contain `modInteger-15.uplc`, +-- and that file should contain a textual UPLC program. The directory should +-- also contain golden files `modInteger-15.uplc.expected`, containing the +-- expected output of the program, and `modInteger-15.uplc.budget.expected`, +-- containing the expected execution budget, although these will be created by +-- the testing machinery if they aren't already present. +discoverTests :: + -- | The evaluator to be tested. + UplcEvaluator -> + CostModelParams -> + -- | A function that takes a test directory and returns a Bool indicating + -- whether the evaluation test for the file in that directory is expected to + -- fail. + (FilePath -> Bool) -> + -- | A function that takes a test directory and returns a Bool indicating + -- whether the budget test for the file in that directory is expected to fail. + (FilePath -> Bool) -> + -- | The directory to search for tests. + FilePath -> + IO TestTree discoverTests eval modelParams evaluationFailureExpected budgetFailureExpected = go - where - go dir = do - let name = takeBaseName dir - children <- listDirectory dir - subdirs <- flip wither children $ \child -> do - let fullPath = dir child - isDir <- doesDirectoryExist fullPath - pure $ if isDir then Just fullPath else Nothing - if null subdirs - -- no children, this is a test case directory - then do - -- Check that the directory contains exactly one .uplc file - -- and that it's called .uplc, where is the final path - -- component of . - uplcFiles <- findByExtension [".uplc"] dir - let expectedInputFile = takeFileName dir <.> ".uplc" - inputFilePath = - case uplcFiles of - [] -> - error $ - "Input file " - ++ expectedInputFile - ++ " missing in " <> dir - _ : _ : _ -> error $ "More than one .uplc file in " <> dir - [file] -> - if takeFileName file /= expectedInputFile - then - error $ - "Found file " - ++ takeFileName file - ++ " in directory " - ++ dir - ++ " (expected " - ++ expectedInputFile - ++ ")" - else file - let tests = case eval of - UplcEvaluatorWithCosting f -> - testGroup - name - [ testForEval dir inputFilePath (fmap fst . f modelParams) - , testForBudget dir inputFilePath (fmap snd . f modelParams) - ] - UplcEvaluatorWithoutCosting f -> testForEval dir inputFilePath f - pure tests - -- has children, so it's a grouping directory - else testGroup name <$> traverse go subdirs - testForEval :: FilePath -> String -> UplcEvaluatorFun UplcProg -> TestTree - testForEval dir inputFilePath e = - let goldenFilePath = inputFilePath <.> "expected" - test = - goldenTest - (takeFileName inputFilePath ++ " (evaluation)") - -- get the golden test value - (expectedToProg <$> T.readFile goldenFilePath) - -- get the tested value - (getTestedValue e inputFilePath) - (\x y -> pure $ compareAlphaEq x y) -- comparison function - (updateGoldenFile goldenFilePath) -- update the golden file - in possiblyFailingTest (evaluationFailureExpected dir) test - testForBudget :: FilePath -> String -> UplcEvaluatorFun ExBudget -> TestTree - testForBudget dir inputFilePath e = - let goldenFilePath = inputFilePath <.> "budget" <.> "expected" - prettyEither (Left l) = pretty l - prettyEither (Right r) = pretty r - test = - goldenVsDocM - (takeFileName inputFilePath ++ " (budget)") - goldenFilePath - (prettyEither <$> getTestedValue e inputFilePath) - in possiblyFailingTest (budgetFailureExpected dir) test - possiblyFailingTest :: Bool -> TestTree -> TestTree - possiblyFailingTest failureExpected test = - if failureExpected - then ignoreTest test - -- TODO: ^ this should really be `expectFail`, but that behaves strangely - -- with `--accept` (the golden files for the failing tests get updated: - -- see https://github.com/IntersectMBO/plutus/issues/6714 and - -- https://github.com/nomeata/tasty-expected-failure/issues/27. - -- If/when that gets fixed `ignoreTest` should be changed to `expectFail`. - else test + where + go dir = do + let name = takeBaseName dir + children <- listDirectory dir + subdirs <- flip wither children $ \child -> do + let fullPath = dir child + isDir <- doesDirectoryExist fullPath + pure $ if isDir then Just fullPath else Nothing + if null subdirs + -- no children, this is a test case directory + then do + -- Check that the directory contains exactly one .uplc file + -- and that it's called .uplc, where is the final path + -- component of . + uplcFiles <- findByExtension [".uplc"] dir + let expectedInputFile = takeFileName dir <.> ".uplc" + inputFilePath = + case uplcFiles of + [] -> + error $ + "Input file " + ++ expectedInputFile + ++ " missing in " <> dir + _ : _ : _ -> error $ "More than one .uplc file in " <> dir + [file] -> + if takeFileName file /= expectedInputFile + then + error $ + "Found file " + ++ takeFileName file + ++ " in directory " + ++ dir + ++ " (expected " + ++ expectedInputFile + ++ ")" + else file + let tests = case eval of + UplcEvaluatorWithCosting f -> + testGroup + name + [ testForEval dir inputFilePath (fmap fst . f modelParams) + , testForBudget dir inputFilePath (fmap snd . f modelParams) + ] + UplcEvaluatorWithoutCosting f -> testForEval dir inputFilePath f + pure tests + -- has children, so it's a grouping directory + else testGroup name <$> traverse go subdirs + testForEval :: FilePath -> String -> UplcEvaluatorFun UplcProg -> TestTree + testForEval dir inputFilePath e = + let goldenFilePath = inputFilePath <.> "expected" + test = + goldenTest + (takeFileName inputFilePath ++ " (evaluation)") + -- get the golden test value + (expectedToProg <$> T.readFile goldenFilePath) + -- get the tested value + (getTestedValue e inputFilePath) + (\x y -> pure $ compareAlphaEq x y) -- comparison function + (updateGoldenFile goldenFilePath) -- update the golden file + in possiblyFailingTest (evaluationFailureExpected dir) test + testForBudget :: FilePath -> String -> UplcEvaluatorFun ExBudget -> TestTree + testForBudget dir inputFilePath e = + let goldenFilePath = inputFilePath <.> "budget" <.> "expected" + prettyEither (Left l) = pretty l + prettyEither (Right r) = pretty r + test = + goldenVsDocM + (takeFileName inputFilePath ++ " (budget)") + goldenFilePath + (prettyEither <$> getTestedValue e inputFilePath) + in possiblyFailingTest (budgetFailureExpected dir) test + possiblyFailingTest :: Bool -> TestTree -> TestTree + possiblyFailingTest failureExpected test = + if failureExpected + then ignoreTest test + -- TODO: ^ this should really be `expectFail`, but that behaves strangely + -- with `--accept` (the golden files for the failing tests get updated: + -- see https://github.com/IntersectMBO/plutus/issues/6714 and + -- https://github.com/nomeata/tasty-expected-failure/issues/27. + -- If/when that gets fixed `ignoreTest` should be changed to `expectFail`. + else test -{-| Turn the expected file content in text to a `UplcProg` unless the expected -result is a parse or evaluation error. --} +-- | Turn the expected file content in text to a `UplcProg` unless the expected +-- result is a parse or evaluation error. expectedToProg :: T.Text -> Either T.Text UplcProg expectedToProg txt | txt == shownEvaluationFailure = @@ -192,38 +186,35 @@ expectedToProg txt Left txt | otherwise = case parseTxt txt of - Left _ -> Left txt + Left _ -> Left txt Right p -> Right $ void p -{-| Get the tested value from a file (in this case a textual UPLC source -file). The tested value is either the shown parse error or evaluation error, -or a `UplcProg`. --} -getTestedValue - :: UplcEvaluatorFun res - -> FilePath - -> IO (Either T.Text res) +-- | Get the tested value from a file (in this case a textual UPLC source +-- file). The tested value is either the shown parse error or evaluation error, +-- or a `UplcProg`. +getTestedValue :: + UplcEvaluatorFun res -> + FilePath -> + IO (Either T.Text res) getTestedValue eval file = do input <- T.readFile file pure $ case parseTxt input of Left _ -> Left shownParseError Right p -> case eval (void p) of - Nothing -> Left shownEvaluationFailure + Nothing -> Left shownEvaluationFailure Just prog -> Right prog -{-| The comparison function used for the golden test. -This function checks alpha-equivalence of programs when the output is a program. --} -compareAlphaEq - :: Either T.Text UplcProg - -- ^ golden value - -> Either T.Text UplcProg - -- ^ tested value - -> Maybe String - {- ^ If two values are the same, it returns `Nothing`. - If they are different, it returns an error that will be printed to the user. - -} +-- | The comparison function used for the golden test. +-- This function checks alpha-equivalence of programs when the output is a program. +compareAlphaEq :: + -- | golden value + Either T.Text UplcProg -> + -- | tested value + Either T.Text UplcProg -> + -- | If two values are the same, it returns `Nothing`. + -- If they are different, it returns an error that will be printed to the user. + Maybe String compareAlphaEq (Left expectedTxt) (Left actualTxt) = if actualTxt == expectedTxt then Nothing @@ -268,32 +259,28 @@ compareAlphaEq (Left txt) (Right actual) = <> ". But the expected result is: " <> T.unpack txt -{-| Update the golden file with the tested value. -TODO abstract out for other tests. --} -updateGoldenFile - :: FilePath - -- ^ the path to write the golden file to - -> Either T.Text UplcProg - -> IO () +-- | Update the golden file with the tested value. +-- TODO abstract out for other tests. +updateGoldenFile :: + -- | the path to write the golden file to + FilePath -> + Either T.Text UplcProg -> + IO () updateGoldenFile goldenPath (Left txt) = T.writeFile goldenPath txt -updateGoldenFile goldenPath (Right p) = T.writeFile goldenPath (display p) +updateGoldenFile goldenPath (Right p) = T.writeFile goldenPath (display p) -{-| Run the UPLC evaluation tests given an `evaluator` that evaluates UPLC -programs. --} -runUplcEvalTests - :: UplcEvaluator - -- ^ The action to run the input through for the tests. - -> (FilePath -> Bool) - {- ^ A function that takes a test name and returns - whether it should labelled as `ExpectedFailure`. - -} - -> (FilePath -> Bool) - {- ^ A function that takes a test name and returns - whether it should labelled as `ExpectedBudgetFailure`. - -} - -> IO () +-- | Run the UPLC evaluation tests given an `evaluator` that evaluates UPLC +-- programs. +runUplcEvalTests :: + -- | The action to run the input through for the tests. + UplcEvaluator -> + -- | A function that takes a test name and returns + -- whether it should labelled as `ExpectedFailure`. + (FilePath -> Bool) -> + -- | A function that takes a test name and returns + -- whether it should labelled as `ExpectedBudgetFailure`. + (FilePath -> Bool) -> + IO () runUplcEvalTests eval expectedFailTests expectedBudgetFailTests = do let params = fromJust defaultCostModelParamsForTesting tests <- diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Arrays.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Arrays.hs index c322f19a659..a76c6e8168b 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Arrays.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Arrays.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Benchmarks.Arrays (makeBenchmarks) where @@ -31,24 +31,24 @@ makeBenchmarks gen = benchLengthOfArray :: StdGen -> Benchmark benchLengthOfArray gen = createOneTermBuiltinBench LengthOfArray [tyArrayOfBS] listOfArrays - where - listOfArrays :: [Vector ByteString] = - runStateGen_ gen \g -> replicateM 100 do - arraySize <- uniformRM (1, 100) g - Vector.replicateM arraySize do - bsSize <- uniformRM (0, 10_000) g - uniformByteStringM bsSize g + where + listOfArrays :: [Vector ByteString] = + runStateGen_ gen \g -> replicateM 100 do + arraySize <- uniformRM (1, 100) g + Vector.replicateM arraySize do + bsSize <- uniformRM (0, 10_000) g + uniformByteStringM bsSize g benchListToArray :: StdGen -> Benchmark benchListToArray gen = createOneTermBuiltinBench ListToArray [tyListOfBS] listOfLists - where - listOfLists :: [[ByteString]] = - runStateGen_ gen \g -> replicateM 100 do - listSize <- uniformRM (1, 100) g - replicateM listSize do - bsSize <- uniformRM (0, 10_000) g - uniformByteStringM bsSize g + where + listOfLists :: [[ByteString]] = + runStateGen_ gen \g -> replicateM 100 do + listSize <- uniformRM (1, 100) g + replicateM listSize do + bsSize <- uniformRM (0, 10_000) g + uniformByteStringM bsSize g benchIndexArray :: StdGen -> Benchmark benchIndexArray gen = @@ -56,15 +56,15 @@ benchIndexArray gen = IndexArray [tyArrayOfBS] (zip arrays idxs) - where - (arrays :: [Vector ByteString], idxs :: [Integer]) = - unzip $ runStateGen_ gen \g -> replicateM 100 do - arraySize <- uniformRM (1, 100) g - vec <- Vector.replicateM arraySize do - bsSize <- uniformRM (0, 10_000) g - uniformByteStringM bsSize g - idx <- uniformRM (0, arraySize - 1) g - pure (vec, fromIntegral idx) + where + (arrays :: [Vector ByteString], idxs :: [Integer]) = + unzip $ runStateGen_ gen \g -> replicateM 100 do + arraySize <- uniformRM (1, 100) g + vec <- Vector.replicateM arraySize do + bsSize <- uniformRM (0, 10_000) g + uniformByteStringM bsSize g + idx <- uniformRM (0, arraySize - 1) g + pure (vec, fromIntegral idx) -------------------------------------------------------------------------------- -- Helpers --------------------------------------------------------------------- diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Bitwise.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Bitwise.hs index c09247d6857..2d60c55ea50 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Bitwise.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Bitwise.hs @@ -6,16 +6,20 @@ import Generators import PlutusCore import PlutusCore.Evaluation.Machine.CostStream (sumCostStream) -import PlutusCore.Evaluation.Machine.ExMemoryUsage (ExMemoryUsage, IntegerCostedLiterally (..), - NumBytesCostedAsNumWords (..), flattenCostRose, - memoryUsage) +import PlutusCore.Evaluation.Machine.ExMemoryUsage ( + ExMemoryUsage, + IntegerCostedLiterally (..), + NumBytesCostedAsNumWords (..), + flattenCostRose, + memoryUsage, + ) import Criterion.Main import Data.ByteString qualified as BS import Data.SatInt (fromSatInt) import Hedgehog qualified as H -{- | Costing benchmarks for bitwise bytestring builtins and integer/bytestring conversions. -} +-- | Costing benchmarks for bitwise bytestring builtins and integer/bytestring conversions. {- Most of the initial exploratory benchmarks were run with a set of small input bytestrings (up to size 160 / 1280 bytes) and then again with a set of large @@ -27,7 +31,7 @@ numSamples :: Int numSamples = 150 sampleSizes :: [Int] -sampleSizes = [1..numSamples] +sampleSizes = [1 .. numSamples] -- Smallish bytestring inputs: 150 entries. Note that the length of a -- bytestring is eight times the size. @@ -36,14 +40,14 @@ makeSample seed = makeSizedByteStrings seed sampleSizes -- Make an integer of size n which encodes to 0xFF...FF repunitOfSize :: Int -> Integer -repunitOfSize n = 256^(8*n) - 1 +repunitOfSize n = 256 ^ (8 * n) - 1 -- Calculate the index of the top (ie, righmost) bit in a bytestring. topBitIndex :: BS.ByteString -> Integer -topBitIndex s = fromIntegral $ 8*(BS.length s)-1 +topBitIndex s = fromIntegral $ 8 * (BS.length s) - 1 memoryUsageAsNumBytes :: ExMemoryUsage a => a -> Int -memoryUsageAsNumBytes = (8*) . fromSatInt . sumCostStream . flattenCostRose . memoryUsage +memoryUsageAsNumBytes = (8 *) . fromSatInt . sumCostStream . flattenCostRose . memoryUsage {- Experiments show that the times for big-endian and little-endian `byteStringToInteger` conversions are very similar, with big-endian @@ -53,7 +57,7 @@ memoryUsageAsNumBytes = (8*) . fromSatInt . sumCostStream . flattenCostRose . me gives a good fit and extrapolates well to larger inputs. -} benchByteStringToInteger :: Benchmark benchByteStringToInteger = - createTwoTermBuiltinBenchElementwise ByteStringToInteger [] $ fmap (\x -> (True,x)) (makeSample seedA) + createTwoTermBuiltinBenchElementwise ByteStringToInteger [] $ fmap (\x -> (True, x)) (makeSample seedA) {- We have four possibilities for integer to bytestring conversions: they can be big- or little-endian, and they can also be of bounded or unbounded width. @@ -71,13 +75,15 @@ benchByteStringToInteger = This is well within the 8192-byte limit. -} benchIntegerToByteString :: Benchmark benchIntegerToByteString = - let b = IntegerToByteString - inputs = fmap repunitOfSize sampleSizes - -- The minimum width of bytestring needed to fit the inputs into. - widthsInBytes = fmap (fromIntegral . memoryUsageAsNumBytes) inputs - in createThreeTermBuiltinBenchElementwiseWithWrappers - (id, NumBytesCostedAsNumWords, id) b [] $ - zip3 (repeat True) widthsInBytes inputs + let b = IntegerToByteString + inputs = fmap repunitOfSize sampleSizes + -- The minimum width of bytestring needed to fit the inputs into. + widthsInBytes = fmap (fromIntegral . memoryUsageAsNumBytes) inputs + in createThreeTermBuiltinBenchElementwiseWithWrappers + (id, NumBytesCostedAsNumWords, id) + b + [] + $ zip3 (repeat True) widthsInBytes inputs {- For `andByteString` with different-sized inputs, calling it with extension semantics (ie, first argument=True) takes up to about 5% longer than with @@ -101,26 +107,27 @@ those. -} benchAndByteString :: Benchmark benchAndByteString = - let inputSizes = fmap (20*) [1..25] -- 20..400: 625 cases, which should take an hour or so. + let inputSizes = fmap (20 *) [1 .. 25] -- 20..400: 625 cases, which should take an hour or so. xs = makeSizedByteStrings seedA inputSizes ys = makeSizedByteStrings seedB inputSizes - in createTwoTermBuiltinBenchWithFlag AndByteString [] True xs ys - -- This requires a special case in the costing codet because we don't include - -- the first argument (the flag). + in createTwoTermBuiltinBenchWithFlag AndByteString [] True xs ys + +-- This requires a special case in the costing codet because we don't include +-- the first argument (the flag). {- For `complementByteString`, the time taken is linear in the length. A model based on small input sizes extrapolates well to results for large inputs -} benchComplementByteString :: Benchmark benchComplementByteString = let xs = makeSample seedA - in createOneTermBuiltinBench ComplementByteString [] xs + in createOneTermBuiltinBench ComplementByteString [] xs {- `readBit` is pretty much constant time regardless of input size and the position of the bit to be read. -} benchReadBit :: Benchmark benchReadBit = let xs = makeSample seedA - in createTwoTermBuiltinBenchElementwise ReadBit [] $ pairWith topBitIndex xs + in createTwoTermBuiltinBenchElementwise ReadBit [] $ pairWith topBitIndex xs {- The `writeBits` function takes a bytestring, a list of positions to write to, and a boolean value to write at those positions. Benchmarks show that the @@ -132,14 +139,14 @@ benchReadBit = -} benchWriteBits :: Benchmark benchWriteBits = - let size = 128 -- This is equal to length 1024. + let size = 128 -- This is equal to length 1024. xs = makeSizedByteStrings seedA $ replicate numSamples size - updateCounts = [1..numSamples] - positions = zipWith (\x n -> replicate (10*n) (topBitIndex x)) xs updateCounts + updateCounts = [1 .. numSamples] + positions = zipWith (\x n -> replicate (10 * n) (topBitIndex x)) xs updateCounts -- Given an integer k, return a list of updates which write a bit 10*k -- times. Here k will range from 1 to numSamples, which is 150. inputs = zip3 xs positions (replicate numSamples True) - in createThreeTermBuiltinBenchElementwise WriteBits [] inputs + in createThreeTermBuiltinBenchElementwise WriteBits [] inputs {- For small inputs `replicateByte` looks constant-time. For larger inputs it's linear. We're limiting the output to 8192 bytes (size 1024), so we may as @@ -150,11 +157,14 @@ benchWriteBits = benchReplicateByte :: Benchmark benchReplicateByte = let numCases = 128 :: Int - xs = fmap (fromIntegral . (64*)) [1..numCases] :: [Integer] - -- ^ This gives us replication counts up to 64*128 = 8192, the maximum allowed. - inputs = pairWith (const (0xFF::Integer)) xs - in createTwoTermBuiltinBenchElementwiseWithWrappers - (NumBytesCostedAsNumWords, id) ReplicateByte [] inputs + xs = fmap (fromIntegral . (64 *)) [1 .. numCases] :: [Integer] + -- \^ This gives us replication counts up to 64*128 = 8192, the maximum allowed. + inputs = pairWith (const (0xFF :: Integer)) xs + in createTwoTermBuiltinBenchElementwiseWithWrappers + (NumBytesCostedAsNumWords, id) + ReplicateByte + [] + inputs {- Benchmarks with varying sizes of bytestrings and varying amounts of shifting show that the execution time of `shiftByteString` depends linearly on the @@ -173,8 +183,11 @@ benchShiftByteString :: Benchmark benchShiftByteString = let xs = makeSample seedA inputs = pairWith (const 1) xs - in createTwoTermBuiltinBenchElementwiseWithWrappers - (id, IntegerCostedLiterally) ShiftByteString [] inputs + in createTwoTermBuiltinBenchElementwiseWithWrappers + (id, IntegerCostedLiterally) + ShiftByteString + [] + inputs {- The behaviour of `rotateByteString` is very similar to that of `shiftByteString` except that the time taken depends pretty much linearly on @@ -188,8 +201,11 @@ benchRotateBytestring :: Benchmark benchRotateBytestring = let xs = makeSample seedA inputs = pairWith (const 1) xs - in createTwoTermBuiltinBenchElementwiseWithWrappers - (id, IntegerCostedLiterally) RotateByteString [] inputs + in createTwoTermBuiltinBenchElementwiseWithWrappers + (id, IntegerCostedLiterally) + RotateByteString + [] + inputs {- For `countSetBits`, the time taken is linear in the length. A model based on small input sizes (up to 1280 bytes) extrapolates well to results for large @@ -197,8 +213,8 @@ benchRotateBytestring = take 1% or so longer than for an all-0x00 bytestring. -} benchCountSetBits :: Benchmark benchCountSetBits = - let xs = fmap (\n -> BS.replicate (8*n) 0xFF) sampleSizes -- length 8, 16, ..., 1200 - in createOneTermBuiltinBench CountSetBits [] xs + let xs = fmap (\n -> BS.replicate (8 * n) 0xFF) sampleSizes -- length 8, 16, ..., 1200 + in createOneTermBuiltinBench CountSetBits [] xs {- For `findFirstSetBits` the time taken is pretty much linear in the length, with occasional bumps. Unsurprisingly the function takes longest for an all-0x00 @@ -210,20 +226,20 @@ benchCountSetBits = well to results for large inputs. -} benchFindFirstSetBit :: Benchmark benchFindFirstSetBit = - let xs = fmap (\n -> BS.cons 0x80 (BS.replicate (8*n-1) 0x00)) sampleSizes - in createOneTermBuiltinBench FindFirstSetBit [] xs + let xs = fmap (\n -> BS.cons 0x80 (BS.replicate (8 * n - 1) 0x00)) sampleSizes + in createOneTermBuiltinBench FindFirstSetBit [] xs makeBenchmarks :: [Benchmark] makeBenchmarks = - [ benchIntegerToByteString - , benchByteStringToInteger - , benchAndByteString - , benchComplementByteString - , benchReadBit - , benchWriteBits - , benchReplicateByte - , benchShiftByteString - , benchRotateBytestring - , benchCountSetBits - , benchFindFirstSetBit - ] + [ benchIntegerToByteString + , benchByteStringToInteger + , benchAndByteString + , benchComplementByteString + , benchReadBit + , benchWriteBits + , benchReplicateByte + , benchShiftByteString + , benchRotateBytestring + , benchCountSetBits + , benchFindFirstSetBit + ] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Bool.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Bool.hs index dc57a41e2ea..3e6d6f37739 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Bool.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Bool.hs @@ -13,16 +13,21 @@ import System.Random (StdGen) benchIfThenElse :: Benchmark benchIfThenElse = - let name = IfThenElse - resultSizes = [100, 500, 1000, 2000, 5000, 10000, 20000] - results1 = makeSizedByteStrings seedA resultSizes - results2 = makeSizedByteStrings seedB resultSizes - mkBMs ty b = [ bgroup (showMemoryUsage r1) - [ benchDefault (showMemoryUsage r2) $ mkApp3 name ty b r1 r2 - | r2 <- results2 ] - | r1 <- results1 ] - in bgroup (show name) (mkBMs [bytestring] True ++ mkBMs [bytestring] False) - -- This gives 98 datapoints (2*7*7). + let name = IfThenElse + resultSizes = [100, 500, 1000, 2000, 5000, 10000, 20000] + results1 = makeSizedByteStrings seedA resultSizes + results2 = makeSizedByteStrings seedB resultSizes + mkBMs ty b = + [ bgroup + (showMemoryUsage r1) + [ benchDefault (showMemoryUsage r2) $ mkApp3 name ty b r1 r2 + | r2 <- results2 + ] + | r1 <- results1 + ] + in bgroup (show name) (mkBMs [bytestring] True ++ mkBMs [bytestring] False) + +-- This gives 98 datapoints (2*7*7). makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks _gen = [benchIfThenElse] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/ByteStrings.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/ByteStrings.hs index a010d0293ee..12b315d94f1 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/ByteStrings.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/ByteStrings.hs @@ -19,50 +19,57 @@ integerLength = fromIntegral . BS.length -- Arguments for single-argument benchmarks: 150 entries. -- Note that the length is eight times the size. smallerByteStrings150 :: H.Seed -> [BS.ByteString] -smallerByteStrings150 seed = makeSizedByteStrings seed $ fmap (10*) [1..150] +smallerByteStrings150 seed = makeSizedByteStrings seed $ fmap (10 *) [1 .. 150] -- Arguments for two-argument benchmarks: 21 entries. -- Note that the length is eight times the size. largerByteStrings21 :: H.Seed -> [BS.ByteString] -largerByteStrings21 seed = makeSizedByteStrings seed $ fmap (250*) [0..20] +largerByteStrings21 seed = makeSizedByteStrings seed $ fmap (250 *) [0 .. 20] benchTwoByteStrings :: DefaultFun -> Benchmark benchTwoByteStrings name = - createTwoTermBuiltinBench name [] (largerByteStrings21 seedA) (largerByteStrings21 seedB) + createTwoTermBuiltinBench name [] (largerByteStrings21 seedA) (largerByteStrings21 seedB) benchLengthOfByteString :: Benchmark benchLengthOfByteString = - bgroup (show name) $ fmap mkBM (smallerByteStrings150 seedA) - where mkBM b = benchDefault (showMemoryUsage b) $ mkApp1 name [] b - name = LengthOfByteString + bgroup (show name) $ fmap mkBM (smallerByteStrings150 seedA) + where + mkBM b = benchDefault (showMemoryUsage b) $ mkApp1 name [] b + name = LengthOfByteString -- Copy the byteString here, because otherwise it'll be exactly the same and the equality will -- short-circuit. benchSameTwoByteStrings :: DefaultFun -> Benchmark benchSameTwoByteStrings name = - createTwoTermBuiltinBenchElementwise name [] $ pairWith BS.copy inputs - where inputs = smallerByteStrings150 seedA + createTwoTermBuiltinBenchElementwise name [] $ pairWith BS.copy inputs + where + inputs = smallerByteStrings150 seedA -- Here we benchmark different pairs of bytestrings elementwise. This is used -- to get times for off-diagonal comparisons, which we expect to be roughly -- constant since the equality test returns quickly in that case. benchDifferentByteStringsElementwise :: DefaultFun -> Benchmark benchDifferentByteStringsElementwise name = - createTwoTermBuiltinBenchElementwise name [] $ zip inputs1 inputs2 - where inputs1 = smallerByteStrings150 seedA - inputs2 = smallerByteStrings150 seedB + createTwoTermBuiltinBenchElementwise name [] $ zip inputs1 inputs2 + where + inputs1 = smallerByteStrings150 seedA + inputs2 = smallerByteStrings150 seedB -- This is constant, even for large inputs benchIndexByteString :: StdGen -> Benchmark benchIndexByteString gen = - createTwoTermBuiltinBenchElementwise - IndexByteString [] $ zip bytestrings (randomIndices gen bytestrings) - where bytestrings = smallerByteStrings150 seedA - randomIndices gen1 l = - case l of - [] -> [] - b:bs -> let (i,gen2) = randomR (0, (integerLength b)-1) gen1 - in i:randomIndices gen2 bs + createTwoTermBuiltinBenchElementwise + IndexByteString + [] + $ zip bytestrings (randomIndices gen bytestrings) + where + bytestrings = smallerByteStrings150 seedA + randomIndices gen1 l = + case l of + [] -> [] + b : bs -> + let (i, gen2) = randomR (0, (integerLength b) - 1) gen1 + in i : randomIndices gen2 bs {- This should be constant time, since the underlying operations are just returning modified pointers into a C array. We still want a decent number of @@ -71,38 +78,45 @@ benchIndexByteString gen = slice (so 16 (index,length) pairs for each bytestring size). -} benchSliceByteString :: Benchmark benchSliceByteString = - let name = SliceByteString - quarters n = if n < 4 then [n] else [0, t..(n-t)] where t = n `div` 4 - -- quarters n may contain more than four elements if n < 16, but we - -- won't encounter that case. For n<4 then the 'else' branch would give - -- you an infinite list of zeros. - byteStrings = makeSizedByteString seedA <$> fmap (100*) [1..10] - mkBMsFor b = - [bgroup (showMemoryUsage start) - [bgroup (showMemoryUsage len) - [benchDefault (showMemoryUsage b) $ mkApp3 name [] start len b] | - len <- quarters (blen - start)] | - start <- quarters blen] - where blen = integerLength b - in bgroup (show name) $ concatMap mkBMsFor byteStrings - + let name = SliceByteString + quarters n = if n < 4 then [n] else [0, t .. (n - t)] where t = n `div` 4 + -- quarters n may contain more than four elements if n < 16, but we + -- won't encounter that case. For n<4 then the 'else' branch would give + -- you an infinite list of zeros. + byteStrings = makeSizedByteString seedA <$> fmap (100 *) [1 .. 10] + mkBMsFor b = + [ bgroup + (showMemoryUsage start) + [ bgroup + (showMemoryUsage len) + [benchDefault (showMemoryUsage b) $ mkApp3 name [] start len b] + | len <- quarters (blen - start) + ] + | start <- quarters blen + ] + where + blen = integerLength b + in bgroup (show name) $ concatMap mkBMsFor byteStrings benchConsByteString :: Benchmark benchConsByteString = - createTwoTermBuiltinBench ConsByteString [] [n] (smallerByteStrings150 seedA) - where n = 123 :: Integer - -- The precise numbers don't seem to matter here, as long as they are in - -- the range of [0..255] (Word8). Otherwise - -- we run the risk of costing also the (fast) failures of the builtin call. + createTwoTermBuiltinBench ConsByteString [] [n] (smallerByteStrings150 seedA) + where + n = 123 :: Integer + +-- The precise numbers don't seem to matter here, as long as they are in +-- the range of [0..255] (Word8). Otherwise +-- we run the risk of costing also the (fast) failures of the builtin call. makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks gen = - [ benchTwoByteStrings AppendByteString, - benchConsByteString, - benchLengthOfByteString, - benchIndexByteString gen, - benchSliceByteString - ] + [ benchTwoByteStrings AppendByteString + , benchConsByteString + , benchLengthOfByteString + , benchIndexByteString gen + , benchSliceByteString + ] <> [benchDifferentByteStringsElementwise EqualsByteString] - <> (benchSameTwoByteStrings <$> - [ EqualsByteString, LessThanEqualsByteString, LessThanByteString ]) + <> ( benchSameTwoByteStrings + <$> [EqualsByteString, LessThanEqualsByteString, LessThanByteString] + ) diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Crypto.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Crypto.hs index afa9a3b4b1e..418fc214994 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Crypto.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Crypto.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Benchmarks.Crypto (makeBenchmarks) where @@ -10,9 +10,16 @@ import Common import Generators import PlutusCore -import Cardano.Crypto.DSIGN.Class (ContextDSIGN, DSIGNAlgorithm, Signable, deriveVerKeyDSIGN, - genKeyDSIGN, rawSerialiseSigDSIGN, rawSerialiseVerKeyDSIGN, - signDSIGN) +import Cardano.Crypto.DSIGN.Class ( + ContextDSIGN, + DSIGNAlgorithm, + Signable, + deriveVerKeyDSIGN, + genKeyDSIGN, + rawSerialiseSigDSIGN, + rawSerialiseVerKeyDSIGN, + signDSIGN, + ) import Cardano.Crypto.DSIGN.EcdsaSecp256k1 (EcdsaSecp256k1DSIGN, toMessageHash) import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN) import Cardano.Crypto.DSIGN.SchnorrSecp256k1 (SchnorrSecp256k1DSIGN) @@ -31,13 +38,14 @@ numSamples :: Int numSamples = 50 byteStringSizes :: [Int] -byteStringSizes = fmap (200*) [0..numSamples-1] +byteStringSizes = fmap (200 *) [0 .. numSamples - 1] mediumByteStrings :: H.Seed -> [ByteString] mediumByteStrings seed = makeSizedByteStrings seed byteStringSizes bigByteStrings :: H.Seed -> [ByteString] -bigByteStrings seed = makeSizedByteStrings seed (fmap (10*) byteStringSizes) +bigByteStrings seed = makeSizedByteStrings seed (fmap (10 *) byteStringSizes) + -- Up to 784,000 bytes. ---------------- Signature verification ---------------- @@ -61,70 +69,71 @@ data MessageSize = Arbitrary | Fixed Int triple is valid or not. -} -{- | Create a list of valid (key,message,signature) triples. The DSIGN - infrastructure lets us do this in a fairly generic way. However, to sign an - EcdsaSecp256k1DSIGN message we can't use a raw bytestring: we have to wrap it - up using Crypto.Secp256k1.msg, which checks that the bytestring is the right - length. This means that we have to add a ByteString -> message conversion - function as a parameter here. --} -mkDsignBmInputs :: forall v msg . - (Signable v msg, DSIGNAlgorithm v, ContextDSIGN v ~ ()) - => (ByteString -> msg) - -> MessageSize - -> [(ByteString, ByteString, ByteString)] +-- | Create a list of valid (key,message,signature) triples. The DSIGN +-- infrastructure lets us do this in a fairly generic way. However, to sign an +-- EcdsaSecp256k1DSIGN message we can't use a raw bytestring: we have to wrap it +-- up using Crypto.Secp256k1.msg, which checks that the bytestring is the right +-- length. This means that we have to add a ByteString -> message conversion +-- function as a parameter here. +mkDsignBmInputs :: + forall v msg. + (Signable v msg, DSIGNAlgorithm v, ContextDSIGN v ~ ()) => + (ByteString -> msg) -> + MessageSize -> + [(ByteString, ByteString, ByteString)] mkDsignBmInputs toMsg msgSize = - map mkOneInput (zip seeds messages) - where seeds = listOfByteStringsOfLength numSamples 128 - -- ^ Seeds for key generation. For some algorithms the seed has to be - -- a certain minimal size and there's a SeedBytesExhausted error if - -- it's not big enough; 128 is big enough for everything here though. - messages = - case msgSize of - Arbitrary -> bigByteStrings seedA - Fixed n -> listOfByteStringsOfLength numSamples n - mkOneInput (seed, msg) = - let signKey = genKeyDSIGN @v $ mkSeedFromBytes seed -- Signing key (private) - vkBytes = rawSerialiseVerKeyDSIGN $ deriveVerKeyDSIGN signKey -- Verification key (public) - sigBytes = rawSerialiseSigDSIGN $ signDSIGN () (toMsg msg) signKey - in (vkBytes, msg, sigBytes) + map mkOneInput (zip seeds messages) + where + seeds = listOfByteStringsOfLength numSamples 128 + -- \^ Seeds for key generation. For some algorithms the seed has to be + -- a certain minimal size and there's a SeedBytesExhausted error if + -- it's not big enough; 128 is big enough for everything here though. + messages = + case msgSize of + Arbitrary -> bigByteStrings seedA + Fixed n -> listOfByteStringsOfLength numSamples n + mkOneInput (seed, msg) = + let signKey = genKeyDSIGN @v $ mkSeedFromBytes seed -- Signing key (private) + vkBytes = rawSerialiseVerKeyDSIGN $ deriveVerKeyDSIGN signKey -- Verification key (public) + sigBytes = rawSerialiseSigDSIGN $ signDSIGN () (toMsg msg) signKey + in (vkBytes, msg, sigBytes) benchVerifyEd25519Signature :: Benchmark benchVerifyEd25519Signature = - let name = VerifyEd25519Signature - inputs = mkDsignBmInputs @Ed25519DSIGN id Arbitrary - in createThreeTermBuiltinBenchElementwise name [] inputs + let name = VerifyEd25519Signature + inputs = mkDsignBmInputs @Ed25519DSIGN id Arbitrary + in createThreeTermBuiltinBenchElementwise name [] inputs benchVerifyEcdsaSecp256k1Signature :: Benchmark benchVerifyEcdsaSecp256k1Signature = - let name = VerifyEcdsaSecp256k1Signature - inputs = mkDsignBmInputs @EcdsaSecp256k1DSIGN toMsg (Fixed 32) - in createThreeTermBuiltinBenchElementwise name [] inputs - where toMsg b = - case toMessageHash b of - Just m -> m - Nothing -> error "Invalid EcdsaSecp256k1DSIGN message" - -- This should only happen if we give it a message which isn't - -- 32 bytes long, but that shouldn't happen because of Fixed 32. + let name = VerifyEcdsaSecp256k1Signature + inputs = mkDsignBmInputs @EcdsaSecp256k1DSIGN toMsg (Fixed 32) + in createThreeTermBuiltinBenchElementwise name [] inputs + where + toMsg b = + case toMessageHash b of + Just m -> m + Nothing -> error "Invalid EcdsaSecp256k1DSIGN message" + +-- This should only happen if we give it a message which isn't +-- 32 bytes long, but that shouldn't happen because of Fixed 32. benchVerifySchnorrSecp256k1Signature :: Benchmark benchVerifySchnorrSecp256k1Signature = - let name = VerifySchnorrSecp256k1Signature - inputs = mkDsignBmInputs @SchnorrSecp256k1DSIGN id Arbitrary - in createThreeTermBuiltinBenchElementwise name [] inputs - + let name = VerifySchnorrSecp256k1Signature + inputs = mkDsignBmInputs @SchnorrSecp256k1DSIGN id Arbitrary + in createThreeTermBuiltinBenchElementwise name [] inputs ---------------- Hashing functions ---------------- benchByteStringOneArgOp :: DefaultFun -> Benchmark benchByteStringOneArgOp name = - bgroup (show name) $ fmap mkBM (mediumByteStrings seedA) - where mkBM b = benchDefault (showMemoryUsage b) $ mkApp1 name [] b - + bgroup (show name) $ fmap mkBM (mediumByteStrings seedA) + where + mkBM b = benchDefault (showMemoryUsage b) $ mkApp1 name [] b ---------------- BLS12_381 buitlins ---------------- - byteStrings :: [ByteString] byteStrings = listOfByteStringsOfLength 200 20 @@ -134,7 +143,6 @@ byteStringsA = take 100 byteStrings byteStringsB :: [ByteString] byteStringsB = take 100 (drop 100 byteStrings) - -- Random elements in G1 -- Create random group elements by hashing a random bytestring (with an empty @@ -142,9 +150,9 @@ byteStringsB = take 100 (drop 100 byteStrings) -- random bytestrings, which will almost always fail. randomG1Element :: ByteString -> G1.Element randomG1Element s = - case G1.hashToGroup s Data.ByteString.empty of - Left err -> error $ "Error in randomG1Element: " ++ show err - Right p -> p + case G1.hashToGroup s Data.ByteString.empty of + Left err -> error $ "Error in randomG1Element: " ++ show err + Right p -> p g1inputsA :: [G1.Element] g1inputsA = fmap randomG1Element byteStringsA @@ -155,9 +163,9 @@ g1inputsB = fmap randomG1Element byteStringsB -- Random elements in G2 randomG2Element :: ByteString -> G2.Element randomG2Element s = - case G2.hashToGroup s Data.ByteString.empty of - Left err -> error $ "Error in randomG2Element: " ++ show err - Right p -> p + case G2.hashToGroup s Data.ByteString.empty of + Left err -> error $ "Error in randomG2Element: " ++ show err + Right p -> p g2inputsA :: [G2.Element] g2inputsA = fmap randomG2Element byteStringsA @@ -176,129 +184,148 @@ gtinputsB = zipWith Pairing.millerLoop g1inputsB g2inputsB benchBls12_381_G1_add :: Benchmark benchBls12_381_G1_add = - let name = Bls12_381_G1_add - in createTwoTermBuiltinBenchElementwise name [] $ zip g1inputsA g1inputsB + let name = Bls12_381_G1_add + in createTwoTermBuiltinBenchElementwise name [] $ zip g1inputsA g1inputsB + -- constant time -- Two arguments, points on G1 benchBls12_381_G1_neg :: Benchmark benchBls12_381_G1_neg = - let name = Bls12_381_G1_neg - in createOneTermBuiltinBench name [] g1inputsA + let name = Bls12_381_G1_neg + in createOneTermBuiltinBench name [] g1inputsA + -- constant time benchBls12_381_G1_scalarMul :: [Integer] -> Benchmark benchBls12_381_G1_scalarMul multipliers = - let name = Bls12_381_G1_scalarMul - in createTwoTermBuiltinBenchElementwise name [] $ zip multipliers g1inputsA + let name = Bls12_381_G1_scalarMul + in createTwoTermBuiltinBenchElementwise name [] $ zip multipliers g1inputsA + -- linear in x (size of scalar) benchBls12_381_G1_multiScalarMul :: [[Integer]] -> Benchmark benchBls12_381_G1_multiScalarMul scalarLists = - let name = Bls12_381_G1_multiScalarMul - g1Lists = [ fmap randomG1Element (listOfByteStringsOfLength (length scalars) 20) | scalars <- scalarLists ] - in createTwoTermBuiltinBenchElementwise name [] (zip scalarLists g1Lists) + let name = Bls12_381_G1_multiScalarMul + g1Lists = [fmap randomG1Element (listOfByteStringsOfLength (length scalars) 20) | scalars <- scalarLists] + in createTwoTermBuiltinBenchElementwise name [] (zip scalarLists g1Lists) + -- linear in size of the minimum of both lists benchBls12_381_G1_equal :: Benchmark benchBls12_381_G1_equal = - let name = Bls12_381_G1_equal - in createTwoTermBuiltinBenchElementwise name [] $ zip g1inputsA g1inputsA - -- Same arguments twice + let name = Bls12_381_G1_equal + in createTwoTermBuiltinBenchElementwise name [] $ zip g1inputsA g1inputsA + +-- Same arguments twice -- constant time benchBls12_381_G1_hashToGroup :: Benchmark benchBls12_381_G1_hashToGroup = - let name = Bls12_381_G1_hashToGroup - inputs = listOfByteStrings 100 - -- The maximum length of a DST is 255 bytes, so let's use that for all - -- cases (DST size shouldn't make much difference anyway). - dsts = listOfByteStringsOfLength 100 255 - in createTwoTermBuiltinBenchElementwise name [] $ zip inputs dsts + let name = Bls12_381_G1_hashToGroup + inputs = listOfByteStrings 100 + -- The maximum length of a DST is 255 bytes, so let's use that for all + -- cases (DST size shouldn't make much difference anyway). + dsts = listOfByteStringsOfLength 100 255 + in createTwoTermBuiltinBenchElementwise name [] $ zip inputs dsts + -- linear in input size benchBls12_381_G1_compress :: Benchmark benchBls12_381_G1_compress = - let name = Bls12_381_G1_compress - in createOneTermBuiltinBench name [] g1inputsA + let name = Bls12_381_G1_compress + in createOneTermBuiltinBench name [] g1inputsA + -- constant time benchBls12_381_G1_uncompress :: Benchmark benchBls12_381_G1_uncompress = - let name = Bls12_381_G1_uncompress - inputs = fmap G1.compress g1inputsA - in createOneTermBuiltinBench name [] inputs + let name = Bls12_381_G1_uncompress + inputs = fmap G1.compress g1inputsA + in createOneTermBuiltinBench name [] inputs + -- constant time benchBls12_381_G2_add :: Benchmark benchBls12_381_G2_add = - let name = Bls12_381_G2_add - in createTwoTermBuiltinBenchElementwise name [] $ zip g2inputsA g2inputsB + let name = Bls12_381_G2_add + in createTwoTermBuiltinBenchElementwise name [] $ zip g2inputsA g2inputsB + -- constant time benchBls12_381_G2_neg :: Benchmark benchBls12_381_G2_neg = - let name = Bls12_381_G2_neg - in createOneTermBuiltinBench name [] g2inputsB + let name = Bls12_381_G2_neg + in createOneTermBuiltinBench name [] g2inputsB + -- constant time benchBls12_381_G2_scalarMul :: [Integer] -> Benchmark benchBls12_381_G2_scalarMul multipliers = - let name = Bls12_381_G2_scalarMul - in createTwoTermBuiltinBenchElementwise name [] $ zip multipliers g2inputsA + let name = Bls12_381_G2_scalarMul + in createTwoTermBuiltinBenchElementwise name [] $ zip multipliers g2inputsA + -- linear in x (size of scalar) benchBls12_381_G2_multiScalarMul :: [[Integer]] -> Benchmark benchBls12_381_G2_multiScalarMul scalarLists = - let name = Bls12_381_G2_multiScalarMul - g2Lists = [ fmap randomG2Element (listOfByteStringsOfLength (length scalars) 20) | scalars <- scalarLists ] - in createTwoTermBuiltinBenchElementwise name [] (zip scalarLists g2Lists) + let name = Bls12_381_G2_multiScalarMul + g2Lists = [fmap randomG2Element (listOfByteStringsOfLength (length scalars) 20) | scalars <- scalarLists] + in createTwoTermBuiltinBenchElementwise name [] (zip scalarLists g2Lists) + -- linear in size of the minimum of both lists benchBls12_381_G2_equal :: Benchmark benchBls12_381_G2_equal = - let name = Bls12_381_G2_equal - in createTwoTermBuiltinBenchElementwise name [] $ zip g2inputsA g2inputsA - -- Same arguments twice + let name = Bls12_381_G2_equal + in createTwoTermBuiltinBenchElementwise name [] $ zip g2inputsA g2inputsA + +-- Same arguments twice -- constant time benchBls12_381_G2_hashToGroup :: Benchmark benchBls12_381_G2_hashToGroup = - let name = Bls12_381_G2_hashToGroup - inputs = listOfByteStrings 100 - dsts = listOfByteStringsOfLength 100 255 - in createTwoTermBuiltinBenchElementwise name [] $ zip inputs dsts + let name = Bls12_381_G2_hashToGroup + inputs = listOfByteStrings 100 + dsts = listOfByteStringsOfLength 100 255 + in createTwoTermBuiltinBenchElementwise name [] $ zip inputs dsts + -- linear in size of input benchBls12_381_G2_compress :: Benchmark benchBls12_381_G2_compress = - let name = Bls12_381_G2_compress - in createOneTermBuiltinBench name [] g2inputsA + let name = Bls12_381_G2_compress + in createOneTermBuiltinBench name [] g2inputsA + -- constant time benchBls12_381_G2_uncompress :: Benchmark benchBls12_381_G2_uncompress = - let name = Bls12_381_G2_uncompress - inputs = fmap G2.compress g2inputsA - in createOneTermBuiltinBench name [] inputs + let name = Bls12_381_G2_uncompress + inputs = fmap G2.compress g2inputsA + in createOneTermBuiltinBench name [] inputs + -- constant time benchBls12_381_millerLoop :: Benchmark benchBls12_381_millerLoop = - let name = Bls12_381_millerLoop - in createTwoTermBuiltinBenchElementwise name [] $ zip g1inputsA g2inputsA + let name = Bls12_381_millerLoop + in createTwoTermBuiltinBenchElementwise name [] $ zip g1inputsA g2inputsA + -- constant time benchBls12_381_mulMlResult :: Benchmark benchBls12_381_mulMlResult = - let name = Bls12_381_mulMlResult - in createTwoTermBuiltinBenchElementwise name [] $ zip gtinputsA gtinputsB + let name = Bls12_381_mulMlResult + in createTwoTermBuiltinBenchElementwise name [] $ zip gtinputsA gtinputsB + -- constant time benchBls12_381_finalVerify :: Benchmark benchBls12_381_finalVerify = - let name = Bls12_381_finalVerify - in createTwoTermBuiltinBenchElementwise name [] $ zip gtinputsA gtinputsB + let name = Bls12_381_finalVerify + in createTwoTermBuiltinBenchElementwise name [] $ zip gtinputsA gtinputsB + -- constant time -- A helper function to generate lists of integers of a given sizes @@ -306,40 +333,41 @@ mkVariableLengthScalarLists :: StdGen -> [Int] -> ([[Integer]], StdGen) mkVariableLengthScalarLists gen = foldl go ([], gen) where go (acc, g) size = - let (ints, g') = makeSizedIntegers g [1..size] - in (acc ++ [ints], g') + let (ints, g') = makeSizedIntegers g [1 .. size] + in (acc ++ [ints], g') blsBenchmarks :: StdGen -> [Benchmark] blsBenchmarks gen = - let multipliers = fst $ makeSizedIntegers gen [1..100] -- Constants for scalar multiplication functions - scalarLists = fst $ mkVariableLengthScalarLists gen [1..100] -- Create a list of lists of integers of various sizes between 1 and 100 elements - in [ benchBls12_381_G1_add - , benchBls12_381_G1_neg - , benchBls12_381_G1_scalarMul multipliers - , benchBls12_381_G1_multiScalarMul scalarLists - , benchBls12_381_G1_equal - , benchBls12_381_G1_hashToGroup - , benchBls12_381_G1_compress - , benchBls12_381_G1_uncompress - , benchBls12_381_G2_add - , benchBls12_381_G2_neg - , benchBls12_381_G2_scalarMul multipliers - , benchBls12_381_G2_multiScalarMul scalarLists - , benchBls12_381_G2_equal - , benchBls12_381_G2_hashToGroup - , benchBls12_381_G2_compress - , benchBls12_381_G2_uncompress - , benchBls12_381_millerLoop - , benchBls12_381_mulMlResult - , benchBls12_381_finalVerify - ] + let multipliers = fst $ makeSizedIntegers gen [1 .. 100] -- Constants for scalar multiplication functions + scalarLists = fst $ mkVariableLengthScalarLists gen [1 .. 100] -- Create a list of lists of integers of various sizes between 1 and 100 elements + in [ benchBls12_381_G1_add + , benchBls12_381_G1_neg + , benchBls12_381_G1_scalarMul multipliers + , benchBls12_381_G1_multiScalarMul scalarLists + , benchBls12_381_G1_equal + , benchBls12_381_G1_hashToGroup + , benchBls12_381_G1_compress + , benchBls12_381_G1_uncompress + , benchBls12_381_G2_add + , benchBls12_381_G2_neg + , benchBls12_381_G2_scalarMul multipliers + , benchBls12_381_G2_multiScalarMul scalarLists + , benchBls12_381_G2_equal + , benchBls12_381_G2_hashToGroup + , benchBls12_381_G2_compress + , benchBls12_381_G2_uncompress + , benchBls12_381_millerLoop + , benchBls12_381_mulMlResult + , benchBls12_381_finalVerify + ] ---------------- Main benchmarks ---------------- makeBenchmarks :: StdGen -> [Benchmark] -makeBenchmarks gen = [ benchVerifyEd25519Signature - , benchVerifyEcdsaSecp256k1Signature - , benchVerifySchnorrSecp256k1Signature - ] - <> (benchByteStringOneArgOp <$> [Sha2_256, Sha3_256, Blake2b_224, Blake2b_256, Keccak_256, Ripemd_160]) - <> blsBenchmarks gen +makeBenchmarks gen = + [ benchVerifyEd25519Signature + , benchVerifyEcdsaSecp256k1Signature + , benchVerifySchnorrSecp256k1Signature + ] + <> (benchByteStringOneArgOp <$> [Sha2_256, Sha3_256, Blake2b_224, Blake2b_256, Keccak_256, Ripemd_160]) + <> blsBenchmarks gen diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs index ec8a2e1c66a..cfaffee2442 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs @@ -11,32 +11,28 @@ import PlutusCore.Data import Criterion.Main import System.Random (StdGen) -{- | Benchmarks for builtins operating on Data. Recall that Data is defined by - - data Data = - Constr Integer [Data] - | Map [(Data, Data)] - | List [Data] - | I Integer - | B ByteString --} - - +-- | Benchmarks for builtins operating on Data. Recall that Data is defined by +-- +-- data Data = +-- Constr Integer [Data] +-- | Map [(Data, Data)] +-- | List [Data] +-- | I Integer +-- | B ByteString isConstr :: Data -> Bool -isConstr = \case {Constr {} -> True; _ -> False} +isConstr = \case Constr {} -> True; _ -> False isMap :: Data -> Bool -isMap = \case {Map {} -> True; _ -> False} +isMap = \case Map {} -> True; _ -> False isList :: Data -> Bool -isList = \case {List {} -> True; _ -> False} +isList = \case List {} -> True; _ -> False isI :: Data -> Bool -isI = \case {I {} -> True; _ -> False} +isI = \case I {} -> True; _ -> False isB :: Data -> Bool -isB = \case {B {} -> True; _ -> False} - +isB = \case B {} -> True; _ -> False ---------------- ChooseData ---------------- @@ -46,74 +42,91 @@ isB = \case {B {} -> True; _ -> False} -- just give it integers for those. benchChooseData :: Benchmark benchChooseData = bgroup (show name) [mkBM d | d <- take 100 dataSample] - where name = ChooseData - mkBM d = benchDefault (showMemoryUsage d) $ - mkApp6 name [integer] d (111::Integer) (222::Integer) - (333::Integer) (444::Integer) (555::Integer) - + where + name = ChooseData + mkBM d = + benchDefault (showMemoryUsage d) $ + mkApp6 + name + [integer] + d + (111 :: Integer) + (222 :: Integer) + (333 :: Integer) + (444 :: Integer) + (555 :: Integer) ---------------- Construction ---------------- -- Apply Constr to an integer and a list of Data benchConstrData :: StdGen -> Benchmark benchConstrData gen = createTwoTermBuiltinBench ConstrData [] ints lists - where (ints, _) = makeSizedIntegers gen [1..20] - lists = take 20 . map unList $ filter isList dataSample - unList = \case { List l -> l ; _ -> error "Expected List" } + where + (ints, _) = makeSizedIntegers gen [1 .. 20] + lists = take 20 . map unList $ filter isList dataSample + unList = \case List l -> l; _ -> error "Expected List" benchMapData :: Benchmark benchMapData = createOneTermBuiltinBench MapData [] pairs - where pairs = take 50 . map unMap $ filter isMap dataSample - unMap = \case { Map l -> l ; _ -> error "Expected Map" } + where + pairs = take 50 . map unMap $ filter isMap dataSample + unMap = \case Map l -> l; _ -> error "Expected Map" + -- -- Apply List benchListData :: Benchmark benchListData = createOneTermBuiltinBench ListData [] lists - where lists = take 50 . map unList $ filter isList dataSample - unList = \case { List l -> l ; _ -> error "Expected List" } + where + lists = take 50 . map unList $ filter isList dataSample + unList = \case List l -> l; _ -> error "Expected List" -- Apply I benchIData :: Benchmark benchIData = - createOneTermBuiltinBench IData [] ints - where ints = take 50 . map unI $ filter isI dataSample - unI = \case { I n -> n ; _ -> error "Expected I" } + createOneTermBuiltinBench IData [] ints + where + ints = take 50 . map unI $ filter isI dataSample + unI = \case I n -> n; _ -> error "Expected I" -- Apply B benchBData :: Benchmark benchBData = - createOneTermBuiltinBench BData [] bss - where bss = take 50 . map unB $ filter isB dataSample - unB = \case { B s -> s ; _ -> error "Expected B" } - + createOneTermBuiltinBench BData [] bss + where + bss = take 50 . map unB $ filter isB dataSample + unB = \case B s -> s; _ -> error "Expected B" ---------------- Elimination ---------------- -- Match against Constr, failing otherwise benchUnConstrData :: Benchmark benchUnConstrData = createOneTermBuiltinBench UnConstrData [] constrData - where constrData = take 50 $ filter isConstr dataSample + where + constrData = take 50 $ filter isConstr dataSample -- Match against Map, failing otherwise benchUnMapData :: Benchmark benchUnMapData = createOneTermBuiltinBench UnMapData [] mapData - where mapData = take 50 $ filter isMap dataSample - + where + mapData = take 50 $ filter isMap dataSample -- Match against List, failing otherwise benchUnListData :: Benchmark benchUnListData = createOneTermBuiltinBench UnListData [] listData - where listData = take 100 $ filter isList dataSample + where + listData = take 100 $ filter isList dataSample -- Match against I, failing otherwise benchUnIData :: Benchmark benchUnIData = createOneTermBuiltinBench UnIData [] idata - where idata = take 50 $ filter isI dataSample + where + idata = take 50 $ filter isI dataSample -- Match against B, failing otherwise benchUnBData :: Benchmark benchUnBData = createOneTermBuiltinBench UnBData [] bdata - where bdata = take 50 $ filter isB dataSample + where + bdata = take 50 $ filter isB dataSample ---------------- Equality ---------------- @@ -122,30 +135,33 @@ benchUnBData = createOneTermBuiltinBench UnBData [] bdata -- the costs of sub-components. benchEqualsData :: Benchmark benchEqualsData = - createTwoTermBuiltinBenchElementwise EqualsData [] $ pairWith copyData dataSampleForEq - -- 400 elements: should take about 35 minutes to benchmark + createTwoTermBuiltinBenchElementwise EqualsData [] $ pairWith copyData dataSampleForEq + +-- 400 elements: should take about 35 minutes to benchmark benchSerialiseData :: Benchmark benchSerialiseData = - createOneTermBuiltinBench SerialiseData [] args - where args = dataSampleForEq - -- FIXME: see if we can find a better sample for this. More generally, how - -- does the internal structure of a Data object influence serialisation - -- time? What causes a Data object to be quick or slow to serialise? + createOneTermBuiltinBench SerialiseData [] args + where + args = dataSampleForEq + +-- FIXME: see if we can find a better sample for this. More generally, how +-- does the internal structure of a Data object influence serialisation +-- time? What causes a Data object to be quick or slow to serialise? makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks gen = - [ benchChooseData - , benchConstrData gen - , benchMapData - , benchListData - , benchIData - , benchBData - , benchUnConstrData - , benchUnMapData - , benchUnListData - , benchUnIData - , benchUnBData - , benchEqualsData - , benchSerialiseData - ] + [ benchChooseData + , benchConstrData gen + , benchMapData + , benchListData + , benchIData + , benchBData + , benchUnConstrData + , benchUnMapData + , benchUnListData + , benchUnIData + , benchUnBData + , benchEqualsData + , benchSerialiseData + ] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Integers.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Integers.hs index 2873f0e200a..312b1661450 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Integers.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Integers.hs @@ -16,19 +16,19 @@ import System.Random (StdGen) fact probably only occupy one word). We still need to guard against denial of service, and we may need to impose penalties for *really* large inputs. -} makeDefaultIntegerArgs :: StdGen -> ([Integer], StdGen) -makeDefaultIntegerArgs gen = makeSizedIntegers gen [1, 3..31] -- 16 entries +makeDefaultIntegerArgs gen = makeSizedIntegers gen [1, 3 .. 31] -- 16 entries {- The default arguments give a constant costing function for addition and subtraction. These ones give us data where the linear trend is clear. -} makeLargeIntegerArgs :: StdGen -> ([Integer], StdGen) -makeLargeIntegerArgs gen = makeSizedIntegers gen [1, 70..1000] -- 15 entries +makeLargeIntegerArgs gen = makeSizedIntegers gen [1, 70 .. 1000] -- 15 entries benchTwoIntegers :: StdGen -> (StdGen -> ([Integer], StdGen)) -> DefaultFun -> Benchmark benchTwoIntegers gen makeArgs builtinName = - createTwoTermBuiltinBench builtinName [] inputs inputs' - where - (inputs, gen') = makeArgs gen - (inputs', _) = makeArgs gen' + createTwoTermBuiltinBench builtinName [] inputs inputs' + where + (inputs, gen') = makeArgs gen + (inputs', _) = makeArgs gen' {- Some larger inputs for cases where we're using the same number for both arguments. (A) If we're not examining all NxN pairs then we can examine @@ -36,12 +36,13 @@ benchTwoIntegers gen makeArgs builtinName = the results are very uniform with the smaller numbers, leading to occasional models with negative slopes. Using larger numbers may help to avoid this. -} makeBiggerIntegerArgs :: StdGen -> ([Integer], StdGen) -makeBiggerIntegerArgs gen = makeSizedIntegers gen [1, 3..101] +makeBiggerIntegerArgs gen = makeSizedIntegers gen [1, 3 .. 101] benchSameTwoIntegers :: StdGen -> DefaultFun -> Benchmark benchSameTwoIntegers gen builtinName = - createTwoTermBuiltinBenchElementwise builtinName [] $ pairWith copyInteger numbers - where (numbers,_) = makeBiggerIntegerArgs gen + createTwoTermBuiltinBenchElementwise builtinName [] $ pairWith copyInteger numbers + where + (numbers, _) = makeBiggerIntegerArgs gen {- `expModInteger a e m` calculates `a^e` modulo `m`; if `e` is negative then the function fails unless gcd(a,m) = 1, in which case there is an integer `a'` such @@ -69,29 +70,40 @@ call `modInteger` before calling `expModInteger`. benchExpModInteger :: StdGen -> Benchmark benchExpModInteger _gen = let fun = ExpModInteger - pow (a::Integer) (b::Integer) = a^b - moduli = fmap (\n -> pow 2 (32*n) - 11) [1, 3..31] - -- ^ 16 entries, sizes = 4, 12, ..., 124 bytes (memoryUsage = 1,2,...,16) + pow (a :: Integer) (b :: Integer) = a ^ b + moduli = fmap (\n -> pow 2 (32 * n) - 11) [1, 3 .. 31] + -- \^ 16 entries, sizes = 4, 12, ..., 124 bytes (memoryUsage = 1,2,...,16) es = fmap (\n -> pow 2 (fromIntegral $ integerLog2 n) - 1) moduli - -- ^ Largest number less than modulus with binary expansion 1111...1. + in -- \^ Largest number less than modulus with binary expansion 1111...1. -- This is the worst case. - in bgroup (show fun) - [bgroup (showMemoryUsage (m `div` 3)) - [bgroup (showMemoryUsage e) - [mkBM a e m | a <- [m `div` 3] ] | e <- es ] | m <- moduli ] - where mkBM a e m = - benchDefault (showMemoryUsage m) $ - mkApp3 ExpModInteger [] a e m + bgroup + (show fun) + [ bgroup + (showMemoryUsage (m `div` 3)) + [ bgroup + (showMemoryUsage e) + [mkBM a e m | a <- [m `div` 3]] + | e <- es + ] + | m <- moduli + ] + where + mkBM a e m = + benchDefault (showMemoryUsage m) $ + mkApp3 ExpModInteger [] a e m makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks gen = - [benchTwoIntegers gen makeLargeIntegerArgs AddInteger]-- SubtractInteger behaves identically. + [benchTwoIntegers gen makeLargeIntegerArgs AddInteger] -- SubtractInteger behaves identically. <> (benchTwoIntegers gen makeDefaultIntegerArgs <$> [MultiplyInteger, DivideInteger]) - -- RemainderInteger, QuotientInteger, and ModInteger all behave identically. - <> (benchSameTwoIntegers gen <$> [ EqualsInteger - , LessThanInteger - , LessThanEqualsInteger - ]) - <> [-- benchExpModInteger gen, - benchExpModInteger gen] + -- RemainderInteger, QuotientInteger, and ModInteger all behave identically. + <> ( benchSameTwoIntegers gen + <$> [ EqualsInteger + , LessThanInteger + , LessThanEqualsInteger + ] + ) + <> [ -- benchExpModInteger gen, + benchExpModInteger gen + ] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Lists.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Lists.hs index 2d973a124b6..4a44532c7cc 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Lists.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Lists.hs @@ -11,7 +11,6 @@ import Hedgehog qualified as H import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally (..)) import System.Random (StdGen, randomR) - {- Some functions for generating lists of sizes integers/bytestrings The time behaviour of the list functions should be independent of the sizes and types of the arguments (and in fact constant), but we benchmark them with both @@ -19,44 +18,46 @@ import System.Random (StdGen, randomR) makeListOfSizedIntegers :: StdGen -> Int -> Int -> ([Integer], StdGen) makeListOfSizedIntegers gen count size = - makeSizedIntegers gen (take count $ repeat size) + makeSizedIntegers gen (take count $ repeat size) makeListOfIntegerLists :: StdGen -> [(Int, Int)] -> [[Integer]] -makeListOfIntegerLists _ [] = [] -makeListOfIntegerLists gen ((count, size):rest) = - let (l, gen') = makeListOfSizedIntegers gen count size - in l:(makeListOfIntegerLists gen' rest) +makeListOfIntegerLists _ [] = [] +makeListOfIntegerLists gen ((count, size) : rest) = + let (l, gen') = makeListOfSizedIntegers gen count size + in l : (makeListOfIntegerLists gen' rest) makeListOfSizedBytestrings :: H.Seed -> Int -> Int -> [ByteString] makeListOfSizedBytestrings seed count size = - makeSizedByteStrings seed (take count $ repeat size) + makeSizedByteStrings seed (take count $ repeat size) makeListOfByteStringLists :: H.Seed -> [(Int, Int)] -> [[ByteString]] -makeListOfByteStringLists _ [] = [] -makeListOfByteStringLists seed ((count, size):rest) = - let l = makeListOfSizedBytestrings seed count size - in l:makeListOfByteStringLists seed rest +makeListOfByteStringLists _ [] = [] +makeListOfByteStringLists seed ((count, size) : rest) = + let l = makeListOfSizedBytestrings seed count size + in l : makeListOfByteStringLists seed rest + -- Don't like reusing the seed here. intLists :: StdGen -> [[Integer]] -intLists gen = makeListOfIntegerLists gen [(count,size) | count <- [0..7], size <- [1..7]] +intLists gen = makeListOfIntegerLists gen [(count, size) | count <- [0 .. 7], size <- [1 .. 7]] -- Make a list of n integers whose value is less than or equal to m intMaxList :: Integer -> Integer -> StdGen -> [Integer] intMaxList 0 _ _ = [] -intMaxList n m gen = (v : (intMaxList (n-1) m g2)) - where (v , g2) = randomR ((0::Integer),m) gen +intMaxList n m gen = (v : (intMaxList (n - 1) m g2)) + where + (v, g2) = randomR ((0 :: Integer), m) gen nonEmptyIntLists :: StdGen -> [[Integer]] -nonEmptyIntLists gen = makeListOfIntegerLists gen [(count,size) | count <- [1..7], size <- [1..7]] +nonEmptyIntLists gen = makeListOfIntegerLists gen [(count, size) | count <- [1 .. 7], size <- [1 .. 7]] byteStringLists :: H.Seed -> [[ByteString]] byteStringLists seed = - makeListOfByteStringLists seed [(count,size) | count <- [0..7], size <- [0, 500..3000]] + makeListOfByteStringLists seed [(count, size) | count <- [0 .. 7], size <- [0, 500 .. 3000]] nonEmptyByteStringLists :: H.Seed -> [[ByteString]] nonEmptyByteStringLists seed = - makeListOfByteStringLists seed [(count,size) | count <- [1..7], size <- [0, 500..3000]] + makeListOfByteStringLists seed [(count, size) | count <- [1 .. 7], size <- [0, 500 .. 3000]] -- chooseList l a b = case l of [] -> a | _ -> b -- We expect this to be constant time, but check anyway. We look at a subset of @@ -64,66 +65,84 @@ nonEmptyByteStringLists seed = -- different sizes. benchChooseList :: StdGen -> Benchmark benchChooseList gen = - let name = ChooseList - resultSizes = [100, 500, 1500, 3000, 5000] - results1 = makeSizedByteStrings seedA resultSizes - results2 = makeSizedByteStrings seedB resultSizes - intInputs = take 10 $ intLists gen - bsInputs = take 10 $ byteStringLists seedA - mkBMs tys inputs = [ bgroup (showMemoryUsage x) - [ bgroup (showMemoryUsage r1) - [ benchDefault (showMemoryUsage r2) $ mkApp3 name tys x r1 r2 - | r2 <- results2 ] - | r1 <- results1 ] - | x <- inputs ] - in bgroup (show name) (mkBMs [integer,bytestring] intInputs - ++ mkBMs [bytestring,bytestring] bsInputs) + let name = ChooseList + resultSizes = [100, 500, 1500, 3000, 5000] + results1 = makeSizedByteStrings seedA resultSizes + results2 = makeSizedByteStrings seedB resultSizes + intInputs = take 10 $ intLists gen + bsInputs = take 10 $ byteStringLists seedA + mkBMs tys inputs = + [ bgroup + (showMemoryUsage x) + [ bgroup + (showMemoryUsage r1) + [ benchDefault (showMemoryUsage r2) $ mkApp3 name tys x r1 r2 + | r2 <- results2 + ] + | r1 <- results1 + ] + | x <- inputs + ] + in bgroup + (show name) + ( mkBMs [integer, bytestring] intInputs + ++ mkBMs [bytestring, bytestring] bsInputs + ) benchMkCons :: StdGen -> Benchmark benchMkCons gen = - let name = MkCons - intInputs = intLists gen - (intsToCons, _) = makeSizedIntegers gen $ take (length intInputs) (cycle [1,2,4,10,15]) - bsInputs = byteStringLists seedA - bssToCons = - makeSizedByteStrings seedA $ take (length bsInputs) (cycle [5,80,500, 1000, 5000]) - mkBM ty (x,xs) = benchDefault (showMemoryUsage x) $ mkApp2 name [ty] x xs - in bgroup (show name) $ fmap (mkBM integer) (zip intsToCons intInputs) - ++ fmap (mkBM bytestring) (zip bssToCons bsInputs) + let name = MkCons + intInputs = intLists gen + (intsToCons, _) = makeSizedIntegers gen $ take (length intInputs) (cycle [1, 2, 4, 10, 15]) + bsInputs = byteStringLists seedA + bssToCons = + makeSizedByteStrings seedA $ take (length bsInputs) (cycle [5, 80, 500, 1000, 5000]) + mkBM ty (x, xs) = benchDefault (showMemoryUsage x) $ mkApp2 name [ty] x xs + in bgroup (show name) $ + fmap (mkBM integer) (zip intsToCons intInputs) + ++ fmap (mkBM bytestring) (zip bssToCons bsInputs) -- For headList and tailList benchNonEmptyList :: StdGen -> DefaultFun -> Benchmark benchNonEmptyList gen name = - bgroup (show name) $ fmap (mkBM integer) (nonEmptyIntLists gen) - ++ fmap (mkBM bytestring) (nonEmptyByteStringLists seedA) - where mkBM ty x = benchDefault (showMemoryUsage x) $ mkApp1 name [ty] x + bgroup (show name) $ + fmap (mkBM integer) (nonEmptyIntLists gen) + ++ fmap (mkBM bytestring) (nonEmptyByteStringLists seedA) + where + mkBM ty x = benchDefault (showMemoryUsage x) $ mkApp1 name [ty] x -- nullList tests if a list is empty benchNullList :: StdGen -> Benchmark benchNullList gen = - bgroup (show name) $ fmap (mkBM integer) (intLists gen) - ++ fmap (mkBM bytestring) (byteStringLists seedA) - where mkBM ty x = benchDefault (showMemoryUsage x) $ mkApp1 name [ty] x - name = NullList + bgroup (show name) $ + fmap (mkBM integer) (intLists gen) + ++ fmap (mkBM bytestring) (byteStringLists seedA) + where + mkBM ty x = benchDefault (showMemoryUsage x) $ mkApp1 name [ty] x + name = NullList -- dropList n ls -- We expect this to be linear with the value of n. benchDropList :: StdGen -> Benchmark benchDropList gen = - let name = DropList - resultSizes = [100, 500, 1500, 3000, 5000] - -- Produce lists of sz items, each of sz length - stringlists = makeListOfByteStringLists seedA [ (sz , sz) | sz <- resultSizes ] - intInputs = [ intMaxList 10 (toInteger sz) gen | sz <- resultSizes ] - inputs = concat [[(n , rs) | n <- ns] | (ns, rs) <- zip intInputs stringlists] - in createTwoTermBuiltinBenchElementwiseWithWrappers - (IntegerCostedLiterally, id) name [bytestring] inputs + let name = DropList + resultSizes = [100, 500, 1500, 3000, 5000] + -- Produce lists of sz items, each of sz length + stringlists = makeListOfByteStringLists seedA [(sz, sz) | sz <- resultSizes] + intInputs = [intMaxList 10 (toInteger sz) gen | sz <- resultSizes] + inputs = concat [[(n, rs) | n <- ns] | (ns, rs) <- zip intInputs stringlists] + in createTwoTermBuiltinBenchElementwiseWithWrappers + (IntegerCostedLiterally, id) + name + [bytestring] + inputs makeBenchmarks :: StdGen -> [Benchmark] -makeBenchmarks gen = [ benchChooseList gen - , benchMkCons gen - , benchNonEmptyList gen HeadList - , benchNonEmptyList gen TailList - , benchNullList gen - , benchDropList gen - ] +makeBenchmarks gen = + [ benchChooseList gen + , benchMkCons gen + , benchNonEmptyList gen HeadList + , benchNonEmptyList gen TailList + , benchNullList gen + , benchDropList gen + ] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Misc.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Misc.hs index 0bc72d35ec7..4e3b934f850 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Misc.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Misc.hs @@ -8,19 +8,20 @@ import PlutusCore import Criterion.Main import System.Random (StdGen) - -- mkPairData takes two 'Data' arguments d1 and d2 and creates the pair -- (d1,d2). This shouldn't depend on the size of the argumnts, but we'll run it -- with a selection of different sizes just to make sure. benchMkPairData :: Benchmark benchMkPairData = - createTwoTermBuiltinBench MkPairData [] l1 l2 - where l1 = take 20 dataSample - l2 = take 20 (drop 20 dataSample) + createTwoTermBuiltinBench MkPairData [] l1 l2 + where + l1 = take 20 dataSample + l2 = take 20 (drop 20 dataSample) benchUnitArgBuiltin :: DefaultFun -> Benchmark benchUnitArgBuiltin fun = createOneTermBuiltinBench fun [] (take 100 $ repeat ()) makeBenchmarks :: StdGen -> [Benchmark] -makeBenchmarks _gen = [ benchMkPairData ] - <> (benchUnitArgBuiltin <$> [MkNilData, MkNilPairData]) +makeBenchmarks _gen = + [benchMkPairData] + <> (benchUnitArgBuiltin <$> [MkNilData, MkNilPairData]) diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs index 9aac5e56194..bcd4e294a48 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs @@ -1,16 +1,14 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{- | A set of no-op built-in functions used in cost model calibration. Benchmarks - based on these are used to estimate the overhead of calling a built-in - function. --} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | A set of no-op built-in functions used in cost model calibration. Benchmarks +-- based on these are used to estimate the overhead of calling a built-in +-- function. module Benchmarks.Nops (makeBenchmarks) where import Common @@ -31,263 +29,278 @@ import Criterion.Main (Benchmark, bgroup) import Data.Ix (Ix) import System.Random (StdGen) -{- | A benchmark that just loads the unit constant, which is about the minimal - amount of work we can do. This should give an idea of the cost of starting - the evaluator. -} +-- | A benchmark that just loads the unit constant, which is about the minimal +-- amount of work we can do. This should give an idea of the cost of starting +-- the evaluator. benchUnitTerm :: Benchmark benchUnitTerm = - bgroup "UnitTerm" [benchWith nopCostParameters (showMemoryUsage ()) $ mkUnit ] - - -{- | Arguments to builtins can be treated in several different ways. Constants of - built-in types are unlifted to Haskell values automatically and Opaque values - don't need to be unlifted; unlifting can also be done manually using - SomeConstant. Each of these has different costs, and each is used in the - existing set of builtins (and even for a single function different arguments - may be handled in different ways, as in ifThenElse where the first argument - is a built-in Bool value but the last two are Opaque PLC values). These - benchmarks are intended to give some idea of how much overhead each of these - processses incurs; the results are used in the R code that we use to fit cost - models. There's also a cost for lifting the result of a builtin call back to - a Plutus value, and that's included in the benchmark results as well. -} + bgroup "UnitTerm" [benchWith nopCostParameters (showMemoryUsage ()) $ mkUnit] +-- | Arguments to builtins can be treated in several different ways. Constants of +-- built-in types are unlifted to Haskell values automatically and Opaque values +-- don't need to be unlifted; unlifting can also be done manually using +-- SomeConstant. Each of these has different costs, and each is used in the +-- existing set of builtins (and even for a single function different arguments +-- may be handled in different ways, as in ifThenElse where the first argument +-- is a built-in Bool value but the last two are Opaque PLC values). These +-- benchmarks are intended to give some idea of how much overhead each of these +-- processses incurs; the results are used in the R code that we use to fit cost +-- models. There's also a cost for lifting the result of a builtin call back to +-- a Plutus value, and that's included in the benchmark results as well. data NopFun - = Nop1b -- Built-in Bool - | Nop2b - | Nop3b - | Nop4b - | Nop5b - | Nop6b - | Nop1i -- Built-in Integer - | Nop2i - | Nop3i - | Nop4i - | Nop5i - | Nop6i - | Nop1c -- Integer: lifted via SomeConstant - | Nop2c - | Nop3c - | Nop4c - | Nop5c - | Nop6c - | Nop1o -- Opaque Integer: no unlifting required - | Nop2o - | Nop3o - | Nop4o - | Nop5o - | Nop6o - deriving stock (Show, Eq, Ord, Enum, Ix, Bounded, Generic) - deriving anyclass (PrettyBy PrettyConfigPlc) + = Nop1b -- Built-in Bool + | Nop2b + | Nop3b + | Nop4b + | Nop5b + | Nop6b + | Nop1i -- Built-in Integer + | Nop2i + | Nop3i + | Nop4i + | Nop5i + | Nop6i + | Nop1c -- Integer: lifted via SomeConstant + | Nop2c + | Nop3c + | Nop4c + | Nop5c + | Nop6c + | Nop1o -- Opaque Integer: no unlifting required + | Nop2o + | Nop3o + | Nop4o + | Nop5o + | Nop6o + deriving stock (Show, Eq, Ord, Enum, Ix, Bounded, Generic) + deriving anyclass (PrettyBy PrettyConfigPlc) instance Pretty NopFun where - pretty fun = pretty $ lowerInitialChar $ show fun + pretty fun = pretty $ lowerInitialChar $ show fun -data NopCostModel = - NopCostModel - { paramNop1 :: CostingFun ModelOneArgument - , paramNop2 :: CostingFun ModelTwoArguments - , paramNop3 :: CostingFun ModelThreeArguments - , paramNop4 :: CostingFun ModelFourArguments - , paramNop5 :: CostingFun ModelFiveArguments - , paramNop6 :: CostingFun ModelSixArguments - } +data NopCostModel + = NopCostModel + { paramNop1 :: CostingFun ModelOneArgument + , paramNop2 :: CostingFun ModelTwoArguments + , paramNop3 :: CostingFun ModelThreeArguments + , paramNop4 :: CostingFun ModelFourArguments + , paramNop5 :: CostingFun ModelFiveArguments + , paramNop6 :: CostingFun ModelSixArguments + } -{- | A fake cost model for nops. This is just to make sure that the overhead of - calling a costing function of the expected form is included, so the precise - contents don't matter as long as the basic form is correct (and benchmarks - suggest that nops indeed have constant costs). -} +-- | A fake cost model for nops. This is just to make sure that the overhead of +-- calling a costing function of the expected form is included, so the precise +-- contents don't matter as long as the basic form is correct (and benchmarks +-- suggest that nops indeed have constant costs). nopCostModel :: NopCostModel nopCostModel = - NopCostModel - { - paramNop1 = CostingFun - (ModelOneArgumentConstantCost 1000000) - (ModelOneArgumentConstantCost 100) - , paramNop2 = CostingFun - (ModelTwoArgumentsConstantCost 1250000) - (ModelTwoArgumentsConstantCost 200) - , paramNop3 = CostingFun - (ModelThreeArgumentsConstantCost 1500000) - (ModelThreeArgumentsConstantCost 300) - , paramNop4 = CostingFun - (ModelFourArgumentsConstantCost 1750000) - (ModelFourArgumentsConstantCost 400) - , paramNop5 = CostingFun - (ModelFiveArgumentsConstantCost 2000000) - (ModelFiveArgumentsConstantCost 500) - , paramNop6 = CostingFun - (ModelSixArgumentsConstantCost 2250000) - (ModelSixArgumentsConstantCost 600) + NopCostModel + { paramNop1 = + CostingFun + (ModelOneArgumentConstantCost 1000000) + (ModelOneArgumentConstantCost 100) + , paramNop2 = + CostingFun + (ModelTwoArgumentsConstantCost 1250000) + (ModelTwoArgumentsConstantCost 200) + , paramNop3 = + CostingFun + (ModelThreeArgumentsConstantCost 1500000) + (ModelThreeArgumentsConstantCost 300) + , paramNop4 = + CostingFun + (ModelFourArgumentsConstantCost 1750000) + (ModelFourArgumentsConstantCost 400) + , paramNop5 = + CostingFun + (ModelFiveArgumentsConstantCost 2000000) + (ModelFiveArgumentsConstantCost 500) + , paramNop6 = + CostingFun + (ModelSixArgumentsConstantCost 2250000) + (ModelSixArgumentsConstantCost 600) } nopCostParameters :: MachineParameters CekMachineCosts NopFun (CekValue DefaultUni NopFun ()) nopCostParameters = - MachineParameters def . mkMachineVariantParameters def $ - CostModel defaultCekMachineCostsForTesting nopCostModel + MachineParameters def . mkMachineVariantParameters def $ + CostModel defaultCekMachineCostsForTesting nopCostModel -- This is just to avoid some deeply nested case expressions for the NopNc -- functions below. There is a Monad instance for EvaluationResult, but that -- appears to be a little slower than this. -infixr >: -(>:) :: uni ~ DefaultUni - => SomeConstant uni Integer - -> BuiltinResult Integer - -> BuiltinResult Integer +infixr 9 >: +(>:) :: + uni ~ DefaultUni => + SomeConstant uni Integer -> + BuiltinResult Integer -> + BuiltinResult Integer n >: k = - case n of - SomeConstant (Some (ValueOf DefaultUniInteger _)) -> k - _ -> builtinResultFailure + case n of + SomeConstant (Some (ValueOf DefaultUniInteger _)) -> k + _ -> builtinResultFailure {-# INLINE (>:) #-} -{- | The meanings of the builtins. Each one takes a number of arguments and - returns a result without doing any other work. A builtin can process its - arguments in several different ways (see Note [How to add a built-in - function: simple cases] etc.), and these have different costs. We measure - all of these here to facilitate exploration of their different contributions - to execution costs (which may change if there are changes in the builtin - machinery in future). Most of the builtins take Integers since we can easily - change the sizes of these to check that the size doesn't influence the cost; - we also have some nops over Bool to check that the type doesn't influence the - cost either. --} +-- | The meanings of the builtins. Each one takes a number of arguments and +-- returns a result without doing any other work. A builtin can process its +-- arguments in several different ways (see Note [How to add a built-in +-- function: simple cases] etc.), and these have different costs. We measure +-- all of these here to facilitate exploration of their different contributions +-- to execution costs (which may change if there are changes in the builtin +-- machinery in future). Most of the builtins take Integers since we can easily +-- change the sizes of these to check that the size doesn't influence the cost; +-- we also have some nops over Bool to check that the type doesn't influence the +-- cost either. instance uni ~ DefaultUni => ToBuiltinMeaning uni NopFun where - type CostingPart uni NopFun = NopCostModel + type CostingPart uni NopFun = NopCostModel - data BuiltinSemanticsVariant NopFun = NopFunSemanticsVariantX + data BuiltinSemanticsVariant NopFun = NopFunSemanticsVariantX - -- Built-in Bools - toBuiltinMeaning - :: forall val . HasMeaningIn uni val - => BuiltinSemanticsVariant NopFun - -> NopFun - -> BuiltinMeaning val NopCostModel - toBuiltinMeaning _semvar Nop1b = - makeBuiltinMeaning - @(Bool -> Bool) - (\_ -> True) - (runCostingFunOneArgument . paramNop1) - toBuiltinMeaning _semvar Nop2b = - makeBuiltinMeaning - @(Bool -> Bool -> Bool) - (\_ _ -> True) - (runCostingFunTwoArguments . paramNop2) - toBuiltinMeaning _semvar Nop3b = - makeBuiltinMeaning - @(Bool -> Bool -> Bool -> Bool) - (\_ _ _ -> True) - (runCostingFunThreeArguments . paramNop3) - toBuiltinMeaning _semvar Nop4b = - makeBuiltinMeaning - @(Bool -> Bool -> Bool -> Bool -> Bool) - (\_ _ _ _ -> True) - (runCostingFunFourArguments . paramNop4) - toBuiltinMeaning _semvar Nop5b = - makeBuiltinMeaning - @(Bool -> Bool -> Bool -> Bool -> Bool -> Bool) - (\_ _ _ _ _ -> True) - (runCostingFunFiveArguments . paramNop5) - toBuiltinMeaning _semvar Nop6b = - makeBuiltinMeaning - @(Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool) - (\_ _ _ _ _ _ -> True) - (runCostingFunSixArguments . paramNop6) - -- Built-in Integers - toBuiltinMeaning _semvar Nop1i = - makeBuiltinMeaning - @(Integer -> Integer) - (\_ -> 11) - (runCostingFunOneArgument . paramNop1) - toBuiltinMeaning _semvar Nop2i = - makeBuiltinMeaning - @(Integer -> Integer -> Integer) - (\_ _ -> 22) - (runCostingFunTwoArguments . paramNop2) - toBuiltinMeaning _semvar Nop3i = - makeBuiltinMeaning - @(Integer -> Integer -> Integer -> Integer) - (\_ _ _ -> 33) - (runCostingFunThreeArguments . paramNop3) - toBuiltinMeaning _semvar Nop4i = - makeBuiltinMeaning - @(Integer -> Integer -> Integer -> Integer -> Integer) - (\_ _ _ _ -> 44) - (runCostingFunFourArguments . paramNop4) - toBuiltinMeaning _semvar Nop5i = - makeBuiltinMeaning - @(Integer -> Integer -> Integer -> Integer -> Integer -> Integer) - (\_ _ _ _ _ -> 55) - (runCostingFunFiveArguments . paramNop5) - toBuiltinMeaning _semvar Nop6i = - makeBuiltinMeaning - @(Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer) - (\_ _ _ _ _ _ -> 66) - (runCostingFunSixArguments . paramNop6) - -- Integers unlifted via SomeConstant - toBuiltinMeaning _semvar Nop1c = - makeBuiltinMeaning - (\c1 -> c1 >: BuiltinSuccess 11) - (runCostingFunOneArgument . paramNop1) - toBuiltinMeaning _semvar Nop2c = - makeBuiltinMeaning - (\c1 c2 -> c1 >: c2 >: BuiltinSuccess 22) - (runCostingFunTwoArguments . paramNop2) - toBuiltinMeaning _semvar Nop3c = - makeBuiltinMeaning - (\c1 c2 c3 -> c1 >: c2 >: c3 >: BuiltinSuccess 33) - (runCostingFunThreeArguments . paramNop3) - toBuiltinMeaning _semvar Nop4c = - makeBuiltinMeaning - (\c1 c2 c3 c4 -> c1 >: c2 >: c3 >: c4 >: BuiltinSuccess 44) - (runCostingFunFourArguments . paramNop4) - toBuiltinMeaning _semvar Nop5c = - makeBuiltinMeaning - (\c1 c2 c3 c4 c5 -> c1 >: c2 >: c3 >: c4 >: c5 >: BuiltinSuccess 55) - (runCostingFunFiveArguments . paramNop5) - toBuiltinMeaning _semvar Nop6c = - makeBuiltinMeaning - (\c1 c2 c3 c4 c5 c6 -> c1 >: c2 >: c3 >: c4 >: c5 >: c6 >: BuiltinSuccess 66) - (runCostingFunSixArguments . paramNop6) - -- Opaque Integers - toBuiltinMeaning _semvar Nop1o = - makeBuiltinMeaning - @(Opaque val Integer -> Opaque val Integer) - (\_ -> fromValueOf DefaultUniInteger 11) - (runCostingFunOneArgument . paramNop1) - toBuiltinMeaning _semvar Nop2o = - makeBuiltinMeaning - @(Opaque val Integer -> Opaque val Integer-> Opaque val Integer) - (\_ _ -> fromValueOf DefaultUniInteger 22) - (runCostingFunTwoArguments . paramNop2) - toBuiltinMeaning _semvar Nop3o = - makeBuiltinMeaning - @(Opaque val Integer -> Opaque val Integer-> Opaque val Integer-> Opaque val Integer) - (\_ _ _ -> fromValueOf DefaultUniInteger 33) - (runCostingFunThreeArguments . paramNop3) - toBuiltinMeaning _semvar Nop4o = - makeBuiltinMeaning - @(Opaque val Integer - -> Opaque val Integer - -> Opaque val Integer - -> Opaque val Integer - -> Opaque val Integer) - (\_ _ _ _ -> fromValueOf DefaultUniInteger 44) - (runCostingFunFourArguments . paramNop4) - toBuiltinMeaning _semvar Nop5o = - makeBuiltinMeaning - @(Opaque val Integer -> Opaque val Integer-> Opaque val Integer - -> Opaque val Integer -> Opaque val Integer -> Opaque val Integer) - (\_ _ _ _ _ -> fromValueOf DefaultUniInteger 55) - (runCostingFunFiveArguments . paramNop5) - toBuiltinMeaning _semvar Nop6o = - makeBuiltinMeaning - @(Opaque val Integer -> Opaque val Integer-> Opaque val Integer - -> Opaque val Integer -> Opaque val Integer -> Opaque val Integer - -> Opaque val Integer) - (\_ _ _ _ _ _ -> fromValueOf DefaultUniInteger 66) - (runCostingFunSixArguments . paramNop6) + -- Built-in Bools + toBuiltinMeaning :: + forall val. + HasMeaningIn uni val => + BuiltinSemanticsVariant NopFun -> + NopFun -> + BuiltinMeaning val NopCostModel + toBuiltinMeaning _semvar Nop1b = + makeBuiltinMeaning + @(Bool -> Bool) + (\_ -> True) + (runCostingFunOneArgument . paramNop1) + toBuiltinMeaning _semvar Nop2b = + makeBuiltinMeaning + @(Bool -> Bool -> Bool) + (\_ _ -> True) + (runCostingFunTwoArguments . paramNop2) + toBuiltinMeaning _semvar Nop3b = + makeBuiltinMeaning + @(Bool -> Bool -> Bool -> Bool) + (\_ _ _ -> True) + (runCostingFunThreeArguments . paramNop3) + toBuiltinMeaning _semvar Nop4b = + makeBuiltinMeaning + @(Bool -> Bool -> Bool -> Bool -> Bool) + (\_ _ _ _ -> True) + (runCostingFunFourArguments . paramNop4) + toBuiltinMeaning _semvar Nop5b = + makeBuiltinMeaning + @(Bool -> Bool -> Bool -> Bool -> Bool -> Bool) + (\_ _ _ _ _ -> True) + (runCostingFunFiveArguments . paramNop5) + toBuiltinMeaning _semvar Nop6b = + makeBuiltinMeaning + @(Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool) + (\_ _ _ _ _ _ -> True) + (runCostingFunSixArguments . paramNop6) + -- Built-in Integers + toBuiltinMeaning _semvar Nop1i = + makeBuiltinMeaning + @(Integer -> Integer) + (\_ -> 11) + (runCostingFunOneArgument . paramNop1) + toBuiltinMeaning _semvar Nop2i = + makeBuiltinMeaning + @(Integer -> Integer -> Integer) + (\_ _ -> 22) + (runCostingFunTwoArguments . paramNop2) + toBuiltinMeaning _semvar Nop3i = + makeBuiltinMeaning + @(Integer -> Integer -> Integer -> Integer) + (\_ _ _ -> 33) + (runCostingFunThreeArguments . paramNop3) + toBuiltinMeaning _semvar Nop4i = + makeBuiltinMeaning + @(Integer -> Integer -> Integer -> Integer -> Integer) + (\_ _ _ _ -> 44) + (runCostingFunFourArguments . paramNop4) + toBuiltinMeaning _semvar Nop5i = + makeBuiltinMeaning + @(Integer -> Integer -> Integer -> Integer -> Integer -> Integer) + (\_ _ _ _ _ -> 55) + (runCostingFunFiveArguments . paramNop5) + toBuiltinMeaning _semvar Nop6i = + makeBuiltinMeaning + @(Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer) + (\_ _ _ _ _ _ -> 66) + (runCostingFunSixArguments . paramNop6) + -- Integers unlifted via SomeConstant + toBuiltinMeaning _semvar Nop1c = + makeBuiltinMeaning + (\c1 -> c1 >: BuiltinSuccess 11) + (runCostingFunOneArgument . paramNop1) + toBuiltinMeaning _semvar Nop2c = + makeBuiltinMeaning + (\c1 c2 -> c1 >: c2 >: BuiltinSuccess 22) + (runCostingFunTwoArguments . paramNop2) + toBuiltinMeaning _semvar Nop3c = + makeBuiltinMeaning + (\c1 c2 c3 -> c1 >: c2 >: c3 >: BuiltinSuccess 33) + (runCostingFunThreeArguments . paramNop3) + toBuiltinMeaning _semvar Nop4c = + makeBuiltinMeaning + (\c1 c2 c3 c4 -> c1 >: c2 >: c3 >: c4 >: BuiltinSuccess 44) + (runCostingFunFourArguments . paramNop4) + toBuiltinMeaning _semvar Nop5c = + makeBuiltinMeaning + (\c1 c2 c3 c4 c5 -> c1 >: c2 >: c3 >: c4 >: c5 >: BuiltinSuccess 55) + (runCostingFunFiveArguments . paramNop5) + toBuiltinMeaning _semvar Nop6c = + makeBuiltinMeaning + (\c1 c2 c3 c4 c5 c6 -> c1 >: c2 >: c3 >: c4 >: c5 >: c6 >: BuiltinSuccess 66) + (runCostingFunSixArguments . paramNop6) + -- Opaque Integers + toBuiltinMeaning _semvar Nop1o = + makeBuiltinMeaning + @(Opaque val Integer -> Opaque val Integer) + (\_ -> fromValueOf DefaultUniInteger 11) + (runCostingFunOneArgument . paramNop1) + toBuiltinMeaning _semvar Nop2o = + makeBuiltinMeaning + @(Opaque val Integer -> Opaque val Integer -> Opaque val Integer) + (\_ _ -> fromValueOf DefaultUniInteger 22) + (runCostingFunTwoArguments . paramNop2) + toBuiltinMeaning _semvar Nop3o = + makeBuiltinMeaning + @(Opaque val Integer -> Opaque val Integer -> Opaque val Integer -> Opaque val Integer) + (\_ _ _ -> fromValueOf DefaultUniInteger 33) + (runCostingFunThreeArguments . paramNop3) + toBuiltinMeaning _semvar Nop4o = + makeBuiltinMeaning + @( Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer + ) + (\_ _ _ _ -> fromValueOf DefaultUniInteger 44) + (runCostingFunFourArguments . paramNop4) + toBuiltinMeaning _semvar Nop5o = + makeBuiltinMeaning + @( Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer + ) + (\_ _ _ _ _ -> fromValueOf DefaultUniInteger 55) + (runCostingFunFiveArguments . paramNop5) + toBuiltinMeaning _semvar Nop6o = + makeBuiltinMeaning + @( Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer -> + Opaque val Integer + ) + (\_ _ _ _ _ _ -> fromValueOf DefaultUniInteger 66) + (runCostingFunSixArguments . paramNop6) instance Default (BuiltinSemanticsVariant NopFun) where - def = NopFunSemanticsVariantX + def = NopFunSemanticsVariantX ---------------- Benchmarks ---------------- @@ -303,143 +316,163 @@ instance Default (BuiltinSemanticsVariant NopFun) where -- There seems to be quite a lot of variation in repeated runs of these benchmarks. -- In general we have Built-in > SomeConstant > Opaque though. -{- | `benchNopN` generates N random inputs and makes a benchmark measuring how - long it takes the given function to run with those arguments. Take care that - N matches the number of arguments of the function or else you'll be - benchmarking an overapplication (which will fail) or a partial application - (which will succeed, but would give misleading results). For example, only - apply benchNop5 to a Nop5 function, not to something like Nop6i or Nop2o. - -} - -benchNop1 - :: (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) - => NopFun - -> (StdGen -> (a, StdGen)) - -> StdGen - -> Benchmark +-- | `benchNopN` generates N random inputs and makes a benchmark measuring how +-- long it takes the given function to run with those arguments. Take care that +-- N matches the number of arguments of the function or else you'll be +-- benchmarking an overapplication (which will fail) or a partial application +-- (which will succeed, but would give misleading results). For example, only +-- apply benchNop5 to a Nop5 function, not to something like Nop6i or Nop2o. +benchNop1 :: + (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) => + NopFun -> + (StdGen -> (a, StdGen)) -> + StdGen -> + Benchmark benchNop1 nop rand gen = - let (x,_) = rand gen - in bgroup (show nop) [benchWith nopCostParameters (showMemoryUsage x) $ mkApp1 nop [] x] + let (x, _) = rand gen + in bgroup (show nop) [benchWith nopCostParameters (showMemoryUsage x) $ mkApp1 nop [] x] -benchNop2 - :: (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) - => NopFun - -> (StdGen -> (a, StdGen)) - -> StdGen - -> Benchmark +benchNop2 :: + (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) => + NopFun -> + (StdGen -> (a, StdGen)) -> + StdGen -> + Benchmark benchNop2 nop rand gen = - let (x,gen1) = rand gen - (y,_) = rand gen1 - in bgroup (show nop) - [bgroup (showMemoryUsage x) + let (x, gen1) = rand gen + (y, _) = rand gen1 + in bgroup + (show nop) + [ bgroup + (showMemoryUsage x) [benchWith nopCostParameters (showMemoryUsage y) $ mkApp2 nop [] x y] - ] + ] -benchNop3 - :: (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) - => NopFun - -> (StdGen -> (a, StdGen)) - -> StdGen - -> Benchmark +benchNop3 :: + (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) => + NopFun -> + (StdGen -> (a, StdGen)) -> + StdGen -> + Benchmark benchNop3 nop rand gen = - let (x,gen1) = rand gen - (y,gen2) = rand gen1 - (z,_) = rand gen2 - in bgroup (show nop) - [bgroup (showMemoryUsage x) - [bgroup (showMemoryUsage y) - [benchWith nopCostParameters (showMemoryUsage z) $ mkApp3 nop [] x y z] + let (x, gen1) = rand gen + (y, gen2) = rand gen1 + (z, _) = rand gen2 + in bgroup + (show nop) + [ bgroup + (showMemoryUsage x) + [ bgroup + (showMemoryUsage y) + [benchWith nopCostParameters (showMemoryUsage z) $ mkApp3 nop [] x y z] ] - ] + ] -benchNop4 - :: (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) - => NopFun - -> (StdGen -> (a, StdGen)) - -> StdGen - -> Benchmark +benchNop4 :: + (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) => + NopFun -> + (StdGen -> (a, StdGen)) -> + StdGen -> + Benchmark benchNop4 nop rand gen = - let (x,gen1) = rand gen - (y,gen2) = rand gen1 - (z,gen3) = rand gen2 - (t,_) = rand gen3 - in bgroup (show nop) - [bgroup (showMemoryUsage x) - [bgroup (showMemoryUsage y) - [bgroup (showMemoryUsage z) - [benchWith nopCostParameters (showMemoryUsage t) $ mkApp4 nop [] x y z t] - ] + let (x, gen1) = rand gen + (y, gen2) = rand gen1 + (z, gen3) = rand gen2 + (t, _) = rand gen3 + in bgroup + (show nop) + [ bgroup + (showMemoryUsage x) + [ bgroup + (showMemoryUsage y) + [ bgroup + (showMemoryUsage z) + [benchWith nopCostParameters (showMemoryUsage t) $ mkApp4 nop [] x y z t] + ] ] - ] + ] -benchNop5 - :: (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) - => NopFun - -> (StdGen -> (a, StdGen)) - -> StdGen - -> Benchmark +benchNop5 :: + (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) => + NopFun -> + (StdGen -> (a, StdGen)) -> + StdGen -> + Benchmark benchNop5 nop rand gen = - let (x,gen1) = rand gen - (y,gen2) = rand gen1 - (z,gen3) = rand gen2 - (t,gen4) = rand gen3 - (u,_) = rand gen4 - in bgroup (show nop) - [bgroup (showMemoryUsage x) - [bgroup (showMemoryUsage y) - [bgroup (showMemoryUsage z) - [bgroup (showMemoryUsage t) - [benchWith nopCostParameters (showMemoryUsage u) $ mkApp5 nop [] x y z t u] - ] - ] + let (x, gen1) = rand gen + (y, gen2) = rand gen1 + (z, gen3) = rand gen2 + (t, gen4) = rand gen3 + (u, _) = rand gen4 + in bgroup + (show nop) + [ bgroup + (showMemoryUsage x) + [ bgroup + (showMemoryUsage y) + [ bgroup + (showMemoryUsage z) + [ bgroup + (showMemoryUsage t) + [benchWith nopCostParameters (showMemoryUsage u) $ mkApp5 nop [] x y z t u] + ] + ] ] - ] + ] -benchNop6 - :: (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) - => NopFun - -> (StdGen -> (a, StdGen)) - -> StdGen - -> Benchmark +benchNop6 :: + (ExMemoryUsage a, DefaultUni `HasTermLevel` a, NFData a) => + NopFun -> + (StdGen -> (a, StdGen)) -> + StdGen -> + Benchmark benchNop6 nop rand gen = - let (x,gen1) = rand gen - (y,gen2) = rand gen1 - (z,gen3) = rand gen2 - (t,gen4) = rand gen3 - (u,gen5) = rand gen4 - (v,_) = rand gen5 - in bgroup (show nop) - [bgroup (showMemoryUsage x) - [bgroup (showMemoryUsage y) - [bgroup (showMemoryUsage z) - [bgroup (showMemoryUsage t) - [bgroup (showMemoryUsage u) - [benchWith nopCostParameters (showMemoryUsage v) $ mkApp6 nop [] x y z t u v] - ] - ] - ] + let (x, gen1) = rand gen + (y, gen2) = rand gen1 + (z, gen3) = rand gen2 + (t, gen4) = rand gen3 + (u, gen5) = rand gen4 + (v, _) = rand gen5 + in bgroup + (show nop) + [ bgroup + (showMemoryUsage x) + [ bgroup + (showMemoryUsage y) + [ bgroup + (showMemoryUsage z) + [ bgroup + (showMemoryUsage t) + [ bgroup + (showMemoryUsage u) + [benchWith nopCostParameters (showMemoryUsage v) $ mkApp6 nop [] x y z t u v] + ] + ] + ] ] - ] - + ] -- | The actual benchmarks makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks gen = - [ benchUnitTerm ] + [benchUnitTerm] ++ mkBMs mkBmB (Nop1b, Nop2b, Nop3b, Nop4b, Nop5b, Nop6b) ++ mkBMs mkBmI (Nop1i, Nop2i, Nop3i, Nop4i, Nop5i, Nop6i) ++ mkBMs mkBmI (Nop1c, Nop2c, Nop3c, Nop4c, Nop5c, Nop6c) ++ mkBMs mkBmI (Nop1o, Nop2o, Nop3o, Nop4o, Nop5o, Nop6o) - -- The subsidiary functions below make it a lot easier to see that we're - -- benchmarking the right things with the right benchmarking functions. - -- Maybe we could use some TH instead. - where mkBMs mkBM (nop1, nop2, nop3, nop4, nop5, nop6) = - [ mkBM benchNop1 nop1 - , mkBM benchNop2 nop2 - , mkBM benchNop3 nop3 - , mkBM benchNop4 nop4 - , mkBM benchNop5 nop5 - , mkBM benchNop6 nop6 ] - mkBmB benchfn nop = benchfn nop randBool gen - mkBmI benchfn nop = benchfn nop (randNwords 1) gen - -- Benchmark using Integer inputs with memory usage 1 + where + -- The subsidiary functions below make it a lot easier to see that we're + -- benchmarking the right things with the right benchmarking functions. + -- Maybe we could use some TH instead. + mkBMs mkBM (nop1, nop2, nop3, nop4, nop5, nop6) = + [ mkBM benchNop1 nop1 + , mkBM benchNop2 nop2 + , mkBM benchNop3 nop3 + , mkBM benchNop4 nop4 + , mkBM benchNop5 nop5 + , mkBM benchNop6 nop6 + ] + mkBmB benchfn nop = benchfn nop randBool gen + mkBmI benchfn nop = benchfn nop (randNwords 1) gen + +-- Benchmark using Integer inputs with memory usage 1 diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Pairs.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Pairs.hs index d2bdc5a3a8d..a5079855a2a 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Pairs.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Pairs.hs @@ -8,15 +8,15 @@ import PlutusCore import Criterion.Main import System.Random (StdGen) - -- The pair projection operations should be constant time, but we check that by -- giving it a list of pairs whose components are of increasing size. benchPairOp :: StdGen -> DefaultFun -> Benchmark benchPairOp gen fun = - createOneTermBuiltinBench fun [integer, bytestring] pairs - where pairs = zip ints bytestrings - (ints, _) = makeSizedIntegers gen [1..100] - bytestrings = makeSizedByteStrings seedA [1..100] + createOneTermBuiltinBench fun [integer, bytestring] pairs + where + pairs = zip ints bytestrings + (ints, _) = makeSizedIntegers gen [1 .. 100] + bytestrings = makeSizedByteStrings seedA [1 .. 100] makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks gen = benchPairOp gen <$> [FstPair, SndPair] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Strings.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Strings.hs index 3657d3be671..7760e7ef163 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Strings.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Strings.hs @@ -1,5 +1,4 @@ -{- | Benchmarks for string builtins. Remember that "strings" are actually Text. -} - +-- | Benchmarks for string builtins. Remember that "strings" are actually Text. module Benchmarks.Strings (makeSizedTextStrings, makeBenchmarks) where import Common @@ -11,7 +10,6 @@ import Criterion.Main import Data.Text qualified as T import System.Random (StdGen) - {- The memory usage of a string is defined to be four bytes per character. Plutus strings are implemented as Text objects, which are UTF-16 encoded sequences of Unicode characters. For characters (by which Text means codepoints) in the @@ -77,7 +75,6 @@ average number of bytes per character is 3/2). decodeUtf8 with different kinds of input to check which gave the worst case, and we use the worst-case inputs for the costing benchmarks above. - encodeUtf8: we looked at two different types of input, both containing n 64-bit words and generated with Hedgehog's 'text' generator: @@ -95,7 +92,6 @@ average number of bytes per character is 3/2). inputs to covert the worst case. The strings we're likely to see in practice will be of type A, so we'll overestimate the cost of encoding them. - decodeUtf8: similarly to encodeUtf8, we looked at two different types of UTF-8 encoded inputs generated with the 'utf8' generator, each requiring 8n bytes (ie size n in words): @@ -125,39 +121,41 @@ average number of bytes per character is 3/2). -} oneArgumentSizes :: [Integer] -oneArgumentSizes = [0, 100..10000] -- 101 entries +oneArgumentSizes = [0, 100 .. 10000] -- 101 entries twoArgumentSizes :: [Integer] -twoArgumentSizes = [0, 250..5000] -- 21 entries +twoArgumentSizes = [0, 250 .. 5000] -- 21 entries {- This is for benchmarking DecodeUtf8. That fails if the encoded data is invalid, so we make sure that the input data is valid data for it by using data produced by G.utf8 (see above). -} benchOneUtf8ByteString :: DefaultFun -> Benchmark benchOneUtf8ByteString name = - createOneTermBuiltinBench name [] $ makeSizedUtf8ByteStrings seedA oneArgumentSizes + createOneTermBuiltinBench name [] $ makeSizedUtf8ByteStrings seedA oneArgumentSizes benchOneTextString :: DefaultFun -> Benchmark benchOneTextString name = - createOneTermBuiltinBench name [] $ makeSizedTextStrings seedA oneArgumentSizes + createOneTermBuiltinBench name [] $ makeSizedTextStrings seedA oneArgumentSizes benchTwoTextStrings :: DefaultFun -> Benchmark benchTwoTextStrings name = - let s1 = makeSizedTextStrings seedA twoArgumentSizes - s2 = makeSizedTextStrings seedB twoArgumentSizes - in createTwoTermBuiltinBench name [] s1 s2 + let s1 = makeSizedTextStrings seedA twoArgumentSizes + s2 = makeSizedTextStrings seedB twoArgumentSizes + in createTwoTermBuiltinBench name [] s1 s2 -- Benchmark times for a function applied to equal arguments. This is used for -- benchmarking EqualsString on the diagonal. Copy the string here, because -- otherwise it'll be exactly the same and the equality will short-circuit. benchSameTwoTextStrings :: DefaultFun -> Benchmark benchSameTwoTextStrings name = - createTwoTermBuiltinBenchElementwise name [] $ pairWith T.copy inputs - where inputs = makeSizedTextStrings seedA oneArgumentSizes + createTwoTermBuiltinBenchElementwise name [] $ pairWith T.copy inputs + where + inputs = makeSizedTextStrings seedA oneArgumentSizes makeBenchmarks :: StdGen -> [Benchmark] -makeBenchmarks _gen = [ benchOneTextString EncodeUtf8 - , benchOneUtf8ByteString DecodeUtf8 - , benchTwoTextStrings AppendString - , benchSameTwoTextStrings EqualsString - ] +makeBenchmarks _gen = + [ benchOneTextString EncodeUtf8 + , benchOneUtf8ByteString DecodeUtf8 + , benchTwoTextStrings AppendString + , benchSameTwoTextStrings EqualsString + ] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Tracing.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Tracing.hs index f19f9e6bcae..a70ed0ac8b5 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Tracing.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Tracing.hs @@ -8,16 +8,16 @@ import Generators import Criterion.Main import System.Random (StdGen) - -- We expect tracing (with a null emitter) to be constant time, but generate -- multiple input sizes to be sure. benchTracing :: StdGen -> Benchmark benchTracing gen = - createTwoTermBuiltinBench name [bytestring] inputs1 inputs2 - where name = Trace - inputs1 = makeSizedTextStrings seedA [10, 20, 30, 40, 50, 100, 200, 300, 400, 500] - -- The numbers above are the approximate number of characters in the trace message - (inputs2, _) = makeSizedIntegers gen [1,2,3,4,5,10,20,34,40,50] + createTwoTermBuiltinBench name [bytestring] inputs1 inputs2 + where + name = Trace + inputs1 = makeSizedTextStrings seedA [10, 20, 30, 40, 50, 100, 200, 300, 400, 500] + -- The numbers above are the approximate number of characters in the trace message + (inputs2, _) = makeSizedIntegers gen [1, 2, 3, 4, 5, 10, 20, 34, 40, 50] makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks gen = [benchTracing gen] diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Unit.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Unit.hs index 6f5feca1f14..c81444d1d28 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Unit.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Unit.hs @@ -12,21 +12,25 @@ import Control.DeepSeq (NFData) import Criterion.Main import System.Random (StdGen) - -createChooseUnitBench - :: (DefaultUni `HasTermLevel` a, ExMemoryUsage a, NFData a) - => Type TyName DefaultUni () - -> [a] - -> Benchmark +createChooseUnitBench :: + (DefaultUni `HasTermLevel` a, ExMemoryUsage a, NFData a) => + Type TyName DefaultUni () -> + [a] -> + Benchmark createChooseUnitBench ty xs = - bgroup (show name) [bgroup (showMemoryUsage ()) [mkBM x | x <- xs]] - where name = ChooseUnit - mkBM x = benchDefault (showMemoryUsage x) $ mkApp2 name [ty] () x + bgroup (show name) [bgroup (showMemoryUsage ()) [mkBM x | x <- xs]] + where + name = ChooseUnit + mkBM x = benchDefault (showMemoryUsage x) $ mkApp2 name [ty] () x makeBenchmarks :: StdGen -> [Benchmark] -makeBenchmarks gen = [ createChooseUnitBench integer numbers - , createChooseUnitBench bytestring bytestrings ] - where (numbers, _) = makeSizedIntegers gen (fmap (100 *) [1..50]) - bytestrings = fmap (makeSizedByteString seedA) (fmap (100 *) [51..100]) - -- The time should be independent of the type and size of the input, - -- but let's vary them to make sure. +makeBenchmarks gen = + [ createChooseUnitBench integer numbers + , createChooseUnitBench bytestring bytestrings + ] + where + (numbers, _) = makeSizedIntegers gen (fmap (100 *) [1 .. 50]) + bytestrings = fmap (makeSizedByteString seedA) (fmap (100 *) [51 .. 100]) + +-- The time should be independent of the type and size of the input, +-- but let's vary them to make sure. diff --git a/plutus-core/cost-model/budgeting-bench/Common.hs b/plutus-core/cost-model/budgeting-bench/Common.hs index 1812fe78731..49ecf8c9954 100644 --- a/plutus-core/cost-model/budgeting-bench/Common.hs +++ b/plutus-core/cost-model/budgeting-bench/Common.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Common where @@ -34,22 +34,20 @@ showMemoryUsage = show . sumCostStream . flattenCostRose . memoryUsage ---------------- Cloning objects ---------------- -- TODO: look at GHC.Compact -{- | In some cases (for example, equality testing) the worst-case behaviour of a -builtin will be when it has two identical arguments However, there's a danger -that if the arguments are physically identical (ie, they are (pointers to) the -same object in the heap) the underlying implementation may notice that and -return immediately. The code below attempts to avoid this by producing a -completely new copy of an integer. Experiments with 'realyUnsafePtrEquality#` -indicate that it does what's required (in fact, `cloneInteger n = (n+1)-1` with -OPAQUE suffices, but that's perhaps a bit too fragile). --} - +-- | In some cases (for example, equality testing) the worst-case behaviour of a +-- builtin will be when it has two identical arguments However, there's a danger +-- that if the arguments are physically identical (ie, they are (pointers to) the +-- same object in the heap) the underlying implementation may notice that and +-- return immediately. The code below attempts to avoid this by producing a +-- completely new copy of an integer. Experiments with 'realyUnsafePtrEquality#` +-- indicate that it does what's required (in fact, `cloneInteger n = (n+1)-1` with +-- OPAQUE suffices, but that's perhaps a bit too fragile). incInteger :: Integer -> Integer -incInteger n = n+1 +incInteger n = n + 1 {-# OPAQUE incInteger #-} decInteger :: Integer -> Integer -decInteger n = n-1 +decInteger n = n - 1 {-# OPAQUE decInteger #-} copyInteger :: Integer -> Integer @@ -62,31 +60,32 @@ copyByteString = BS.copy copyData :: Data -> Data copyData = - \case - Constr n l -> Constr (copyInteger n) (map copyData l) - Map l -> Map $ map (bimap copyData copyData) l - List l -> List (map copyData l) - I n -> I $ copyInteger n - B b -> B $ copyByteString b + \case + Constr n l -> Constr (copyInteger n) (map copyData l) + Map l -> Map $ map (bimap copyData copyData) l + List l -> List (map copyData l) + I n -> I $ copyInteger n + B b -> B $ copyByteString b {-# OPAQUE copyData #-} -pairWith :: (a -> b) -> [a] -> [(a,b)] +pairWith :: (a -> b) -> [a] -> [(a, b)] pairWith f = fmap (\a -> (a, f a)) ---------------- Creating benchmarks ---------------- -benchWith - :: (Pretty fun, Typeable fun) - => MachineParameters CekMachineCosts fun (CekValue DefaultUni fun ()) - -> String - -> PlainTerm DefaultUni fun - -> Benchmark +benchWith :: + (Pretty fun, Typeable fun) => + MachineParameters CekMachineCosts fun (CekValue DefaultUni fun ()) -> + String -> + PlainTerm DefaultUni fun -> + Benchmark -- Note that to get sensible results with 'whnf', we must use an evaluation function that looks at -- the result, so e.g. 'evaluateCek' won't work properly because it returns a pair whose components -- won't be evaluated by 'whnf'. We can't use 'nf' because it does too much work: for instance if it -- gets back a 'Data' value it'll traverse all of it. -benchWith params name term = bench name $ - whnf (handleEvaluationErrors . evaluateCekNoEmit params) term +benchWith params name term = + bench name $ + whnf (handleEvaluationErrors . evaluateCekNoEmit params) term where handleEvaluationErrors = \case Right res -> res @@ -98,7 +97,6 @@ benchWith params name term = bench name $ benchDefault :: String -> PlainTerm DefaultUni DefaultFun -> Benchmark benchDefault = benchWith defaultCekParametersForTesting - ---------------- Constructing Polymorphic PLC terms for benchmarking ---------------- integer :: uni `HasTypeLevel` Integer => Type TyName uni () @@ -107,104 +105,148 @@ integer = mkTyBuiltin @_ @Integer () bytestring :: uni `HasTypeLevel` BS.ByteString => Type TyName uni () bytestring = mkTyBuiltin @_ @BS.ByteString () - -- To make monomorphic terms, make tys equal to [] in the mkApp functions -- Just make the term (con unit ()), which is about the simplest possible. mkUnit :: uni `HasTermLevel` () => PlainTerm uni fun -mkUnit = eraseTerm $ mkConstant () () +mkUnit = eraseTerm $ mkConstant () () -- Create a term instantiating a builtin and applying it to one argument -mkApp1 - :: (uni `HasTermLevel` a, NFData a) - => fun -> [Type tyname uni ()] -> a -> PlainTerm uni fun +mkApp1 :: + (uni `HasTermLevel` a, NFData a) => + fun -> [Type tyname uni ()] -> a -> PlainTerm uni fun mkApp1 !fun !tys (force -> !x) = - eraseTerm $ mkIterAppNoAnn instantiated [mkConstant () x] - where instantiated = mkIterInstNoAnn (builtin () fun) tys - + eraseTerm $ mkIterAppNoAnn instantiated [mkConstant () x] + where + instantiated = mkIterInstNoAnn (builtin () fun) tys -- Create a term instantiating a builtin and applying it to two arguments -mkApp2 - :: (uni `HasTermLevel` a, uni `HasTermLevel` b, NFData a, NFData b) - => fun -> [Type tyname uni ()]-> a -> b -> PlainTerm uni fun +mkApp2 :: + (uni `HasTermLevel` a, uni `HasTermLevel` b, NFData a, NFData b) => + fun -> [Type tyname uni ()] -> a -> b -> PlainTerm uni fun mkApp2 !fun !tys (force -> !x) (force -> !y) = - eraseTerm $ mkIterAppNoAnn instantiated [mkConstant () x, mkConstant () y] - where instantiated = mkIterInstNoAnn (builtin () fun) tys - + eraseTerm $ mkIterAppNoAnn instantiated [mkConstant () x, mkConstant () y] + where + instantiated = mkIterInstNoAnn (builtin () fun) tys -- Create a term instantiating a builtin and applying it to three arguments -mkApp3 - :: ( uni `HasTermLevel` a, uni `HasTermLevel` b, uni `HasTermLevel` c - , NFData a, NFData b, NFData c - ) - => fun -> [Type tyname uni ()] -> a -> b -> c -> PlainTerm uni fun +mkApp3 :: + ( uni `HasTermLevel` a + , uni `HasTermLevel` b + , uni `HasTermLevel` c + , NFData a + , NFData b + , NFData c + ) => + fun -> [Type tyname uni ()] -> a -> b -> c -> PlainTerm uni fun mkApp3 !fun !tys (force -> !x) (force -> !y) (force -> !z) = - eraseTerm $ mkIterAppNoAnn instantiated [mkConstant () x, mkConstant () y, mkConstant () z] - where instantiated = mkIterInstNoAnn (builtin () fun) tys - + eraseTerm $ mkIterAppNoAnn instantiated [mkConstant () x, mkConstant () y, mkConstant () z] + where + instantiated = mkIterInstNoAnn (builtin () fun) tys -- Create a term instantiating a builtin and applying it to four arguments -mkApp4 - :: ( uni `HasTermLevel` a, uni `HasTermLevel` b - , uni `HasTermLevel` c, uni `HasTermLevel` d - , NFData a, NFData b, NFData c, NFData d - ) - => fun -> [Type tyname uni ()] -> a -> b -> c -> d -> PlainTerm uni fun +mkApp4 :: + ( uni `HasTermLevel` a + , uni `HasTermLevel` b + , uni `HasTermLevel` c + , uni `HasTermLevel` d + , NFData a + , NFData b + , NFData c + , NFData d + ) => + fun -> [Type tyname uni ()] -> a -> b -> c -> d -> PlainTerm uni fun mkApp4 !fun !tys (force -> !x) (force -> !y) (force -> !z) (force -> !t) = - eraseTerm $ mkIterAppNoAnn instantiated [ mkConstant () x, mkConstant () y - , mkConstant () z, mkConstant () t ] - where instantiated = mkIterInstNoAnn (builtin () fun) tys - + eraseTerm $ + mkIterAppNoAnn + instantiated + [ mkConstant () x + , mkConstant () y + , mkConstant () z + , mkConstant () t + ] + where + instantiated = mkIterInstNoAnn (builtin () fun) tys -- Create a term instantiating a builtin and applying it to five arguments -mkApp5 - :: ( uni `HasTermLevel` a, uni `HasTermLevel` b, uni `HasTermLevel` c - , uni `HasTermLevel` d, uni `HasTermLevel` e - , NFData a, NFData b, NFData c, NFData d, NFData e - ) - => fun -> [Type tyname uni ()] -> a -> b -> c -> d -> e -> PlainTerm uni fun +mkApp5 :: + ( uni `HasTermLevel` a + , uni `HasTermLevel` b + , uni `HasTermLevel` c + , uni `HasTermLevel` d + , uni `HasTermLevel` e + , NFData a + , NFData b + , NFData c + , NFData d + , NFData e + ) => + fun -> [Type tyname uni ()] -> a -> b -> c -> d -> e -> PlainTerm uni fun mkApp5 !fun !tys (force -> !x) (force -> !y) (force -> !z) (force -> !t) (force -> !u) = - eraseTerm $ mkIterAppNoAnn instantiated [ mkConstant () x, mkConstant () y, mkConstant () z - , mkConstant () t, mkConstant () u ] - where instantiated = mkIterInstNoAnn (builtin () fun) tys - + eraseTerm $ + mkIterAppNoAnn + instantiated + [ mkConstant () x + , mkConstant () y + , mkConstant () z + , mkConstant () t + , mkConstant () u + ] + where + instantiated = mkIterInstNoAnn (builtin () fun) tys -- Create a term instantiating a builtin and applying it to six arguments -mkApp6 - :: ( uni `HasTermLevel` a, uni `HasTermLevel` b, uni `HasTermLevel` c - , uni `HasTermLevel` d, uni `HasTermLevel` e, uni `HasTermLevel` f - , NFData a, NFData b, NFData c, NFData d, NFData e, NFData f - ) - => fun -> [Type tyname uni ()] -> a -> b -> c -> d -> e -> f-> PlainTerm uni fun -mkApp6 fun tys (force -> !x) (force -> !y) (force -> !z) (force -> !t) (force -> !u) (force -> !v)= - eraseTerm $ mkIterAppNoAnn instantiated [mkConstant () x, mkConstant () y, mkConstant () z, - mkConstant () t, mkConstant () u, mkConstant () v] - where instantiated = mkIterInstNoAnn (builtin () fun) tys - +mkApp6 :: + ( uni `HasTermLevel` a + , uni `HasTermLevel` b + , uni `HasTermLevel` c + , uni `HasTermLevel` d + , uni `HasTermLevel` e + , uni `HasTermLevel` f + , NFData a + , NFData b + , NFData c + , NFData d + , NFData e + , NFData f + ) => + fun -> [Type tyname uni ()] -> a -> b -> c -> d -> e -> f -> PlainTerm uni fun +mkApp6 fun tys (force -> !x) (force -> !y) (force -> !z) (force -> !t) (force -> !u) (force -> !v) = + eraseTerm $ + mkIterAppNoAnn + instantiated + [ mkConstant () x + , mkConstant () y + , mkConstant () z + , mkConstant () t + , mkConstant () u + , mkConstant () v + ] + where + instantiated = mkIterInstNoAnn (builtin () fun) tys ---------------- Creating benchmarks ---------------- -{- | The use of bgroups in the functions below will cause Criterion to give the - benchmarks names like "AddInteger/ExMemory 11/ExMemory 5": these are saved in - the CSV file and the 'benchData' function in 'models.R' subsequently extracts - the names and memory figures for use as entries in the data frame used to - generate the cost models. Hence changing the nesting of the bgroups would - cause trouble elsewhere. - -} - -{- | Given a builtin function f of type a -> _ together with a lists xs, create a - collection of benchmarks which run f on all elements of xs. -} -createOneTermBuiltinBench - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , ExMemoryUsage a - , NFData a - ) - => fun - -> [Type tyname uni ()] - -> [a] - -> Benchmark +-- | The use of bgroups in the functions below will cause Criterion to give the +-- benchmarks names like "AddInteger/ExMemory 11/ExMemory 5": these are saved in +-- the CSV file and the 'benchData' function in 'models.R' subsequently extracts +-- the names and memory figures for use as entries in the data frame used to +-- generate the cost models. Hence changing the nesting of the bgroups would +-- cause trouble elsewhere. + +-- | Given a builtin function f of type a -> _ together with a lists xs, create a +-- collection of benchmarks which run f on all elements of xs. +createOneTermBuiltinBench :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , ExMemoryUsage a + , NFData a + ) => + fun -> + [Type tyname uni ()] -> + [a] -> + Benchmark createOneTermBuiltinBench = createOneTermBuiltinBenchWithWrapper id {- Note [Adjusting the memory usage of arguments of costing benchmarks] In some @@ -216,218 +258,234 @@ createOneTermBuiltinBench = createOneTermBuiltinBenchWithWrapper id the costing functions are costed in the same way as the are in thhe benchmmarks. -} -createOneTermBuiltinBenchWithWrapper - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , ExMemoryUsage a' - , NFData a - ) - => (a -> a') - -> fun - -> [Type tyname uni ()] - -> [a] - -> Benchmark +createOneTermBuiltinBenchWithWrapper :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , ExMemoryUsage a' + , NFData a + ) => + (a -> a') -> + fun -> + [Type tyname uni ()] -> + [a] -> + Benchmark createOneTermBuiltinBenchWithWrapper wrapX fun tys xs = - bgroup (show fun) + bgroup + (show fun) [ benchDefault (showMemoryUsage (wrapX x)) (mkApp1 fun tys x) | x <- xs ] -{- | Given a builtin function f of type a * b -> _ together with lists xs::[a] and - ys::[b], create a collection of benchmarks which run f on all pairs in - {(x,y}: x in xs, y in ys}. -} -createTwoTermBuiltinBench - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , ExMemoryUsage a - , ExMemoryUsage b - , NFData a - , NFData b - ) - => fun - -> [Type tyname uni ()] - -> [a] - -> [b] - -> Benchmark +-- | Given a builtin function f of type a * b -> _ together with lists xs::[a] and +-- ys::[b], create a collection of benchmarks which run f on all pairs in +-- {(x,y}: x in xs, y in ys}. +createTwoTermBuiltinBench :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , ExMemoryUsage a + , ExMemoryUsage b + , NFData a + , NFData b + ) => + fun -> + [Type tyname uni ()] -> + [a] -> + [b] -> + Benchmark createTwoTermBuiltinBench fun tys xs ys = bgroup (show fun) [bgroup (showMemoryUsage x) [mkBM x y | y <- ys] | x <- xs] - where mkBM x y = benchDefault (showMemoryUsage y) $ mkApp2 fun tys x y - -createTwoTermBuiltinBenchWithFlag - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , ExMemoryUsage a - , ExMemoryUsage b - , NFData a - , NFData b - ) - => fun - -> [Type tyname uni ()] - -> Bool - -> [a] - -> [b] - -> Benchmark + where + mkBM x y = benchDefault (showMemoryUsage y) $ mkApp2 fun tys x y + +createTwoTermBuiltinBenchWithFlag :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , ExMemoryUsage a + , ExMemoryUsage b + , NFData a + , NFData b + ) => + fun -> + [Type tyname uni ()] -> + Bool -> + [a] -> + [b] -> + Benchmark createTwoTermBuiltinBenchWithFlag fun tys flag ys zs = - bgroup (show fun) [bgroup (showMemoryUsage flag) - [bgroup (showMemoryUsage y) [mkBM y z | z <- zs] | y <- ys]] - where mkBM y z = benchDefault (showMemoryUsage z) $ mkApp3 fun tys flag y z - -{- | Given a builtin function f of type a * b -> _ together with lists xs::[a] and - ys::[b], create a collection of benchmarks which run f on all pairs in - {(x,y}: x in xs, y in ys}. -} -createTwoTermBuiltinBenchWithWrappers - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , ExMemoryUsage a' - , ExMemoryUsage b' - , NFData a - , NFData b - ) - => (a -> a', b-> b') - -> fun - -> [Type tyname uni ()] - -> [a] - -> [b] - -> Benchmark + bgroup + (show fun) + [ bgroup + (showMemoryUsage flag) + [bgroup (showMemoryUsage y) [mkBM y z | z <- zs] | y <- ys] + ] + where + mkBM y z = benchDefault (showMemoryUsage z) $ mkApp3 fun tys flag y z + +-- | Given a builtin function f of type a * b -> _ together with lists xs::[a] and +-- ys::[b], create a collection of benchmarks which run f on all pairs in +-- {(x,y}: x in xs, y in ys}. +createTwoTermBuiltinBenchWithWrappers :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , ExMemoryUsage a' + , ExMemoryUsage b' + , NFData a + , NFData b + ) => + (a -> a', b -> b') -> + fun -> + [Type tyname uni ()] -> + [a] -> + [b] -> + Benchmark createTwoTermBuiltinBenchWithWrappers (wrapX, wrapY) fun tys xs ys = bgroup (show fun) [bgroup (showMemoryUsage (wrapX x)) [mkBM x y | y <- ys] | x <- xs] - where mkBM x y = benchDefault (showMemoryUsage (wrapY y)) $ mkApp2 fun tys x y - -{- | Given a builtin function f of type a * b -> _ together with a list of (a,b) - pairs, create a collection of benchmarks which run f on all of the pairs in - the list. This can be used when the worst-case execution time of a - two-argument builtin is known to occur when it is given two identical - arguments (for example equality testing, where the function has to examine - the whole of both inputs in that case; with unequal arguments it will usually - be able to return more quickly). The caller may wish to ensure that the - elements of the two lists are physically different to avoid early return if a - builtin can spot that its arguments both point to the same heap object. --} -createTwoTermBuiltinBenchElementwise - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , ExMemoryUsage a - , ExMemoryUsage b - , NFData a - , NFData b - ) - => fun - -> [Type tyname uni ()] - -> [(a,b)] - -> Benchmark + where + mkBM x y = benchDefault (showMemoryUsage (wrapY y)) $ mkApp2 fun tys x y + +-- | Given a builtin function f of type a * b -> _ together with a list of (a,b) +-- pairs, create a collection of benchmarks which run f on all of the pairs in +-- the list. This can be used when the worst-case execution time of a +-- two-argument builtin is known to occur when it is given two identical +-- arguments (for example equality testing, where the function has to examine +-- the whole of both inputs in that case; with unequal arguments it will usually +-- be able to return more quickly). The caller may wish to ensure that the +-- elements of the two lists are physically different to avoid early return if a +-- builtin can spot that its arguments both point to the same heap object. +createTwoTermBuiltinBenchElementwise :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , ExMemoryUsage a + , ExMemoryUsage b + , NFData a + , NFData b + ) => + fun -> + [Type tyname uni ()] -> + [(a, b)] -> + Benchmark createTwoTermBuiltinBenchElementwise = createTwoTermBuiltinBenchElementwiseWithWrappers (id, id) + -- TODO: throw an error if xmem != ymem? That would suggest that the caller has -- done something wrong. {- See Note [Adjusting the memory usage of arguments of costing benchmarks]. -} -createTwoTermBuiltinBenchElementwiseWithWrappers - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , ExMemoryUsage a' - , ExMemoryUsage b' - , NFData a - , NFData b - ) - => (a -> a', b -> b') - -> fun - -> [Type tyname uni ()] - -> [(a,b)] - -> Benchmark +createTwoTermBuiltinBenchElementwiseWithWrappers :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , ExMemoryUsage a' + , ExMemoryUsage b' + , NFData a + , NFData b + ) => + (a -> a', b -> b') -> + fun -> + [Type tyname uni ()] -> + [(a, b)] -> + Benchmark createTwoTermBuiltinBenchElementwiseWithWrappers (wrapX, wrapY) fun tys inputs = bgroup (show fun) $ - fmap(\(x, y) -> bgroup (showMemoryUsage $ wrapX x) [mkBM x y]) inputs - where mkBM x y = benchDefault (showMemoryUsage $ wrapY y) $ mkApp2 fun tys x y - -{- | Given a builtin function f of type a * b * c -> _ together with a list of - inputs of type (a,b,c), create a collection of benchmarks which run f on all - inputs. --} -createThreeTermBuiltinBenchElementwise - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , uni `HasTermLevel` c - , ExMemoryUsage a - , ExMemoryUsage b - , ExMemoryUsage c - , NFData a - , NFData b - , NFData c - ) - => fun - -> [Type tyname uni ()] - -> [(a,b,c)] - -> Benchmark + fmap (\(x, y) -> bgroup (showMemoryUsage $ wrapX x) [mkBM x y]) inputs + where + mkBM x y = benchDefault (showMemoryUsage $ wrapY y) $ mkApp2 fun tys x y + +-- | Given a builtin function f of type a * b * c -> _ together with a list of +-- inputs of type (a,b,c), create a collection of benchmarks which run f on all +-- inputs. +createThreeTermBuiltinBenchElementwise :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , uni `HasTermLevel` c + , ExMemoryUsage a + , ExMemoryUsage b + , ExMemoryUsage c + , NFData a + , NFData b + , NFData c + ) => + fun -> + [Type tyname uni ()] -> + [(a, b, c)] -> + Benchmark createThreeTermBuiltinBenchElementwise = createThreeTermBuiltinBenchElementwiseWithWrappers (id, id, id) {- See Note [Adjusting the memory usage of arguments of costing benchmarks]. -} -createThreeTermBuiltinBenchElementwiseWithWrappers - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , uni `HasTermLevel` c - , ExMemoryUsage a' - , ExMemoryUsage b' - , ExMemoryUsage c' - , NFData a - , NFData b - , NFData c - ) - => (a -> a', b -> b', c -> c') - -> fun - -> [Type tyname uni ()] - -> [(a,b,c)] - -> Benchmark +createThreeTermBuiltinBenchElementwiseWithWrappers :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , uni `HasTermLevel` c + , ExMemoryUsage a' + , ExMemoryUsage b' + , ExMemoryUsage c' + , NFData a + , NFData b + , NFData c + ) => + (a -> a', b -> b', c -> c') -> + fun -> + [Type tyname uni ()] -> + [(a, b, c)] -> + Benchmark createThreeTermBuiltinBenchElementwiseWithWrappers (wrapX, wrapY, wrapZ) fun tys inputs = bgroup (show fun) $ - fmap - (\(x, y, z) -> - bgroup (showMemoryUsage $ wrapX x) - [bgroup (showMemoryUsage $ wrapY y) [mkBM x y z]] - ) - inputs - where mkBM x y z = benchDefault (showMemoryUsage $ wrapZ z) $ mkApp3 fun tys x y z - - -createThreeTermBuiltinBenchWithWrappers - :: ( fun ~ DefaultFun - , uni ~ DefaultUni - , uni `HasTermLevel` a - , uni `HasTermLevel` b - , uni `HasTermLevel` c - , ExMemoryUsage a' - , ExMemoryUsage b' - , ExMemoryUsage c' - , NFData a - , NFData b - , NFData c - ) - => (a -> a', b-> b', c -> c') - -> fun - -> [Type tyname uni ()] - -> [a] - -> [b] - -> [c] - -> Benchmark + fmap + ( \(x, y, z) -> + bgroup + (showMemoryUsage $ wrapX x) + [bgroup (showMemoryUsage $ wrapY y) [mkBM x y z]] + ) + inputs + where + mkBM x y z = benchDefault (showMemoryUsage $ wrapZ z) $ mkApp3 fun tys x y z + +createThreeTermBuiltinBenchWithWrappers :: + ( fun ~ DefaultFun + , uni ~ DefaultUni + , uni `HasTermLevel` a + , uni `HasTermLevel` b + , uni `HasTermLevel` c + , ExMemoryUsage a' + , ExMemoryUsage b' + , ExMemoryUsage c' + , NFData a + , NFData b + , NFData c + ) => + (a -> a', b -> b', c -> c') -> + fun -> + [Type tyname uni ()] -> + [a] -> + [b] -> + [c] -> + Benchmark createThreeTermBuiltinBenchWithWrappers (wrapX, wrapY, wrapZ) fun tys xs ys zs = - bgroup (show fun) - [bgroup (showMemoryUsage (wrapX x)) - [bgroup (showMemoryUsage (wrapY y)) - [mkBM x y z | z <- zs] | y <- ys] | x <- xs] - where mkBM x y z = benchDefault (showMemoryUsage (wrapZ z)) $ mkApp3 fun tys x y z - + bgroup + (show fun) + [ bgroup + (showMemoryUsage (wrapX x)) + [ bgroup + (showMemoryUsage (wrapY y)) + [mkBM x y z | z <- zs] + | y <- ys + ] + | x <- xs + ] + where + mkBM x y z = benchDefault (showMemoryUsage (wrapZ z)) $ mkApp3 fun tys x y z diff --git a/plutus-core/cost-model/budgeting-bench/CriterionExtensions.hs b/plutus-core/cost-model/budgeting-bench/CriterionExtensions.hs index d3b89093e98..50649cbdbaf 100644 --- a/plutus-core/cost-model/budgeting-bench/CriterionExtensions.hs +++ b/plutus-core/cost-model/budgeting-bench/CriterionExtensions.hs @@ -1,10 +1,10 @@ {-# LANGUAGE LambdaCase #-} -module CriterionExtensions (criterionMainWith, BenchmarkingPhase(..)) where +module CriterionExtensions (criterionMainWith, BenchmarkingPhase (..)) where import Control.Monad.Trans (liftIO) -import Criterion.Internal (runAndAnalyse, runFixedIters) import Criterion.IO.Printf (printError, writeCsv) +import Criterion.Internal (runAndAnalyse, runFixedIters) import Criterion.Main (makeMatcher) import Criterion.Main.Options (MatchType (..), Mode (..), describe, versionInfo) import Criterion.Measurement (initializeTime) @@ -20,77 +20,76 @@ import System.Exit (exitFailure) import System.FilePath ((<.>)) import System.IO (hPutStrLn, stderr) - -{- | The first time we call criterionMainWith we want to check that the CSV file - exists and if it does we make a backup and open a new version, writing a - header to the it. If we call criterionMainWith again then we just want to - append to the existing file: this type tells us which of these things we want - to do. --} +-- | The first time we call criterionMainWith we want to check that the CSV file +-- exists and if it does we make a backup and open a new version, writing a +-- header to the it. If we call criterionMainWith again then we just want to +-- append to the existing file: this type tells us which of these things we want +-- to do. data BenchmarkingPhase = Start | Continue -{- | We require the user to specify a CSV output file: without this, Criterion - won't save the output that we really need. We previously wrote the data to a - fixed location, but that was too inflexible. If the phase is Start and the - output file already exists then we move it to a backup file because by - default Criterion will just append data to the existing file (including a new - header). --} +-- | We require the user to specify a CSV output file: without this, Criterion +-- won't save the output that we really need. We previously wrote the data to a +-- fixed location, but that was too inflexible. If the phase is Start and the +-- output file already exists then we move it to a backup file because by +-- default Criterion will just append data to the existing file (including a new +-- header). initCsvFile :: BenchmarkingPhase -> Config -> Criterion () initCsvFile phase cfg = - let putStrLnErr = hPutStrLn stderr - in case csvFile cfg of - Nothing -> - liftIO $ do - prog <- getProgName - putStrLnErr "" - putStrLnErr "ERROR: a CSV output file must be specified for the benchmarking results." - putStrLnErr "Use" - putStrLnErr "" - putStrLnErr $ " cabal run " ++ prog ++ " -- --csv " - putStrLnErr "" - putStrLnErr "The CSV file location will be relative to the current shell directory." - exitFailure - Just file -> do - case phase of - Start -> do - csvExists <- liftIO $ doesFileExist file - if csvExists - then liftIO $ renameFile file (file <.> "backup") - else pure () - time <- liftIO getCurrentTime - liftIO $ appendFile file $ "# Plutus Core cost model benchmark results\n" - liftIO $ appendFile file $ "# Started at " ++ show time ++ "\n" - writeCsv ("benchmark","t","t.mean.lb","t.mean.ub","t.sd","t.sd.lb", "t.sd.ub") - -- Criterion will append output to the CSV file specified in `cfg`. - Continue -> pure () + let putStrLnErr = hPutStrLn stderr + in case csvFile cfg of + Nothing -> + liftIO $ do + prog <- getProgName + putStrLnErr "" + putStrLnErr "ERROR: a CSV output file must be specified for the benchmarking results." + putStrLnErr "Use" + putStrLnErr "" + putStrLnErr $ " cabal run " ++ prog ++ " -- --csv " + putStrLnErr "" + putStrLnErr "The CSV file location will be relative to the current shell directory." + exitFailure + Just file -> do + case phase of + Start -> do + csvExists <- liftIO $ doesFileExist file + if csvExists + then liftIO $ renameFile file (file <.> "backup") + else pure () + time <- liftIO getCurrentTime + liftIO $ appendFile file $ "# Plutus Core cost model benchmark results\n" + liftIO $ appendFile file $ "# Started at " ++ show time ++ "\n" + writeCsv ("benchmark", "t", "t.mean.lb", "t.mean.ub", "t.sd", "t.sd.lb", "t.sd.ub") + -- Criterion will append output to the CSV file specified in `cfg`. + Continue -> pure () + +-- | A modified version of Criterion's 'defaultMainWith' function. We want to be +-- able to run different benchmarks with different time limits, but that doesn't +-- work with the original version because the relevant function appends output +-- to a CSV file but writes a header into the file every time it's called. This +-- adds an option to stop it doing that so we only get one header (at the top, +-- where it belongs). This also calls `initCsvFile` to make sure that a CSV +-- output file has been specified. -{- | A modified version of Criterion's 'defaultMainWith' function. We want to be - able to run different benchmarks with different time limits, but that doesn't - work with the original version because the relevant function appends output - to a CSV file but writes a header into the file every time it's called. This - adds an option to stop it doing that so we only get one header (at the top, - where it belongs). This also calls `initCsvFile` to make sure that a CSV - output file has been specified. -} -- TODO: bypass Criterion's command line parser altogether. -criterionMainWith :: BenchmarkingPhase -> Config -> [Benchmark] -> IO () +criterionMainWith :: BenchmarkingPhase -> Config -> [Benchmark] -> IO () criterionMainWith phase defCfg bs = - execParser (describe defCfg) >>= - \case + execParser (describe defCfg) + >>= \case List -> mapM_ putStrLn . sort . concatMap benchNames $ bs Version -> putStrLn versionInfo RunIters cfg iters matchType benches -> - withConfig cfg $ do - () <- initCsvFile phase cfg - shouldRun <- liftIO $ selectBenches matchType benches - runFixedIters iters shouldRun bsgroup + withConfig cfg $ do + () <- initCsvFile phase cfg + shouldRun <- liftIO $ selectBenches matchType benches + runFixedIters iters shouldRun bsgroup Run cfg matchType benches -> - withConfig cfg $ do - () <- initCsvFile phase cfg - shouldRun <- liftIO $ selectBenches matchType benches - liftIO initializeTime - runAndAnalyse shouldRun bsgroup - where bsgroup = BenchGroup "" bs + withConfig cfg $ do + () <- initCsvFile phase cfg + shouldRun <- liftIO $ selectBenches matchType benches + liftIO initializeTime + runAndAnalyse shouldRun bsgroup + where + bsgroup = BenchGroup "" bs -- Select the benchmarks to be run. If a pattern is specified on the command -- line then only the matching benchmarks will be run. If there are no matching diff --git a/plutus-core/cost-model/budgeting-bench/Generators.hs b/plutus-core/cost-model/budgeting-bench/Generators.hs index 3eb4f61f024..a200478f76d 100644 --- a/plutus-core/cost-model/budgeting-bench/Generators.hs +++ b/plutus-core/cost-model/budgeting-bench/Generators.hs @@ -1,5 +1,4 @@ -{- | Generators for various types of data for benchmarking built-in functions -} - +-- | Generators for various types of data for benchmarking built-in functions module Generators where import PlutusCore.Data @@ -23,7 +22,6 @@ import System.Random (StdGen, randomR) import Test.QuickCheck import Test.QuickCheck.Instances.ByteString () - {- TODO: we're using Hedgehog for some things, QuickCheck for others, and System.Random for others. We should rationalise this. Pehaps Hedgehog is more future-proof since it can produce random instances of a wide variety of @@ -32,7 +30,6 @@ import Test.QuickCheck.Instances.ByteString () use Hedgehog everywhere because we'd need a lot of monadic code to take care of generator states. -} - ---------------- Creating things of a given size ---------------- -- Generate a random n-word (ie, 64n-bit) integer @@ -40,15 +37,15 @@ import Test.QuickCheck.Instances.ByteString () fewer words, but we're generating uniformly distributed values so the probability of that happening should be at most 1 in 2^64. -} randNwords :: Int -> StdGen -> (Integer, StdGen) -randNwords n gen = randomR (lb,ub) gen - where lb = 2^(64*(n-1)) - ub = 2^(64*n) - 1 +randNwords n gen = randomR (lb, ub) gen + where + lb = 2 ^ (64 * (n - 1)) + ub = 2 ^ (64 * n) - 1 -- Generate a random Bool (just here for consistency) randBool :: StdGen -> (Bool, StdGen) randBool gen = randomR (False, True) gen - -- Hedgehog generators seedA :: H.Seed seedA = H.Seed 42 43 @@ -58,28 +55,29 @@ seedB = H.Seed 44 45 genSample :: H.Seed -> G.Gen a -> a genSample seed gen = - Prelude.maybe - (Prelude.error "Couldn't create a sample") T.treeValue $ G.evalGen (H.Size 1) seed gen + Prelude.maybe + (Prelude.error "Couldn't create a sample") + T.treeValue + $ G.evalGen (H.Size 1) seed gen -- Given a list [n_1, n_2, ...] create a list [m_1, m_2, ...] where m_i is an n_i-word random -- integer makeSizedIntegers :: StdGen -> [Int] -> ([Integer], StdGen) makeSizedIntegers g [] = ([], g) -makeSizedIntegers g (n:ns) = - let (m,g1) = randNwords n g - (ms,g2) = makeSizedIntegers g1 ns - in (m:ms,g2) +makeSizedIntegers g (n : ns) = + let (m, g1) = randNwords n g + (ms, g2) = makeSizedIntegers g1 ns + in (m : ms, g2) -- Create a bytestring whose memory usage is n. Since we measure memory usage -- in 64-bit words we have to create a bytestring containing 8*n bytes. makeSizedByteString :: H.Seed -> Int -> ByteString -makeSizedByteString seed n = genSample seed (G.bytes (R.singleton (8*n))) +makeSizedByteString seed n = genSample seed (G.bytes (R.singleton (8 * n))) -- FIXME: this is terrible makeSizedByteStrings :: H.Seed -> [Int] -> [ByteString] makeSizedByteStrings seed l = map (makeSizedByteString seed) l - -- TODO: don't use Hedgehog's 'sample' below: it silently resizes the generator -- to size 30, so listOfByteStringsOfLength and listOfByteStrings are biased -- towards low byte values. @@ -87,13 +85,12 @@ makeSizedByteStrings seed l = map (makeSizedByteString seed) l -- Create a list containing m bytestrings of length n (also terrible) listOfByteStringsOfLength :: Int -> Int -> [ByteString] listOfByteStringsOfLength m n = - unsafePerformIO . G.sample $ G.list (R.singleton m) (G.bytes (R.singleton n)) + unsafePerformIO . G.sample $ G.list (R.singleton m) (G.bytes (R.singleton n)) -- Create a list containing m bytestrings of random lengths listOfByteStrings :: Int -> [ByteString] listOfByteStrings m = - unsafePerformIO . G.sample $ G.list (R.singleton m) (G.bytes (R.linear 0 10000)) - + unsafePerformIO . G.sample $ G.list (R.singleton m) (G.bytes (R.linear 0 10000)) ---------------- Strings (Hedgehog) ---------------- @@ -102,23 +99,21 @@ listOfByteStrings m = case. If we were to use the ascii generator that would give us two bytes per character. See Note [Choosing the inputs for costing benchmarks] in Strings.hs. -} makeSizedTextString :: H.Seed -> Int -> Text -makeSizedTextString seed n = genSample seed (G.text (R.singleton (2*n)) G.unicode) +makeSizedTextString seed n = genSample seed (G.text (R.singleton (2 * n)) G.unicode) makeSizedTextStrings :: H.Seed -> [Integer] -> [Text] makeSizedTextStrings seed sizes = fmap (makeSizedTextString seed . fromInteger) sizes - -{- | Generate a valid UTF-8 bytestring with memory usage approximately n for - benchmarking decodeUtf8. We use the 'unicode' generator beacuse that gives - the worst-case behaviour: see Note [Choosing the inputs for costing - benchmarks] in Strings.hs).-} +-- | Generate a valid UTF-8 bytestring with memory usage approximately n for +-- benchmarking decodeUtf8. We use the 'unicode' generator beacuse that gives +-- the worst-case behaviour: see Note [Choosing the inputs for costing +-- benchmarks] in Strings.hs). makeSizedUtf8ByteString :: H.Seed -> Int -> ByteString -makeSizedUtf8ByteString seed n = genSample seed (G.utf8 (R.singleton (2*n)) G.unicode) +makeSizedUtf8ByteString seed n = genSample seed (G.utf8 (R.singleton (2 * n)) G.unicode) makeSizedUtf8ByteStrings :: H.Seed -> [Integer] -> [ByteString] makeSizedUtf8ByteStrings seed sizes = (makeSizedUtf8ByteString seed . fromInteger) <$> sizes - ---------------- Data (QuickCheck) ---------------- {- Create a large Integer. QuckCheck doesn't provide this by default (and @@ -131,82 +126,88 @@ makeSizedUtf8ByteStrings seed sizes = (makeSizedUtf8ByteString seed . fromIntege -} genBigInteger :: Int -> Gen Integer genBigInteger n = do - body :: [Word64] <- vectorOf (n-1) arbitrary + body :: [Word64] <- vectorOf (n - 1) arbitrary first :: Int64 <- arbitrary pure $ List.foldl' go (fromIntegral first) body - where go :: Integer -> Word64 -> Integer - go acc w = acc `shiftL` 64 + fromIntegral w + where + go :: Integer -> Word64 -> Integer + go acc w = acc `shiftL` 64 + fromIntegral w -{- | Generate an arbitrary integer of size n (words) -} +-- | Generate an arbitrary integer of size n (words) genI :: Int -> Gen Data genI n = do I <$> genBigInteger n -{- | Generate an arbitrary bytestring of size n (words) -} +-- | Generate an arbitrary bytestring of size n (words) genB :: Int -> Gen Data genB n = do - let size = 4*n + let size = 4 * n B <$> resize size arbitrary -{- | Generate an arbitrary Data object of depth at most n containing btyrestrings - with memory usage bmem and integers with memory usage imem. The `memUsage` - instance for Data can only return a single number, and we could have for - example a deep tree containing small bytsetrings/integers which has exactly - the same memory usage as an object consisting of a single B constructor with - a very large bytestring. The costing function for certain operations - (specifically 'equalsData') would assign the same cost to processing both - objects even though they have very different structures. This generator - allows us to explore a large space of objects to see how the costs of - operations vary with the size. For size 5 we generally get trees of depth 3 - and up to 4000 nodes in total (although skewed towards smaller numbers of - nodes); for size 10 we get trees of depth 4 and up to about 20000 nodes; for - size 20, depth 5 and up to about one million nodes. --} +-- | Generate an arbitrary Data object of depth at most n containing btyrestrings +-- with memory usage bmem and integers with memory usage imem. The `memUsage` +-- instance for Data can only return a single number, and we could have for +-- example a deep tree containing small bytsetrings/integers which has exactly +-- the same memory usage as an object consisting of a single B constructor with +-- a very large bytestring. The costing function for certain operations +-- (specifically 'equalsData') would assign the same cost to processing both +-- objects even though they have very different structures. This generator +-- allows us to explore a large space of objects to see how the costs of +-- operations vary with the size. For size 5 we generally get trees of depth 3 +-- and up to 4000 nodes in total (although skewed towards smaller numbers of +-- nodes); for size 10 we get trees of depth 4 and up to about 20000 nodes; for +-- size 20, depth 5 and up to about one million nodes. genBoundedData :: Int -> Int -> Int -> Gen Data genBoundedData imem bmem size = genD size - where genD n = - if n <= 1 - then - Test.QuickCheck.oneof [ genI imem, genB bmem] - else - Test.QuickCheck.oneof - [ Constr <$> choose (1,100) <*> resize 5 (listOf (genD (n `div` 2))) - -- Constr is unilkely to have very many arguments. - , List <$> listOf' (genD (n `div` 2)) - , Map <$> (listOf' $ (,) <$> genD (n `div` 2) <*> genD (n `div` 2)) - ] - where listOf' g = frequency [ (800, resize 10 (listOf g)) - , (200, resize 100 (listOf g)) - , (2, resize 1000 (listOf g)) - ] - -- We probably will get large lists occasionally in practice, - -- but if we generate them too often we get enormous objects. - -- listOf' attempts to give us very occasional large lists. - -{- | Given a list [(n1, (i1, b1, s1)), (n2, (i2, b2, s2)), ...], return a list - containing n1 samples generated by genBoundedData i1 b1 s1 followed by n2 - samples from genBoundedData i2 b2 s2, and so on. -} + where + genD n = + if n <= 1 + then + Test.QuickCheck.oneof [genI imem, genB bmem] + else + Test.QuickCheck.oneof + [ Constr <$> choose (1, 100) <*> resize 5 (listOf (genD (n `div` 2))) + , -- Constr is unilkely to have very many arguments. + List <$> listOf' (genD (n `div` 2)) + , Map <$> (listOf' $ (,) <$> genD (n `div` 2) <*> genD (n `div` 2)) + ] + where + listOf' g = + frequency + [ (800, resize 10 (listOf g)) + , (200, resize 100 (listOf g)) + , (2, resize 1000 (listOf g)) + ] + +-- We probably will get large lists occasionally in practice, +-- but if we generate them too often we get enormous objects. +-- listOf' attempts to give us very occasional large lists. + +-- | Given a list [(n1, (i1, b1, s1)), (n2, (i2, b2, s2)), ...], return a list +-- containing n1 samples generated by genBoundedData i1 b1 s1 followed by n2 +-- samples from genBoundedData i2 b2 s2, and so on. genDataSample :: [(Int, (Int, Int, Int))] -> [Data] genDataSample l = - unsafePerformIO $ concat <$> mapM gen1 l - where gen1 (count, (imem, bmem, size)) = - replicateM count . generate $ genBoundedData imem bmem size - + unsafePerformIO $ concat <$> mapM gen1 l + where + gen1 (count, (imem, bmem, size)) = + replicateM count . generate $ genBoundedData imem bmem size -- A list of parameters for genDataSample dataParams :: [(Int, (Int, Int, Int))] -dataParams = [ (10, ( 10, 10, 1)) - , (10, ( 5, 10, 2)) - , (10, (100, 100, 2)) - , (10, ( 1, 1, 3)) - , (10, ( 2, 4, 4)) - , (30, ( 10, 7, 5)) - , (20, ( 1, 1, 10)) - , (20, ( 30, 30, 10)) - , (10, ( 4, 6, 15)) - , (10, ( 5, 5, 20)) - , (10, ( 1, 10, 25)) - ] -- 150 entries in all +dataParams = + [ (10, (10, 10, 1)) + , (10, (5, 10, 2)) + , (10, (100, 100, 2)) + , (10, (1, 1, 3)) + , (10, (2, 4, 4)) + , (30, (10, 7, 5)) + , (20, (1, 1, 10)) + , (20, (30, 30, 10)) + , (10, (4, 6, 15)) + , (10, (5, 5, 20)) + , (10, (1, 10, 25)) + ] -- 150 entries in all -- We want a list of random data, but for benchmarking purposes we also want to -- be able to filter out sublists for various constructors. To do this we @@ -215,7 +216,6 @@ dataParams = [ (10, ( 10, 10, 1)) dataSample :: [Data] dataSample = genDataSample (take 500 $ cycle dataParams) - -- A list of data for EqualsData, which is difficult to cost. We want some very -- small objects in here to give us an idea of what the intercept of regression -- line should be (but note tht the minimum ExMemoryUsage of a Data object is @@ -223,7 +223,7 @@ dataSample = genDataSample (take 500 $ cycle dataParams) -- objects. dataSampleForEq :: [Data] dataSampleForEq = - take 400 . filter (\d -> budgetUsage d < 1000000) . genDataSample . take 1000 $ - cycle ((20, (1,1,1)):dataParams) + take 400 . filter (\d -> budgetUsage d < 1000000) . genDataSample . take 1000 $ + cycle ((20, (1, 1, 1)) : dataParams) where budgetUsage = sumCostStream . flattenCostRose . memoryUsage diff --git a/plutus-core/cost-model/budgeting-bench/Main.hs b/plutus-core/cost-model/budgeting-bench/Main.hs index 51be377f0e8..4913c989608 100644 --- a/plutus-core/cost-model/budgeting-bench/Main.hs +++ b/plutus-core/cost-model/budgeting-bench/Main.hs @@ -45,25 +45,25 @@ main = do gen <- System.Random.getStdGen criterionMainWith - Start - defaultConfig $ - Benchmarks.Bitwise.makeBenchmarks - <> Benchmarks.Bool.makeBenchmarks gen - <> Benchmarks.ByteStrings.makeBenchmarks gen - <> Benchmarks.Crypto.makeBenchmarks gen - <> Benchmarks.Data.makeBenchmarks gen - <> Benchmarks.Integers.makeBenchmarks gen - <> Benchmarks.Lists.makeBenchmarks gen - <> Benchmarks.Arrays.makeBenchmarks gen - <> Benchmarks.Misc.makeBenchmarks gen - <> Benchmarks.Pairs.makeBenchmarks gen - <> Benchmarks.Strings.makeBenchmarks gen - <> Benchmarks.Tracing.makeBenchmarks gen - <> Benchmarks.Unit.makeBenchmarks gen + Start + defaultConfig + $ Benchmarks.Bitwise.makeBenchmarks + <> Benchmarks.Bool.makeBenchmarks gen + <> Benchmarks.ByteStrings.makeBenchmarks gen + <> Benchmarks.Crypto.makeBenchmarks gen + <> Benchmarks.Data.makeBenchmarks gen + <> Benchmarks.Integers.makeBenchmarks gen + <> Benchmarks.Lists.makeBenchmarks gen + <> Benchmarks.Arrays.makeBenchmarks gen + <> Benchmarks.Misc.makeBenchmarks gen + <> Benchmarks.Pairs.makeBenchmarks gen + <> Benchmarks.Strings.makeBenchmarks gen + <> Benchmarks.Tracing.makeBenchmarks gen + <> Benchmarks.Unit.makeBenchmarks gen {- Run the nop benchmarks with a large time limit (30 seconds) in an attempt to get accurate results. -} criterionMainWith - Continue - (defaultConfig { C.timeLimit = 30 }) $ - Benchmarks.Nops.makeBenchmarks gen + Continue + (defaultConfig {C.timeLimit = 30}) + $ Benchmarks.Nops.makeBenchmarks gen diff --git a/plutus-core/cost-model/create-cost-model/BuiltinMemoryModels.hs b/plutus-core/cost-model/create-cost-model/BuiltinMemoryModels.hs index 65e647d48f9..9a9bc17b422 100644 --- a/plutus-core/cost-model/create-cost-model/BuiltinMemoryModels.hs +++ b/plutus-core/cost-model/create-cost-model/BuiltinMemoryModels.hs @@ -3,8 +3,7 @@ -- | The memory models for the default set of builtins. These are copied into -- builtinCostModel.json by generate-cost-model. - -module BuiltinMemoryModels (builtinMemoryModels, Id(..)) +module BuiltinMemoryModels (builtinMemoryModels, Id (..)) where import PlutusCore.Crypto.BLS12_381.G1 qualified as G1 @@ -63,118 +62,120 @@ mlResultMemSize = toMemSize Pairing.mlResultMemSizeBytes -- The memory models for the default builtins -newtype Id a = Id { getId :: a } +newtype Id a = Id {getId :: a} builtinMemoryModels :: BuiltinCostModelBase Id -builtinMemoryModels = BuiltinCostModelBase - { paramAddInteger = Id $ ModelTwoArgumentsMaxSize $ OneVariableLinearFunction 1 1 - , paramSubtractInteger = Id $ ModelTwoArgumentsMaxSize $ OneVariableLinearFunction 1 1 - , paramMultiplyInteger = Id $ ModelTwoArgumentsAddedSizes $ identityFunction - , paramDivideInteger = Id $ ModelTwoArgumentsSubtractedSizes $ ModelSubtractedSizes 0 1 1 - , paramQuotientInteger = Id $ ModelTwoArgumentsSubtractedSizes $ ModelSubtractedSizes 0 1 1 - , paramRemainderInteger = Id $ ModelTwoArgumentsLinearInY $ identityFunction - , paramModInteger = Id $ ModelTwoArgumentsLinearInY $ identityFunction - , paramEqualsInteger = Id $ boolMemModel - , paramLessThanInteger = Id $ boolMemModel - , paramLessThanEqualsInteger = Id $ boolMemModel - , paramAppendByteString = Id $ ModelTwoArgumentsAddedSizes $ identityFunction - , paramConsByteString = Id $ ModelTwoArgumentsAddedSizes $ identityFunction - -- sliceByteString doesn't actually allocate a new bytestring: it creates an - -- object containing a pointer into the original, together with a length. - , paramSliceByteString = Id $ ModelThreeArgumentsLinearInZ $ OneVariableLinearFunction 4 0 - , paramLengthOfByteString = Id $ ModelOneArgumentConstantCost 10 - , paramIndexByteString = Id $ ModelTwoArgumentsConstantCost 4 - , paramEqualsByteString = Id $ boolMemModel - , paramLessThanByteString = Id $ boolMemModel - , paramLessThanEqualsByteString = Id $ boolMemModel - , paramSha2_256 = Id $ hashMemModel Hash.sha2_256 - , paramSha3_256 = Id $ hashMemModel Hash.sha3_256 - , paramBlake2b_256 = Id $ hashMemModel Hash.blake2b_256 - , paramVerifyEd25519Signature = Id $ ModelThreeArgumentsConstantCost 10 - , paramVerifyEcdsaSecp256k1Signature = Id $ ModelThreeArgumentsConstantCost 10 - , paramVerifySchnorrSecp256k1Signature = Id $ ModelThreeArgumentsConstantCost 10 - , paramAppendString = Id $ ModelTwoArgumentsAddedSizes $ OneVariableLinearFunction 4 1 - , paramEqualsString = Id $ boolMemModel - -- In the worst case two UTF-16 bytes encode to three UTF-8 bytes, so two - -- output words per input word should cover that. - , paramEncodeUtf8 = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 4 2 - -- In the worst case one UTF-8 byte decodes to two UTF-16 bytes - , paramDecodeUtf8 = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 4 2 - , paramIfThenElse = Id $ ModelThreeArgumentsConstantCost 1 - , paramChooseUnit = Id $ ModelTwoArgumentsConstantCost 4 - , paramTrace = Id $ ModelTwoArgumentsConstantCost 32 - , paramFstPair = Id $ ModelOneArgumentConstantCost 32 - , paramSndPair = Id $ ModelOneArgumentConstantCost 32 - , paramChooseList = Id $ ModelThreeArgumentsConstantCost 32 - , paramMkCons = Id $ ModelTwoArgumentsConstantCost 32 - , paramHeadList = Id $ ModelOneArgumentConstantCost 32 - , paramTailList = Id $ ModelOneArgumentConstantCost 32 - , paramNullList = Id $ ModelOneArgumentConstantCost 32 - , paramChooseData = Id $ ModelSixArgumentsConstantCost 32 - , paramConstrData = Id $ ModelTwoArgumentsConstantCost 32 - , paramMapData = Id $ ModelOneArgumentConstantCost 32 - , paramListData = Id $ ModelOneArgumentConstantCost 32 - , paramIData = Id $ ModelOneArgumentConstantCost 32 - , paramBData = Id $ ModelOneArgumentConstantCost 32 - , paramUnConstrData = Id $ ModelOneArgumentConstantCost 32 - , paramUnMapData = Id $ ModelOneArgumentConstantCost 32 - , paramUnListData = Id $ ModelOneArgumentConstantCost 32 - , paramUnIData = Id $ ModelOneArgumentConstantCost 32 - , paramUnBData = Id $ ModelOneArgumentConstantCost 32 - , paramEqualsData = Id $ ModelTwoArgumentsConstantCost 1 - , paramMkPairData = Id $ ModelTwoArgumentsConstantCost 32 - , paramMkNilData = Id $ ModelOneArgumentConstantCost 32 - , paramMkNilPairData = Id $ ModelOneArgumentConstantCost 32 - , paramSerialiseData = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 0 2 - , paramBls12_381_G1_add = Id $ ModelTwoArgumentsConstantCost g1MemSize - , paramBls12_381_G1_neg = Id $ ModelOneArgumentConstantCost g1MemSize - , paramBls12_381_G1_scalarMul = Id $ ModelTwoArgumentsConstantCost g1MemSize - , paramBls12_381_G1_multiScalarMul = Id $ ModelTwoArgumentsConstantCost g1MemSize - , paramBls12_381_G1_equal = Id $ boolMemModel - , paramBls12_381_G1_compress = Id $ ModelOneArgumentConstantCost g1CompressedSize - , paramBls12_381_G1_uncompress = Id $ ModelOneArgumentConstantCost g1MemSize - , paramBls12_381_G1_hashToGroup = Id $ ModelTwoArgumentsConstantCost g1MemSize - , paramBls12_381_G2_add = Id $ ModelTwoArgumentsConstantCost g2MemSize - , paramBls12_381_G2_neg = Id $ ModelOneArgumentConstantCost g2MemSize - , paramBls12_381_G2_scalarMul = Id $ ModelTwoArgumentsConstantCost g2MemSize - , paramBls12_381_G2_multiScalarMul = Id $ ModelTwoArgumentsConstantCost g2MemSize - , paramBls12_381_G2_equal = Id $ boolMemModel - , paramBls12_381_G2_compress = Id $ ModelOneArgumentConstantCost g2CompressedSize - , paramBls12_381_G2_uncompress = Id $ ModelOneArgumentConstantCost g2MemSize - , paramBls12_381_G2_hashToGroup = Id $ ModelTwoArgumentsConstantCost g2MemSize - , paramBls12_381_millerLoop = Id $ ModelTwoArgumentsConstantCost mlResultMemSize - , paramBls12_381_mulMlResult = Id $ ModelTwoArgumentsConstantCost mlResultMemSize - , paramBls12_381_finalVerify = Id $ boolMemModel - , paramBlake2b_224 = Id $ hashMemModel Hash.blake2b_224 - , paramKeccak_256 = Id $ hashMemModel Hash.keccak_256 - -- integerToByteString e w n allocates a bytestring of length w if w is - -- nonzero and a bytestring just big enough to contain n otherwise, so we need - -- a special memory costing function to handle that. - , paramIntegerToByteString = Id $ ModelThreeArgumentsLiteralInYOrLinearInZ identityFunction - , paramByteStringToInteger = Id $ ModelTwoArgumentsLinearInY identityFunction - -- andByteString b y z etc. return something whose length is min(length(y),length(z)) if b is - -- False, max (...) otherwise. For the time being we conservatively assume max in all cases. - , paramAndByteString = Id $ ModelThreeArgumentsLinearInMaxYZ identityFunction - , paramOrByteString = Id $ ModelThreeArgumentsLinearInMaxYZ identityFunction - , paramXorByteString = Id $ ModelThreeArgumentsLinearInMaxYZ identityFunction - , paramComplementByteString = Id $ ModelOneArgumentLinearInX identityFunction - , paramReadBit = Id $ ModelTwoArgumentsConstantCost 1 - , paramWriteBits = Id $ ModelThreeArgumentsLinearInX identityFunction - -- The empty bytestring has memory usage 1, so we add an extra memory unit here to make sure that - -- the memory cost of `replicateByte` is always nonzero. That means that we're charging one unit - -- more than we perhaps should for nonempty bytestrings, but that's negligible (plus there's some - -- overhead for bytesrings anyway). Note also that `replicateByte`'s argument is costed as a - -- literal size. - , paramReplicateByte = Id $ ModelTwoArgumentsLinearInX $ OneVariableLinearFunction 1 1 - , paramShiftByteString = Id $ ModelTwoArgumentsLinearInX identityFunction - , paramRotateByteString = Id $ ModelTwoArgumentsLinearInX identityFunction - , paramCountSetBits = Id $ ModelOneArgumentConstantCost 1 - , paramFindFirstSetBit = Id $ ModelOneArgumentConstantCost 1 - , paramRipemd_160 = Id $ hashMemModel Hash.ripemd_160 - , paramExpModInteger = Id $ ModelThreeArgumentsLinearInZ identityFunction - , paramDropList = Id $ ModelTwoArgumentsConstantCost 4 - , paramLengthOfArray = Id $ ModelOneArgumentConstantCost 10 - , paramListToArray = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 7 1 - , paramIndexArray = Id $ ModelTwoArgumentsConstantCost 32 - } - where identityFunction = OneVariableLinearFunction 0 1 +builtinMemoryModels = + BuiltinCostModelBase + { paramAddInteger = Id $ ModelTwoArgumentsMaxSize $ OneVariableLinearFunction 1 1 + , paramSubtractInteger = Id $ ModelTwoArgumentsMaxSize $ OneVariableLinearFunction 1 1 + , paramMultiplyInteger = Id $ ModelTwoArgumentsAddedSizes $ identityFunction + , paramDivideInteger = Id $ ModelTwoArgumentsSubtractedSizes $ ModelSubtractedSizes 0 1 1 + , paramQuotientInteger = Id $ ModelTwoArgumentsSubtractedSizes $ ModelSubtractedSizes 0 1 1 + , paramRemainderInteger = Id $ ModelTwoArgumentsLinearInY $ identityFunction + , paramModInteger = Id $ ModelTwoArgumentsLinearInY $ identityFunction + , paramEqualsInteger = Id $ boolMemModel + , paramLessThanInteger = Id $ boolMemModel + , paramLessThanEqualsInteger = Id $ boolMemModel + , paramAppendByteString = Id $ ModelTwoArgumentsAddedSizes $ identityFunction + , paramConsByteString = Id $ ModelTwoArgumentsAddedSizes $ identityFunction + , -- sliceByteString doesn't actually allocate a new bytestring: it creates an + -- object containing a pointer into the original, together with a length. + paramSliceByteString = Id $ ModelThreeArgumentsLinearInZ $ OneVariableLinearFunction 4 0 + , paramLengthOfByteString = Id $ ModelOneArgumentConstantCost 10 + , paramIndexByteString = Id $ ModelTwoArgumentsConstantCost 4 + , paramEqualsByteString = Id $ boolMemModel + , paramLessThanByteString = Id $ boolMemModel + , paramLessThanEqualsByteString = Id $ boolMemModel + , paramSha2_256 = Id $ hashMemModel Hash.sha2_256 + , paramSha3_256 = Id $ hashMemModel Hash.sha3_256 + , paramBlake2b_256 = Id $ hashMemModel Hash.blake2b_256 + , paramVerifyEd25519Signature = Id $ ModelThreeArgumentsConstantCost 10 + , paramVerifyEcdsaSecp256k1Signature = Id $ ModelThreeArgumentsConstantCost 10 + , paramVerifySchnorrSecp256k1Signature = Id $ ModelThreeArgumentsConstantCost 10 + , paramAppendString = Id $ ModelTwoArgumentsAddedSizes $ OneVariableLinearFunction 4 1 + , paramEqualsString = Id $ boolMemModel + , -- In the worst case two UTF-16 bytes encode to three UTF-8 bytes, so two + -- output words per input word should cover that. + paramEncodeUtf8 = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 4 2 + , -- In the worst case one UTF-8 byte decodes to two UTF-16 bytes + paramDecodeUtf8 = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 4 2 + , paramIfThenElse = Id $ ModelThreeArgumentsConstantCost 1 + , paramChooseUnit = Id $ ModelTwoArgumentsConstantCost 4 + , paramTrace = Id $ ModelTwoArgumentsConstantCost 32 + , paramFstPair = Id $ ModelOneArgumentConstantCost 32 + , paramSndPair = Id $ ModelOneArgumentConstantCost 32 + , paramChooseList = Id $ ModelThreeArgumentsConstantCost 32 + , paramMkCons = Id $ ModelTwoArgumentsConstantCost 32 + , paramHeadList = Id $ ModelOneArgumentConstantCost 32 + , paramTailList = Id $ ModelOneArgumentConstantCost 32 + , paramNullList = Id $ ModelOneArgumentConstantCost 32 + , paramChooseData = Id $ ModelSixArgumentsConstantCost 32 + , paramConstrData = Id $ ModelTwoArgumentsConstantCost 32 + , paramMapData = Id $ ModelOneArgumentConstantCost 32 + , paramListData = Id $ ModelOneArgumentConstantCost 32 + , paramIData = Id $ ModelOneArgumentConstantCost 32 + , paramBData = Id $ ModelOneArgumentConstantCost 32 + , paramUnConstrData = Id $ ModelOneArgumentConstantCost 32 + , paramUnMapData = Id $ ModelOneArgumentConstantCost 32 + , paramUnListData = Id $ ModelOneArgumentConstantCost 32 + , paramUnIData = Id $ ModelOneArgumentConstantCost 32 + , paramUnBData = Id $ ModelOneArgumentConstantCost 32 + , paramEqualsData = Id $ ModelTwoArgumentsConstantCost 1 + , paramMkPairData = Id $ ModelTwoArgumentsConstantCost 32 + , paramMkNilData = Id $ ModelOneArgumentConstantCost 32 + , paramMkNilPairData = Id $ ModelOneArgumentConstantCost 32 + , paramSerialiseData = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 0 2 + , paramBls12_381_G1_add = Id $ ModelTwoArgumentsConstantCost g1MemSize + , paramBls12_381_G1_neg = Id $ ModelOneArgumentConstantCost g1MemSize + , paramBls12_381_G1_scalarMul = Id $ ModelTwoArgumentsConstantCost g1MemSize + , paramBls12_381_G1_multiScalarMul = Id $ ModelTwoArgumentsConstantCost g1MemSize + , paramBls12_381_G1_equal = Id $ boolMemModel + , paramBls12_381_G1_compress = Id $ ModelOneArgumentConstantCost g1CompressedSize + , paramBls12_381_G1_uncompress = Id $ ModelOneArgumentConstantCost g1MemSize + , paramBls12_381_G1_hashToGroup = Id $ ModelTwoArgumentsConstantCost g1MemSize + , paramBls12_381_G2_add = Id $ ModelTwoArgumentsConstantCost g2MemSize + , paramBls12_381_G2_neg = Id $ ModelOneArgumentConstantCost g2MemSize + , paramBls12_381_G2_scalarMul = Id $ ModelTwoArgumentsConstantCost g2MemSize + , paramBls12_381_G2_multiScalarMul = Id $ ModelTwoArgumentsConstantCost g2MemSize + , paramBls12_381_G2_equal = Id $ boolMemModel + , paramBls12_381_G2_compress = Id $ ModelOneArgumentConstantCost g2CompressedSize + , paramBls12_381_G2_uncompress = Id $ ModelOneArgumentConstantCost g2MemSize + , paramBls12_381_G2_hashToGroup = Id $ ModelTwoArgumentsConstantCost g2MemSize + , paramBls12_381_millerLoop = Id $ ModelTwoArgumentsConstantCost mlResultMemSize + , paramBls12_381_mulMlResult = Id $ ModelTwoArgumentsConstantCost mlResultMemSize + , paramBls12_381_finalVerify = Id $ boolMemModel + , paramBlake2b_224 = Id $ hashMemModel Hash.blake2b_224 + , paramKeccak_256 = Id $ hashMemModel Hash.keccak_256 + , -- integerToByteString e w n allocates a bytestring of length w if w is + -- nonzero and a bytestring just big enough to contain n otherwise, so we need + -- a special memory costing function to handle that. + paramIntegerToByteString = Id $ ModelThreeArgumentsLiteralInYOrLinearInZ identityFunction + , paramByteStringToInteger = Id $ ModelTwoArgumentsLinearInY identityFunction + , -- andByteString b y z etc. return something whose length is min(length(y),length(z)) if b is + -- False, max (...) otherwise. For the time being we conservatively assume max in all cases. + paramAndByteString = Id $ ModelThreeArgumentsLinearInMaxYZ identityFunction + , paramOrByteString = Id $ ModelThreeArgumentsLinearInMaxYZ identityFunction + , paramXorByteString = Id $ ModelThreeArgumentsLinearInMaxYZ identityFunction + , paramComplementByteString = Id $ ModelOneArgumentLinearInX identityFunction + , paramReadBit = Id $ ModelTwoArgumentsConstantCost 1 + , paramWriteBits = Id $ ModelThreeArgumentsLinearInX identityFunction + , -- The empty bytestring has memory usage 1, so we add an extra memory unit here to make sure that + -- the memory cost of `replicateByte` is always nonzero. That means that we're charging one unit + -- more than we perhaps should for nonempty bytestrings, but that's negligible (plus there's some + -- overhead for bytesrings anyway). Note also that `replicateByte`'s argument is costed as a + -- literal size. + paramReplicateByte = Id $ ModelTwoArgumentsLinearInX $ OneVariableLinearFunction 1 1 + , paramShiftByteString = Id $ ModelTwoArgumentsLinearInX identityFunction + , paramRotateByteString = Id $ ModelTwoArgumentsLinearInX identityFunction + , paramCountSetBits = Id $ ModelOneArgumentConstantCost 1 + , paramFindFirstSetBit = Id $ ModelOneArgumentConstantCost 1 + , paramRipemd_160 = Id $ hashMemModel Hash.ripemd_160 + , paramExpModInteger = Id $ ModelThreeArgumentsLinearInZ identityFunction + , paramDropList = Id $ ModelTwoArgumentsConstantCost 4 + , paramLengthOfArray = Id $ ModelOneArgumentConstantCost 10 + , paramListToArray = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 7 1 + , paramIndexArray = Id $ ModelTwoArgumentsConstantCost 32 + } + where + identityFunction = OneVariableLinearFunction 0 1 diff --git a/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs b/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs index 889d43da60a..42bc103f762 100644 --- a/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs +++ b/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} module CreateBuiltinCostModel (costModelsR, createBuiltinCostModel, microToPico) where @@ -36,258 +36,258 @@ microToPico = unsafeToSatInt . ceiling . (1e6 *) -- If you get one of these wrong you'll probably get a message saying -- 'parse error (not enough input) at ""'. builtinCostModelNames :: BuiltinCostModelBase (Const Text) -builtinCostModelNames = BuiltinCostModelBase - { paramAddInteger = "addIntegerModel" - , paramSubtractInteger = "subtractIntegerModel" - , paramMultiplyInteger = "multiplyIntegerModel" - , paramDivideInteger = "divideIntegerModel" - , paramQuotientInteger = "quotientIntegerModel" - , paramRemainderInteger = "remainderIntegerModel" - , paramModInteger = "modIntegerModel" - , paramEqualsInteger = "equalsIntegerModel" - , paramLessThanInteger = "lessThanIntegerModel" - , paramLessThanEqualsInteger = "lessThanEqualsIntegerModel" - , paramAppendByteString = "appendByteStringModel" - , paramConsByteString = "consByteStringModel" - , paramSliceByteString = "sliceByteStringModel" - , paramLengthOfByteString = "lengthOfByteStringModel" - , paramIndexByteString = "indexByteStringModel" - , paramEqualsByteString = "equalsByteStringModel" - , paramLessThanByteString = "lessThanByteStringModel" - , paramLessThanEqualsByteString = "lessThanEqualsByteStringModel" - , paramSha2_256 = "sha2_256Model" - , paramSha3_256 = "sha3_256Model" - , paramBlake2b_256 = "blake2b_256Model" - , paramVerifyEd25519Signature = "verifyEd25519SignatureModel" - , paramVerifyEcdsaSecp256k1Signature = "verifyEcdsaSecp256k1SignatureModel" - , paramVerifySchnorrSecp256k1Signature = "verifySchnorrSecp256k1SignatureModel" - , paramAppendString = "appendStringModel" - , paramEqualsString = "equalsStringModel" - , paramEncodeUtf8 = "encodeUtf8Model" - , paramDecodeUtf8 = "decodeUtf8Model" - , paramIfThenElse = "ifThenElseModel" - , paramChooseUnit = "chooseUnitModel" - , paramTrace = "traceModel" - , paramFstPair = "fstPairModel" - , paramSndPair = "sndPairModel" - , paramChooseList = "chooseListModel" - , paramMkCons = "mkConsModel" - , paramHeadList = "headListModel" - , paramTailList = "tailListModel" - , paramNullList = "nullListModel" - , paramChooseData = "chooseDataModel" - , paramConstrData = "constrDataModel" - , paramMapData = "mapDataModel" - , paramListData = "listDataModel" - , paramIData = "iDataModel" - , paramBData = "bDataModel" - , paramUnConstrData = "unConstrDataModel" - , paramUnMapData = "unMapDataModel" - , paramUnListData = "unListDataModel" - , paramUnIData = "unIDataModel" - , paramUnBData = "unBDataModel" - , paramEqualsData = "equalsDataModel" - , paramMkPairData = "mkPairDataModel" - , paramMkNilData = "mkNilDataModel" - , paramMkNilPairData = "mkNilPairDataModel" - , paramSerialiseData = "serialiseDataModel" - , paramBls12_381_G1_add = "bls12_381_G1_addModel" - , paramBls12_381_G1_neg = "bls12_381_G1_negModel" - , paramBls12_381_G1_scalarMul = "bls12_381_G1_scalarMulModel" - , paramBls12_381_G1_multiScalarMul = "bls12_381_G1_multiScalarMulModel" - , paramBls12_381_G1_equal = "bls12_381_G1_equalModel" - , paramBls12_381_G1_compress = "bls12_381_G1_compressModel" - , paramBls12_381_G1_uncompress = "bls12_381_G1_uncompressModel" - , paramBls12_381_G1_hashToGroup = "bls12_381_G1_hashToGroupModel" - , paramBls12_381_G2_add = "bls12_381_G2_addModel" - , paramBls12_381_G2_neg = "bls12_381_G2_negModel" - , paramBls12_381_G2_scalarMul = "bls12_381_G2_scalarMulModel" - , paramBls12_381_G2_multiScalarMul = "bls12_381_G2_multiScalarMulModel" - , paramBls12_381_G2_equal = "bls12_381_G2_equalModel" - , paramBls12_381_G2_compress = "bls12_381_G2_compressModel" - , paramBls12_381_G2_uncompress = "bls12_381_G2_uncompressModel" - , paramBls12_381_G2_hashToGroup = "bls12_381_G2_hashToGroupModel" - , paramBls12_381_millerLoop = "bls12_381_millerLoopModel" - , paramBls12_381_mulMlResult = "bls12_381_mulMlResultModel" - , paramBls12_381_finalVerify = "bls12_381_finalVerifyModel" - , paramBlake2b_224 = "blake2b_224Model" - , paramKeccak_256 = "keccak_256Model" - , paramIntegerToByteString = "integerToByteStringModel" - , paramByteStringToInteger = "byteStringToIntegerModel" - , paramAndByteString = "andByteStringModel" - , paramOrByteString = "orByteStringModel" - , paramXorByteString = "xorByteStringModel" - , paramComplementByteString = "complementByteStringModel" - , paramReadBit = "readBitModel" - , paramWriteBits = "writeBitsModel" - , paramReplicateByte = "replicateByteModel" - , paramShiftByteString = "shiftByteStringModel" - , paramRotateByteString = "rotateByteStringModel" - , paramCountSetBits = "countSetBitsModel" - , paramFindFirstSetBit = "findFirstSetBitModel" - , paramRipemd_160 = "ripemd_160Model" - , paramExpModInteger = "expModIntegerModel" - , paramDropList = "dropListModel" - , paramLengthOfArray = "lengthOfArrayModel" - , paramListToArray = "listToArrayModel" - , paramIndexArray = "indexArrayModel" - } - +builtinCostModelNames = + BuiltinCostModelBase + { paramAddInteger = "addIntegerModel" + , paramSubtractInteger = "subtractIntegerModel" + , paramMultiplyInteger = "multiplyIntegerModel" + , paramDivideInteger = "divideIntegerModel" + , paramQuotientInteger = "quotientIntegerModel" + , paramRemainderInteger = "remainderIntegerModel" + , paramModInteger = "modIntegerModel" + , paramEqualsInteger = "equalsIntegerModel" + , paramLessThanInteger = "lessThanIntegerModel" + , paramLessThanEqualsInteger = "lessThanEqualsIntegerModel" + , paramAppendByteString = "appendByteStringModel" + , paramConsByteString = "consByteStringModel" + , paramSliceByteString = "sliceByteStringModel" + , paramLengthOfByteString = "lengthOfByteStringModel" + , paramIndexByteString = "indexByteStringModel" + , paramEqualsByteString = "equalsByteStringModel" + , paramLessThanByteString = "lessThanByteStringModel" + , paramLessThanEqualsByteString = "lessThanEqualsByteStringModel" + , paramSha2_256 = "sha2_256Model" + , paramSha3_256 = "sha3_256Model" + , paramBlake2b_256 = "blake2b_256Model" + , paramVerifyEd25519Signature = "verifyEd25519SignatureModel" + , paramVerifyEcdsaSecp256k1Signature = "verifyEcdsaSecp256k1SignatureModel" + , paramVerifySchnorrSecp256k1Signature = "verifySchnorrSecp256k1SignatureModel" + , paramAppendString = "appendStringModel" + , paramEqualsString = "equalsStringModel" + , paramEncodeUtf8 = "encodeUtf8Model" + , paramDecodeUtf8 = "decodeUtf8Model" + , paramIfThenElse = "ifThenElseModel" + , paramChooseUnit = "chooseUnitModel" + , paramTrace = "traceModel" + , paramFstPair = "fstPairModel" + , paramSndPair = "sndPairModel" + , paramChooseList = "chooseListModel" + , paramMkCons = "mkConsModel" + , paramHeadList = "headListModel" + , paramTailList = "tailListModel" + , paramNullList = "nullListModel" + , paramChooseData = "chooseDataModel" + , paramConstrData = "constrDataModel" + , paramMapData = "mapDataModel" + , paramListData = "listDataModel" + , paramIData = "iDataModel" + , paramBData = "bDataModel" + , paramUnConstrData = "unConstrDataModel" + , paramUnMapData = "unMapDataModel" + , paramUnListData = "unListDataModel" + , paramUnIData = "unIDataModel" + , paramUnBData = "unBDataModel" + , paramEqualsData = "equalsDataModel" + , paramMkPairData = "mkPairDataModel" + , paramMkNilData = "mkNilDataModel" + , paramMkNilPairData = "mkNilPairDataModel" + , paramSerialiseData = "serialiseDataModel" + , paramBls12_381_G1_add = "bls12_381_G1_addModel" + , paramBls12_381_G1_neg = "bls12_381_G1_negModel" + , paramBls12_381_G1_scalarMul = "bls12_381_G1_scalarMulModel" + , paramBls12_381_G1_multiScalarMul = "bls12_381_G1_multiScalarMulModel" + , paramBls12_381_G1_equal = "bls12_381_G1_equalModel" + , paramBls12_381_G1_compress = "bls12_381_G1_compressModel" + , paramBls12_381_G1_uncompress = "bls12_381_G1_uncompressModel" + , paramBls12_381_G1_hashToGroup = "bls12_381_G1_hashToGroupModel" + , paramBls12_381_G2_add = "bls12_381_G2_addModel" + , paramBls12_381_G2_neg = "bls12_381_G2_negModel" + , paramBls12_381_G2_scalarMul = "bls12_381_G2_scalarMulModel" + , paramBls12_381_G2_multiScalarMul = "bls12_381_G2_multiScalarMulModel" + , paramBls12_381_G2_equal = "bls12_381_G2_equalModel" + , paramBls12_381_G2_compress = "bls12_381_G2_compressModel" + , paramBls12_381_G2_uncompress = "bls12_381_G2_uncompressModel" + , paramBls12_381_G2_hashToGroup = "bls12_381_G2_hashToGroupModel" + , paramBls12_381_millerLoop = "bls12_381_millerLoopModel" + , paramBls12_381_mulMlResult = "bls12_381_mulMlResultModel" + , paramBls12_381_finalVerify = "bls12_381_finalVerifyModel" + , paramBlake2b_224 = "blake2b_224Model" + , paramKeccak_256 = "keccak_256Model" + , paramIntegerToByteString = "integerToByteStringModel" + , paramByteStringToInteger = "byteStringToIntegerModel" + , paramAndByteString = "andByteStringModel" + , paramOrByteString = "orByteStringModel" + , paramXorByteString = "xorByteStringModel" + , paramComplementByteString = "complementByteStringModel" + , paramReadBit = "readBitModel" + , paramWriteBits = "writeBitsModel" + , paramReplicateByte = "replicateByteModel" + , paramShiftByteString = "shiftByteStringModel" + , paramRotateByteString = "rotateByteStringModel" + , paramCountSetBits = "countSetBitsModel" + , paramFindFirstSetBit = "findFirstSetBitModel" + , paramRipemd_160 = "ripemd_160Model" + , paramExpModInteger = "expModIntegerModel" + , paramDropList = "dropListModel" + , paramLengthOfArray = "lengthOfArrayModel" + , paramListToArray = "listToArrayModel" + , paramIndexArray = "indexArrayModel" + } -- | Loads the models from R. -- The "_hs" suffixes below make Haskell variables accessible inside [r| ... |] -costModelsR - :: MonadR m - => FilePath - -> FilePath - -> m (BuiltinCostModelBase (Const (SomeSEXP (Region m)))) +costModelsR :: + MonadR m => + FilePath -> + FilePath -> + m (BuiltinCostModelBase (Const (SomeSEXP (Region m)))) costModelsR bmfile rfile = do - list <- [r| + list <- + [r| source(rfile_hs) modelFun(bmfile_hs) |] let makeCostModelEntry name = - let n = getConst name - in Compose $ fmap Const $ [r| list_hs [[n_hs]] |] + let n = getConst name + in Compose $ fmap Const $ [r| list_hs [[n_hs]] |] bsequence $ bmap makeCostModelEntry builtinCostModelNames -{- | Creates the cost model from a CSV benchmarking results file and a file -containing R modelling code. Note that R must be initialised before this is -called, typically like this: - withEmbeddedR defaultConfig $ runRegion $ createBuiltinCostModel ... --} +-- | Creates the cost model from a CSV benchmarking results file and a file +-- containing R modelling code. Note that R must be initialised before this is +-- called, typically like this: +-- withEmbeddedR defaultConfig $ runRegion $ createBuiltinCostModel ... createBuiltinCostModel :: FilePath -> FilePath -> R s (BuiltinCostModelBase CostingFun) createBuiltinCostModel bmfile rfile = do cpuModels :: BuiltinCostModelBase (Const (SomeSEXP s)) <- costModelsR bmfile rfile - let getParams - :: (SomeSEXP s -> R s model) - -> (forall f. BuiltinCostModelBase f -> f model) - -> R s (CostingFun model) + let getParams :: + (SomeSEXP s -> R s model) -> + (forall f. BuiltinCostModelBase f -> f model) -> + R s (CostingFun model) getParams readCF param = do let memModel = getId $ param builtinMemoryModels cpuModel <- readCF $ getConst $ param cpuModels pure $ CostingFun cpuModel memModel -- Integers - paramAddInteger <- getParams readCF2 paramAddInteger - paramSubtractInteger <- getParams readCF2 paramSubtractInteger - paramMultiplyInteger <- getParams readCF2 paramMultiplyInteger - paramDivideInteger <- getParams readCF2 paramDivideInteger - paramQuotientInteger <- getParams readCF2 paramQuotientInteger - paramRemainderInteger <- getParams readCF2 paramRemainderInteger - paramModInteger <- getParams readCF2 paramModInteger - paramEqualsInteger <- getParams readCF2 paramEqualsInteger - paramLessThanInteger <- getParams readCF2 paramLessThanInteger - paramLessThanEqualsInteger <- getParams readCF2 paramLessThanEqualsInteger + paramAddInteger <- getParams readCF2 paramAddInteger + paramSubtractInteger <- getParams readCF2 paramSubtractInteger + paramMultiplyInteger <- getParams readCF2 paramMultiplyInteger + paramDivideInteger <- getParams readCF2 paramDivideInteger + paramQuotientInteger <- getParams readCF2 paramQuotientInteger + paramRemainderInteger <- getParams readCF2 paramRemainderInteger + paramModInteger <- getParams readCF2 paramModInteger + paramEqualsInteger <- getParams readCF2 paramEqualsInteger + paramLessThanInteger <- getParams readCF2 paramLessThanInteger + paramLessThanEqualsInteger <- getParams readCF2 paramLessThanEqualsInteger -- Bytestrings - paramAppendByteString <- getParams readCF2 paramAppendByteString - paramConsByteString <- getParams readCF2 paramConsByteString - paramSliceByteString <- getParams readCF3 paramSliceByteString - paramLengthOfByteString <- getParams readCF1 paramLengthOfByteString - paramIndexByteString <- getParams readCF2 paramIndexByteString - paramEqualsByteString <- getParams readCF2 paramEqualsByteString - paramLessThanByteString <- getParams readCF2 paramLessThanByteString - paramLessThanEqualsByteString <- getParams readCF2 paramLessThanEqualsByteString + paramAppendByteString <- getParams readCF2 paramAppendByteString + paramConsByteString <- getParams readCF2 paramConsByteString + paramSliceByteString <- getParams readCF3 paramSliceByteString + paramLengthOfByteString <- getParams readCF1 paramLengthOfByteString + paramIndexByteString <- getParams readCF2 paramIndexByteString + paramEqualsByteString <- getParams readCF2 paramEqualsByteString + paramLessThanByteString <- getParams readCF2 paramLessThanByteString + paramLessThanEqualsByteString <- getParams readCF2 paramLessThanEqualsByteString -- Cryptography and hashes - paramSha2_256 <- getParams readCF1 paramSha2_256 - paramSha3_256 <- getParams readCF1 paramSha3_256 - paramBlake2b_256 <- getParams readCF1 paramBlake2b_256 - paramVerifyEd25519Signature <- getParams readCF3 paramVerifyEd25519Signature - paramVerifyEcdsaSecp256k1Signature <- getParams readCF3 paramVerifyEcdsaSecp256k1Signature + paramSha2_256 <- getParams readCF1 paramSha2_256 + paramSha3_256 <- getParams readCF1 paramSha3_256 + paramBlake2b_256 <- getParams readCF1 paramBlake2b_256 + paramVerifyEd25519Signature <- getParams readCF3 paramVerifyEd25519Signature + paramVerifyEcdsaSecp256k1Signature <- getParams readCF3 paramVerifyEcdsaSecp256k1Signature paramVerifySchnorrSecp256k1Signature <- getParams readCF3 paramVerifySchnorrSecp256k1Signature -- Strings - paramAppendString <- getParams readCF2 paramAppendString - paramEqualsString <- getParams readCF2 paramEqualsString - paramEncodeUtf8 <- getParams readCF1 paramEncodeUtf8 - paramDecodeUtf8 <- getParams readCF1 paramDecodeUtf8 + paramAppendString <- getParams readCF2 paramAppendString + paramEqualsString <- getParams readCF2 paramEqualsString + paramEncodeUtf8 <- getParams readCF1 paramEncodeUtf8 + paramDecodeUtf8 <- getParams readCF1 paramDecodeUtf8 -- Bool - paramIfThenElse <- getParams readCF3 paramIfThenElse + paramIfThenElse <- getParams readCF3 paramIfThenElse -- Unit - paramChooseUnit <- getParams readCF2 paramChooseUnit + paramChooseUnit <- getParams readCF2 paramChooseUnit -- Tracing - paramTrace <- getParams readCF2 paramTrace + paramTrace <- getParams readCF2 paramTrace -- Pairs - paramFstPair <- getParams readCF1 paramFstPair - paramSndPair <- getParams readCF1 paramSndPair + paramFstPair <- getParams readCF1 paramFstPair + paramSndPair <- getParams readCF1 paramSndPair -- Lists - paramChooseList <- getParams readCF3 paramChooseList - paramMkCons <- getParams readCF2 paramMkCons - paramHeadList <- getParams readCF1 paramHeadList - paramTailList <- getParams readCF1 paramTailList - paramNullList <- getParams readCF1 paramNullList + paramChooseList <- getParams readCF3 paramChooseList + paramMkCons <- getParams readCF2 paramMkCons + paramHeadList <- getParams readCF1 paramHeadList + paramTailList <- getParams readCF1 paramTailList + paramNullList <- getParams readCF1 paramNullList -- Data - paramChooseData <- getParams readCF6 paramChooseData - paramConstrData <- getParams readCF2 paramConstrData - paramMapData <- getParams readCF1 paramMapData - paramListData <- getParams readCF1 paramListData - paramIData <- getParams readCF1 paramIData - paramBData <- getParams readCF1 paramBData - paramUnConstrData <- getParams readCF1 paramUnConstrData - paramUnMapData <- getParams readCF1 paramUnMapData - paramUnListData <- getParams readCF1 paramUnListData - paramUnIData <- getParams readCF1 paramUnIData - paramUnBData <- getParams readCF1 paramUnBData - paramEqualsData <- getParams readCF2 paramEqualsData - paramSerialiseData <- getParams readCF1 paramSerialiseData + paramChooseData <- getParams readCF6 paramChooseData + paramConstrData <- getParams readCF2 paramConstrData + paramMapData <- getParams readCF1 paramMapData + paramListData <- getParams readCF1 paramListData + paramIData <- getParams readCF1 paramIData + paramBData <- getParams readCF1 paramBData + paramUnConstrData <- getParams readCF1 paramUnConstrData + paramUnMapData <- getParams readCF1 paramUnMapData + paramUnListData <- getParams readCF1 paramUnListData + paramUnIData <- getParams readCF1 paramUnIData + paramUnBData <- getParams readCF1 paramUnBData + paramEqualsData <- getParams readCF2 paramEqualsData + paramSerialiseData <- getParams readCF1 paramSerialiseData -- Misc constructors - paramMkPairData <- getParams readCF2 paramMkPairData - paramMkNilData <- getParams readCF1 paramMkNilData - paramMkNilPairData <- getParams readCF1 paramMkNilPairData + paramMkPairData <- getParams readCF2 paramMkPairData + paramMkNilData <- getParams readCF1 paramMkNilData + paramMkNilPairData <- getParams readCF1 paramMkNilPairData -- BLS12-381 - paramBls12_381_G1_add <- getParams readCF2 paramBls12_381_G1_add - paramBls12_381_G1_neg <- getParams readCF1 paramBls12_381_G1_neg - paramBls12_381_G1_scalarMul <- getParams readCF2 paramBls12_381_G1_scalarMul - paramBls12_381_G1_multiScalarMul <- getParams readCF2 paramBls12_381_G1_multiScalarMul - paramBls12_381_G1_equal <- getParams readCF2 paramBls12_381_G1_equal - paramBls12_381_G1_compress <- getParams readCF1 paramBls12_381_G1_compress - paramBls12_381_G1_uncompress <- getParams readCF1 paramBls12_381_G1_uncompress - paramBls12_381_G1_hashToGroup <- getParams readCF2 paramBls12_381_G1_hashToGroup - paramBls12_381_G2_add <- getParams readCF2 paramBls12_381_G2_add - paramBls12_381_G2_neg <- getParams readCF1 paramBls12_381_G2_neg - paramBls12_381_G2_scalarMul <- getParams readCF2 paramBls12_381_G2_scalarMul - paramBls12_381_G2_multiScalarMul <- getParams readCF2 paramBls12_381_G2_multiScalarMul - paramBls12_381_G2_equal <- getParams readCF2 paramBls12_381_G2_equal - paramBls12_381_G2_compress <- getParams readCF1 paramBls12_381_G2_compress - paramBls12_381_G2_uncompress <- getParams readCF1 paramBls12_381_G2_uncompress - paramBls12_381_G2_hashToGroup <- getParams readCF2 paramBls12_381_G2_hashToGroup - paramBls12_381_millerLoop <- getParams readCF2 paramBls12_381_millerLoop - paramBls12_381_mulMlResult <- getParams readCF2 paramBls12_381_mulMlResult - paramBls12_381_finalVerify <- getParams readCF2 paramBls12_381_finalVerify + paramBls12_381_G1_add <- getParams readCF2 paramBls12_381_G1_add + paramBls12_381_G1_neg <- getParams readCF1 paramBls12_381_G1_neg + paramBls12_381_G1_scalarMul <- getParams readCF2 paramBls12_381_G1_scalarMul + paramBls12_381_G1_multiScalarMul <- getParams readCF2 paramBls12_381_G1_multiScalarMul + paramBls12_381_G1_equal <- getParams readCF2 paramBls12_381_G1_equal + paramBls12_381_G1_compress <- getParams readCF1 paramBls12_381_G1_compress + paramBls12_381_G1_uncompress <- getParams readCF1 paramBls12_381_G1_uncompress + paramBls12_381_G1_hashToGroup <- getParams readCF2 paramBls12_381_G1_hashToGroup + paramBls12_381_G2_add <- getParams readCF2 paramBls12_381_G2_add + paramBls12_381_G2_neg <- getParams readCF1 paramBls12_381_G2_neg + paramBls12_381_G2_scalarMul <- getParams readCF2 paramBls12_381_G2_scalarMul + paramBls12_381_G2_multiScalarMul <- getParams readCF2 paramBls12_381_G2_multiScalarMul + paramBls12_381_G2_equal <- getParams readCF2 paramBls12_381_G2_equal + paramBls12_381_G2_compress <- getParams readCF1 paramBls12_381_G2_compress + paramBls12_381_G2_uncompress <- getParams readCF1 paramBls12_381_G2_uncompress + paramBls12_381_G2_hashToGroup <- getParams readCF2 paramBls12_381_G2_hashToGroup + paramBls12_381_millerLoop <- getParams readCF2 paramBls12_381_millerLoop + paramBls12_381_mulMlResult <- getParams readCF2 paramBls12_381_mulMlResult + paramBls12_381_finalVerify <- getParams readCF2 paramBls12_381_finalVerify -- More hashes - paramKeccak_256 <- getParams readCF1 paramKeccak_256 - paramBlake2b_224 <- getParams readCF1 paramBlake2b_224 + paramKeccak_256 <- getParams readCF1 paramKeccak_256 + paramBlake2b_224 <- getParams readCF1 paramBlake2b_224 -- Bitwise operations - paramByteStringToInteger <- getParams readCF2 paramByteStringToInteger - paramIntegerToByteString <- getParams readCF3 paramIntegerToByteString - paramAndByteString <- getParams readCF3 paramAndByteString - paramOrByteString <- getParams readCF3 paramOrByteString - paramXorByteString <- getParams readCF3 paramXorByteString - paramComplementByteString <- getParams readCF1 paramComplementByteString - paramReadBit <- getParams readCF2 paramReadBit - paramWriteBits <- getParams readCF3 paramWriteBits - paramReplicateByte <- getParams readCF2 paramReplicateByte - paramShiftByteString <- getParams readCF2 paramShiftByteString - paramRotateByteString <- getParams readCF2 paramRotateByteString - paramCountSetBits <- getParams readCF1 paramCountSetBits - paramFindFirstSetBit <- getParams readCF1 paramFindFirstSetBit + paramByteStringToInteger <- getParams readCF2 paramByteStringToInteger + paramIntegerToByteString <- getParams readCF3 paramIntegerToByteString + paramAndByteString <- getParams readCF3 paramAndByteString + paramOrByteString <- getParams readCF3 paramOrByteString + paramXorByteString <- getParams readCF3 paramXorByteString + paramComplementByteString <- getParams readCF1 paramComplementByteString + paramReadBit <- getParams readCF2 paramReadBit + paramWriteBits <- getParams readCF3 paramWriteBits + paramReplicateByte <- getParams readCF2 paramReplicateByte + paramShiftByteString <- getParams readCF2 paramShiftByteString + paramRotateByteString <- getParams readCF2 paramRotateByteString + paramCountSetBits <- getParams readCF1 paramCountSetBits + paramFindFirstSetBit <- getParams readCF1 paramFindFirstSetBit -- And another hash function - paramRipemd_160 <- getParams readCF1 paramRipemd_160 + paramRipemd_160 <- getParams readCF1 paramRipemd_160 -- Batch 6 - paramExpModInteger <- getParams readCF3 paramExpModInteger - paramDropList <- getParams readCF2 paramDropList + paramExpModInteger <- getParams readCF3 paramExpModInteger + paramDropList <- getParams readCF2 paramDropList -- Arrays - paramLengthOfArray <- getParams readCF1 paramLengthOfArray - paramListToArray <- getParams readCF1 paramListToArray - paramIndexArray <- getParams readCF2 paramIndexArray + paramLengthOfArray <- getParams readCF1 paramLengthOfArray + paramListToArray <- getParams readCF1 paramListToArray + paramIndexArray <- getParams readCF2 paramIndexArray pure $ BuiltinCostModelBase {..} - {- Extracting fields from R objects is a bit delicate. If you get a field name wrong you'll get an error message from inline-r like "Dynamic type cast failed. Expected: Real. Actual: Nil." from fromSEXP or "fromSEXP:Not a singleton vector." from dynSEXP. -} + -- | Extract the model type descriptor from an R object getString :: MonadR m => String -> SomeSEXP (Region m) -> m String getString s e = fromSomeSEXP <$> [r| e_hs[[s_hs]] |] @@ -302,7 +302,7 @@ getSubtype e = getString "subtype" e -- | Extract a named regression coefficient from an R object getCoeff :: MonadR m => String -> SomeSEXP (Region m) -> m CostingInteger -getCoeff f e = microToPico . fromSomeSEXP <$> [r| e_hs$model$coefficients[[f_hs]] |] +getCoeff f e = microToPico . fromSomeSEXP <$> [r| e_hs$model$coefficients[[f_hs]] |] -- | Extract some other parameter from an R object. You can add arbitrary named -- parameters in mk.result in the R code and access them using this. This can @@ -380,23 +380,20 @@ readTwoVariableFunConstOr e = do nonConstantPart <- readCF2AtType subtype e pure $ ModelConstantOrTwoArguments constantPart nonConstantPart -{- | Functions to read CPU costing functions from R. There are some costing -function types which are currently only used for memory models (which are -constructed directly, not via R), and those won't be handled here. These -functions have short names to improve formatting elsewhere. --} - +-- | Functions to read CPU costing functions from R. There are some costing +-- function types which are currently only used for memory models (which are +-- constructed directly, not via R), and those won't be handled here. These +-- functions have short names to improve formatting elsewhere. -{- | Read in a one-variable costing function of a given type. We have to supply - the type as a parameter so that we can deal with nested costing functions which - have type and subtype tags. --} +-- | Read in a one-variable costing function of a given type. We have to supply +-- the type as a parameter so that we can deal with nested costing functions which +-- have type and subtype tags. readCF1AtType :: MonadR m => String -> SomeSEXP (Region m) -> m ModelOneArgument readCF1AtType ty e = do case ty of "constant_cost" -> ModelOneArgumentConstantCost <$> getConstant e - "linear_in_x" -> ModelOneArgumentLinearInX <$> readOneVariableLinearFunction "x_mem" e - _ -> error $ "Unknown one-variable model type: " ++ ty + "linear_in_x" -> ModelOneArgumentLinearInX <$> readOneVariableLinearFunction "x_mem" e + _ -> error $ "Unknown one-variable model type: " ++ ty readCF1 :: MonadR m => SomeSEXP (Region m) -> m ModelOneArgument readCF1 e = do @@ -406,22 +403,22 @@ readCF1 e = do readCF2AtType :: MonadR m => String -> SomeSEXP (Region m) -> m ModelTwoArguments readCF2AtType ty e = do case ty of - "constant_cost" -> ModelTwoArgumentsConstantCost <$> getConstant e - "linear_in_x" -> ModelTwoArgumentsLinearInX <$> readOneVariableLinearFunction "x_mem" e - "linear_in_y" -> ModelTwoArgumentsLinearInY <$> readOneVariableLinearFunction "y_mem" e - "linear_in_x_and_y" -> ModelTwoArgumentsLinearInXAndY <$> readTwoVariableLinearFunction "x_mem" "y_mem" e - "added_sizes" -> ModelTwoArgumentsAddedSizes <$> readOneVariableLinearFunction "I(x_mem + y_mem)" e - "multiplied_sizes" -> ModelTwoArgumentsMultipliedSizes <$> readOneVariableLinearFunction "I(x_mem * y_mem)" e - "min_size" -> ModelTwoArgumentsMinSize <$> readOneVariableLinearFunction "pmin(x_mem, y_mem)" e - "max_size" -> ModelTwoArgumentsMaxSize <$> readOneVariableLinearFunction "pmax(x_mem, y_mem)" e + "constant_cost" -> ModelTwoArgumentsConstantCost <$> getConstant e + "linear_in_x" -> ModelTwoArgumentsLinearInX <$> readOneVariableLinearFunction "x_mem" e + "linear_in_y" -> ModelTwoArgumentsLinearInY <$> readOneVariableLinearFunction "y_mem" e + "linear_in_x_and_y" -> ModelTwoArgumentsLinearInXAndY <$> readTwoVariableLinearFunction "x_mem" "y_mem" e + "added_sizes" -> ModelTwoArgumentsAddedSizes <$> readOneVariableLinearFunction "I(x_mem + y_mem)" e + "multiplied_sizes" -> ModelTwoArgumentsMultipliedSizes <$> readOneVariableLinearFunction "I(x_mem * y_mem)" e + "min_size" -> ModelTwoArgumentsMinSize <$> readOneVariableLinearFunction "pmin(x_mem, y_mem)" e + "max_size" -> ModelTwoArgumentsMaxSize <$> readOneVariableLinearFunction "pmax(x_mem, y_mem)" e -- See Note [Backward compatibility for costing functions] for linear_on_diagonal - "linear_on_diagonal" -> ModelTwoArgumentsLinearOnDiagonal <$> readTwoVariableFunLinearOnDiagonal "x_mem" e + "linear_on_diagonal" -> ModelTwoArgumentsLinearOnDiagonal <$> readTwoVariableFunLinearOnDiagonal "x_mem" e "const_below_diagonal" -> ModelTwoArgumentsConstBelowDiagonal <$> readTwoVariableFunConstOr e "const_above_diagonal" -> ModelTwoArgumentsConstAboveDiagonal <$> readTwoVariableFunConstOr e - "const_off_diagonal" -> ModelTwoArgumentsConstOffDiagonal <$> readOneVariableFunConstOr e - "quadratic_in_y" -> ModelTwoArgumentsQuadraticInY <$> readOneVariableQuadraticFunction "y_mem" e - "quadratic_in_x_and_y" -> ModelTwoArgumentsQuadraticInXAndY <$> readTwoVariableQuadraticFunction "x_mem" "y_mem" e - _ -> error $ "Unknown two-variable model type: " ++ ty + "const_off_diagonal" -> ModelTwoArgumentsConstOffDiagonal <$> readOneVariableFunConstOr e + "quadratic_in_y" -> ModelTwoArgumentsQuadraticInY <$> readOneVariableQuadraticFunction "y_mem" e + "quadratic_in_x_and_y" -> ModelTwoArgumentsQuadraticInXAndY <$> readTwoVariableQuadraticFunction "x_mem" "y_mem" e + _ -> error $ "Unknown two-variable model type: " ++ ty readCF2 :: MonadR m => SomeSEXP (Region m) -> m ModelTwoArguments readCF2 e = do @@ -432,19 +429,19 @@ readCF3 :: MonadR m => SomeSEXP (Region m) -> m ModelThreeArguments readCF3 e = do ty <- getType e case ty of - "constant_cost" -> ModelThreeArgumentsConstantCost <$> getConstant e - "linear_in_x" -> ModelThreeArgumentsLinearInX <$> readOneVariableLinearFunction "x_mem" e - "linear_in_y" -> ModelThreeArgumentsLinearInY <$> readOneVariableLinearFunction "y_mem" e - "linear_in_z" -> ModelThreeArgumentsLinearInZ <$> readOneVariableLinearFunction "z_mem" e - "quadratic_in_z" -> ModelThreeArgumentsQuadraticInZ <$> readOneVariableQuadraticFunction "z_mem" e - "linear_in_y_and_z" -> ModelThreeArgumentsLinearInYAndZ <$> readTwoVariableLinearFunction "y_mem" "z_mem" e + "constant_cost" -> ModelThreeArgumentsConstantCost <$> getConstant e + "linear_in_x" -> ModelThreeArgumentsLinearInX <$> readOneVariableLinearFunction "x_mem" e + "linear_in_y" -> ModelThreeArgumentsLinearInY <$> readOneVariableLinearFunction "y_mem" e + "linear_in_z" -> ModelThreeArgumentsLinearInZ <$> readOneVariableLinearFunction "z_mem" e + "quadratic_in_z" -> ModelThreeArgumentsQuadraticInZ <$> readOneVariableQuadraticFunction "z_mem" e + "linear_in_y_and_z" -> ModelThreeArgumentsLinearInYAndZ <$> readTwoVariableLinearFunction "y_mem" "z_mem" e "literal_in_y_or_linear_in_z" -> ModelThreeArgumentsLiteralInYOrLinearInZ <$> error "literal" - "exp_mod_cost" -> ModelThreeArgumentsExpModCost <$> readExpModCostingFunction "y_mem" "z_mem" e - _ -> error $ "Unknown three-variable model type: " ++ ty + "exp_mod_cost" -> ModelThreeArgumentsExpModCost <$> readExpModCostingFunction "y_mem" "z_mem" e + _ -> error $ "Unknown three-variable model type: " ++ ty readCF6 :: MonadR m => SomeSEXP (Region m) -> m ModelSixArguments readCF6 e = do ty <- getType e case ty of "constant_cost" -> ModelSixArgumentsConstantCost <$> getConstant e - _ -> error $ "Unknown six-variable model type: " ++ ty + _ -> error $ "Unknown six-variable model type: " ++ ty diff --git a/plutus-core/cost-model/create-cost-model/Main.hs b/plutus-core/cost-model/create-cost-model/Main.hs index 5ee2312cfd2..22056f5c1df 100644 --- a/plutus-core/cost-model/create-cost-model/Main.hs +++ b/plutus-core/cost-model/create-cost-model/Main.hs @@ -11,16 +11,15 @@ import System.IO (hPutStrLn, stderr) import Language.R (defaultConfig, runRegion, withEmbeddedR) -{- | This takes a CSV file of benchmark results for built-in functions, runs the R - code in `models.R` to construct costing functions based on the benchmark - results, and then produces JSON output containing the types and coefficients - of the costing functions. For best results, run this in - `plutus-core/cost-model/data` to make `models.R` easy to find; if that's - inconvenient for some reason, use the `-m` option to provide a path to - `models.R`. - - See also CostModelGeneration.md. --} +-- | This takes a CSV file of benchmark results for built-in functions, runs the R +-- code in `models.R` to construct costing functions based on the benchmark +-- results, and then produces JSON output containing the types and coefficients +-- of the costing functions. For best results, run this in +-- `plutus-core/cost-model/data` to make `models.R` easy to find; if that's +-- inconvenient for some reason, use the `-m` option to provide a path to +-- `models.R`. +-- +-- See also CostModelGeneration.md. -- | The file containing the benchmark results, 'benching.csv' by default. We -- can't read this from stdin because we have to supply the filename to inline R @@ -41,7 +40,6 @@ defaultRFile = RFile "models.R" -- | Where to write the JSON output, stdout by default data Output = NamedOutput FilePath | StdOutput - ---------------- Option parsers ---------------- benchmarkFile :: Parser BenchmarkFile @@ -50,23 +48,27 @@ benchmarkFile = namedBenchmarkFile <|> pure defaultBenchmarkFile -- | Parser for an input stream. If none is specified, default to stdin: -- this makes use in pipelines easier namedBenchmarkFile :: Parser BenchmarkFile -namedBenchmarkFile = BenchmarkFile <$> strOption - ( long "csv" - <> short 'i' - <> metavar "FILENAME" - <> help "CSV file containing built-in function benchmark results") - +namedBenchmarkFile = + BenchmarkFile + <$> strOption + ( long "csv" + <> short 'i' + <> metavar "FILENAME" + <> help "CSV file containing built-in function benchmark results" + ) rFile :: Parser RFile -rFile = namedRFile <|> pure defaultRFile +rFile = namedRFile <|> pure defaultRFile namedRFile :: Parser RFile -namedRFile = RFile <$> strOption - ( long "models" - <> short 'm' - <> metavar "FILENAME" - <> help "The file containing the R modelling code" ) - +namedRFile = + RFile + <$> strOption + ( long "models" + <> short 'm' + <> metavar "FILENAME" + <> help "The file containing the R modelling code" + ) -- | Parser for an output stream. If none is specified, default to stdout: -- this makes use in pipelines easier @@ -74,31 +76,38 @@ output :: Parser Output output = fileOutput <|> stdOutput <|> pure StdOutput fileOutput :: Parser Output -fileOutput = NamedOutput <$> strOption - ( long "output" - <> short 'o' - <> metavar "FILENAME" - <> help "Output file" ) +fileOutput = + NamedOutput + <$> strOption + ( long "output" + <> short 'o' + <> metavar "FILENAME" + <> help "Output file" + ) stdOutput :: Parser Output -stdOutput = flag' StdOutput - ( long "stdout" - <> help "Write to stdout (default)" ) +stdOutput = + flag' + StdOutput + ( long "stdout" + <> help "Write to stdout (default)" + ) inputsAndOutput :: Parser (BenchmarkFile, RFile, Output) -inputsAndOutput = (,,) <$> benchmarkFile <*> rFile <*> output +inputsAndOutput = (,,) <$> benchmarkFile <*> rFile <*> output arguments :: ParserInfo (BenchmarkFile, RFile, Output) -arguments = info - (inputsAndOutput <**> helper) - (fullDesc - <> header "Plutus Core cost model creation tool" - <> progDesc - ( "Creates a JSON description of Plutus Core cost model " - ++ "for built-in functions from a set of benchmark results " - ++ "produced by cost-model-budgeting-bench") - ) - +arguments = + info + (inputsAndOutput <**> helper) + ( fullDesc + <> header "Plutus Core cost model creation tool" + <> progDesc + ( "Creates a JSON description of Plutus Core cost model " + ++ "for built-in functions from a set of benchmark results " + ++ "produced by cost-model-budgeting-bench" + ) + ) ---------------- Checking files and processing input/output ---------------- @@ -107,41 +116,42 @@ checkInputFile file filespec advice = do let putStrLnErr = hPutStrLn stderr exists <- doesFileExist file if not exists - then do - putStrLnErr "" - putStrLnErr $ "ERROR: Cannot open " ++ filespec ++ " " ++ file - putStrLnErr advice - exitFailure - else do - perms <- getPermissions file - if not $ readable perms then do putStrLnErr "" - putStrLnErr $ "ERROR: cannot read " ++ filespec ++ " " ++ file + putStrLnErr $ "ERROR: Cannot open " ++ filespec ++ " " ++ file putStrLnErr advice exitFailure - else pure () + else do + perms <- getPermissions file + if not $ readable perms + then do + putStrLnErr "" + putStrLnErr $ "ERROR: cannot read " ++ filespec ++ " " ++ file + putStrLnErr advice + exitFailure + else pure () checkRFile :: FilePath -> IO () checkRFile file = - let advice = "The default R model file is models.R in plutus-core/cost-model/data;\n" - ++ "either run this program in that directory or supply the path to a\n" - ++ "suitable R file with -m." - in checkInputFile file "R model file" advice + let advice = + "The default R model file is models.R in plutus-core/cost-model/data;\n" + ++ "either run this program in that directory or supply the path to a\n" + ++ "suitable R file with -m." + in checkInputFile file "R model file" advice checkBenchmarkFile :: FilePath -> IO () checkBenchmarkFile file = - let advice = "Supply the path to a suitable benchmark results file with --csv.\n" - ++ "The default results file is plutus-core/cost-model/data/benching.csv." - in checkInputFile file "benchmark results file" advice - + let advice = + "Supply the path to a suitable benchmark results file with --csv.\n" + ++ "The default results file is plutus-core/cost-model/data/benching.csv." + in checkInputFile file "benchmark results file" advice writeOutput :: Output -> BSL.ByteString -> IO () writeOutput outp v = do case outp of - NamedOutput file -> BSL.writeFile file v - StdOutput -> BSL.putStr v + NamedOutput file -> BSL.writeFile file v + StdOutput -> BSL.putStr v main :: IO () main = do @@ -149,4 +159,4 @@ main = do checkBenchmarkFile bmfile checkRFile rfile model <- withEmbeddedR defaultConfig $ runRegion $ createBuiltinCostModel bmfile rfile - writeOutput out $ encodePretty' (defConfig { confCompare = \_ _-> EQ }) model + writeOutput out $ encodePretty' (defConfig {confCompare = \_ _ -> EQ}) model diff --git a/plutus-core/cost-model/print-cost-model/Main.hs b/plutus-core/cost-model/print-cost-model/Main.hs index 51193a784ab..b617ee7a011 100644 --- a/plutus-core/cost-model/print-cost-model/Main.hs +++ b/plutus-core/cost-model/print-cost-model/Main.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- | A program to parse a JSON representation of costing functions for Plutus Core - builtins and print it in readable form. -} +-- | A program to parse a JSON representation of costing functions for Plutus Core +-- builtins and print it in readable form. module Main where import Paths_plutus_core @@ -25,59 +25,91 @@ data ModelComponent = Cpu | Memory -- Print a monomial like 5*x or 11*max(x,y) stringOfMonomial :: Integer -> String -> String stringOfMonomial s v = - if s == 1 then unparen v -- Just so we don't get things like 5 + (x+y). - else if s == -1 then "-" ++ v - else printf "%d*%s" s v - -- Print the slope even if it's zero, so we know the - -- function's not constant. - where unparen w = - if w /= "" && head w == '(' && last w == ')' - then tail $ init w - else w + if s == 1 + then unparen v -- Just so we don't get things like 5 + (x+y). + else + if s == -1 + then "-" ++ v + else printf "%d*%s" s v + where + -- Print the slope even if it's zero, so we know the + -- function's not constant. + unparen w = + if w /= "" && head w == '(' && last w == ')' + then tail $ init w + else w -- | Print a linear function in readable form. The string argument is -- supposed to represent the input to the function: x, y, y+z, etc. renderLinearFunction :: LinearFunction -> String -> String renderLinearFunction (LinearFunction intercept slope) var = - if intercept == 0 then stringOfMonomial slope var + if intercept == 0 + then stringOfMonomial slope var else printf "%d + %s" intercept (stringOfMonomial slope var) renderTwoVariableLinearFunction :: TwoVariableLinearFunction -> String -> String -> String renderTwoVariableLinearFunction (TwoVariableLinearFunction intercept slope1 slope2) var1 var2 = - if intercept == 0 + if intercept == 0 then stringOfMonomial slope1 var1 ++ " + " ++ stringOfMonomial slope2 var2 - else printf "%d + %s + %s" - intercept - (stringOfMonomial slope1 var1) - (stringOfMonomial slope2 var2) + else + printf + "%d + %s + %s" + intercept + (stringOfMonomial slope1 var1) + (stringOfMonomial slope2 var2) +renderOneVariableQuadraticFunction :: + OneVariableQuadraticFunction -> + String -> + String renderOneVariableQuadraticFunction - :: OneVariableQuadraticFunction - -> String - -> String -renderOneVariableQuadraticFunction - (OneVariableQuadraticFunction c0 c1 c2) var = + (OneVariableQuadraticFunction c0 c1 c2) + var = printf "%d + %d*%s + %d*%s^2" c0 c1 var c2 var +renderTwoVariableQuadraticFunction :: + TwoVariableQuadraticFunction -> + String -> + String -> + String renderTwoVariableQuadraticFunction - :: TwoVariableQuadraticFunction - -> String - -> String - -> String -renderTwoVariableQuadraticFunction - (TwoVariableQuadraticFunction minVal c00 c10 c01 c20 c11 c02) var1 var2 = - printf "max(%d, %d + %d*%s + %d*%s + %d*%s^2 + %d*%s*%s + %d*%s^2)" - minVal c00 c10 var1 c01 var2 c20 var1 c11 var1 var2 c02 var2 + (TwoVariableQuadraticFunction minVal c00 c10 c01 c20 c11 c02) + var1 + var2 = + printf + "max(%d, %d + %d*%s + %d*%s + %d*%s^2 + %d*%s*%s + %d*%s^2)" + minVal + c00 + c10 + var1 + c01 + var2 + c20 + var1 + c11 + var1 + var2 + c02 + var2 +renderExpModCostingFunction :: + ExpModCostingFunction -> + String -> + String -> + String renderExpModCostingFunction - :: ExpModCostingFunction - -> String - -> String - -> String -renderExpModCostingFunction - (ExpModCostingFunction c00 c11 c12) var1 var2 = - printf "%d + %d*%s*%s + %d*%s*%s^2" - c00 c11 var1 var2 c12 var1 var2 + (ExpModCostingFunction c00 c11 c12) + var1 + var2 = + printf + "%d + %d*%s*%s + %d*%s*%s^2" + c00 + c11 + var1 + var2 + c12 + var1 + var2 -- FIXME. This is arguably slightly incorrect because some of the arguments are -- wrapped in newtypes that change the memory usage instance of their content @@ -91,68 +123,74 @@ renderExpModCostingFunction -- the output accordingly, but it would be helpful to make it explicit. renderModel :: Model -> [String] renderModel = - \case - ConstantCost n -> [ printf "%d" n ] - AddedSizes f -> [ renderLinearFunction f "(x+y)" ] - MultipliedSizes f -> [ renderLinearFunction f "(x*y)" ] - MinSize f -> [ renderLinearFunction f "min(x,y)" ] - MaxSize f -> [ renderLinearFunction f "max(x,y)" ] - LinearInX f -> [ renderLinearFunction f "x" ] - LinearInY f -> [ renderLinearFunction f "y" ] - LinearInZ f -> [ renderLinearFunction f "z" ] - QuadraticInY f -> [ renderOneVariableQuadraticFunction f "y" ] - QuadraticInZ f -> [ renderOneVariableQuadraticFunction f "z" ] - QuadraticInXAndY f -> [ renderTwoVariableQuadraticFunction f "x" "y" ] - ExpModCost f -> [ renderExpModCostingFunction f "y" "z" ] - LinearInMaxYZ f -> [ renderLinearFunction f "max(y,z)" ] - LinearInYAndZ f -> [ renderTwoVariableLinearFunction f "y" "z" ] - LiteralInYOrLinearInZ f -> [ "if y==0" - , printf "then %s" $ renderLinearFunction f "z" - , printf "else y bytes" - ] -- This is only used for the memory usage of - -- `integerToByteString` at the moment, so - -- this makes sense. - SubtractedSizes l c -> [ renderLinearFunction l $ printf "max(x-y,%d)" c - ] - ConstAboveDiagonal c m -> [ "if x [ "if x>y" - , printf "then %d" c - , printf "else %s" $ intercalate "\n" (renderModel m) - ] - ConstOffDiagonal c m -> [ "if x==y" - , printf "then %s" $ intercalate "\n" (renderModel m) - , printf "else %d" c - ] - -- ^ We're not properly indenting submodels in the above/below diagonal - -- cases, but at present our submodels all fit on one line (eg, constant or - -- linear). It seems improbable that we'd ever have a submodel that - -- required more than one line because then we'd be dividing the plane up - -- into more than two regions. + \case + ConstantCost n -> [printf "%d" n] + AddedSizes f -> [renderLinearFunction f "(x+y)"] + MultipliedSizes f -> [renderLinearFunction f "(x*y)"] + MinSize f -> [renderLinearFunction f "min(x,y)"] + MaxSize f -> [renderLinearFunction f "max(x,y)"] + LinearInX f -> [renderLinearFunction f "x"] + LinearInY f -> [renderLinearFunction f "y"] + LinearInZ f -> [renderLinearFunction f "z"] + QuadraticInY f -> [renderOneVariableQuadraticFunction f "y"] + QuadraticInZ f -> [renderOneVariableQuadraticFunction f "z"] + QuadraticInXAndY f -> [renderTwoVariableQuadraticFunction f "x" "y"] + ExpModCost f -> [renderExpModCostingFunction f "y" "z"] + LinearInMaxYZ f -> [renderLinearFunction f "max(y,z)"] + LinearInYAndZ f -> [renderTwoVariableLinearFunction f "y" "z"] + LiteralInYOrLinearInZ f -> + [ "if y==0" + , printf "then %s" $ renderLinearFunction f "z" + , printf "else y bytes" + ] -- This is only used for the memory usage of + -- `integerToByteString` at the moment, so + -- this makes sense. + SubtractedSizes l c -> + [ renderLinearFunction l $ printf "max(x-y,%d)" c + ] + ConstAboveDiagonal c m -> + [ "if x + [ "if x>y" + , printf "then %d" c + , printf "else %s" $ intercalate "\n" (renderModel m) + ] + ConstOffDiagonal c m -> + [ "if x==y" + , printf "then %s" $ intercalate "\n" (renderModel m) + , printf "else %d" c + ] + +-- \^ We're not properly indenting submodels in the above/below diagonal +-- cases, but at present our submodels all fit on one line (eg, constant or +-- linear). It seems improbable that we'd ever have a submodel that +-- required more than one line because then we'd be dividing the plane up +-- into more than two regions. -- | Take a list of strings and print them line by line, the first with no extra -- spaces then the rest preceded by `width` spaces. The assumption is that we'll -- already have printed the first part of the first line. printListIndented :: Int -> [String] -> IO () printListIndented width l = - case l of - [] -> pure () - first:rest -> do - printf "%s\n" first - mapM_ (\s -> printf "%s%s\n" spaces s) rest - where spaces = take width $ repeat ' ' + case l of + [] -> pure () + first : rest -> do + printf "%s\n" first + mapM_ (\s -> printf "%s%s\n" spaces s) rest + where + spaces = take width $ repeat ' ' -- | Print a the name of a builtin (the Key below) and then a possibly -- multi-line representation of the model, alinged so that each line of the -- model has the same indentation. printModel :: ModelComponent -> Int -> (Key, CpuAndMemoryModel) -> IO () printModel component width (name, CpuAndMemoryModel cpu mem) = do - let model = case component of {Cpu -> cpu; Memory -> mem} - printf "%-*s: " width (Key.toString name) - printListIndented (width+2) (renderModel model) -- +2 to account for ": " after builtin name - + let model = case component of Cpu -> cpu; Memory -> mem + printf "%-*s: " width (Key.toString name) + printListIndented (width + 2) (renderModel model) -- +2 to account for ": " after builtin name ---------------- Command line processing ---------------- @@ -165,7 +203,7 @@ semvars :: [String] semvars = ["A", "B", "C"] semvarOptions :: [String] -semvarOptions = fmap ('-':) semvars +semvarOptions = fmap ('-' :) semvars usage :: [String] -> IO a usage paths = do @@ -184,8 +222,9 @@ usage paths = do printf " -d, --default: print the contents of the default cost model in\n" printf " %s\n" (last paths) printf " : read and print the cost model in the given file\n" - printf " %s: read and print out the cost model for the given semantics variant\n" - (intercalate "," semvarOptions) + printf + " %s: read and print out the cost model for the given semantics variant\n" + (intercalate "," semvarOptions) exitSuccess parseArgs :: [String] -> IO (ModelComponent, Maybe String) @@ -194,16 +233,16 @@ parseArgs args = do extension = ".json" paths <- mapM (\x -> getDataFileName (prefix ++ x ++ extension)) semvars let parse [] result = pure result - parse (arg:rest) (component, input) = + parse (arg : rest) (component, input) = case arg of - [] -> errorWithoutStackTrace "Empty argument" - '-':_ -> parseOption arg rest (component, input) - _ -> parse rest (component, Just arg) + [] -> errorWithoutStackTrace "Empty argument" + '-' : _ -> parseOption arg rest (component, input) + _ -> parse rest (component, Just arg) parseOption arg rest (component, input) | Just path <- lookup arg $ zip semvarOptions paths = parse rest (component, Just path) | elem arg ["-d", "--default"] = - parse rest (component, Just $ last paths) + parse rest (component, Just $ last paths) | elem arg ["-c", "--cpu"] = parse rest (Cpu, input) | elem arg ["-m", "--mem", "--memory"] = parse rest (Memory, input) | elem arg ["-h", "--help"] = usage paths @@ -216,13 +255,13 @@ main = do args <- getArgs (component, input) <- parseArgs args bytes <- case input of - Nothing -> BSL.getContents -- Read from stdin - Just file -> BSL.readFile file + Nothing -> BSL.getContents -- Read from stdin + Just file -> BSL.readFile file case eitherDecode bytes :: Either String (KeyMap.KeyMap CpuAndMemoryModel) of Left err -> putStrLn err - Right m -> - let l = KeyMap.toList m - width = 1 + (maximum $ fmap (length . toString . fst) l) - -- ^ Width for indentation, leaving at least one space after the name of each builtin. - -- We want all the costing function to be aligned with each other. - in mapM_ (printModel component width) l + Right m -> + let l = KeyMap.toList m + width = 1 + (maximum $ fmap (length . toString . fst) l) + in -- \^ Width for indentation, leaving at least one space after the name of each builtin. + -- We want all the costing function to be aligned with each other. + mapM_ (printModel component width) l diff --git a/plutus-core/cost-model/test/TH.hs b/plutus-core/cost-model/test/TH.hs index e193400d399..e565caabf84 100644 --- a/plutus-core/cost-model/test/TH.hs +++ b/plutus-core/cost-model/test/TH.hs @@ -1,36 +1,32 @@ -{- | Some basic Template Haskell to reduce boilerplate in the cost model tests. - We have to put this in a separate source file because of staging - restrictions. --} - +-- | Some basic Template Haskell to reduce boilerplate in the cost model tests. +-- We have to put this in a separate source file because of staging +-- restrictions. module TH (genTest) where import Data.Char (toUpper) import Language.Haskell.TH toUpper1 :: String -> String -toUpper1 [] = error "empty string in toUpper1" -toUpper1 (c:cs) = toUpper c : cs +toUpper1 [] = error "empty string in toUpper1" +toUpper1 (c : cs) = toUpper c : cs mkIterApp :: Exp -> [Exp] -> Exp mkIterApp = foldl AppE -{- | The genTest function generates calls to the appropriate "makeProp" functions: eg - - $(genTest 3 "xyz") -> makeProp3 "xyz" paramXyz modelsH modelsR - - Appropriate variables/functions must be in scope when 'genTest' is called, - but this should always be the case if it's used inside the 'tests' list in - TestCostModels (and the error messages are very helpful if something goes - wrong). Note that we can supply extra arguments after the generated code if - makePropN requires them: we use this when generating tests for makeProp2. --} +-- | The genTest function generates calls to the appropriate "makeProp" functions: eg +-- +-- $(genTest 3 "xyz") -> makeProp3 "xyz" paramXyz modelsH modelsR +-- +-- Appropriate variables/functions must be in scope when 'genTest' is called, +-- but this should always be the case if it's used inside the 'tests' list in +-- TestCostModels (and the error messages are very helpful if something goes +-- wrong). Note that we can supply extra arguments after the generated code if +-- makePropN requires them: we use this when generating tests for makeProp2. genTest :: Int -> String -> Q Exp genTest n s = - let makePropN = VarE $ mkName ("makeProp" ++ show n) - testname = LitE $ StringL s - params = VarE $ mkName ("param" ++ toUpper1 s) - modelsH = VarE $ mkName "modelsH" - modelsR = VarE $ mkName "modelsR" - in pure $ mkIterApp makePropN [testname, params, modelsH, modelsR] - + let makePropN = VarE $ mkName ("makeProp" ++ show n) + testname = LitE $ StringL s + params = VarE $ mkName ("param" ++ toUpper1 s) + modelsH = VarE $ mkName "modelsH" + modelsR = VarE $ mkName "modelsR" + in pure $ mkIterApp makePropN [testname, params, modelsH, modelsR] diff --git a/plutus-core/cost-model/test/TestCostModels.hs b/plutus-core/cost-model/test/TestCostModels.hs index e202ce228d7..8d72a9f59c4 100644 --- a/plutus-core/cost-model/test/TestCostModels.hs +++ b/plutus-core/cost-model/test/TestCostModels.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} import PlutusCore.DataFilePaths qualified as DFP import PlutusCore.Evaluation.Machine.BuiltinCostModel @@ -23,8 +23,15 @@ import Data.String (fromString) import Unsafe.Coerce (unsafeCoerce) import H.Prelude as H (MonadR, io) -import Language.R as R (R, SomeSEXP, defaultConfig, fromSomeSEXP, runRegion, unsafeRunRegion, - withEmbeddedR) +import Language.R as R ( + R, + SomeSEXP, + defaultConfig, + fromSomeSEXP, + runRegion, + unsafeRunRegion, + withEmbeddedR, + ) import Language.R.QQ (r) import Hedgehog @@ -32,22 +39,21 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Main qualified as HH (defaultMain) import Hedgehog.Range qualified as Range -{- | This module is supposed to test that the R cost models for built-in functions - defined in models.R (using the CSV output from 'cost-model-budgeting-bench')) - produce the same results as the Haskell versions. However there are a couple - of subtleties. (A) The R models use floating point numbers and the Haskell - versions use CostingIntegers, and there will be some difference in precision - because of this. (B) The R models produce results in microseconds and the - Haskell versions produce results in picoseconds. We deal with (B) by using - the microToPico function from CreateBuiltinCostModel to convert R results to - picoseconds expressed as CostingIntegers. To deal with (A), we don't check - for exact equality of the outputs but instead check that the R result and the - Haskell result agreee to within a factor of 2/100 (two percent). --} +-- | This module is supposed to test that the R cost models for built-in functions +-- defined in models.R (using the CSV output from 'cost-model-budgeting-bench')) +-- produce the same results as the Haskell versions. However there are a couple +-- of subtleties. (A) The R models use floating point numbers and the Haskell +-- versions use CostingIntegers, and there will be some difference in precision +-- because of this. (B) The R models produce results in microseconds and the +-- Haskell versions produce results in picoseconds. We deal with (B) by using +-- the microToPico function from CreateBuiltinCostModel to convert R results to +-- picoseconds expressed as CostingIntegers. To deal with (A), we don't check +-- for exact equality of the outputs but instead check that the R result and the +-- Haskell result agreee to within a factor of 2/100 (two percent). -- Maximum allowable difference beween R result and Haskell result. epsilon :: Double -epsilon = 2/100 +epsilon = 2 / 100 {- The tests here use Haskell costing functions (in 'costModelsR' from @@ -76,9 +82,10 @@ numberOfTests = 100 -- of inputs, but that we also get small inputs. memUsageGen :: Gen CostingInteger memUsageGen = - Gen.choice [small, large] - where small = unsafeToSatInt <$> Gen.integral (Range.constant 0 2) - large = unsafeToSatInt <$> Gen.integral (Range.linear 0 5000) + Gen.choice [small, large] + where + small = unsafeToSatInt <$> Gen.integral (Range.constant 0 2) + large = unsafeToSatInt <$> Gen.integral (Range.linear 0 5000) -- Smaller inputs for testing the piecewise costing functions for integer -- division operations, where the Haskell model differs from the R one for @@ -104,18 +111,19 @@ data TestDomain = Everywhere | OnDiagonal | BelowDiagonal - -- Small values for integer division builtins with quadratic costing functions; we want - -- to keep away from the regions where the floor comes into play. - | BelowDiagonal' + | -- Small values for integer division builtins with quadratic costing functions; we want + -- to keep away from the regions where the floor comes into play. + BelowDiagonal' -- Approximate equality (~=) :: CostingInteger -> CostingInteger -> Bool x ~= y - | x==0 && y==0 = True + | x == 0 && y == 0 = True | otherwise = err < epsilon - where x' = fromSatInt x :: Double - y' = fromSatInt y :: Double - err = abs ((x'-y')/y') + where + x' = fromSatInt x :: Double + y' = fromSatInt y :: Double + err = abs ((x' - y') / y') -- Runs property tests in the `R` Monad. propertyR :: PropertyT (R s) () -> Property @@ -155,166 +163,191 @@ propertyR prop = withTests numberOfTests $ property $ unsafeHoist unsafeRunRegio -} newtype ExM = ExM CostingInteger instance ExMemoryUsage ExM where - memoryUsage (ExM n) = singletonRose n + memoryUsage (ExM n) = singletonRose n -- Creates the model on the R side, loads the parameters over to Haskell, and -- runs both models with a bunch of ExMemory combinations and compares the -- outputs. -testPredictOne - :: CostingFun ModelOneArgument - -> SomeSEXP s - -> Property -testPredictOne costingFunH modelR = propertyR $ - let predictR :: MonadR m => CostingInteger -> m CostingInteger - predictR x = - let - xD = fromSatInt x :: Double - in - microToPico . fromSomeSEXP <$> [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs))[[1]]|] - predictH :: CostingInteger -> CostingInteger - predictH x = - coerce $ exBudgetCPU $ sumExBudgetStream $ - runCostingFunOneArgument costingFunH (ExM x) - sizeGen = memUsageGen - in do - x <- forAll sizeGen - byR <- lift $ predictR x - -- Sometimes R gives us models which pass through the origin, so we have to allow zero cost - -- because of that - diff byR (>=) 0 - diff byR (~=) (predictH x) - -testPredictTwo - :: CostingFun ModelTwoArguments - -> SomeSEXP s - -> TestDomain - -> Property -testPredictTwo costingFunH modelR domain = propertyR $ - let predictR :: MonadR m => CostingInteger -> CostingInteger -> m CostingInteger - predictR x y = - let - xD = fromSatInt x :: Double - yD = fromSatInt y :: Double - in - microToPico . fromSomeSEXP <$> - [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs, y_mem=yD_hs))[[1]]|] - predictH :: CostingInteger -> CostingInteger -> CostingInteger - predictH x y = - coerce $ exBudgetCPU $ sumExBudgetStream $ - runCostingFunTwoArguments costingFunH (ExM x) (ExM y) - sizeGen = case domain of - Everywhere -> twoArgs - OnDiagonal -> memUsageGen >>= \x -> pure (x,x) - BelowDiagonal -> Gen.filter (uncurry (>=)) twoArgs - BelowDiagonal' -> Gen.filter (uncurry (>=)) twoArgs' - where twoArgs = (,) <$> memUsageGen <*> memUsageGen - twoArgs' = (,) <$> memUsageGen40 <*> memUsageGen40 - in do - (x, y) <- forAll sizeGen - byR <- lift $ predictR x y - diff byR (>=) 0 - diff byR (~=) (predictH x y) - -testPredictThree - :: CostingFun ModelThreeArguments - -> SomeSEXP s - -> Property -testPredictThree costingFunH modelR = propertyR $ - let predictR :: MonadR m => CostingInteger -> CostingInteger -> CostingInteger -> m CostingInteger - predictR x y z = - let - xD = fromSatInt x :: Double - yD = fromSatInt y :: Double - zD = fromSatInt z :: Double - in microToPico . fromSomeSEXP <$> - [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs, y_mem=yD_hs, z_mem=zD_hs))[[1]]|] - predictH :: CostingInteger -> CostingInteger -> CostingInteger -> CostingInteger - predictH x y z = - coerce $ exBudgetCPU $ sumExBudgetStream $ - runCostingFunThreeArguments costingFunH (ExM x) (ExM y) (ExM z) - sizeGen = (,,) <$> memUsageGen <*> memUsageGen <*> memUsageGen - in do - (x, y, z) <- forAll sizeGen - byR <- lift $ predictR x y z - diff byR (>=) 0 - diff byR (~=) (predictH x y z) - - -testPredictSix - :: CostingFun ModelSixArguments - -> SomeSEXP s - -> Property -testPredictSix costingFunH modelR = propertyR $ - let predictR :: MonadR m => CostingInteger -> CostingInteger -> CostingInteger - -> CostingInteger -> CostingInteger -> CostingInteger -> m CostingInteger - predictR x y z u v w = - let - xD = fromSatInt x :: Double - yD = fromSatInt y :: Double - zD = fromSatInt z :: Double - uD = fromSatInt u :: Double - vD = fromSatInt v :: Double - wD = fromSatInt w :: Double - in - microToPico . fromSomeSEXP <$> - [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs, y_mem=yD_hs, z_mem=zD_hs, +testPredictOne :: + CostingFun ModelOneArgument -> + SomeSEXP s -> + Property +testPredictOne costingFunH modelR = + propertyR $ + let predictR :: MonadR m => CostingInteger -> m CostingInteger + predictR x = + let + xD = fromSatInt x :: Double + in + microToPico . fromSomeSEXP <$> [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs))[[1]]|] + predictH :: CostingInteger -> CostingInteger + predictH x = + coerce $ + exBudgetCPU $ + sumExBudgetStream $ + runCostingFunOneArgument costingFunH (ExM x) + sizeGen = memUsageGen + in do + x <- forAll sizeGen + byR <- lift $ predictR x + -- Sometimes R gives us models which pass through the origin, so we have to allow zero cost + -- because of that + diff byR (>=) 0 + diff byR (~=) (predictH x) + +testPredictTwo :: + CostingFun ModelTwoArguments -> + SomeSEXP s -> + TestDomain -> + Property +testPredictTwo costingFunH modelR domain = + propertyR $ + let predictR :: MonadR m => CostingInteger -> CostingInteger -> m CostingInteger + predictR x y = + let + xD = fromSatInt x :: Double + yD = fromSatInt y :: Double + in + microToPico . fromSomeSEXP + <$> [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs, y_mem=yD_hs))[[1]]|] + predictH :: CostingInteger -> CostingInteger -> CostingInteger + predictH x y = + coerce $ + exBudgetCPU $ + sumExBudgetStream $ + runCostingFunTwoArguments costingFunH (ExM x) (ExM y) + sizeGen = case domain of + Everywhere -> twoArgs + OnDiagonal -> memUsageGen >>= \x -> pure (x, x) + BelowDiagonal -> Gen.filter (uncurry (>=)) twoArgs + BelowDiagonal' -> Gen.filter (uncurry (>=)) twoArgs' + where + twoArgs = (,) <$> memUsageGen <*> memUsageGen + twoArgs' = (,) <$> memUsageGen40 <*> memUsageGen40 + in do + (x, y) <- forAll sizeGen + byR <- lift $ predictR x y + diff byR (>=) 0 + diff byR (~=) (predictH x y) + +testPredictThree :: + CostingFun ModelThreeArguments -> + SomeSEXP s -> + Property +testPredictThree costingFunH modelR = + propertyR $ + let predictR :: MonadR m => CostingInteger -> CostingInteger -> CostingInteger -> m CostingInteger + predictR x y z = + let + xD = fromSatInt x :: Double + yD = fromSatInt y :: Double + zD = fromSatInt z :: Double + in + microToPico . fromSomeSEXP + <$> [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs, y_mem=yD_hs, z_mem=zD_hs))[[1]]|] + predictH :: CostingInteger -> CostingInteger -> CostingInteger -> CostingInteger + predictH x y z = + coerce $ + exBudgetCPU $ + sumExBudgetStream $ + runCostingFunThreeArguments costingFunH (ExM x) (ExM y) (ExM z) + sizeGen = (,,) <$> memUsageGen <*> memUsageGen <*> memUsageGen + in do + (x, y, z) <- forAll sizeGen + byR <- lift $ predictR x y z + diff byR (>=) 0 + diff byR (~=) (predictH x y z) + +testPredictSix :: + CostingFun ModelSixArguments -> + SomeSEXP s -> + Property +testPredictSix costingFunH modelR = + propertyR $ + let predictR :: + MonadR m => + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger -> + m CostingInteger + predictR x y z u v w = + let + xD = fromSatInt x :: Double + yD = fromSatInt y :: Double + zD = fromSatInt z :: Double + uD = fromSatInt u :: Double + vD = fromSatInt v :: Double + wD = fromSatInt w :: Double + in + microToPico . fromSomeSEXP + <$> [r|predict(modelR_hs$model, data.frame(x_mem=xD_hs, y_mem=yD_hs, z_mem=zD_hs, u_mem=uD_hs, v_mem=vD_hs, w_mem=wD_hs))[[1]]|] - predictH - :: CostingInteger - -> CostingInteger - -> CostingInteger - -> CostingInteger - -> CostingInteger - -> CostingInteger - -> CostingInteger - predictH x y z u v w = - coerce $ exBudgetCPU $ sumExBudgetStream $ - runCostingFunSixArguments costingFunH (ExM x) (ExM y) (ExM z) (ExM u) (ExM v) (ExM w) - sizeGen = - (,,,,,) <$> memUsageGen <*> memUsageGen <*> memUsageGen <*> memUsageGen <*> memUsageGen - <*> memUsageGen - in do - (x, y, z, u, v, w) <- forAll sizeGen - byR <- lift $ predictR x y z u v w - diff byR (>=) 0 - diff byR (~=) (predictH x y z u v w) - -makeProp1 - :: String - -> (forall f . BuiltinCostModelBase f -> f ModelOneArgument) - -> HModels - -> RModels s - -> (PropertyName, Property) + predictH :: + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger + predictH x y z u v w = + coerce $ + exBudgetCPU $ + sumExBudgetStream $ + runCostingFunSixArguments costingFunH (ExM x) (ExM y) (ExM z) (ExM u) (ExM v) (ExM w) + sizeGen = + (,,,,,) + <$> memUsageGen + <*> memUsageGen + <*> memUsageGen + <*> memUsageGen + <*> memUsageGen + <*> memUsageGen + in do + (x, y, z, u, v, w) <- forAll sizeGen + byR <- lift $ predictR x y z u v w + diff byR (>=) 0 + diff byR (~=) (predictH x y z u v w) + +makeProp1 :: + String -> + (forall f. BuiltinCostModelBase f -> f ModelOneArgument) -> + HModels -> + RModels s -> + (PropertyName, Property) makeProp1 name getField modelsH modelsR = - (fromString name, testPredictOne (getField modelsH) (getConst $ getField modelsR)) - -makeProp2 - :: String - -> (forall f . BuiltinCostModelBase f -> f ModelTwoArguments) - -> HModels - -> RModels s - -> TestDomain - -> (PropertyName, Property) + (fromString name, testPredictOne (getField modelsH) (getConst $ getField modelsR)) + +makeProp2 :: + String -> + (forall f. BuiltinCostModelBase f -> f ModelTwoArguments) -> + HModels -> + RModels s -> + TestDomain -> + (PropertyName, Property) makeProp2 name getField modelsH modelsR domain = - (fromString name, testPredictTwo (getField modelsH) (getConst $ getField modelsR) domain) - -makeProp3 - :: String - -> (forall f . BuiltinCostModelBase f -> f ModelThreeArguments) - -> HModels - -> RModels s - -> (PropertyName, Property) -makeProp3 name getField modelsH modelsR = - (fromString name, testPredictThree (getField modelsH) (getConst $ getField modelsR)) - -makeProp6 - :: String - -> (forall f . BuiltinCostModelBase f -> f ModelSixArguments) - -> HModels - -> RModels s - -> (PropertyName, Property) + (fromString name, testPredictTwo (getField modelsH) (getConst $ getField modelsR) domain) + +makeProp3 :: + String -> + (forall f. BuiltinCostModelBase f -> f ModelThreeArguments) -> + HModels -> + RModels s -> + (PropertyName, Property) +makeProp3 name getField modelsH modelsR = + (fromString name, testPredictThree (getField modelsH) (getConst $ getField modelsR)) + +makeProp6 :: + String -> + (forall f. BuiltinCostModelBase f -> f ModelSixArguments) -> + HModels -> + RModels s -> + (PropertyName, Property) makeProp6 name getField modelsH modelsR = - (fromString name, testPredictSix (getField modelsH) (getConst $ getField modelsR)) + (fromString name, testPredictSix (getField modelsH) (getConst $ getField modelsR)) main :: IO () main = @@ -322,128 +355,115 @@ main = modelsH <- CreateBuiltinCostModel.createBuiltinCostModel DFP.benchingResultsFile DFP.rModelFile modelsR <- CreateBuiltinCostModel.costModelsR DFP.benchingResultsFile DFP.rModelFile H.io $ HH.defaultMain [checkSequential $ Group "Costing function tests" (tests modelsH modelsR)] - where tests modelsH modelsR = - -- 'modelsR' and `modelsH' don't appear explicitly below, but 'genTest' generates code which uses them. - [ $(genTest 2 "addInteger") Everywhere - , $(genTest 2 "subtractInteger") Everywhere - , $(genTest 2 "multiplyInteger") Everywhere - , $(genTest 2 "divideInteger") BelowDiagonal' - , $(genTest 2 "quotientInteger") BelowDiagonal' - , $(genTest 2 "remainderInteger") BelowDiagonal' - , $(genTest 2 "modInteger") BelowDiagonal' - , $(genTest 2 "lessThanInteger") Everywhere - , $(genTest 2 "lessThanEqualsInteger") Everywhere - , $(genTest 2 "equalsInteger") Everywhere - -- , $(genTest 3 "expModInteger") - -- ^ Doesn't work because of the penalty for initial modular reduction. - - -- Bytestrings - , $(genTest 2 "appendByteString") Everywhere - , $(genTest 2 "consByteString") Everywhere - , $(genTest 3 "sliceByteString") - , $(genTest 1 "lengthOfByteString") - , $(genTest 2 "indexByteString") Everywhere - , $(genTest 2 "equalsByteString") OnDiagonal - , $(genTest 2 "lessThanByteString") Everywhere - , $(genTest 2 "lessThanEqualsByteString") Everywhere - - -- Cryptography and hashes - , $(genTest 1 "sha2_256") - , $(genTest 1 "sha3_256") - , $(genTest 1 "blake2b_256") - , $(genTest 3 "verifyEd25519Signature") - , $(genTest 3 "verifyEcdsaSecp256k1Signature") - , $(genTest 3 "verifySchnorrSecp256k1Signature") - - -- Strings - , $(genTest 2 "appendString") Everywhere - , $(genTest 2 "equalsString") OnDiagonal - , $(genTest 1 "encodeUtf8") - , $(genTest 1 "decodeUtf8") - - -- Bool - , $(genTest 3 "ifThenElse") - - -- Unit - , $(genTest 2 "chooseUnit") Everywhere - - -- Tracing - , $(genTest 2 "trace") Everywhere - - -- Pairs - , $(genTest 1 "fstPair") - , $(genTest 1 "sndPair") - - -- Lists - , $(genTest 3 "chooseList") - , $(genTest 2 "mkCons") Everywhere - , $(genTest 1 "headList") - , $(genTest 1 "tailList") - , $(genTest 1 "nullList") - , $(genTest 2 "dropList") Everywhere - - -- Arrays - , $(genTest 1 "lengthOfArray") - , $(genTest 1 "listToArray") - , $(genTest 2 "indexArray") Everywhere - - -- Data - , $(genTest 6 "chooseData") - , $(genTest 2 "constrData") Everywhere - , $(genTest 1 "mapData") - , $(genTest 1 "listData") - , $(genTest 1 "iData") - , $(genTest 1 "bData") - , $(genTest 1 "unConstrData") - , $(genTest 1 "unMapData") - , $(genTest 1 "unListData") - , $(genTest 1 "unIData") - , $(genTest 1 "unBData") - , $(genTest 2 "equalsData") Everywhere - , $(genTest 1 "serialiseData") - - -- Misc constructors - , $(genTest 2 "mkPairData") Everywhere - , $(genTest 1 "mkNilData") - , $(genTest 1 "mkNilPairData") - - -- BLS - , $(genTest 2 "bls12_381_G1_add") Everywhere - , $(genTest 1 "bls12_381_G1_neg") - , $(genTest 2 "bls12_381_G1_scalarMul") Everywhere - , $(genTest 2 "bls12_381_G1_equal") Everywhere - , $(genTest 1 "bls12_381_G1_compress") - , $(genTest 1 "bls12_381_G1_uncompress") - , $(genTest 2 "bls12_381_G1_hashToGroup") Everywhere - , $(genTest 2 "bls12_381_G2_add") Everywhere - , $(genTest 1 "bls12_381_G2_neg") - , $(genTest 2 "bls12_381_G2_scalarMul") Everywhere - , $(genTest 2 "bls12_381_G2_equal") Everywhere - , $(genTest 1 "bls12_381_G2_compress") - , $(genTest 1 "bls12_381_G2_uncompress") - , $(genTest 2 "bls12_381_G2_hashToGroup") Everywhere - , $(genTest 2 "bls12_381_millerLoop") Everywhere - , $(genTest 2 "bls12_381_mulMlResult") Everywhere - , $(genTest 2 "bls12_381_finalVerify") Everywhere - - -- Keccak_256, Blake2b_224, Ripemd_160 - , $(genTest 1 "keccak_256") - , $(genTest 1 "blake2b_224") - , $(genTest 1 "ripemd_160") - - -- Bitwise operations - , $(genTest 3 "integerToByteString") - , $(genTest 2 "byteStringToInteger") Everywhere - , $(genTest 3 "andByteString") - , $(genTest 3 "orByteString") - , $(genTest 3 "xorByteString") - , $(genTest 1 "complementByteString") - , $(genTest 2 "readBit") Everywhere - , $(genTest 3 "writeBits") - , $(genTest 2 "replicateByte") Everywhere - , $(genTest 2 "shiftByteString") Everywhere - , $(genTest 2 "rotateByteString") Everywhere - , $(genTest 1 "countSetBits") - , $(genTest 1 "findFirstSetBit") - ] - + where + tests modelsH modelsR = + -- 'modelsR' and `modelsH' don't appear explicitly below, but 'genTest' generates code which uses them. + [ $(genTest 2 "addInteger") Everywhere + , $(genTest 2 "subtractInteger") Everywhere + , $(genTest 2 "multiplyInteger") Everywhere + , $(genTest 2 "divideInteger") BelowDiagonal' + , $(genTest 2 "quotientInteger") BelowDiagonal' + , $(genTest 2 "remainderInteger") BelowDiagonal' + , $(genTest 2 "modInteger") BelowDiagonal' + , $(genTest 2 "lessThanInteger") Everywhere + , $(genTest 2 "lessThanEqualsInteger") Everywhere + , $(genTest 2 "equalsInteger") Everywhere + , -- , $(genTest 3 "expModInteger") + -- \^ Doesn't work because of the penalty for initial modular reduction. + + -- Bytestrings + $(genTest 2 "appendByteString") Everywhere + , $(genTest 2 "consByteString") Everywhere + , $(genTest 3 "sliceByteString") + , $(genTest 1 "lengthOfByteString") + , $(genTest 2 "indexByteString") Everywhere + , $(genTest 2 "equalsByteString") OnDiagonal + , $(genTest 2 "lessThanByteString") Everywhere + , $(genTest 2 "lessThanEqualsByteString") Everywhere + , -- Cryptography and hashes + $(genTest 1 "sha2_256") + , $(genTest 1 "sha3_256") + , $(genTest 1 "blake2b_256") + , $(genTest 3 "verifyEd25519Signature") + , $(genTest 3 "verifyEcdsaSecp256k1Signature") + , $(genTest 3 "verifySchnorrSecp256k1Signature") + , -- Strings + $(genTest 2 "appendString") Everywhere + , $(genTest 2 "equalsString") OnDiagonal + , $(genTest 1 "encodeUtf8") + , $(genTest 1 "decodeUtf8") + , -- Bool + $(genTest 3 "ifThenElse") + , -- Unit + $(genTest 2 "chooseUnit") Everywhere + , -- Tracing + $(genTest 2 "trace") Everywhere + , -- Pairs + $(genTest 1 "fstPair") + , $(genTest 1 "sndPair") + , -- Lists + $(genTest 3 "chooseList") + , $(genTest 2 "mkCons") Everywhere + , $(genTest 1 "headList") + , $(genTest 1 "tailList") + , $(genTest 1 "nullList") + , $(genTest 2 "dropList") Everywhere + , -- Arrays + $(genTest 1 "lengthOfArray") + , $(genTest 1 "listToArray") + , $(genTest 2 "indexArray") Everywhere + , -- Data + $(genTest 6 "chooseData") + , $(genTest 2 "constrData") Everywhere + , $(genTest 1 "mapData") + , $(genTest 1 "listData") + , $(genTest 1 "iData") + , $(genTest 1 "bData") + , $(genTest 1 "unConstrData") + , $(genTest 1 "unMapData") + , $(genTest 1 "unListData") + , $(genTest 1 "unIData") + , $(genTest 1 "unBData") + , $(genTest 2 "equalsData") Everywhere + , $(genTest 1 "serialiseData") + , -- Misc constructors + $(genTest 2 "mkPairData") Everywhere + , $(genTest 1 "mkNilData") + , $(genTest 1 "mkNilPairData") + , -- BLS + $(genTest 2 "bls12_381_G1_add") Everywhere + , $(genTest 1 "bls12_381_G1_neg") + , $(genTest 2 "bls12_381_G1_scalarMul") Everywhere + , $(genTest 2 "bls12_381_G1_equal") Everywhere + , $(genTest 1 "bls12_381_G1_compress") + , $(genTest 1 "bls12_381_G1_uncompress") + , $(genTest 2 "bls12_381_G1_hashToGroup") Everywhere + , $(genTest 2 "bls12_381_G2_add") Everywhere + , $(genTest 1 "bls12_381_G2_neg") + , $(genTest 2 "bls12_381_G2_scalarMul") Everywhere + , $(genTest 2 "bls12_381_G2_equal") Everywhere + , $(genTest 1 "bls12_381_G2_compress") + , $(genTest 1 "bls12_381_G2_uncompress") + , $(genTest 2 "bls12_381_G2_hashToGroup") Everywhere + , $(genTest 2 "bls12_381_millerLoop") Everywhere + , $(genTest 2 "bls12_381_mulMlResult") Everywhere + , $(genTest 2 "bls12_381_finalVerify") Everywhere + , -- Keccak_256, Blake2b_224, Ripemd_160 + $(genTest 1 "keccak_256") + , $(genTest 1 "blake2b_224") + , $(genTest 1 "ripemd_160") + , -- Bitwise operations + $(genTest 3 "integerToByteString") + , $(genTest 2 "byteStringToInteger") Everywhere + , $(genTest 3 "andByteString") + , $(genTest 3 "orByteString") + , $(genTest 3 "xorByteString") + , $(genTest 1 "complementByteString") + , $(genTest 2 "readBit") Everywhere + , $(genTest 3 "writeBits") + , $(genTest 2 "replicateByte") Everywhere + , $(genTest 2 "shiftByteString") Everywhere + , $(genTest 2 "rotateByteString") Everywhere + , $(genTest 1 "countSetBits") + , $(genTest 1 "findFirstSetBit") + ] diff --git a/plutus-core/executables/plutus/AnyProgram/Apply.hs b/plutus-core/executables/plutus/AnyProgram/Apply.hs index 66ac70f6333..9d5a2c91836 100644 --- a/plutus-core/executables/plutus/AnyProgram/Apply.hs +++ b/plutus-core/executables/plutus/AnyProgram/Apply.hs @@ -1,6 +1,6 @@ -module AnyProgram.Apply - ( applyProgram - ) where +module AnyProgram.Apply ( + applyProgram, +) where import AnyProgram.With import PlutusCore qualified as PLC @@ -12,12 +12,14 @@ import UntypedPlutusCore qualified as UPLC import Control.Monad.Except -- | Given a singleton witness and two programs of that type witness, apply them together. -applyProgram :: MonadError PLC.ApplyProgramError m - => SLang s -> FromLang s -> FromLang s -> m (FromLang s) +applyProgram :: + MonadError PLC.ApplyProgramError m => + SLang s -> FromLang s -> FromLang s -> m (FromLang s) applyProgram sng p1 p2 = withA @Semigroup (_sann sng) $ - case sng of - SPir{} -> PIR.applyProgram p1 p2 - SPlc{} -> PLC.applyProgram p1 p2 - SUplc{} -> UPLC.UnrestrictedProgram <$> - UPLC.unUnrestrictedProgram p1 `UPLC.applyProgram` UPLC.unUnrestrictedProgram p2 - SData{} -> error "Cannot apply to Data. This should have failed earlier during compilation." + case sng of + SPir {} -> PIR.applyProgram p1 p2 + SPlc {} -> PLC.applyProgram p1 p2 + SUplc {} -> + UPLC.UnrestrictedProgram + <$> UPLC.unUnrestrictedProgram p1 `UPLC.applyProgram` UPLC.unUnrestrictedProgram p2 + SData {} -> error "Cannot apply to Data. This should have failed earlier during compilation." diff --git a/plutus-core/executables/plutus/AnyProgram/Bench.hs b/plutus-core/executables/plutus/AnyProgram/Bench.hs index c87eb949187..d525ab4a7e6 100644 --- a/plutus-core/executables/plutus/AnyProgram/Bench.hs +++ b/plutus-core/executables/plutus/AnyProgram/Bench.hs @@ -1,6 +1,6 @@ -module AnyProgram.Bench - ( runBench - ) where +module AnyProgram.Bench ( + runBench, +) where import Types diff --git a/plutus-core/executables/plutus/AnyProgram/Compile.hs b/plutus-core/executables/plutus/AnyProgram/Compile.hs index 459bfe6e513..269ddade9ea 100644 --- a/plutus-core/executables/plutus/AnyProgram/Compile.hs +++ b/plutus-core/executables/plutus/AnyProgram/Compile.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -module AnyProgram.Compile - ( compileProgram - , checkProgram - , toOutAnn - , plcToOutName - , uplcToOutName - , uplcToOutName' - ) where +module AnyProgram.Compile ( + compileProgram, + checkProgram, + toOutAnn, + plcToOutName, + uplcToOutName, + uplcToOutName', +) where import AnyProgram.With import GetOpt @@ -39,277 +39,320 @@ import Data.Text import PlutusPrelude hiding ((%~)) -- Note that we use for erroring the original term's annotation -compileProgram :: (?opts :: Opts, e ~ PIR.Provenance (FromAnn (US_ann s1)), - MonadError (PIR.Error DefaultUni DefaultFun e) m) - => SLang s1 - -> SLang s2 - -> FromLang s1 - -> m (FromLang s2) +compileProgram :: + ( ?opts :: Opts + , e ~ PIR.Provenance (FromAnn (US_ann s1)) + , MonadError (PIR.Error DefaultUni DefaultFun e) m + ) => + SLang s1 -> + SLang s2 -> + FromLang s1 -> + m (FromLang s2) compileProgram = curry $ \case - -- exclude all pir-debruijn input&output combinations - ---------------------------------------- - (SPir SNamedDeBruijn _, _) -> throwingPIR "pir input cannot be debruijn" - (SPir SDeBruijn _, _ ) -> throwingPIR "pir input cannot be nameddebruijn" - (_, SPir SDeBruijn _) -> throwingPIR "pir out cannot be debruijn" - (_, SPir SNamedDeBruijn _) -> throwingPIR "pir out cannot be nameddebruijn" - - -- self-lang to self-lang patterns - ---------------------------------------- - (SPir n1@SName a1, SPir n2@SName a2) -> - through (modifyError (fmap PIR.Original) . pirTypecheck a1) - -- TODO: optimise - >=> pirToOutName n1 n2 - >=> toOutAnn a1 a2 - (SPlc n1 a1, SPlc n2 a2) -> -- TODO: modifyError ... is repeated multiple times - through (modifyError (fmap PIR.Original) . plcTypecheck n1 a1) - >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) . plcToOutName n1 n2 - >=> toOutAnn a1 a2 - (SUplc n1 a1, SUplc n2 a2) -> - through (modifyError (fmap PIR.Original . PIR.PLCError) . uplcTypecheck n1 a1) - >=> modifyError (fmap PIR.Original) . uplcOptimise n1 - >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) . uplcToOutName n1 n2 - >=> toOutAnn a1 a2 - -- nothing to be done; seems silly, but can be used for later changing format of Data - (SData, SData) -> pure - - -- exclude other cases of Data as target - (_, SData) -> throwingPIR "Cannot compile a pir/tplc/uplc program to Data" - - -- pir to plc - ---------------------------------------- - (SPir n1@SName a1, SPlc n2 SUnit) -> - withA @Ord a1 $ withA @Pretty a1 $ withA @AnnInline a1 $ - -- Note: PIR.compileProgram subsumes pir typechecking - (PLC.runQuoteT . flip runReaderT compCtx . PIR.compileProgram) - >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) . plcToOutName n1 n2 - -- completely drop annotations for now - >=> pure . void - where - compCtx = PIR.toDefaultCompilationCtx $ - unsafeFromRight @(PIR.Error DefaultUni DefaultFun ()) $ - modifyError (PIR.PLCError . TypeErrorE) $ PLC.getDefTypeCheckConfig () - - -- note to self: this restriction is because of PIR.Provenance appearing in the output - (SPir _n1@SName _, SPlc _ _) -> throwingPIR "only support unit-ann output for now" - - -- plc to pir (a special case of embedding, since plc is subset of pir) - ---------------------------------------- - (sng1@(SPlc _n1 a1), SPir n2@SName a2) -> - -- first self-"compile" to plc (just for reusing code) - compileProgram sng1 (SPlc n2 a1) - >=> pure . embedProgram - -- here we also run the pir typechecker, and pir optimiser - -- MAYBE: we shouldn't do the above? - >=> compileProgram (SPir n2 a1) (SPir n2 a2) - - -- pir to uplc - ---------------------------------------- - (sng1@(SPir _n1@SName a1), sng2@(SUplc n2 _a2)) -> - -- intermediate through plc==sng12 - let sng12 = SPlc n2 a1 - in compileProgram sng1 sng12 - >=> compileProgram sng12 sng2 - - -- plc to uplc - ---------------------------------------- - (sng1@(SPlc _n1 _a1), SUplc n2 a2) -> - -- first self-"compile" to plc (just for reusing code) - compileProgram sng1 (SPlc n2 a2) - -- PLC.compileProgram subsumes uplcOptimise - >=> (PLC.runQuoteT . flip runReaderT PLC.defaultCompilationOpts . - plcToUplcViaName n2 PLC.compileProgram) - >=> pure . UPLC.UnrestrictedProgram - - -- data to pir/plc/uplc - - -- TODO: deduplicate if we had `withTermLikeL` - (SData, SPir _ a2) -> withA @Monoid a2 $ - pure . PIR.Program mempty PLC.latestVersion . PIR.Constant mempty . someValue - (SData, SPlc _ a2) -> withA @Monoid a2 $ - pure . PLC.Program mempty PLC.latestVersion . PLC.Constant mempty . someValue - (SData, SUplc _ a2) -> withA @Monoid a2 $ - pure . UPLC.UnrestrictedProgram . UPLC.Program mempty PLC.latestVersion . - UPLC.Constant mempty . someValue - - -- uplc to ? - (SUplc _ _, SPlc _ _) -> throwingPIR "Cannot compile uplc to tplc" - (SUplc _ _, SPir SName _) -> throwingPIR "Cannot compile uplc to pir" + -- exclude all pir-debruijn input&output combinations + ---------------------------------------- + (SPir SNamedDeBruijn _, _) -> throwingPIR "pir input cannot be debruijn" + (SPir SDeBruijn _, _) -> throwingPIR "pir input cannot be nameddebruijn" + (_, SPir SDeBruijn _) -> throwingPIR "pir out cannot be debruijn" + (_, SPir SNamedDeBruijn _) -> throwingPIR "pir out cannot be nameddebruijn" + -- self-lang to self-lang patterns + ---------------------------------------- + (SPir n1@SName a1, SPir n2@SName a2) -> + through (modifyError (fmap PIR.Original) . pirTypecheck a1) + -- TODO: optimise + >=> pirToOutName n1 n2 + >=> toOutAnn a1 a2 + (SPlc n1 a1, SPlc n2 a2) -> + -- TODO: modifyError ... is repeated multiple times + through (modifyError (fmap PIR.Original) . plcTypecheck n1 a1) + >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) + . plcToOutName n1 n2 + >=> toOutAnn a1 a2 + (SUplc n1 a1, SUplc n2 a2) -> + through (modifyError (fmap PIR.Original . PIR.PLCError) . uplcTypecheck n1 a1) + >=> modifyError (fmap PIR.Original) + . uplcOptimise n1 + >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) + . uplcToOutName n1 n2 + >=> toOutAnn a1 a2 + -- nothing to be done; seems silly, but can be used for later changing format of Data + (SData, SData) -> pure + -- exclude other cases of Data as target + (_, SData) -> throwingPIR "Cannot compile a pir/tplc/uplc program to Data" + -- pir to plc + ---------------------------------------- + (SPir n1@SName a1, SPlc n2 SUnit) -> + withA @Ord a1 $ + withA @Pretty a1 $ + withA @AnnInline a1 $ + -- Note: PIR.compileProgram subsumes pir typechecking + (PLC.runQuoteT . flip runReaderT compCtx . PIR.compileProgram) + >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) + . plcToOutName n1 n2 + -- completely drop annotations for now + >=> pure + . void + where + compCtx = + PIR.toDefaultCompilationCtx $ + unsafeFromRight @(PIR.Error DefaultUni DefaultFun ()) $ + modifyError (PIR.PLCError . TypeErrorE) $ + PLC.getDefTypeCheckConfig () + + -- note to self: this restriction is because of PIR.Provenance appearing in the output + (SPir _n1@SName _, SPlc _ _) -> throwingPIR "only support unit-ann output for now" + -- plc to pir (a special case of embedding, since plc is subset of pir) + ---------------------------------------- + (sng1@(SPlc _n1 a1), SPir n2@SName a2) -> + -- first self-"compile" to plc (just for reusing code) + compileProgram sng1 (SPlc n2 a1) + >=> pure + . embedProgram + -- here we also run the pir typechecker, and pir optimiser + -- MAYBE: we shouldn't do the above? + >=> compileProgram (SPir n2 a1) (SPir n2 a2) + -- pir to uplc + ---------------------------------------- + (sng1@(SPir _n1@SName a1), sng2@(SUplc n2 _a2)) -> + -- intermediate through plc==sng12 + let sng12 = SPlc n2 a1 + in compileProgram sng1 sng12 + >=> compileProgram sng12 sng2 + -- plc to uplc + ---------------------------------------- + (sng1@(SPlc _n1 _a1), SUplc n2 a2) -> + -- first self-"compile" to plc (just for reusing code) + compileProgram sng1 (SPlc n2 a2) + -- PLC.compileProgram subsumes uplcOptimise + >=> ( PLC.runQuoteT + . flip runReaderT PLC.defaultCompilationOpts + . plcToUplcViaName n2 PLC.compileProgram + ) + >=> pure + . UPLC.UnrestrictedProgram + -- data to pir/plc/uplc + + -- TODO: deduplicate if we had `withTermLikeL` + (SData, SPir _ a2) -> + withA @Monoid a2 $ + pure . PIR.Program mempty PLC.latestVersion . PIR.Constant mempty . someValue + (SData, SPlc _ a2) -> + withA @Monoid a2 $ + pure . PLC.Program mempty PLC.latestVersion . PLC.Constant mempty . someValue + (SData, SUplc _ a2) -> + withA @Monoid a2 $ + pure + . UPLC.UnrestrictedProgram + . UPLC.Program mempty PLC.latestVersion + . UPLC.Constant mempty + . someValue + -- uplc to ? + (SUplc _ _, SPlc _ _) -> throwingPIR "Cannot compile uplc to tplc" + (SUplc _ _, SPir SName _) -> throwingPIR "Cannot compile uplc to pir" embedProgram :: PLC.Program tyname name uni fun ann -> PIR.Program tyname name uni fun ann embedProgram (PLC.Program a v t) = PIR.Program a v $ embedTerm t -toOutAnn :: (Functor f, MonadError (PIR.Error uni fun a) m) - => SAnn s1 - -> SAnn s2 - -> f (FromAnn s1) - -> m (f (FromAnn s2)) +toOutAnn :: + (Functor f, MonadError (PIR.Error uni fun a) m) => + SAnn s1 -> + SAnn s2 -> + f (FromAnn s1) -> + m (f (FromAnn s2)) toOutAnn sng1 ((sng1 %~) -> Proved Refl) = pure -toOutAnn _ SUnit = pure . void -toOutAnn _ _ = throwingPIR "cannot convert annotation" +toOutAnn _ SUnit = pure . void +toOutAnn _ _ = throwingPIR "cannot convert annotation" -- MAYBE: All of the following could be unified under a ProgramLike typeclass. -- or by some singletons type-level programming -pirTypecheck - :: (MonadError (PIR.Error DefaultUni DefaultFun (FromAnn a)) m) - => SAnn a - -> PIR.Program PLC.TyName PLC.Name DefaultUni DefaultFun (FromAnn a) - -> m () +pirTypecheck :: + MonadError (PIR.Error DefaultUni DefaultFun (FromAnn a)) m => + SAnn a -> + PIR.Program PLC.TyName PLC.Name DefaultUni DefaultFun (FromAnn a) -> + m () pirTypecheck sngA p = PLC.runQuoteT $ do - tcConfig <- withA @Monoid sngA $ modifyError (PIR.PLCError . PLC.TypeErrorE) $ PIR.getDefTypeCheckConfig mempty - void $ PIR.inferTypeOfProgram tcConfig p - -plcToUplcViaName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) - => SNaming n - -> (PLC.Program PLC.TyName PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a)) - -> PLC.Program (FromNameTy n) (FromName n) uni fun a - -> m (UPLC.Program (FromName n) uni fun a) + tcConfig <- withA @Monoid sngA $ modifyError (PIR.PLCError . PLC.TypeErrorE) $ PIR.getDefTypeCheckConfig mempty + void $ PIR.inferTypeOfProgram tcConfig p + +plcToUplcViaName :: + (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) => + SNaming n -> + (PLC.Program PLC.TyName PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a)) -> + PLC.Program (FromNameTy n) (FromName n) uni fun a -> + m (UPLC.Program (FromName n) uni fun a) plcToUplcViaName sngN act = case sngN of - SName -> act - SNamedDeBruijn -> - plcToName sngN act >=> - UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm) - SDeBruijn -> - plcToName sngN act - >=> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm) - >=> pure . UPLC.programMapNames PLC.unNameDeBruijn - -plcToName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) - => SNaming n - -> (PLC.Program PLC.TyName PLC.Name uni fun a -> m x) - -> (PLC.Program (FromNameTy n) (FromName n) uni fun a -> m x) + SName -> act + SNamedDeBruijn -> + plcToName sngN act + >=> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm) + SDeBruijn -> + plcToName sngN act + >=> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm) + >=> pure + . UPLC.programMapNames PLC.unNameDeBruijn + +plcToName :: + (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) => + SNaming n -> + (PLC.Program PLC.TyName PLC.Name uni fun a -> m x) -> + (PLC.Program (FromNameTy n) (FromName n) uni fun a -> m x) plcToName sngN act = case sngN of - SName -> act - SNamedDeBruijn -> PLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . PLC.unDeBruijnTerm) - >=> act - SDeBruijn -> pure . PLC.programMapNames PLC.fakeTyNameDeBruijn PLC.fakeNameDeBruijn - >=> plcToName SNamedDeBruijn act - -uplcViaName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) - => (UPLC.Program PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a)) - -> SNaming n - -> UPLC.Program (FromName n) uni fun a - -> m (UPLC.Program (FromName n) uni fun a) + SName -> act + SNamedDeBruijn -> + PLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . PLC.unDeBruijnTerm) + >=> act + SDeBruijn -> + pure + . PLC.programMapNames PLC.fakeTyNameDeBruijn PLC.fakeNameDeBruijn + >=> plcToName SNamedDeBruijn act + +uplcViaName :: + (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) => + (UPLC.Program PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a)) -> + SNaming n -> + UPLC.Program (FromName n) uni fun a -> + m (UPLC.Program (FromName n) uni fun a) uplcViaName act sngN = case sngN of - SName -> act - SNamedDeBruijn -> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.unDeBruijnTerm) - >=> act - >=> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm) - SDeBruijn -> pure . UPLC.programMapNames UPLC.fakeNameDeBruijn - >=> uplcViaName act SNamedDeBruijn - >=> pure . UPLC.programMapNames UPLC.unNameDeBruijn - -plcTypecheck :: (MonadError (PIR.Error DefaultUni DefaultFun (FromAnn a)) m) - => SNaming n - -> SAnn a - -> PLC.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) - -> m () -plcTypecheck sngN sngA p = PLC.runQuoteT $ do - tcConfig <- - withA @Monoid sngA $ - modifyError (PIR.PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig mempty - void $ plcToName sngN (modifyError (PIR.PLCError . PLC.TypeErrorE) . PLC.inferTypeOfProgram tcConfig) p - -uplcOptimise :: (?opts :: Opts - , MonadError (PIR.Error DefaultUni DefaultFun a) m - ) - => SNaming n1 - -> UPLC.UnrestrictedProgram (FromName n1) DefaultUni DefaultFun a - -> m (UPLC.UnrestrictedProgram (FromName n1) DefaultUni DefaultFun a) + SName -> act + SNamedDeBruijn -> + UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.unDeBruijnTerm) + >=> act + >=> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm) + SDeBruijn -> + pure + . UPLC.programMapNames UPLC.fakeNameDeBruijn + >=> uplcViaName act SNamedDeBruijn + >=> pure + . UPLC.programMapNames UPLC.unNameDeBruijn + +plcTypecheck :: + MonadError (PIR.Error DefaultUni DefaultFun (FromAnn a)) m => + SNaming n -> + SAnn a -> + PLC.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) -> + m () +plcTypecheck sngN sngA p = PLC.runQuoteT $ do + tcConfig <- + withA @Monoid sngA $ + modifyError (PIR.PLCError . PLC.TypeErrorE) $ + PLC.getDefTypeCheckConfig mempty + void $ plcToName sngN (modifyError (PIR.PLCError . PLC.TypeErrorE) . PLC.inferTypeOfProgram tcConfig) p + +uplcOptimise :: + ( ?opts :: Opts + , MonadError (PIR.Error DefaultUni DefaultFun a) m + ) => + SNaming n1 -> + UPLC.UnrestrictedProgram (FromName n1) DefaultUni DefaultFun a -> + m (UPLC.UnrestrictedProgram (FromName n1) DefaultUni DefaultFun a) uplcOptimise = - case _optimiseLvl ?opts of - NoOptimise -> const pure -- short-circuit to avoid renaming - safeOrUnsafe -> - let sOpts = UPLC.defaultSimplifyOpts & - case safeOrUnsafe of - SafeOptimise -> set UPLC.soConservativeOpts True - UnsafeOptimise -> id - in fmap PLC.runQuoteT - . _Wrapped - . uplcViaName (UPLC.simplifyProgram sOpts def) + case _optimiseLvl ?opts of + NoOptimise -> const pure -- short-circuit to avoid renaming + safeOrUnsafe -> + let sOpts = + UPLC.defaultSimplifyOpts + & case safeOrUnsafe of + SafeOptimise -> set UPLC.soConservativeOpts True + UnsafeOptimise -> id + in fmap PLC.runQuoteT + . _Wrapped + . uplcViaName (UPLC.simplifyProgram sOpts def) -- | We do not have a typechecker for uplc, but we could pretend that scopecheck is a "typechecker" -uplcTypecheck :: forall sN sA uni fun m - . (MonadError (PLC.Error uni fun (FromAnn sA)) m) - => SNaming sN - -> SAnn sA - -> UPLC.UnrestrictedProgram (FromName sN) uni fun (FromAnn sA) - -> m () +uplcTypecheck :: + forall sN sA uni fun m. + MonadError (PLC.Error uni fun (FromAnn sA)) m => + SNaming sN -> + SAnn sA -> + UPLC.UnrestrictedProgram (FromName sN) uni fun (FromAnn sA) -> + m () uplcTypecheck sngN sngA ast = case sngN of - SName -> - modifyError PLC.UniqueCoherencyErrorE $ - withA @Ord sngA $ UPLC.checkProgram (const True) (ast ^. _Wrapped) - -- TODO: deduplicate - SDeBruijn -> modifyError PLC.FreeVariableErrorE $ UPLC.checkScope (ast ^. _Wrapped. UPLC.progTerm) - SNamedDeBruijn -> modifyError PLC.FreeVariableErrorE $ UPLC.checkScope (ast ^. _Wrapped. UPLC.progTerm) - + SName -> + modifyError PLC.UniqueCoherencyErrorE $ + withA @Ord sngA $ + UPLC.checkProgram (const True) (ast ^. _Wrapped) + -- TODO: deduplicate + SDeBruijn -> modifyError PLC.FreeVariableErrorE $ UPLC.checkScope (ast ^. _Wrapped . UPLC.progTerm) + SNamedDeBruijn -> modifyError PLC.FreeVariableErrorE $ UPLC.checkScope (ast ^. _Wrapped . UPLC.progTerm) -- | Placed here just for uniformity, not really needed -pirToOutName :: (MonadError (PIR.Error uni fun a) m) - => SNaming s1 - -> SNaming s2 - -> PIR.Program (FromNameTy s1) (FromName s1) uni fun ann - -> m (PIR.Program (FromNameTy s2) (FromName s2) uni fun ann) +pirToOutName :: + MonadError (PIR.Error uni fun a) m => + SNaming s1 -> + SNaming s2 -> + PIR.Program (FromNameTy s1) (FromName s1) uni fun ann -> + m (PIR.Program (FromNameTy s2) (FromName s2) uni fun ann) pirToOutName sng1 ((sng1 %~) -> Proved Refl) = pure pirToOutName _ _ = throwingPIR "we do not support name conversion for PIR atm" -plcToOutName :: (MonadError FreeVariableError m) - => SNaming s1 - -> SNaming s2 - -> PLC.Program (FromNameTy s1) (FromName s1) uni fun ann - -> m (PLC.Program (FromNameTy s2) (FromName s2) uni fun ann) +plcToOutName :: + MonadError FreeVariableError m => + SNaming s1 -> + SNaming s2 -> + PLC.Program (FromNameTy s1) (FromName s1) uni fun ann -> + m (PLC.Program (FromNameTy s2) (FromName s2) uni fun ann) plcToOutName sng1 ((sng1 %~) -> Proved Refl) = pure plcToOutName SName SNamedDeBruijn = PLC.progTerm PLC.deBruijnTerm plcToOutName SNamedDeBruijn SName = PLC.runQuoteT . PLC.progTerm PLC.unDeBruijnTerm plcToOutName SDeBruijn SNamedDeBruijn = - pure . PLC.programMapNames PLC.fakeTyNameDeBruijn PLC.fakeNameDeBruijn + pure . PLC.programMapNames PLC.fakeTyNameDeBruijn PLC.fakeNameDeBruijn plcToOutName SNamedDeBruijn SDeBruijn = - pure . PLC.programMapNames PLC.unNameTyDeBruijn PLC.unNameDeBruijn -plcToOutName SName SDeBruijn = plcToOutName SName SNamedDeBruijn - >=> plcToOutName SNamedDeBruijn SDeBruijn -plcToOutName SDeBruijn SName = plcToOutName SDeBruijn SNamedDeBruijn - >=> plcToOutName SNamedDeBruijn SName + pure . PLC.programMapNames PLC.unNameTyDeBruijn PLC.unNameDeBruijn +plcToOutName SName SDeBruijn = + plcToOutName SName SNamedDeBruijn + >=> plcToOutName SNamedDeBruijn SDeBruijn +plcToOutName SDeBruijn SName = + plcToOutName SDeBruijn SNamedDeBruijn + >=> plcToOutName SNamedDeBruijn SName plcToOutName _ _ = error "this is complete, but i don't want to use -fno-warn-incomplete-patterns" -uplcToOutName :: (MonadError FreeVariableError m) - => SNaming s1 - -> SNaming s2 - -> UPLC.UnrestrictedProgram (FromName s1) uni fun ann - -> m (UPLC.UnrestrictedProgram (FromName s2) uni fun ann) +uplcToOutName :: + MonadError FreeVariableError m => + SNaming s1 -> + SNaming s2 -> + UPLC.UnrestrictedProgram (FromName s1) uni fun ann -> + m (UPLC.UnrestrictedProgram (FromName s2) uni fun ann) uplcToOutName = fmap _Wrapped . uplcToOutName' -uplcToOutName' :: (MonadError FreeVariableError m) - => SNaming s1 - -> SNaming s2 - -> UPLC.Program (FromName s1) uni fun ann - -> m (UPLC.Program (FromName s2) uni fun ann) +uplcToOutName' :: + MonadError FreeVariableError m => + SNaming s1 -> + SNaming s2 -> + UPLC.Program (FromName s1) uni fun ann -> + m (UPLC.Program (FromName s2) uni fun ann) uplcToOutName' sng1 ((sng1 %~) -> Proved Refl) = pure uplcToOutName' SName SNamedDeBruijn = UPLC.progTerm UPLC.deBruijnTerm uplcToOutName' SNamedDeBruijn SName = PLC.runQuoteT . UPLC.progTerm UPLC.unDeBruijnTerm uplcToOutName' SDeBruijn SNamedDeBruijn = pure . UPLC.programMapNames UPLC.fakeNameDeBruijn uplcToOutName' SNamedDeBruijn SDeBruijn = pure . UPLC.programMapNames UPLC.unNameDeBruijn -uplcToOutName' SName SDeBruijn = uplcToOutName' SName SNamedDeBruijn - >=> uplcToOutName' SNamedDeBruijn SDeBruijn -uplcToOutName' SDeBruijn SName = uplcToOutName' SDeBruijn SNamedDeBruijn - >=> uplcToOutName' SNamedDeBruijn SName +uplcToOutName' SName SDeBruijn = + uplcToOutName' SName SNamedDeBruijn + >=> uplcToOutName' SNamedDeBruijn SDeBruijn +uplcToOutName' SDeBruijn SName = + uplcToOutName' SDeBruijn SNamedDeBruijn + >=> uplcToOutName' SNamedDeBruijn SName uplcToOutName' _ _ = error "this is complete, but i don't want to use -fno-warn-incomplete-patterns" -- TODO: use better, more detailed erroring -throwingPIR :: (MonadError (PIR.Error uni fun a) m) - => Text -> b -> m c +throwingPIR :: + MonadError (PIR.Error uni fun a) m => + Text -> b -> m c throwingPIR = const . throwError . PIR.OptionsError -checkProgram :: (e ~ PIR.Provenance (FromAnn (US_ann s)), - MonadError (PIR.Error DefaultUni DefaultFun e) m) - => SLang s - -> FromLang s - -> m () +checkProgram :: + ( e ~ PIR.Provenance (FromAnn (US_ann s)) + , MonadError (PIR.Error DefaultUni DefaultFun e) m + ) => + SLang s -> + FromLang s -> + m () checkProgram sng p = modifyError (fmap PIR.Original) $ case sng of - SPlc n a -> plcTypecheck n a p - SUplc n a -> modifyError PIR.PLCError $ uplcTypecheck n a p - SPir SName a -> pirTypecheck a p - SData -> pure () -- data is type correct by construction - SPir{} -> throwingPIR "PIR: Cannot typecheck non-names" () + SPlc n a -> plcTypecheck n a p + SUplc n a -> modifyError PIR.PLCError $ uplcTypecheck n a p + SPir SName a -> pirTypecheck a p + SData -> pure () -- data is type correct by construction + SPir {} -> throwingPIR "PIR: Cannot typecheck non-names" () instance AnnInline SrcSpans where annAlwaysInline = mempty diff --git a/plutus-core/executables/plutus/AnyProgram/Debug.hs b/plutus-core/executables/plutus/AnyProgram/Debug.hs index 36fd7fdd961..37e12be18a0 100644 --- a/plutus-core/executables/plutus/AnyProgram/Debug.hs +++ b/plutus-core/executables/plutus/AnyProgram/Debug.hs @@ -1,8 +1,9 @@ {-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -module AnyProgram.Debug - ( runDebug - ) where +{-# LANGUAGE LambdaCase #-} + +module AnyProgram.Debug ( + runDebug, +) where import Common import Debugger.TUI.Main qualified @@ -10,8 +11,9 @@ import GetOpt import Types import UntypedPlutusCore as UPLC -runDebug :: (?opts :: Opts) - => SLang s -> FromLang s -> IO () -runDebug = \case - SUplc sn sa -> Debugger.TUI.Main.main sn sa . UPLC.unUnrestrictedProgram - _ -> const $ failE "Debugging pir/tplc program is not available." +runDebug :: + (?opts :: Opts) => + SLang s -> FromLang s -> IO () +runDebug = \case + SUplc sn sa -> Debugger.TUI.Main.main sn sa . UPLC.unUnrestrictedProgram + _ -> const $ failE "Debugging pir/tplc program is not available." diff --git a/plutus-core/executables/plutus/AnyProgram/Example.hs b/plutus-core/executables/plutus/AnyProgram/Example.hs index 6e62ad88449..e1045e3b07a 100644 --- a/plutus-core/executables/plutus/AnyProgram/Example.hs +++ b/plutus-core/executables/plutus/AnyProgram/Example.hs @@ -1,8 +1,9 @@ {-# LANGUAGE ImpredicativeTypes #-} -module AnyProgram.Example - ( termExamples - , typeExamples - ) where + +module AnyProgram.Example ( + termExamples, + typeExamples, +) where import Types @@ -18,24 +19,25 @@ import PlutusCore.StdLib.Data.Unit qualified as StdLib -- TODO: generalize annotation after removal of Provenance -- TODO: had to constrain it to Name&TyName, use sth like plcViaName to overcome this -termExamples :: [( ExampleName - , forall term. (TermLike term PLC.TyName PLC.Name DefaultUni DefaultFun) => term () - )] +termExamples :: + [ ( ExampleName + , forall term. TermLike term PLC.TyName PLC.Name DefaultUni DefaultFun => term () + ) + ] termExamples = - [ ("succInteger", StdLib.succInteger) - , ("unitval", StdLib.unitval) - , ("true", StdLib.true) - , ("false", StdLib.false) - , ("churchZero", StdLib.churchZero) - , ("churchSucc", StdLib.churchSucc) - ] + [ ("succInteger", StdLib.succInteger) + , ("unitval", StdLib.unitval) + , ("true", StdLib.true) + , ("false", StdLib.false) + , ("churchZero", StdLib.churchZero) + , ("churchSucc", StdLib.churchSucc) + ] -- TODO: generalize annotation after removal of Provenance -- TODO: had to constrain it to TyName, use sth like plcViaName to overcome this typeExamples :: [(ExampleName, PLC.Type PLC.TyName DefaultUni ())] typeExamples = - [ ("unit", StdLib.unit) - , ("churchNat", StdLib.churchNat) - , ("bool", StdLib.bool) - ] - + [ ("unit", StdLib.unit) + , ("churchNat", StdLib.churchNat) + , ("bool", StdLib.bool) + ] diff --git a/plutus-core/executables/plutus/AnyProgram/IO.hs b/plutus-core/executables/plutus/AnyProgram/IO.hs index 0519b22f238..94ee2aa779f 100644 --- a/plutus-core/executables/plutus/AnyProgram/IO.hs +++ b/plutus-core/executables/plutus/AnyProgram/IO.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module AnyProgram.IO - ( readProgram - , writeProgram - , prettyWithStyle - ) where + +module AnyProgram.IO ( + readProgram, + writeProgram, + prettyWithStyle, +) where import AnyProgram.Parse import AnyProgram.With @@ -28,88 +29,95 @@ import Prettyprinter import Prettyprinter.Render.Text import System.IO -readProgram :: (?opts :: Opts) - => SLang s -> File s -> IO (FromLang s) +readProgram :: + (?opts :: Opts) => + SLang s -> File s -> IO (FromLang s) readProgram sngS fileS = - case fileS^.fName of - Just (Example _eName) -> - error "FIXME: Not implemented yet." - -- case sngS of - -- SPir SName SUnit -> - -- case lookup eName termExamples of - -- Just ast -> pure $ PIR.Program () undefined ast - -- Nothing -> error $ "Couldn't find example with name " ++ eName - _ -> case fileS^.fType.fFormat of - Text -> do - bs <- readFileName (fromJust $ fileS^.fName) - case parseProgram sngS $ T.decodeUtf8Lenient bs of - Left err -> failE $ show err - Right res -> pure res - Flat_ -> withLang @Flat sngS $ do - bs <- readFileName (fromJust $ fileS^.fName) - case unflat bs of - Left err -> failE $ show err - Right res -> pure res - Cbor -> do - bs <- readFileName (fromJust $ fileS^.fName) - -- TODO: deduplicate - case sngS %~ SData of - Proved Refl -> - case deserialiseOrFail $ BSL.fromStrict bs of - Left err -> failE $ show err - Right res -> pure res - _ -> withLang @Flat sngS $ - -- this is a cbor-embedded bytestring of the Flat encoding - -- so we use the SerialiseViaFlat newtype wrapper. - case deserialiseOrFail $ BSL.fromStrict bs of - Left err -> failE $ show err - Right (SerialiseViaFlat res) -> pure res - Json -> error "FIXME: not implemented yet." + case fileS ^. fName of + Just (Example _eName) -> + error "FIXME: Not implemented yet." + -- case sngS of + -- SPir SName SUnit -> + -- case lookup eName termExamples of + -- Just ast -> pure $ PIR.Program () undefined ast + -- Nothing -> error $ "Couldn't find example with name " ++ eName + _ -> case fileS ^. fType . fFormat of + Text -> do + bs <- readFileName (fromJust $ fileS ^. fName) + case parseProgram sngS $ T.decodeUtf8Lenient bs of + Left err -> failE $ show err + Right res -> pure res + Flat_ -> withLang @Flat sngS $ do + bs <- readFileName (fromJust $ fileS ^. fName) + case unflat bs of + Left err -> failE $ show err + Right res -> pure res + Cbor -> do + bs <- readFileName (fromJust $ fileS ^. fName) + -- TODO: deduplicate + case sngS %~ SData of + Proved Refl -> + case deserialiseOrFail $ BSL.fromStrict bs of + Left err -> failE $ show err + Right res -> pure res + _ -> withLang @Flat sngS $ + -- this is a cbor-embedded bytestring of the Flat encoding + -- so we use the SerialiseViaFlat newtype wrapper. + case deserialiseOrFail $ BSL.fromStrict bs of + Left err -> failE $ show err + Right (SerialiseViaFlat res) -> pure res + Json -> error "FIXME: not implemented yet." -writeProgram :: (?opts :: Opts) - => SLang s -> FromLang s -> File s -> AfterCompile -> IO () +writeProgram :: + (?opts :: Opts) => + SLang s -> FromLang s -> File s -> AfterCompile -> IO () writeProgram sng ast file afterCompile = - case file^.fName of - Just fn -> do - printED $ show $ "Outputting" <+> pretty file - case file^.fType.fFormat of - Flat_ -> writeFileName fn $ withLang @Flat sng $ flat ast - Text -> writeFileName fn - $ T.encodeUtf8 - $ renderStrict - $ layoutPretty defaultLayoutOptions - $ withPrettyPlcL sng - $ prettyWithStyle (_prettyStyle ?opts) ast - Cbor -> writeFileName fn $ BSL.toStrict $ - case sng %~ SData of - Proved Refl -> serialise ast - _ -> withLang @Flat sng $ serialise (SerialiseViaFlat ast) - Json -> error "FIXME: not implemented yet" - _ -> case afterCompile of - Exit -> printE - "Compilation succeeded, but no output file was written; use -o or --stdout." - _ -> pure () + case file ^. fName of + Just fn -> do + printED $ show $ "Outputting" <+> pretty file + case file ^. fType . fFormat of + Flat_ -> writeFileName fn $ withLang @Flat sng $ flat ast + Text -> + writeFileName fn $ + T.encodeUtf8 $ + renderStrict $ + layoutPretty defaultLayoutOptions $ + withPrettyPlcL sng $ + prettyWithStyle (_prettyStyle ?opts) ast + Cbor -> writeFileName fn $ + BSL.toStrict $ + case sng %~ SData of + Proved Refl -> serialise ast + _ -> withLang @Flat sng $ serialise (SerialiseViaFlat ast) + Json -> error "FIXME: not implemented yet" + _ -> case afterCompile of + Exit -> + printE + "Compilation succeeded, but no output file was written; use -o or --stdout." + _ -> pure () prettyWithStyle :: PP.PrettyPlc a => PrettyStyle -> a -> Doc ann prettyWithStyle = \case - Classic -> PP.prettyPlcClassic - ClassicSimple -> PP.prettyPlcClassicSimple - Readable -> PP.prettyPlcReadable - ReadableSimple -> PP.prettyPlcReadableSimple + Classic -> PP.prettyPlcClassic + ClassicSimple -> PP.prettyPlcClassicSimple + Readable -> PP.prettyPlcReadable + ReadableSimple -> PP.prettyPlcReadableSimple -readFileName :: (?opts :: Opts) - => FileName -> IO BS.ByteString +readFileName :: + (?opts :: Opts) => + FileName -> IO BS.ByteString readFileName = \case - StdOut -> failE "should not happen" - StdIn -> BS.hGetContents stdin - AbsolutePath fp -> BS.readFile fp - -- TODO: it needs some restructuring in Types, Example is not a FileName and cannot be IO-read - Example{} -> failE "should not happen" + StdOut -> failE "should not happen" + StdIn -> BS.hGetContents stdin + AbsolutePath fp -> BS.readFile fp + -- TODO: it needs some restructuring in Types, Example is not a FileName and cannot be IO-read + Example {} -> failE "should not happen" -writeFileName :: (?opts :: Opts) - => FileName -> BS.ByteString -> IO () +writeFileName :: + (?opts :: Opts) => + FileName -> BS.ByteString -> IO () writeFileName fn bs = case fn of - StdIn -> failE "should not happen" - Example{} -> failE "should not happen" - StdOut -> BS.hPutStr stdout bs - AbsolutePath fp -> BS.writeFile fp bs + StdIn -> failE "should not happen" + Example {} -> failE "should not happen" + StdOut -> BS.hPutStr stdout bs + AbsolutePath fp -> BS.writeFile fp bs diff --git a/plutus-core/executables/plutus/AnyProgram/Parse.hs b/plutus-core/executables/plutus/AnyProgram/Parse.hs index b84c8ad0233..c73688ccb75 100644 --- a/plutus-core/executables/plutus/AnyProgram/Parse.hs +++ b/plutus-core/executables/plutus/AnyProgram/Parse.hs @@ -1,6 +1,6 @@ -module AnyProgram.Parse - ( parseProgram - ) where +module AnyProgram.Parse ( + parseProgram, +) where import PlutusPrelude hiding ((%~)) import Types @@ -22,24 +22,23 @@ import PlutusCore.Data -- -- This could alternatively be achieved by -- using a "Parsable" typeclass + withL @Parsable hasomorphism -parseProgram :: (MonadError ParserErrorBundle m) - => SLang n -> T.Text -> m (FromLang n) +parseProgram :: + MonadError ParserErrorBundle m => + SLang n -> T.Text -> m (FromLang n) parseProgram s txt = PLC.runQuoteT $ - case s of - SData{} -> pure $ read @Data $ T.unpack txt - _ -> case _snaming s %~ SName of - Proved Refl -> case _sann s of - STxSrcSpans -> error "Parsing TxSrcSpans is not available." - SUnit -> - case s of - SPir{} -> void <$> PIR.parseProgram txt - SPlc{} -> void <$> PLC.parseProgram txt - SUplc{} -> UPLC.UnrestrictedProgram . void <$> UPLC.parseProgram txt - -- SSrcSpan_ -> - -- case s of - -- SPir{} -> PIR.parseProgram txt - -- SPlc{} -> PLC.parseProgram txt - -- SUplc{} -> UPLC.UnrestrictedProgram <$> UPLC.parseProgram txt - _ -> error "Parsing (named-)debruijn program is not available." - - + case s of + SData {} -> pure $ read @Data $ T.unpack txt + _ -> case _snaming s %~ SName of + Proved Refl -> case _sann s of + STxSrcSpans -> error "Parsing TxSrcSpans is not available." + SUnit -> + case s of + SPir {} -> void <$> PIR.parseProgram txt + SPlc {} -> void <$> PLC.parseProgram txt + SUplc {} -> UPLC.UnrestrictedProgram . void <$> UPLC.parseProgram txt + -- SSrcSpan_ -> + -- case s of + -- SPir{} -> PIR.parseProgram txt + -- SPlc{} -> PLC.parseProgram txt + -- SUplc{} -> UPLC.UnrestrictedProgram <$> UPLC.parseProgram txt + _ -> error "Parsing (named-)debruijn program is not available." diff --git a/plutus-core/executables/plutus/AnyProgram/Run.hs b/plutus-core/executables/plutus/AnyProgram/Run.hs index f9c4ece523d..c6f89d20749 100644 --- a/plutus-core/executables/plutus/AnyProgram/Run.hs +++ b/plutus-core/executables/plutus/AnyProgram/Run.hs @@ -1,8 +1,9 @@ {-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -module AnyProgram.Run - ( runRun - ) where +{-# LANGUAGE LambdaCase #-} + +module AnyProgram.Run ( + runRun, +) where import AnyProgram.Compile import AnyProgram.IO @@ -20,72 +21,74 @@ import Types import UntypedPlutusCore as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek as UPLC -runRun :: (?opts :: Opts) - => SLang s -> FromLang s -> IO () +runRun :: + (?opts :: Opts) => + SLang s -> FromLang s -> IO () runRun = \case - SPlc sN _ -> plcToOutName sN SName - -- TODO: use proper errors, not unsafeFromRight - >>> unsafeFromRight @FreeVariableError - >>> runPlc - - SUplc sN sA -> withA @Typeable sA $ - uplcToOutName sN SNamedDeBruijn - -- TODO: use proper errors, not unsafeFromRight - >>> unsafeFromRight @FreeVariableError - >>> runUplc - - -- we could compile pir further to plc and run that, but it feels "dishonest". - SPir{} -> const $ failE "Cannot run a pir program." - SData{} -> const $ failE "Cannot run data as a program." - + SPlc sN _ -> + plcToOutName sN SName + -- TODO: use proper errors, not unsafeFromRight + >>> unsafeFromRight @FreeVariableError + >>> runPlc + SUplc sN sA -> + withA @Typeable sA $ + uplcToOutName sN SNamedDeBruijn + -- TODO: use proper errors, not unsafeFromRight + >>> unsafeFromRight @FreeVariableError + >>> runUplc + -- we could compile pir further to plc and run that, but it feels "dishonest". + SPir {} -> const $ failE "Cannot run a pir program." + SData {} -> const $ failE "Cannot run data as a program." -- TODO: add a semantic variant here to get the right machine parameters -runPlc :: (?opts :: Opts) - => PLC.Program TyName Name DefaultUni DefaultFun a -> IO () +runPlc :: + (?opts :: Opts) => + PLC.Program TyName Name DefaultUni DefaultFun a -> IO () runPlc (PLC.Program _ _ t) - | Nothing <- _budget ?opts = + | Nothing <- _budget ?opts = -- CK machine currently only works with ann==() , so we void before case PLC.runCk defaultBuiltinsRuntimeForTesting def False (void t) of (Left errorWithCause, logs) -> do - for_ logs (printE . unpack) - failE $ show errorWithCause + for_ logs (printE . unpack) + failE $ show errorWithCause (Right finalTerm, logs) -> do - for_ logs (printE . unpack) - printE "Execution succeeded. Final Term:" - -- TODO: lift the final term back to the target singleton - printE "Execution succeeded. Final Term:" - printE $ show $ prettyWithStyle (_prettyStyle ?opts) finalTerm - | otherwise = failE "Budget limiting/accounting is not possible for TPLC." + for_ logs (printE . unpack) + printE "Execution succeeded. Final Term:" + -- TODO: lift the final term back to the target singleton + printE "Execution succeeded. Final Term:" + printE $ show $ prettyWithStyle (_prettyStyle ?opts) finalTerm + | otherwise = failE "Budget limiting/accounting is not possible for TPLC." -- TODO: add a semantic variant here to get the right machine parameters -runUplc :: (?opts :: Opts, Typeable a) - => UPLC.UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun a -> IO () +runUplc :: + (?opts :: Opts, Typeable a) => + UPLC.UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun a -> IO () runUplc (UPLC.UnrestrictedProgram (UPLC.Program _ _ t)) = - case (\(UPLC.CekReport res cost logs) -> (UPLC.cekResultToEither res, cost, logs)) $ - UPLC.runCekDeBruijn defaultCekParametersForTesting exBudgetMode logEmitter t of - (Left errorWithCause, _, logs) -> do - for_ logs (printE . unpack) - failE $ show errorWithCause - (Right finalTerm, finalBudget, logs) -> do - for_ logs (printE . unpack) - -- TODO: lift the final term back to the target singleton - printE "Execution succeeded. Final Term:" - printE $ show $ prettyWithStyle (_prettyStyle ?opts) finalTerm - case _budget ?opts of - Nothing -> printE $ "Used budget: " <> show finalBudget - Just startBudget -> do - printE $ "Remaining budget: " <> show finalBudget - printE $ "Used budget: " <> show (startBudget `minusExBudget` finalBudget) - - where - -- if user provided `--budget` the mode is restricting; otherwise just counting - exBudgetMode = case _budget ?opts of - Just budgetLimit -> coerceMode $ restricting $ ExRestrictingBudget budgetLimit - _ -> coerceMode counting + case (\(UPLC.CekReport res cost logs) -> (UPLC.cekResultToEither res, cost, logs)) $ + UPLC.runCekDeBruijn defaultCekParametersForTesting exBudgetMode logEmitter t of + (Left errorWithCause, _, logs) -> do + for_ logs (printE . unpack) + failE $ show errorWithCause + (Right finalTerm, finalBudget, logs) -> do + for_ logs (printE . unpack) + -- TODO: lift the final term back to the target singleton + printE "Execution succeeded. Final Term:" + printE $ show $ prettyWithStyle (_prettyStyle ?opts) finalTerm + case _budget ?opts of + Nothing -> printE $ "Used budget: " <> show finalBudget + Just startBudget -> do + printE $ "Remaining budget: " <> show finalBudget + printE $ "Used budget: " <> show (startBudget `minusExBudget` finalBudget) + where + -- if user provided `--budget` the mode is restricting; otherwise just counting + exBudgetMode = case _budget ?opts of + Just budgetLimit -> coerceMode $ restricting $ ExRestrictingBudget budgetLimit + _ -> coerceMode counting - -- this gets rid of the CountingSt/RestrictingSt newtype wrappers - -- See Note [Budgeting implementation for the debugger] - coerceMode :: Coercible cost ExBudget - => ExBudgetMode cost DefaultUni DefaultFun - -> ExBudgetMode ExBudget DefaultUni DefaultFun - coerceMode = coerce + -- this gets rid of the CountingSt/RestrictingSt newtype wrappers + -- See Note [Budgeting implementation for the debugger] + coerceMode :: + Coercible cost ExBudget => + ExBudgetMode cost DefaultUni DefaultFun -> + ExBudgetMode ExBudget DefaultUni DefaultFun + coerceMode = coerce diff --git a/plutus-core/executables/plutus/AnyProgram/With.hs b/plutus-core/executables/plutus/AnyProgram/With.hs index 2917051d1b5..ae5c54ae099 100644 --- a/plutus-core/executables/plutus/AnyProgram/With.hs +++ b/plutus-core/executables/plutus/AnyProgram/With.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-orphans #-} + -- | BOILERPLATE needed to support Hasochism. -- See module AnyProgram.With where @@ -25,107 +26,123 @@ import Types -- for: (typeclass `compose` type) type ComposeC :: forall a b. (b -> Constraint) -> (a -> b) -> a -> Constraint -class constr (f x) => ComposeC constr f x +class constr (f x) => ComposeC constr f x instance constr (f x) => ComposeC constr f x type UnitC :: forall a. a -> Constraint -class UnitC x +class UnitC x instance UnitC x type AndC :: forall a. (a -> Constraint) -> (a -> Constraint) -> a -> Constraint -class (constr1 x, constr2 x) => AndC constr1 constr2 x +class (constr1 x, constr2 x) => AndC constr1 constr2 x instance (constr1 x, constr2 x) => AndC constr1 constr2 x -withN :: forall constr s r - . ( constr (FromName 'Name) - , constr (FromName 'DeBruijn) - , constr (FromName 'NamedDeBruijn) - ) - => SNaming s -> ((constr (FromName s)) => r) -> r +withN :: + forall constr s r. + ( constr (FromName 'Name) + , constr (FromName 'DeBruijn) + , constr (FromName 'NamedDeBruijn) + ) => + SNaming s -> (constr (FromName s) => r) -> r withN s r = case s of - SName -> r - SDeBruijn -> r - SNamedDeBruijn -> r + SName -> r + SDeBruijn -> r + SNamedDeBruijn -> r -withNT :: forall constr s r - . ( constr (FromNameTy 'Name) - , constr (FromNameTy 'DeBruijn) - , constr (FromNameTy 'NamedDeBruijn) - ) - => SNaming s -> ((constr (FromNameTy s)) => r) -> r +withNT :: + forall constr s r. + ( constr (FromNameTy 'Name) + , constr (FromNameTy 'DeBruijn) + , constr (FromNameTy 'NamedDeBruijn) + ) => + SNaming s -> (constr (FromNameTy s) => r) -> r withNT s r = case s of - SName -> r - SDeBruijn -> r - SNamedDeBruijn -> r + SName -> r + SDeBruijn -> r + SNamedDeBruijn -> r -withA :: forall constr s r - . (constr (FromAnn 'Unit), constr (FromAnn 'TxSrcSpans)) - => SAnn s -> ((constr (FromAnn s)) => r) -> r +withA :: + forall constr s r. + (constr (FromAnn 'Unit), constr (FromAnn 'TxSrcSpans)) => + SAnn s -> (constr (FromAnn s) => r) -> r withA s r = case s of - SUnit -> r - STxSrcSpans -> r + SUnit -> r + STxSrcSpans -> r -withLangGeneral - :: forall constrTyName constrBinder constrName constrAnn constr s r. - ( constrTyName (FromNameTy 'Name) - , constrTyName (FromNameTy 'DeBruijn) - , constrTyName (FromNameTy 'NamedDeBruijn) - , constrBinder (UPLC.Binder UPLC.Name) - , constrBinder (UPLC.Binder UPLC.DeBruijn) - , constrBinder (UPLC.Binder UPLC.NamedDeBruijn) - , constrName (FromName 'Name) - , constrName (FromName 'DeBruijn) - , constrName (FromName 'NamedDeBruijn) - , constrAnn (FromAnn 'Unit) - , constrAnn (FromAnn 'TxSrcSpans) - , (forall tyname name ann. (constrTyName tyname, constrName name, constrAnn ann) => - constr (PIR.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann)) - , (forall tyname name ann. (constrTyName tyname, constrName name, constrAnn ann) => - constr (PLC.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann)) - , (forall name ann. (constrBinder (UPLC.Binder name), constrName name, constrAnn ann) => - constr (UPLC.UnrestrictedProgram name UPLC.DefaultUni UPLC.DefaultFun ann)) - ) - => SLang s -> (constr (FromLang s) => r) -> r +withLangGeneral :: + forall constrTyName constrBinder constrName constrAnn constr s r. + ( constrTyName (FromNameTy 'Name) + , constrTyName (FromNameTy 'DeBruijn) + , constrTyName (FromNameTy 'NamedDeBruijn) + , constrBinder (UPLC.Binder UPLC.Name) + , constrBinder (UPLC.Binder UPLC.DeBruijn) + , constrBinder (UPLC.Binder UPLC.NamedDeBruijn) + , constrName (FromName 'Name) + , constrName (FromName 'DeBruijn) + , constrName (FromName 'NamedDeBruijn) + , constrAnn (FromAnn 'Unit) + , constrAnn (FromAnn 'TxSrcSpans) + , ( forall tyname name ann. + (constrTyName tyname, constrName name, constrAnn ann) => + constr (PIR.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann) + ) + , ( forall tyname name ann. + (constrTyName tyname, constrName name, constrAnn ann) => + constr (PLC.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann) + ) + , ( forall name ann. + (constrBinder (UPLC.Binder name), constrName name, constrAnn ann) => + constr (UPLC.UnrestrictedProgram name UPLC.DefaultUni UPLC.DefaultFun ann) + ) + ) => + SLang s -> (constr (FromLang s) => r) -> r withLangGeneral s r = case s of - SPir sname sann -> - withNT @constrTyName sname - $ withN @constrName sname - $ withA @constrAnn sann r - SPlc sname sann -> - withNT @constrTyName sname - $ withN @constrName sname - $ withA @constrAnn sann r - SUplc sname sann -> - withN @(ComposeC constrBinder UPLC.Binder) sname - $ withN @constrName sname - $ withA @constrAnn sann r - SData -> error "not implemented yet" + SPir sname sann -> + withNT @constrTyName sname $ + withN @constrName sname $ + withA @constrAnn sann r + SPlc sname sann -> + withNT @constrTyName sname $ + withN @constrName sname $ + withA @constrAnn sann r + SUplc sname sann -> + withN @(ComposeC constrBinder UPLC.Binder) sname $ + withN @constrName sname $ + withA @constrAnn sann r + SData -> error "not implemented yet" -withLang - :: forall constr s r. - ( constr (FromNameTy 'Name) - , constr (FromNameTy 'DeBruijn) - , constr (FromNameTy 'NamedDeBruijn) - , constr (UPLC.Binder UPLC.Name) - , constr (UPLC.Binder UPLC.DeBruijn) - , constr (UPLC.Binder UPLC.NamedDeBruijn) - , constr (FromName 'Name) - , constr (FromName 'DeBruijn) - , constr (FromName 'NamedDeBruijn) - , constr (FromAnn 'Unit) - , constr (FromAnn 'TxSrcSpans) - , (forall tyname name ann. (constr tyname, constr name, constr ann) => - constr (PIR.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann)) - , (forall tyname name ann. (constr tyname, constr name, constr ann) => - constr (PLC.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann)) - , (forall name ann. (constr (UPLC.Binder name), constr name, constr ann) => - constr (UPLC.UnrestrictedProgram name UPLC.DefaultUni UPLC.DefaultFun ann)) - ) - => SLang s -> (constr (FromLang s) => r) -> r +withLang :: + forall constr s r. + ( constr (FromNameTy 'Name) + , constr (FromNameTy 'DeBruijn) + , constr (FromNameTy 'NamedDeBruijn) + , constr (UPLC.Binder UPLC.Name) + , constr (UPLC.Binder UPLC.DeBruijn) + , constr (UPLC.Binder UPLC.NamedDeBruijn) + , constr (FromName 'Name) + , constr (FromName 'DeBruijn) + , constr (FromName 'NamedDeBruijn) + , constr (FromAnn 'Unit) + , constr (FromAnn 'TxSrcSpans) + , ( forall tyname name ann. + (constr tyname, constr name, constr ann) => + constr (PIR.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann) + ) + , ( forall tyname name ann. + (constr tyname, constr name, constr ann) => + constr (PLC.Program tyname name UPLC.DefaultUni UPLC.DefaultFun ann) + ) + , ( forall name ann. + (constr (UPLC.Binder name), constr name, constr ann) => + constr (UPLC.UnrestrictedProgram name UPLC.DefaultUni UPLC.DefaultFun ann) + ) + ) => + SLang s -> (constr (FromLang s) => r) -> r withLang = withLangGeneral @constr @constr @constr @constr @constr withPrettyPlcL :: forall s r. SLang s -> (PrettyPlc (FromLang s) => r) -> r -withPrettyPlcL = withLangGeneral +withPrettyPlcL = + withLangGeneral @(PrettyClassic `AndC` PrettyReadable) @UnitC @(PrettyClassic `AndC` PrettyReadable) diff --git a/plutus-core/executables/plutus/Common.hs b/plutus-core/executables/plutus/Common.hs index 86970f6a1a1..701d151e7f1 100644 --- a/plutus-core/executables/plutus/Common.hs +++ b/plutus-core/executables/plutus/Common.hs @@ -1,9 +1,10 @@ {-# LANGUAGE ImplicitParams #-} -module Common - ( printE - , printED - , failE - ) where + +module Common ( + printE, + printED, + failE, +) where import GetOpt import Types @@ -12,17 +13,20 @@ import Control.Monad import System.Exit import System.IO -printE :: (?opts :: Opts) - => String -> IO () +printE :: + (?opts :: Opts) => + String -> IO () printE = when (_verbosity ?opts /= VQuiet) . hPutStrLn stderr -printED :: (?opts :: Opts) - => String -> IO () +printED :: + (?opts :: Opts) => + String -> IO () printED = when (_verbosity ?opts == VDebug) . hPutStrLn stderr -- similar to fail , just no wrap it with the text "user error" -failE :: (?opts :: Opts) - => String -> IO b +failE :: + (?opts :: Opts) => + String -> IO b failE a = do - printE a - exitFailure + printE a + exitFailure diff --git a/plutus-core/executables/plutus/Debugger/TUI/Draw.hs b/plutus-core/executables/plutus/Debugger/TUI/Draw.hs index 8aac8579a25..5b4f87e9991 100644 --- a/plutus-core/executables/plutus/Debugger/TUI/Draw.hs +++ b/plutus-core/executables/plutus/Debugger/TUI/Draw.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + -- | Renders the debugger in the terminal. module Debugger.TUI.Draw where @@ -21,115 +22,119 @@ import Lens.Micro import Prettyprinter hiding (line) drawDebugger :: - DebuggerState -> - [B.Widget ResourceName] + DebuggerState -> + [B.Widget ResourceName] drawDebugger st = - withKeyBindingsOverlay - (st ^. dsKeyBindingsMode) - [header "Plutus Core Debugger" $ BC.center ui] + withKeyBindingsOverlay + (st ^. dsKeyBindingsMode) + [header "Plutus Core Debugger" $ BC.center ui] where focusRing = st ^. dsFocusRing (curLine, curCol) = BE.getCursorPosition (st ^. dsUplcEditor) cursorPos = "Ln " <> show (curLine + 1) <> ", Col " <> show (curCol + 1) uplcEditor = - BB.borderWithLabel (B.txt "UPLC program") $ - B.vBox - [ B.withFocusRing - focusRing - (BE.renderEditor (drawDocumentWithHighlight (st ^. dsUplcHighlight))) - (st ^. dsUplcEditor) - , B.padTop (B.Pad 1) . BC.hCenter $ B.str cursorPos - ] - sourceEditor = maybe B.emptyWidget - (BB.borderWithLabel (B.txt "Source program") . - B.withFocusRing - focusRing - (BE.renderEditor (drawDocumentWithHighlight (st ^. dsSourceHighlight))) - ) (st ^. dsSourceEditor) + BB.borderWithLabel (B.txt "UPLC program") $ + B.vBox + [ B.withFocusRing + focusRing + (BE.renderEditor (drawDocumentWithHighlight (st ^. dsUplcHighlight))) + (st ^. dsUplcEditor) + , B.padTop (B.Pad 1) . BC.hCenter $ B.str cursorPos + ] + sourceEditor = + maybe + B.emptyWidget + ( BB.borderWithLabel (B.txt "Source program") + . B.withFocusRing + focusRing + (BE.renderEditor (drawDocumentWithHighlight (st ^. dsSourceHighlight))) + ) + (st ^. dsSourceEditor) returnValueEditor = - BB.borderWithLabel (B.txt "UPLC value being returned") $ - B.withFocusRing - focusRing - (BE.renderEditor (B.txt . Text.unlines)) - (st ^. dsReturnValueEditor) + BB.borderWithLabel (B.txt "UPLC value being returned") $ + B.withFocusRing + focusRing + (BE.renderEditor (B.txt . Text.unlines)) + (st ^. dsReturnValueEditor) logsEditor = - BB.borderWithLabel (B.txt "Logs") $ - B.withFocusRing - focusRing - (BE.renderEditor (B.txt . Text.unlines)) - (st ^. dsLogsEditor) - budgetTxt = B.hBox + BB.borderWithLabel (B.txt "Logs") $ + B.withFocusRing + focusRing + (BE.renderEditor (B.txt . Text.unlines)) + (st ^. dsLogsEditor) + budgetTxt = + B.hBox [ prettyTxt "Spent:" (st ^. dsBudgetData . budgetSpent) - -- do not show Remaining in absence of `--budget` - , maybe B.emptyWidget (prettyTxt "Remaining:") (st ^. dsBudgetData . budgetRemaining) + , -- do not show Remaining in absence of `--budget` + maybe B.emptyWidget (prettyTxt "Remaining:") (st ^. dsBudgetData . budgetRemaining) ] prettyTxt title = B.txt . render . group . (title <>) . pretty ui = - B.vBox - [ BC.center uplcEditor B.<+> B.hLimit (st ^. dsHLimitRightEditors) sourceEditor - , B.vLimit (st ^. dsVLimitBottomEditors) $ - BC.center returnValueEditor B.<+> - B.hLimit (st ^. dsHLimitRightEditors) logsEditor - , budgetTxt - , footer - ] + B.vBox + [ BC.center uplcEditor B.<+> B.hLimit (st ^. dsHLimitRightEditors) sourceEditor + , B.vLimit (st ^. dsVLimitBottomEditors) $ + BC.center returnValueEditor + B.<+> B.hLimit (st ^. dsHLimitRightEditors) logsEditor + , budgetTxt + , footer + ] -- | Draw a document, a consecutive part of which may be highlighted. drawDocumentWithHighlight :: - forall n. - -- | The part of the document to be highlighted. - Maybe HighlightSpan -> - -- | The document to draw, one `Text` per line. - [Text] -> - B.Widget n + forall n. + -- | The part of the document to be highlighted. + Maybe HighlightSpan -> + -- | The document to draw, one `Text` per line. + [Text] -> + B.Widget n drawDocumentWithHighlight = \case - Nothing -> B.txt . Text.unlines - Just (HighlightSpan (B.Location (sLine, sCol)) eLoc) -> - let toWidgets :: [Text] -> [B.Widget n] - toWidgets lns = - let alg :: (Text, Int) -> B.Widget n - alg (line, lineNo) - | lineNo < sLine || lineNo > eLine = B.txt line - -- The current line (either entirely or part of it) needs to be highlighted. - | otherwise = - let s = - if lineNo > sLine - then 0 - else sCol - 1 - e = - if lineNo < eLine - then Text.length line - else eCol - in highlightLine line s e - where - B.Location (eLine, eCol) = - fromMaybe - (B.Location (sLine, Text.length line)) - eLoc - in fmap alg (zip lns [1 ..]) - in B.vBox - . toWidgets - -- This is needed for empty lines to be rendered correctly. - -- `Brick.Widgets.Core.txt` does the same via `fixEmpty`. - . fmap (\t -> if Text.null t then " " else t) + Nothing -> B.txt . Text.unlines + Just (HighlightSpan (B.Location (sLine, sCol)) eLoc) -> + let toWidgets :: [Text] -> [B.Widget n] + toWidgets lns = + let alg :: (Text, Int) -> B.Widget n + alg (line, lineNo) + | lineNo < sLine || lineNo > eLine = B.txt line + -- The current line (either entirely or part of it) needs to be highlighted. + | otherwise = + let s = + if lineNo > sLine + then 0 + else sCol - 1 + e = + if lineNo < eLine + then Text.length line + else eCol + in highlightLine line s e + where + B.Location (eLine, eCol) = + fromMaybe + (B.Location (sLine, Text.length line)) + eLoc + in fmap alg (zip lns [1 ..]) + in B.vBox + . toWidgets + -- This is needed for empty lines to be rendered correctly. + -- `Brick.Widgets.Core.txt` does the same via `fixEmpty`. + . fmap (\t -> if Text.null t then " " else t) -- | Draw a line and highlight from the start column to the end column. highlightLine :: - forall n. - Text -> - -- | Start column - Int -> - -- End column - Int -> - B.Widget n + forall n. + Text -> + -- | Start column + Int -> + -- End column + Int -> + B.Widget n highlightLine line s e = - B.hBox $ - [B.txt left | not (Text.null left)] - ++ [ B.withAttr highlightAttr $ B.txt middle - | not (Text.null middle) - ] - ++ [B.txt right | not (Text.null right)] + B.hBox $ + [B.txt left | not (Text.null left)] + ++ [ B.withAttr highlightAttr $ B.txt middle + | not (Text.null middle) + ] + ++ [B.txt right | not (Text.null right)] where -- left -> no highlight -- middle -> highlight @@ -138,25 +143,25 @@ highlightLine line s e = -- | Show key bindings upon request. withKeyBindingsOverlay :: - KeyBindingsMode -> - [B.Widget ResourceName] -> - [B.Widget ResourceName] + KeyBindingsMode -> + [B.Widget ResourceName] -> + [B.Widget ResourceName] withKeyBindingsOverlay = \case - KeyBindingsShown -> (BC.centerLayer debuggerKeyBindings :) - KeyBindingsHidden -> id + KeyBindingsShown -> (BC.centerLayer debuggerKeyBindings :) + KeyBindingsHidden -> id debuggerKeyBindings :: forall n. B.Widget n debuggerKeyBindings = - B.vBox - [ B.withAttr menuAttr . B.vBox $ - [ B.txt "Step (s)" - , B.txt "Move cursor (Arrow)" - , B.txt "Switch window (Tab)" - , B.txt "Resize windows (^Up/^Down/^Left/^Right)" - , B.txt "Quit (Esc)" - ] - , B.txt "Press any key to exit" + B.vBox + [ B.withAttr menuAttr . B.vBox $ + [ B.txt "Step (s)" + , B.txt "Move cursor (Arrow)" + , B.txt "Switch window (Tab)" + , B.txt "Resize windows (^Up/^Down/^Left/^Right)" + , B.txt "Quit (Esc)" ] + , B.txt "Press any key to exit" + ] menuAttr :: B.AttrName menuAttr = B.attrName "menu" @@ -166,9 +171,9 @@ highlightAttr = B.attrName "highlight" header :: Text -> B.Widget a -> B.Widget a header title = - (B.vLimit 1 (B.withAttr menuAttr . BC.hCenter $ B.txt title) B.<=>) + (B.vLimit 1 (B.withAttr menuAttr . BC.hCenter $ B.txt title) B.<=>) footer :: forall a. B.Widget a footer = - B.padTop (B.Pad 1) . BC.hCenter . B.withAttr menuAttr $ - B.txt "(?): Key Bindings" + B.padTop (B.Pad 1) . BC.hCenter . B.withAttr menuAttr $ + B.txt "(?): Key Bindings" diff --git a/plutus-core/executables/plutus/Debugger/TUI/Event.hs b/plutus-core/executables/plutus/Debugger/TUI/Event.hs index 7d848c9702d..ff8733da208 100644 --- a/plutus-core/executables/plutus/Debugger/TUI/Event.hs +++ b/plutus-core/executables/plutus/Debugger/TUI/Event.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + -- | Handler of debugger events. module Debugger.TUI.Event where @@ -16,6 +17,7 @@ import Brick.Focus qualified as B import Brick.Main qualified as B import Brick.Types qualified as B import Brick.Widgets.Edit qualified as BE + -- ghc>=9.6 has this in base #if ! MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -33,147 +35,161 @@ import Lens.Micro import Prettyprinter import System.FilePath -handleDebuggerEvent :: MVar (D.Cmd Breakpoints) - -> Maybe FilePath - -> B.BrickEvent ResourceName CustomBrickEvent - -> B.EventM ResourceName DebuggerState () +handleDebuggerEvent :: + MVar (D.Cmd Breakpoints) -> + Maybe FilePath -> + B.BrickEvent ResourceName CustomBrickEvent -> + B.EventM ResourceName DebuggerState () handleDebuggerEvent driverMailbox _ bev@(B.VtyEvent ev) = do - focusRing <- gets (^. dsFocusRing) - let handleEditorEvent = case B.focusGetCurrent focusRing of - Just EditorUplc -> - B.zoom dsUplcEditor $ BE.handleEditorEvent bev - Just EditorSource -> - B.zoom (dsSourceEditor.traversed) $ BE.handleEditorEvent bev - Just EditorReturnValue -> - B.zoom dsReturnValueEditor $ BE.handleEditorEvent bev - Just EditorLogs -> - B.zoom dsLogsEditor $ BE.handleEditorEvent bev - _ -> pure () - keyBindingsMode <- gets (^. dsKeyBindingsMode) - case ev of - Vty.EvKey{} - | KeyBindingsShown <- keyBindingsMode -> - modify' $ set dsKeyBindingsMode KeyBindingsHidden - Vty.EvKey (Vty.KChar '?') [] -> - modify' $ set dsKeyBindingsMode KeyBindingsShown - Vty.EvKey Vty.KEsc [] -> B.halt - Vty.EvKey (Vty.KChar 's') [] -> do - -- MAYBE: when not success we could have a dialog show up - -- saying that the debugger seems to be stuck - -- and an option to kill its thread (cek) and reload the program? - _success <- liftIO $ tryPutMVar driverMailbox D.Step - pure () - Vty.EvKey (Vty.KChar '\t') [] -> modify' $ \st -> - st & dsFocusRing %~ B.focusNext - Vty.EvKey Vty.KBackTab [] -> modify' $ \st -> - st & dsFocusRing %~ B.focusPrev - Vty.EvKey Vty.KUp [Vty.MCtrl] -> modify' $ \st -> - st & dsVLimitBottomEditors %~ (+ 1) - Vty.EvKey Vty.KDown [Vty.MCtrl] -> modify' $ \st -> - st & dsVLimitBottomEditors %~ (\x -> x - 1) - Vty.EvKey Vty.KLeft [Vty.MCtrl] -> modify' $ \st -> - st & dsHLimitRightEditors %~ (+ 1) - Vty.EvKey Vty.KRight [Vty.MCtrl] -> modify' $ \st -> - st & dsHLimitRightEditors %~ (\x -> x - 1) - Vty.EvKey Vty.KUp [] -> handleEditorEvent - Vty.EvKey Vty.KDown [] -> handleEditorEvent - Vty.EvKey Vty.KLeft [] -> handleEditorEvent - Vty.EvKey Vty.KRight [] -> handleEditorEvent - Vty.EvKey (Vty.KChar _) [] -> - -- This disables editing the text, making the editors read-only. - pure () - _ -> handleEditorEvent + focusRing <- gets (^. dsFocusRing) + let handleEditorEvent = case B.focusGetCurrent focusRing of + Just EditorUplc -> + B.zoom dsUplcEditor $ BE.handleEditorEvent bev + Just EditorSource -> + B.zoom (dsSourceEditor . traversed) $ BE.handleEditorEvent bev + Just EditorReturnValue -> + B.zoom dsReturnValueEditor $ BE.handleEditorEvent bev + Just EditorLogs -> + B.zoom dsLogsEditor $ BE.handleEditorEvent bev + _ -> pure () + keyBindingsMode <- gets (^. dsKeyBindingsMode) + case ev of + Vty.EvKey {} + | KeyBindingsShown <- keyBindingsMode -> + modify' $ set dsKeyBindingsMode KeyBindingsHidden + Vty.EvKey (Vty.KChar '?') [] -> + modify' $ set dsKeyBindingsMode KeyBindingsShown + Vty.EvKey Vty.KEsc [] -> B.halt + Vty.EvKey (Vty.KChar 's') [] -> do + -- MAYBE: when not success we could have a dialog show up + -- saying that the debugger seems to be stuck + -- and an option to kill its thread (cek) and reload the program? + _success <- liftIO $ tryPutMVar driverMailbox D.Step + pure () + Vty.EvKey (Vty.KChar '\t') [] -> modify' $ \st -> + st & dsFocusRing %~ B.focusNext + Vty.EvKey Vty.KBackTab [] -> modify' $ \st -> + st & dsFocusRing %~ B.focusPrev + Vty.EvKey Vty.KUp [Vty.MCtrl] -> modify' $ \st -> + st & dsVLimitBottomEditors %~ (+ 1) + Vty.EvKey Vty.KDown [Vty.MCtrl] -> modify' $ \st -> + st & dsVLimitBottomEditors %~ (\x -> x - 1) + Vty.EvKey Vty.KLeft [Vty.MCtrl] -> modify' $ \st -> + st & dsHLimitRightEditors %~ (+ 1) + Vty.EvKey Vty.KRight [Vty.MCtrl] -> modify' $ \st -> + st & dsHLimitRightEditors %~ (\x -> x - 1) + Vty.EvKey Vty.KUp [] -> handleEditorEvent + Vty.EvKey Vty.KDown [] -> handleEditorEvent + Vty.EvKey Vty.KLeft [] -> handleEditorEvent + Vty.EvKey Vty.KRight [] -> handleEditorEvent + Vty.EvKey (Vty.KChar _) [] -> + -- This disables editing the text, making the editors read-only. + pure () + _ -> handleEditorEvent handleDebuggerEvent _ hsDir (B.AppEvent (UpdateClientEvent budgetData cekState)) = do - let muplcHighlight :: Maybe HighlightSpan = do - uplcSpan <- uplcAnn <$> cekStateAnn cekState - pure HighlightSpan - { _hcSLoc = B.Location (srcSpanSLine uplcSpan, srcSpanSCol 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) - } - - - let msourceSrcSpan :: Maybe SrcSpan = do - txSpans <- txAnn <$> cekStateAnn cekState - -- FIXME: use some/all spans for highlighting, not just the first one - -- because now we arbitrary selected the first (in-order) srcsspan - firstTxSpan <- S.lookupMin $ coerce txSpans - pure firstTxSpan + let muplcHighlight :: Maybe HighlightSpan = do + uplcSpan <- uplcAnn <$> cekStateAnn cekState + pure + HighlightSpan + { _hcSLoc = B.Location (srcSpanSLine uplcSpan, srcSpanSCol 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) + } - let msourceHighlight :: Maybe HighlightSpan = do - sourceSrcSpan <- msourceSrcSpan - pure HighlightSpan - { _hcSLoc = B.Location ( srcSpanSLine sourceSrcSpan - , srcSpanSCol sourceSrcSpan - ), - -- GHC's SrcSpan's ending column is one larger than the last character's column. - -- See: ghc/compiler/GHC/Types/SrcLoc.hs#L728 - _hcELoc = Just $ B.Location ( srcSpanELine sourceSrcSpan - , srcSpanECol sourceSrcSpan -1 - ) - } - -- the current sourcespan may have jumped to another hs file, update the text of the editor - for_ (liftA2 () hsDir $ srcSpanFile <$> msourceSrcSpan) $ \file -> do - res <- liftIO $ Text.readFile file - -- putting modify directly in here has the upside (or downside) that - -- it keeps the old tx shown in the tx panel when we the jumped tx-sourcespan is empty - modify' $ \ st -> st & dsSourceEditor .~ - (BE.editorText - EditorSource - Nothing <$> Just res) - `catchAll` \ e -> - modify' $ appendToLogsEditor ("DEBUGGER ERROR:" <+> viaShow e) + let msourceSrcSpan :: Maybe SrcSpan = do + txSpans <- txAnn <$> cekStateAnn cekState + -- FIXME: use some/all spans for highlighting, not just the first one + -- because now we arbitrary selected the first (in-order) srcsspan + firstTxSpan <- S.lookupMin $ coerce txSpans + pure firstTxSpan + let msourceHighlight :: Maybe HighlightSpan = do + sourceSrcSpan <- msourceSrcSpan + pure + HighlightSpan + { _hcSLoc = + B.Location + ( srcSpanSLine sourceSrcSpan + , srcSpanSCol sourceSrcSpan + ) + , -- GHC's SrcSpan's ending column is one larger than the last character's column. + -- See: ghc/compiler/GHC/Types/SrcLoc.hs#L728 + _hcELoc = + Just $ + B.Location + ( srcSpanELine sourceSrcSpan + , srcSpanECol sourceSrcSpan - 1 + ) + } + -- the current sourcespan may have jumped to another hs file, update the text of the editor + for_ (liftA2 () hsDir $ srcSpanFile <$> msourceSrcSpan) $ \file -> + do + res <- liftIO $ Text.readFile file + -- putting modify directly in here has the upside (or downside) that + -- it keeps the old tx shown in the tx panel when we the jumped tx-sourcespan is empty + modify' $ \st -> + st + & dsSourceEditor + .~ ( BE.editorText + EditorSource + Nothing + <$> Just res + ) + `catchAll` \e -> + modify' $ appendToLogsEditor ("DEBUGGER ERROR:" <+> viaShow e) - modify' $ \st -> - st & set dsUplcHighlight muplcHighlight - & set dsSourceHighlight msourceHighlight - & set dsBudgetData budgetData - -- & dsSourceEditor .~ - -- (BE.editorText - -- EditorSource - -- Nothing <$> msourceText) - & case cekState of - Computing{} -> - -- Clear the return value editor. - dsReturnValueEditor .~ - BE.editorText - EditorReturnValue - Nothing - mempty - Returning _ v -> - dsReturnValueEditor .~ - BE.editorText - EditorReturnValue - Nothing - (PLC.displayPlc (dischargeCekValue v)) - Terminating t -> - dsReturnValueEditor .~ - BE.editorText - EditorReturnValue - Nothing - (PLC.render $ vcat ["Evaluation Finished. Result:", line, PLC.prettyPlc t]) - Starting{} -> id + modify' $ \st -> + st + & set dsUplcHighlight muplcHighlight + & set dsSourceHighlight msourceHighlight + & set dsBudgetData budgetData + -- & dsSourceEditor .~ + -- (BE.editorText + -- EditorSource + -- Nothing <$> msourceText) + & case cekState of + Computing {} -> + -- Clear the return value editor. + dsReturnValueEditor + .~ BE.editorText + EditorReturnValue + Nothing + mempty + Returning _ v -> + dsReturnValueEditor + .~ BE.editorText + EditorReturnValue + Nothing + (PLC.displayPlc (dischargeCekValue v)) + Terminating t -> + dsReturnValueEditor + .~ BE.editorText + EditorReturnValue + Nothing + (PLC.render $ vcat ["Evaluation Finished. Result:", line, PLC.prettyPlc t]) + Starting {} -> id handleDebuggerEvent _ _ (B.AppEvent (CekErrorEvent budgetData e)) = - modify' $ \st -> - -- Note that in case of an out-of-budget error (i.e. `CekOutOfExError`), - -- the updated budgets (spent&remaining) here do not match the actual budgets - -- on the chain: the difference is that on the chain, a budget may become zero (exhausted) - -- but is not allowed to become negative. - st & set dsBudgetData budgetData - & appendToLogsEditor ("Error happened:" <+> PLC.prettyPlc e) + modify' $ \st -> + -- Note that in case of an out-of-budget error (i.e. `CekOutOfExError`), + -- the updated budgets (spent&remaining) here do not match the actual budgets + -- on the chain: the difference is that on the chain, a budget may become zero (exhausted) + -- but is not allowed to become negative. + st + & set dsBudgetData budgetData + & appendToLogsEditor ("Error happened:" <+> PLC.prettyPlc e) handleDebuggerEvent _ _ (B.AppEvent (DriverLogEvent t)) = - modify' $ appendToLogsEditor ("Driver logged:" <+> pretty t) + modify' $ appendToLogsEditor ("Driver logged:" <+> pretty t) handleDebuggerEvent _ _ (B.AppEvent (CekEmitEvent t)) = - modify' $ appendToLogsEditor ("CEK emitted:" <+> pretty t) + modify' $ appendToLogsEditor ("CEK emitted:" <+> pretty t) handleDebuggerEvent _ _ _ = pure () appendToLogsEditor :: Doc ann -> DebuggerState -> DebuggerState appendToLogsEditor msg = - dsLogsEditor %~ BE.applyEdit - (gotoEOF >>> - insertMany (PLC.render msg) >>> - breakLine - ) + dsLogsEditor + %~ BE.applyEdit + ( gotoEOF + >>> insertMany (PLC.render msg) + >>> breakLine + ) diff --git a/plutus-core/executables/plutus/Debugger/TUI/Main.hs b/plutus-core/executables/plutus/Debugger/TUI/Main.hs index fe3ea9b8ecd..31a6d611c7c 100644 --- a/plutus-core/executables/plutus/Debugger/TUI/Main.hs +++ b/plutus-core/executables/plutus/Debugger/TUI/Main.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{- | A Plutus Core debugger TUI application. - - The application has two stages: browsing for files to debug, and debugging. - If the argument is a directory, it enters the browsing stage. - If the argument is a file, it enters the debugging stage. - If no argument is provided, it defaults to the current working directory. --} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | A Plutus Core debugger TUI application. +-- +-- The application has two stages: browsing for files to debug, and debugging. +-- If the argument is a directory, it enters the browsing stage. +-- If the argument is a file, it enters the debugging stage. +-- If no argument is provided, it defaults to the current working directory. module Debugger.TUI.Main (main) where import AnyProgram.Compile @@ -66,170 +66,179 @@ the `counting` and `restricting` modes, already built for the original cek. debuggerAttrMap :: B.AttrMap debuggerAttrMap = - B.attrMap - Vty.defAttr - [ (BE.editAttr, Vty.white `B.on` Vty.rgbColor @Int 32 32 32) - , (BE.editFocusedAttr, Vty.white `B.on` Vty.black) - , (menuAttr, Vty.withStyle (Vty.white `B.on` darkGreen) Vty.bold) - , (highlightAttr, Vty.blue `B.on` Vty.white) - ] + B.attrMap + Vty.defAttr + [ (BE.editAttr, Vty.white `B.on` Vty.rgbColor @Int 32 32 32) + , (BE.editFocusedAttr, Vty.white `B.on` Vty.black) + , (menuAttr, Vty.withStyle (Vty.white `B.on` darkGreen) Vty.bold) + , (highlightAttr, Vty.blue `B.on` Vty.white) + ] where darkGreen :: Vty.Color darkGreen = Vty.rgbColor @Int 0 100 0 -main :: (?opts :: Opts) - => SNaming n -> SAnn a -> UPLC.Program (FromName n) DefaultUni DefaultFun (FromAnn a) -> IO () +main :: + (?opts :: Opts) => + SNaming n -> SAnn a -> UPLC.Program (FromName n) DefaultUni DefaultFun (FromAnn a) -> IO () main sn sa prog = do - - -- turn it to ast with names - progN <- either (fail . show @FreeVariableError) pure $ uplcToOutName' sn SName prog - let progWithTxSpans = case sa of - SUnit -> mempty <$ progN -- empty srcspans - STxSrcSpans -> progN - - -- make sure to not display annotations - let progTextN = withA @PP.Pretty sa $ PP.displayPlc $ void progN - - -- the parsed prog with uplc.srcspan - progWithUplcSpan <- either (fail . show @(PLC.Error DefaultUni DefaultFun PLC.SrcSpan)) pure $ - runExcept $ PLC.runQuoteT $ UPLC.parseScoped progTextN - - progWithDAnn <- either fail pure $ runExcept $ - pzipWith DAnn progWithUplcSpan progWithTxSpans - - -- The communication "channels" at debugger-driver and at brick - driverMailbox <- newEmptyMVar @(D.Cmd Breakpoints) - -- chan size of 20 is used as default for builtin non-custom events (mouse,key,etc) - brickMailbox <- B.newBChan @CustomBrickEvent 20 - - let app :: B.App DebuggerState CustomBrickEvent ResourceName - app = - B.App - { B.appDraw = drawDebugger - , B.appChooseCursor = B.showFirstCursor - , B.appHandleEvent = handleDebuggerEvent driverMailbox (Just $ _debugDir ?opts) - , B.appStartEvent = pure () - , B.appAttrMap = const debuggerAttrMap - } - initialState = - DebuggerState - { _dsKeyBindingsMode = KeyBindingsHidden - , _dsFocusRing = - B.focusRing $ catMaybes - [ Just EditorUplc - , EditorSource <$ (Just $ _debugDir ?opts) - , Just EditorReturnValue - , Just EditorLogs - ] - , _dsUplcEditor = BE.editorText EditorUplc Nothing progTextN - , _dsUplcHighlight = Nothing - , _dsSourceEditor = Nothing - , _dsSourceHighlight = Nothing - , _dsReturnValueEditor = - BE.editorText - EditorReturnValue - Nothing - "" - , _dsLogsEditor = - BE.editorText - EditorLogs - Nothing - "" - , _dsVLimitBottomEditors = 20 - , _dsHLimitRightEditors = 100 - , _dsBudgetData = BudgetData - { _budgetSpent = mempty - -- the initial remaining budget is based on the passed cli arguments - , _budgetRemaining = _budget ?opts - } + -- turn it to ast with names + progN <- either (fail . show @FreeVariableError) pure $ uplcToOutName' sn SName prog + let progWithTxSpans = case sa of + SUnit -> mempty <$ progN -- empty srcspans + STxSrcSpans -> progN + + -- make sure to not display annotations + let progTextN = withA @PP.Pretty sa $ PP.displayPlc $ void progN + + -- the parsed prog with uplc.srcspan + progWithUplcSpan <- + either (fail . show @(PLC.Error DefaultUni DefaultFun PLC.SrcSpan)) pure $ + runExcept $ + PLC.runQuoteT $ + UPLC.parseScoped progTextN + + progWithDAnn <- + either fail pure $ + runExcept $ + pzipWith DAnn progWithUplcSpan progWithTxSpans + + -- The communication "channels" at debugger-driver and at brick + driverMailbox <- newEmptyMVar @(D.Cmd Breakpoints) + -- chan size of 20 is used as default for builtin non-custom events (mouse,key,etc) + brickMailbox <- B.newBChan @CustomBrickEvent 20 + + let app :: B.App DebuggerState CustomBrickEvent ResourceName + app = + B.App + { B.appDraw = drawDebugger + , B.appChooseCursor = B.showFirstCursor + , B.appHandleEvent = handleDebuggerEvent driverMailbox (Just $ _debugDir ?opts) + , B.appStartEvent = pure () + , B.appAttrMap = const debuggerAttrMap + } + initialState = + DebuggerState + { _dsKeyBindingsMode = KeyBindingsHidden + , _dsFocusRing = + B.focusRing $ + catMaybes + [ Just EditorUplc + , EditorSource <$ (Just $ _debugDir ?opts) + , Just EditorReturnValue + , Just EditorLogs + ] + , _dsUplcEditor = BE.editorText EditorUplc Nothing progTextN + , _dsUplcHighlight = Nothing + , _dsSourceEditor = Nothing + , _dsSourceHighlight = Nothing + , _dsReturnValueEditor = + BE.editorText + EditorReturnValue + Nothing + "" + , _dsLogsEditor = + BE.editorText + EditorLogs + Nothing + "" + , _dsVLimitBottomEditors = 20 + , _dsHLimitRightEditors = 100 + , _dsBudgetData = + BudgetData + { _budgetSpent = mempty + , -- the initial remaining budget is based on the passed cli arguments + _budgetRemaining = _budget ?opts } - - let builder = Vty.mkVty Vty.defaultConfig - initialVty <- builder - - -- TODO: find out if the driver-thread exits when brick exits - -- or should we wait for driver-thread? - _dTid <- forkIO $ driverThread driverMailbox brickMailbox progWithDAnn (_budget ?opts) - - void $ B.customMain initialVty builder (Just brickMailbox) app initialState - -{- | The main entrypoint of the driver thread. - - The driver operates in IO (not in BrickM): the only way to "influence" Brick is via the mailboxes --} -driverThread :: forall uni fun ann - . (uni ~ DefaultUni, fun ~ DefaultFun, ann ~ DAnn) - => MVar (D.Cmd Breakpoints) - -> B.BChan CustomBrickEvent - -> Program Name uni fun ann - -> Maybe ExBudget - -> IO () + } + + let builder = Vty.mkVty Vty.defaultConfig + initialVty <- builder + + -- TODO: find out if the driver-thread exits when brick exits + -- or should we wait for driver-thread? + _dTid <- forkIO $ driverThread driverMailbox brickMailbox progWithDAnn (_budget ?opts) + + void $ B.customMain initialVty builder (Just brickMailbox) app initialState + +-- | The main entrypoint of the driver thread. +-- +-- The driver operates in IO (not in BrickM): the only way to "influence" Brick is via the mailboxes +driverThread :: + forall uni fun ann. + (uni ~ DefaultUni, fun ~ DefaultFun, ann ~ DAnn) => + MVar (D.Cmd Breakpoints) -> + B.BChan CustomBrickEvent -> + Program Name uni fun ann -> + Maybe ExBudget -> + IO () driverThread driverMailbox brickMailbox prog mbudget = do - let term = prog ^. UPLC.progTerm - ndterm <- case runExcept @FreeVariableError $ deBruijnTerm term of - Right t -> pure t - Left _ -> fail $ "deBruijnTerm failed: " <> PLC.displayPlc (void term) - -- if user provided `--budget` the mode is restricting; otherwise just counting + let term = prog ^. UPLC.progTerm + ndterm <- case runExcept @FreeVariableError $ deBruijnTerm term of + Right t -> pure t + Left _ -> fail $ "deBruijnTerm failed: " <> PLC.displayPlc (void term) + -- if user provided `--budget` the mode is restricting; otherwise just counting + -- See Note [Budgeting implementation for the debugger] + let exBudgetMode = case mbudget of + Just budgetLimit -> coerceMode $ restricting $ ExRestrictingBudget budgetLimit + _ -> coerceMode counting + -- nilSlippage is important so as to get correct live up-to-date budget + cekTransWithBudgetRead <- + mkCekTrans + -- TODO: get correct semantics variant + PLC.defaultCekParametersForTesting + exBudgetMode + brickEmitter + nilSlippage + D.iterM (handle cekTransWithBudgetRead) $ D.runDriverT ndterm + where + -- this gets rid of the CountingSt/RestrictingSt newtype wrappers -- See Note [Budgeting implementation for the debugger] - let exBudgetMode = case mbudget of - Just budgetLimit -> coerceMode $ restricting $ ExRestrictingBudget budgetLimit - _ -> coerceMode counting - -- nilSlippage is important so as to get correct live up-to-date budget - cekTransWithBudgetRead <- mkCekTrans - -- TODO: get correct semantics variant - PLC.defaultCekParametersForTesting - exBudgetMode - brickEmitter - nilSlippage - D.iterM (handle cekTransWithBudgetRead) $ D.runDriverT ndterm - - where - -- this gets rid of the CountingSt/RestrictingSt newtype wrappers - -- See Note [Budgeting implementation for the debugger] - coerceMode :: Coercible cost ExBudget - => ExBudgetMode cost uni fun - -> ExBudgetMode ExBudget uni fun - coerceMode = coerce - - -- Peels off one Free monad layer - -- Note to self: for some reason related to implicit params I cannot turn the following - -- into a let block and avoid passing exbudgetinfo as parameter - handle :: (s ~ RealWorld) - => (D.CekTrans uni fun ann s, ExBudgetInfo ExBudget uni fun s) - -> D.DebugF uni fun ann Breakpoints (IO ()) - -> IO () - handle (cekTrans, exBudgetInfo) = \case - D.StepF prevState k -> do - stepRes <- liftCek $ tryError $ cekTrans prevState - -- if error then handle it, otherwise "kontinue" - case stepRes of - Left e -> handleError exBudgetInfo e - Right newState -> k newState - D.InputF k -> handleInput >>= k - D.DriverLogF text k -> handleLog text >> k - D.UpdateClientF ds k -> handleUpdate exBudgetInfo ds >> k - - handleInput = takeMVar driverMailbox - - handleUpdate exBudgetInfo cekState = do - bd <- readBudgetData exBudgetInfo - B.writeBChan brickMailbox $ UpdateClientEvent bd cekState - - handleError exBudgetInfo e = do - bd <- readBudgetData exBudgetInfo - B.writeBChan brickMailbox $ CekErrorEvent bd e - -- no kontinuation in case of error, the driver thread exits - -- TODO: decide what should happen after the error occurs - -- e.g. a user dialog to (r)estart the thread with a button - - handleLog = B.writeBChan brickMailbox . DriverLogEvent - - readBudgetData :: ExBudgetInfo ExBudget uni fun RealWorld -> IO BudgetData - readBudgetData (ExBudgetInfo _ final cumulative) = - stToIO (BudgetData <$> cumulative <*> (for mbudget $ const final)) - - brickEmitter :: EmitterMode uni fun - brickEmitter = EmitterMode $ \_ -> do - -- the simplest solution relies on unsafeIOToPrim (here, unsafeIOToST) - let emitter logs = for_ logs (unsafeIOToPrim . B.writeBChan brickMailbox . CekEmitEvent) - pure $ CekEmitterInfo emitter (pure mempty) + coerceMode :: + Coercible cost ExBudget => + ExBudgetMode cost uni fun -> + ExBudgetMode ExBudget uni fun + coerceMode = coerce + + -- Peels off one Free monad layer + -- Note to self: for some reason related to implicit params I cannot turn the following + -- into a let block and avoid passing exbudgetinfo as parameter + handle :: + s ~ RealWorld => + (D.CekTrans uni fun ann s, ExBudgetInfo ExBudget uni fun s) -> + D.DebugF uni fun ann Breakpoints (IO ()) -> + IO () + handle (cekTrans, exBudgetInfo) = \case + D.StepF prevState k -> do + stepRes <- liftCek $ tryError $ cekTrans prevState + -- if error then handle it, otherwise "kontinue" + case stepRes of + Left e -> handleError exBudgetInfo e + Right newState -> k newState + D.InputF k -> handleInput >>= k + D.DriverLogF text k -> handleLog text >> k + D.UpdateClientF ds k -> handleUpdate exBudgetInfo ds >> k + + handleInput = takeMVar driverMailbox + + handleUpdate exBudgetInfo cekState = do + bd <- readBudgetData exBudgetInfo + B.writeBChan brickMailbox $ UpdateClientEvent bd cekState + + handleError exBudgetInfo e = do + bd <- readBudgetData exBudgetInfo + B.writeBChan brickMailbox $ CekErrorEvent bd e + -- no kontinuation in case of error, the driver thread exits + -- TODO: decide what should happen after the error occurs + -- e.g. a user dialog to (r)estart the thread with a button + + handleLog = B.writeBChan brickMailbox . DriverLogEvent + + readBudgetData :: ExBudgetInfo ExBudget uni fun RealWorld -> IO BudgetData + readBudgetData (ExBudgetInfo _ final cumulative) = + stToIO (BudgetData <$> cumulative <*> (for mbudget $ const final)) + + brickEmitter :: EmitterMode uni fun + brickEmitter = EmitterMode $ \_ -> do + -- the simplest solution relies on unsafeIOToPrim (here, unsafeIOToST) + let emitter logs = for_ logs (unsafeIOToPrim . B.writeBChan brickMailbox . CekEmitEvent) + pure $ CekEmitterInfo emitter (pure mempty) diff --git a/plutus-core/executables/plutus/Debugger/TUI/Types.hs b/plutus-core/executables/plutus/Debugger/TUI/Types.hs index 2d61860aef1..81e84975e53 100644 --- a/plutus-core/executables/plutus/Debugger/TUI/Types.hs +++ b/plutus-core/executables/plutus/Debugger/TUI/Types.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} + -- | Debugger TUI Types. module Debugger.TUI.Types where @@ -21,75 +22,76 @@ import Text.Megaparsec type Breakpoints = [Breakpoint] -data Breakpoint = UplcBP SourcePos - | TxBP SourcePos +data Breakpoint + = UplcBP SourcePos + | TxBP SourcePos -- | Annotation used in the debugger. Contains source locations for the UPLC program -- and the source program. data DAnn = DAnn - { uplcAnn :: SrcSpan - , txAnn :: SrcSpans - } + { uplcAnn :: SrcSpan + , txAnn :: SrcSpans + } instance D.Breakpointable DAnn Breakpoints where - hasBreakpoints ann = any breakpointFired - where - breakpointFired :: Breakpoint -> Bool - breakpointFired = \case - UplcBP p -> unPos (sourceLine p) == srcSpanSLine (uplcAnn ann) - TxBP p -> oany (lineInSrcSpan $ sourceLine p) $ txAnn ann + hasBreakpoints ann = any breakpointFired + where + breakpointFired :: Breakpoint -> Bool + breakpointFired = \case + UplcBP p -> unPos (sourceLine p) == srcSpanSLine (uplcAnn ann) + TxBP p -> oany (lineInSrcSpan $ sourceLine p) $ txAnn ann data BudgetData = BudgetData - { _budgetSpent :: ExBudget - , _budgetRemaining :: Maybe ExBudget - } + { _budgetSpent :: ExBudget + , _budgetRemaining :: Maybe ExBudget + } makeLenses ''BudgetData -- | The custom events that can arrive at our brick mailbox. -data CustomBrickEvent = - UpdateClientEvent BudgetData (CekState DefaultUni DefaultFun DAnn) - -- ^ the driver passes a new cek state to the brick client +data CustomBrickEvent + = -- | the driver passes a new cek state to the brick client -- this should mean that the brick client should update its tui - | DriverLogEvent Text - -- ^ the driver logged some text, the brick client can decide to show it in the tui - | CekEmitEvent Text - -- ^ the underlying cek machine emitted some text (using a trace or other builtin) - | CekErrorEvent BudgetData (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) - -- ^ the underlying cek machine errored (either by call to Error, builtin or type failure) + UpdateClientEvent BudgetData (CekState DefaultUni DefaultFun DAnn) + | -- | the driver logged some text, the brick client can decide to show it in the tui + DriverLogEvent Text + | -- | the underlying cek machine emitted some text (using a trace or other builtin) + CekEmitEvent Text + | -- | the underlying cek machine errored (either by call to Error, builtin or type failure) + CekErrorEvent BudgetData (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) data KeyBindingsMode = KeyBindingsShown | KeyBindingsHidden - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) -- | Highlight between two positions. data HighlightSpan = HighlightSpan - { _hcSLoc :: B.Location - , _hcELoc :: Maybe B.Location - -- ^ @Nothing@ means highlight till the end of the line - } + { _hcSLoc :: B.Location + , _hcELoc :: Maybe B.Location + -- ^ @Nothing@ means highlight till the end of the line + } data ResourceName - = FileBrowserUplc - | EditorUplc - | EditorSource - | EditorReturnValue - | EditorLogs - deriving stock (Eq, Ord, Show) + = FileBrowserUplc + | EditorUplc + | EditorSource + | EditorReturnValue + | EditorLogs + deriving stock (Eq, Ord, Show) data DebuggerState = DebuggerState - { _dsKeyBindingsMode :: KeyBindingsMode - , _dsFocusRing :: B.FocusRing ResourceName - -- ^ Controls which window is in focus. - , _dsUplcEditor :: BE.Editor Text ResourceName - , _dsUplcHighlight :: Maybe HighlightSpan - , _dsSourceEditor :: Maybe (BE.Editor Text ResourceName) - , _dsSourceHighlight :: Maybe HighlightSpan - , _dsReturnValueEditor :: BE.Editor Text ResourceName - , _dsLogsEditor :: BE.Editor Text ResourceName - , _dsVLimitBottomEditors :: Int - -- ^ Controls the height limit of the bottom windows. - , _dsHLimitRightEditors :: Int - -- ^ Controls the width limit of the right windows. - , _dsBudgetData :: BudgetData - } + { _dsKeyBindingsMode :: KeyBindingsMode + , _dsFocusRing :: B.FocusRing ResourceName + -- ^ Controls which window is in focus. + , _dsUplcEditor :: BE.Editor Text ResourceName + , _dsUplcHighlight :: Maybe HighlightSpan + , _dsSourceEditor :: Maybe (BE.Editor Text ResourceName) + , _dsSourceHighlight :: Maybe HighlightSpan + , _dsReturnValueEditor :: BE.Editor Text ResourceName + , _dsLogsEditor :: BE.Editor Text ResourceName + , _dsVLimitBottomEditors :: Int + -- ^ Controls the height limit of the bottom windows. + , _dsHLimitRightEditors :: Int + -- ^ Controls the width limit of the right windows. + , _dsBudgetData :: BudgetData + } makeLenses ''DebuggerState diff --git a/plutus-core/executables/plutus/GetOpt.hs b/plutus-core/executables/plutus/GetOpt.hs index 58e83930be3..5d1fbb50b09 100644 --- a/plutus-core/executables/plutus/GetOpt.hs +++ b/plutus-core/executables/plutus/GetOpt.hs @@ -1,15 +1,23 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module GetOpt - ( Opts (..) - , inputs, target, mode, budget, prettyStyle, optimiseLvl, verbosity, lastFileType - , parseArgs - , optDescrs - , GetOpt.usageInfo - ) where + +module GetOpt ( + Opts (..), + inputs, + target, + mode, + budget, + prettyStyle, + optimiseLvl, + verbosity, + lastFileType, + parseArgs, + optDescrs, + GetOpt.usageInfo, +) where import Types @@ -28,69 +36,77 @@ import System.IO -- (e.g. `_inputs=[]`). It is the responsibility of each mode to later cleanup or -- fail on such erroneous `Opts` value. data Opts = Opts - { _inputs :: [SomeFile] - , _target :: SomeFile - , _mode :: Mode - , _budget :: Maybe ExBudget -- ^ Nothing means: unlimited budget - , _prettyStyle :: PrettyStyle - , _wholeOpt :: Bool - , _optimiseLvl :: OptimiseLvl - , _verbosity :: Verbosity - , _lastFileType :: Maybe FileType -- ^ Nothing means: use smart-suffix - , _debugDir :: FilePath - } - deriving stock Show + { _inputs :: [SomeFile] + , _target :: SomeFile + , _mode :: Mode + , _budget :: Maybe ExBudget + -- ^ Nothing means: unlimited budget + , _prettyStyle :: PrettyStyle + , _wholeOpt :: Bool + , _optimiseLvl :: OptimiseLvl + , _verbosity :: Verbosity + , _lastFileType :: Maybe FileType + -- ^ Nothing means: use smart-suffix + , _debugDir :: FilePath + } + deriving stock (Show) + makeLenses ''Opts parseArgs :: [String] -> IO Opts parseArgs args = do - let (getOptRes, _, getOptErrMsgs) = GetOpt.getOpt (GetOpt.ReturnInOrder fromNonDash) optDescrs args + let (getOptRes, _, getOptErrMsgs) = GetOpt.getOpt (GetOpt.ReturnInOrder fromNonDash) optDescrs args - when (not $ null getOptErrMsgs) $ - fail $ fold getOptErrMsgs + when (not $ null getOptErrMsgs) $ + fail $ + fold getOptErrMsgs - {- MAYBE: I could make --stdout completely implicit when getOptRes.output==Nothing - I think it is possible to also do this if there is no output specified: - a) If there is no unix pipe connected after this command, output to a file with a specific name (a.out or a combination of all applied program names) - b) if there is a pipe connected, do not write to any file like a.out but just redirect the output to the pipe. - I do not know yet how to implement this, but I think it is possible. + {- MAYBE: I could make --stdout completely implicit when getOptRes.output==Nothing + I think it is possible to also do this if there is no output specified: + a) If there is no unix pipe connected after this command, output to a file with a specific name (a.out or a combination of all applied program names) + b) if there is a pipe connected, do not write to any file like a.out but just redirect the output to the pipe. + I do not know yet how to implement this, but I think it is possible. - One benefit of making --stdout explicit is that we use no-out as a way to only typecheck and not write anything. - -} + One benefit of making --stdout explicit is that we use no-out as a way to only typecheck and not write anything. + -} - -- MAYBE: I could make --stdin sometimes implicit, when getOptRes.inputs=[] && pipe is connected - -- , but also allow it explicitly so that it can be used as positioned input in an apply chain of programs + -- MAYBE: I could make --stdin sometimes implicit, when getOptRes.inputs=[] && pipe is connected + -- , but also allow it explicitly so that it can be used as positioned input in an apply chain of programs - -- fold the options - let -- Dual Endo so as to apply the options in the expected left to right CLI order - appDual = appEndo . getDual - finalOpts = foldMap (Dual . Endo) getOptRes `appDual` def - -- reverse the parsed inputs to match the order of appearance in command-line - & inputs %~ reverse + -- fold the options + let + -- Dual Endo so as to apply the options in the expected left to right CLI order + appDual = appEndo . getDual + finalOpts = + foldMap (Dual . Endo) getOptRes `appDual` def + -- reverse the parsed inputs to match the order of appearance in command-line + & inputs %~ reverse - when (_verbosity finalOpts == VDebug) $ - hPutStrLn stderr $ "Parsed opts: " ++ show finalOpts + when (_verbosity finalOpts == VDebug) $ + hPutStrLn stderr $ + "Parsed opts: " ++ show finalOpts - pure finalOpts + pure finalOpts -- | Default Options when omitted. instance Default Opts where - def = Opts - { _inputs = def - , _target = def - , _mode = def - , _prettyStyle = def - , _wholeOpt = False - , _optimiseLvl = def - , _budget = def - , _verbosity = def - , _lastFileType = def -- start in smart-mode - , _debugDir = defDebugDirPath - } + def = + Opts + { _inputs = def + , _target = def + , _mode = def + , _prettyStyle = def + , _wholeOpt = False + , _optimiseLvl = def + , _budget = def + , _verbosity = def + , _lastFileType = def -- start in smart-mode + , _debugDir = defDebugDirPath + } -- | Default Mode is compile and then exit instance Default Mode where - def = Compile Exit + def = Compile Exit defBenchSecs :: Secs defBenchSecs = 10 @@ -99,97 +115,152 @@ defDebugDirPath :: FilePath defDebugDirPath = "." instance Default SomeFile where - def = mkSomeFile def Nothing + def = mkSomeFile def Nothing -- | When smartness fails, assume that the user supplied this filetype (suffix) instance Default FileType where - def = read "uplc-txt" + def = read "uplc-txt" instance Default PrettyStyle where - def = Classic + def = Classic instance Default Verbosity where - def = VStandard + def = VStandard instance Default OptimiseLvl where - def = NoOptimise + def = NoOptimise instance Default DebugInterface where - def = TUI + def = TUI -- Each successful parsing of an option returns a state-transition function type OptsFun = Opts -> Opts optDescrs :: [OptDescr OptsFun] optDescrs = - [ - -- Simple modes - Option ['h'] ["help"] - -- MAYBE: turning Help mode to a simple option, so we can have more detailed sub-information for - -- each mode? We would then need also a --compile option. Or keep it as a mode and use a pager with a full man page. - (NoArg (set mode Help)) "Show usage" - , Option ['V'] ["version"] - (NoArg (set mode Version)) "Show version" - -- VERBOSITY - , Option ['q'] ["quiet"] - (NoArg (set verbosity VQuiet)) "Don't print text (error) output; rely only on exit codes" - , Option ['v'] ["verbose"] - (NoArg (set verbosity VDebug)) "Print more than than the default" - - - , Option [] ["print-builtins"] - (NoArg (set mode PrintBuiltins)) "Print the Default universe & builtins" - , Option [] ["print-cost-model"] - (NoArg (set mode PrintCostModel)) "Print the cost model of latest Plutus Version as JSON" - - -- COMPILE-MODE options - ------------------------------------------ - - -- INPUT - , Option [] ["stdin"] - (NoArg $ addInput StdIn . delInputs StdIn) "Use stdin" -- Note: only the last occurence counts - , Option ['e'] ["example"] - (OptArg (maybe (set mode ListExamples) (addInput . Example)) "NAME") "Use example NAME as input. Leave out NAME to see the list of examples' names" - - -- PRETTY-STYLE for OUTPUT & ERRORS - , Option ['p'] ["pretty"] - (ReqArg (set prettyStyle . read) "STYLE") "Make program's textual-output&error output pretty. Ignored for non-textual output (flat/cbor). Values: `classic`, `readable, `classic-simple`, `readable-simple` " - -- OUTPUT - , Option ['o'] [] - (ReqArg (setOutput . AbsolutePath) "FILE") "Write compiled program to file" - , Option [] ["stdout"] - (NoArg $ setOutput StdOut) "Write compiled program to stdout" - - -- OPTIMISATIONS - , Option ['O'] [] - -- Making -On option also stateful (like -x/-a/-n) does not seem to be worth it. - (OptArg (set optimiseLvl . maybe SafeOptimise read) "INT") "Set optimisation level; default: 0 , safe optimisations: 1, >=2: unsafe optimisations" - , Option [] ["whole-opt"] - (NoArg (set wholeOpt True)) "Run an extra optimisation pass after all inputs are applied together. Ignored if only 1 input given." - - -- INPUT & OUTPUT STATEFUL types - , Option ['x'] [] - -- taken from GHC's -x - -- If that suffix is not known, defaults to def - (ReqArg (set lastFileType . Just . readMaybeDot) "SUFFIX") "Causes all files following this option on the command line to be processed as if they had the suffix SUFFIX" - -- FIXME: naming,ann partial for data - , Option ['n'] ["nam"] - (ReqArg (overFileTypeDefault (fLang . naming) read) "NAMING") "Change naming to `name` (default), `debruijn` or `named-debruijn`" - , Option ['a'] ["ann"] - (ReqArg (overFileTypeDefault (fLang . ann) read) "ANNOTATION") "Change annotation to `unit` (default) or `srcspan`" - - , Option [] ["run"] - (NoArg (set mode (Compile Run))) "Compile and run" - , Option [] ["bench"] - (OptArg (set mode . Compile . Bench . maybe defBenchSecs read) "SECS") ("Compile then run repeatedly up to these number of seconds (default:" ++ show defBenchSecs ++ ") and print statistics") - , Option [] ["debug"] - (OptArg (set mode . Compile . Debug . maybe def read) "INTERFACE") "Compile then Debug program after compilation. Uses a `tui` (default) or a `cli` interface." - , Option [] ["debug-dir"] - (OptArg (set debugDir . fromMaybe defDebugDirPath) "DIR") "When `--debug`, try to search for PlutusTx source files in given DIR (default: .)" - , Option [] ["budget"] - -- having budget for bench-mode seems silly, but let's allow it for uniformity. - (ReqArg (set budget . Just . read) "INT,INT") "Set CPU,MEM budget limit. The default is no limit. Only if --run, --bench, or --debug is given" - ] + [ -- Simple modes + Option + ['h'] + ["help"] + -- MAYBE: turning Help mode to a simple option, so we can have more detailed sub-information for + -- each mode? We would then need also a --compile option. Or keep it as a mode and use a pager with a full man page. + (NoArg (set mode Help)) + "Show usage" + , Option + ['V'] + ["version"] + (NoArg (set mode Version)) + "Show version" + , -- VERBOSITY + Option + ['q'] + ["quiet"] + (NoArg (set verbosity VQuiet)) + "Don't print text (error) output; rely only on exit codes" + , Option + ['v'] + ["verbose"] + (NoArg (set verbosity VDebug)) + "Print more than than the default" + , Option + [] + ["print-builtins"] + (NoArg (set mode PrintBuiltins)) + "Print the Default universe & builtins" + , Option + [] + ["print-cost-model"] + (NoArg (set mode PrintCostModel)) + "Print the cost model of latest Plutus Version as JSON" + , -- COMPILE-MODE options + ------------------------------------------ + + -- INPUT + Option + [] + ["stdin"] + (NoArg $ addInput StdIn . delInputs StdIn) + "Use stdin" -- Note: only the last occurence counts + , Option + ['e'] + ["example"] + (OptArg (maybe (set mode ListExamples) (addInput . Example)) "NAME") + "Use example NAME as input. Leave out NAME to see the list of examples' names" + , -- PRETTY-STYLE for OUTPUT & ERRORS + Option + ['p'] + ["pretty"] + (ReqArg (set prettyStyle . read) "STYLE") + "Make program's textual-output&error output pretty. Ignored for non-textual output (flat/cbor). Values: `classic`, `readable, `classic-simple`, `readable-simple` " + , -- OUTPUT + Option + ['o'] + [] + (ReqArg (setOutput . AbsolutePath) "FILE") + "Write compiled program to file" + , Option + [] + ["stdout"] + (NoArg $ setOutput StdOut) + "Write compiled program to stdout" + , -- OPTIMISATIONS + Option + ['O'] + [] + -- Making -On option also stateful (like -x/-a/-n) does not seem to be worth it. + (OptArg (set optimiseLvl . maybe SafeOptimise read) "INT") + "Set optimisation level; default: 0 , safe optimisations: 1, >=2: unsafe optimisations" + , Option + [] + ["whole-opt"] + (NoArg (set wholeOpt True)) + "Run an extra optimisation pass after all inputs are applied together. Ignored if only 1 input given." + , -- INPUT & OUTPUT STATEFUL types + Option + ['x'] + [] + -- taken from GHC's -x + -- If that suffix is not known, defaults to def + (ReqArg (set lastFileType . Just . readMaybeDot) "SUFFIX") + "Causes all files following this option on the command line to be processed as if they had the suffix SUFFIX" + , -- FIXME: naming,ann partial for data + Option + ['n'] + ["nam"] + (ReqArg (overFileTypeDefault (fLang . naming) read) "NAMING") + "Change naming to `name` (default), `debruijn` or `named-debruijn`" + , Option + ['a'] + ["ann"] + (ReqArg (overFileTypeDefault (fLang . ann) read) "ANNOTATION") + "Change annotation to `unit` (default) or `srcspan`" + , Option + [] + ["run"] + (NoArg (set mode (Compile Run))) + "Compile and run" + , Option + [] + ["bench"] + (OptArg (set mode . Compile . Bench . maybe defBenchSecs read) "SECS") + ("Compile then run repeatedly up to these number of seconds (default:" ++ show defBenchSecs ++ ") and print statistics") + , Option + [] + ["debug"] + (OptArg (set mode . Compile . Debug . maybe def read) "INTERFACE") + "Compile then Debug program after compilation. Uses a `tui` (default) or a `cli` interface." + , Option + [] + ["debug-dir"] + (OptArg (set debugDir . fromMaybe defDebugDirPath) "DIR") + "When `--debug`, try to search for PlutusTx source files in given DIR (default: .)" + , Option + [] + ["budget"] + -- having budget for bench-mode seems silly, but let's allow it for uniformity. + (ReqArg (set budget . Just . read) "INT,INT") + "Set CPU,MEM budget limit. The default is no limit. Only if --run, --bench, or --debug is given" + ] -- Helpers to construct state functions --------------------------------------- @@ -199,24 +270,24 @@ setOutput fn s = set target (mkSomeFile (getFileType s fn) (Just fn)) s addInput :: FileName -> OptsFun addInput fn s = - over inputs (mkSomeFile (getFileType s fn) (Just fn) :) s + over inputs (mkSomeFile (getFileType s fn) (Just fn) :) s -- | naive way to delete some inputs files, used only for fixing StdIn re-setting delInputs :: FileName -> OptsFun -delInputs fn = over inputs (filter (\ (SomeFile _ f) -> f^.fName /= Just fn)) +delInputs fn = over inputs (filter (\(SomeFile _ f) -> f ^. fName /= Just fn)) -- 1) if -x was previously set, reuse that last filetype or -- 2) if its an absolutepath, get filetype from the filepath's extension or -- 3) def in any other case getFileType :: Opts -> FileName -> FileType getFileType = \case - -- -x was specified, so it takes precedence - (_lastFileType -> Just x) -> const x - _ -> \case - -- no -x && has_ext - AbsolutePath (takeExtensions -> '.': exts) -> read exts - -- no -x && (no_ext|stdout|stdin|example) - _ -> def + -- -x was specified, so it takes precedence + (_lastFileType -> Just x) -> const x + _ -> \case + -- no -x && has_ext + AbsolutePath (takeExtensions -> '.' : exts) -> read exts + -- no -x && (no_ext|stdout|stdin|example) + _ -> def -- For options that are not prefixed with dash(es), e.g. plain file/dirs fromNonDash :: FilePath -> OptsFun @@ -224,12 +295,14 @@ fromNonDash = addInput . AbsolutePath -- | Modify part of the last filetype -- Use def if last filetype is unset. -overFileTypeDefault :: ASetter' FileType arg - -> (String -> arg) - -> String - -> OptsFun -overFileTypeDefault setter f arg = over lastFileType $ \ mFt -> - set (mapped . setter) +overFileTypeDefault :: + ASetter' FileType arg -> + (String -> arg) -> + String -> + OptsFun +overFileTypeDefault setter f arg = over lastFileType $ \mFt -> + set + (mapped . setter) (f arg) (mFt <|> Just def) @@ -237,7 +310,8 @@ overFileTypeDefault setter f arg = over lastFileType $ \ mFt -> -------------------------------------------------- instance Read Naming where - readsPrec _prec = one . \case + readsPrec _prec = + one . \case "name" -> Name "debruijn" -> DeBruijn "named-debruijn" -> NamedDeBruijn @@ -249,13 +323,15 @@ instance Read Naming where _ -> error "Failed to read --nam=NAMING." instance Read Ann where - readsPrec _prec = one . \case + readsPrec _prec = + one . \case "unit" -> Unit "srcspan" -> TxSrcSpans _ -> error "Failed to read --ann=ANNOTATION." instance Read PrettyStyle where - readsPrec _prec = one . \case + readsPrec _prec = + one . \case "classic" -> Classic "classic-simple" -> ClassicSimple "readable" -> Readable @@ -271,11 +347,11 @@ instance Read ExBudget where readsPrec _prec s = let (cpu, commamem) = break (== ',') s mem = case commamem of - [] -> [] - _comma:rest -> rest + [] -> [] + _comma : rest -> rest -- if cpu or mem is missing, default it to maxBound (inspired by restrictingEnormous) readOrMax str = if null str then maxBound else read str - in one $ ExBudget (readOrMax cpu) $ readOrMax mem + in one $ ExBudget (readOrMax cpu) $ readOrMax mem instance Read OptimiseLvl where readsPrec _prec s = one $ case read @Int s of @@ -284,52 +360,47 @@ instance Read OptimiseLvl where _ -> UnsafeOptimise instance Read FileType where - readsPrec _prec = one . \case - -- 1-SUFFIX - "pir" -> read "pir-txt" - "tplc" -> read "tplc-txt" - "uplc" -> read "uplc-txt" - "data" -> read "data-cbor" -- data mostly makes sense as cbor - - "txt" -> read "uplc-txt" - "flat" -> read "uplc-flat" - "cbor" -> read "uplc-cbor" - - -- txt wrapped - "pir-txt" -> FileType Text $ Pir Name Unit - "tplc-txt" -> FileType Text $ Plc Name Unit - "uplc-txt" -> FileType Text $ Uplc Name Unit - "data-txt" -> FileType Text Data - - -- flat wrapped - "pir-flat" -> FileType Flat_ $ Pir Name Unit - "tplc-flat" -> FileType Flat_ $ Plc Name Unit - "uplc-flat" -> FileType Flat_ $ Uplc NamedDeBruijn Unit - "data-flat" -> error "data-flat format is not available." - - -- cbor wrapped - "pir-cbor" -> FileType Cbor $ Plc Name Unit -- pir does not have *Debruijn. - "tplc-cbor" -> FileType Cbor $ Plc DeBruijn Unit - "uplc-cbor" -> FileType Cbor $ Uplc DeBruijn Unit - "data-cbor" -> FileType Cbor Data - - -- unknown suffix, use default - _ -> def + readsPrec _prec = + one . \case + -- 1-SUFFIX + "pir" -> read "pir-txt" + "tplc" -> read "tplc-txt" + "uplc" -> read "uplc-txt" + "data" -> read "data-cbor" -- data mostly makes sense as cbor + "txt" -> read "uplc-txt" + "flat" -> read "uplc-flat" + "cbor" -> read "uplc-cbor" + -- txt wrapped + "pir-txt" -> FileType Text $ Pir Name Unit + "tplc-txt" -> FileType Text $ Plc Name Unit + "uplc-txt" -> FileType Text $ Uplc Name Unit + "data-txt" -> FileType Text Data + -- flat wrapped + "pir-flat" -> FileType Flat_ $ Pir Name Unit + "tplc-flat" -> FileType Flat_ $ Plc Name Unit + "uplc-flat" -> FileType Flat_ $ Uplc NamedDeBruijn Unit + "data-flat" -> error "data-flat format is not available." + -- cbor wrapped + "pir-cbor" -> FileType Cbor $ Plc Name Unit -- pir does not have *Debruijn. + "tplc-cbor" -> FileType Cbor $ Plc DeBruijn Unit + "uplc-cbor" -> FileType Cbor $ Uplc DeBruijn Unit + "data-cbor" -> FileType Cbor Data + -- unknown suffix, use default + _ -> def instance Read DebugInterface where - readsPrec _prec = one . \case - "tui" -> TUI - "cli" -> CLI - _ -> error "Failed to read --debug=INTERFACE." - -one :: a -> [(a,String)] -one x = [(x,"")] + readsPrec _prec = + one . \case + "tui" -> TUI + "cli" -> CLI + _ -> error "Failed to read --debug=INTERFACE." +one :: a -> [(a, String)] +one x = [(x, "")] -- maybe drop a leading dot readMaybeDot :: Read a => String -> a readMaybeDot = - \case - ('.': ext) -> read ext - ext -> read ext - + \case + ('.' : ext) -> read ext + ext -> read ext diff --git a/plutus-core/executables/plutus/Main.hs b/plutus-core/executables/plutus/Main.hs index 0e16a1abe4c..b34979510e4 100644 --- a/plutus-core/executables/plutus/Main.hs +++ b/plutus-core/executables/plutus/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ImplicitParams #-} + module Main where import GetOpt @@ -13,13 +14,12 @@ import System.Environment main :: IO () main = do - opts <- GetOpt.parseArgs =<< getArgs - let ?opts = opts - in case _mode ?opts of - Help{} -> runHelp - Version{} -> runVersion - PrintBuiltins{} -> runPrintBuiltins - PrintCostModel{} -> runPrintCostModel - ListExamples{} -> runListExamples + opts <- GetOpt.parseArgs =<< getArgs + let ?opts = opts + in case _mode ?opts of + Help {} -> runHelp + Version {} -> runVersion + PrintBuiltins {} -> runPrintBuiltins + PrintCostModel {} -> runPrintCostModel + ListExamples {} -> runListExamples Compile afterCompile -> runCompile afterCompile - diff --git a/plutus-core/executables/plutus/Mode/Compile.hs b/plutus-core/executables/plutus/Mode/Compile.hs index 1da71a03f3a..a7ec5253f34 100644 --- a/plutus-core/executables/plutus/Mode/Compile.hs +++ b/plutus-core/executables/plutus/Mode/Compile.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-} -module Mode.Compile - ( runCompile - ) where + +module Mode.Compile ( + runCompile, +) where import AnyProgram.Apply import AnyProgram.Bench @@ -20,68 +21,73 @@ import PlutusPrelude import Prettyprinter import System.Exit -runCompile :: (?opts :: Opts) - => AfterCompile -> IO () +runCompile :: + (?opts :: Opts) => + AfterCompile -> IO () runCompile afterCompile = case ?opts of - Opts {_inputs = []} -> - failE "No input given. Use --stdin if you want to read program from stdin. See also --help" - Opts {_inputs = hdS:tlS, _target = SomeFile sngT fileT} -> do - -- compile the head targetting sngT - hdT <- readCompile sngT hdS - -- compile the tail targetting sngT, and fold-apply the results together with the head - astT <- foldlM (readCompileApply sngT) hdT tlS + Opts {_inputs = []} -> + failE "No input given. Use --stdin if you want to read program from stdin. See also --help" + Opts {_inputs = hdS : tlS, _target = SomeFile sngT fileT} -> do + -- compile the head targetting sngT + hdT <- readCompile sngT hdS + -- compile the tail targetting sngT, and fold-apply the results together with the head + astT <- foldlM (readCompileApply sngT) hdT tlS - appliedAstT <- - if _wholeOpt ?opts - then -- self-compile one last time for optimisation (also runs the checks) - compile sngT sngT astT - else -- The checks should run also at the whole (applied) program - check sngT astT + appliedAstT <- + if _wholeOpt ?opts + then -- self-compile one last time for optimisation (also runs the checks) + compile sngT sngT astT + else -- The checks should run also at the whole (applied) program + check sngT astT - writeProgram sngT appliedAstT fileT afterCompile + writeProgram sngT appliedAstT fileT afterCompile - case afterCompile of - Exit{} -> exitSuccess -- nothing left to do - Run{} -> runRun sngT appliedAstT - Bench{} -> runBench sngT appliedAstT - Debug{} -> runDebug sngT appliedAstT + case afterCompile of + Exit {} -> exitSuccess -- nothing left to do + Run {} -> runRun sngT appliedAstT + Bench {} -> runBench sngT appliedAstT + Debug {} -> runDebug sngT appliedAstT -readCompileApply :: (?opts :: Opts) - => SLang t -> FromLang t -> SomeFile -> IO (FromLang t) +readCompileApply :: + (?opts :: Opts) => + SLang t -> FromLang t -> SomeFile -> IO (FromLang t) readCompileApply sngT accT someFileS = do - astT <- readCompile sngT someFileS - case accT `applyTarget` astT of - -- application errors use the annotation type of the target - Left err -> withA @Pretty (_sann sngT) $ failE $ show err - Right applied -> pure applied + astT <- readCompile sngT someFileS + case accT `applyTarget` astT of + -- application errors use the annotation type of the target + Left err -> withA @Pretty (_sann sngT) $ failE $ show err + Right applied -> pure applied where applyTarget = applyProgram sngT -readCompile :: (?opts :: Opts) - => SLang t -> SomeFile -> IO (FromLang t) +readCompile :: + (?opts :: Opts) => + SLang t -> SomeFile -> IO (FromLang t) readCompile sngT (SomeFile sngS fileS) = do - printED $ show $ "Compiling" <+> pretty fileS - astS <- readProgram sngS fileS - compile sngS sngT astS + printED $ show $ "Compiling" <+> pretty fileS + astS <- readProgram sngS fileS + compile sngS sngT astS -compile :: (?opts :: Opts) - => SLang s -> SLang t -> FromLang s -> IO (FromLang t) +compile :: + (?opts :: Opts) => + SLang s -> SLang t -> FromLang s -> IO (FromLang t) compile sngS sngT astS = - case compileProgram sngS sngT astS of - -- compilation errors use the annotation type of the sources - Left err -> withA @Pretty (_sann sngS) $ failE $ show err - Right res -> pure res + case compileProgram sngS sngT astS of + -- compilation errors use the annotation type of the sources + Left err -> withA @Pretty (_sann sngS) $ failE $ show err + Right res -> pure res -check :: (?opts :: Opts) - => SLang t -> FromLang t -> IO (FromLang t) +check :: + (?opts :: Opts) => + SLang t -> FromLang t -> IO (FromLang t) check sngT astT = - if length (_inputs ?opts) == 1 + if length (_inputs ?opts) == 1 -- optimization: no need to do more checks if there was no application involved then pure astT else case checkProgram sngT astT of - -- compilation errors use the annotation type of the sources - Left err -> do - printE "Failed to typecheck fully-applied program. The error was:" - withA @Pretty (_sann sngT) $ failE $ show err - -- passed the checks, return it - _ -> pure astT + -- compilation errors use the annotation type of the sources + Left err -> do + printE "Failed to typecheck fully-applied program. The error was:" + withA @Pretty (_sann sngT) $ failE $ show err + -- passed the checks, return it + _ -> pure astT diff --git a/plutus-core/executables/plutus/Mode/HelpVersion.hs b/plutus-core/executables/plutus/Mode/HelpVersion.hs index ba99006aee3..8070b8d7210 100644 --- a/plutus-core/executables/plutus/Mode/HelpVersion.hs +++ b/plutus-core/executables/plutus/Mode/HelpVersion.hs @@ -1,7 +1,7 @@ -module Mode.HelpVersion - ( runHelp - , runVersion - ) where +module Mode.HelpVersion ( + runHelp, + runVersion, +) where import Data.Version.Extras (gitAwareVersionInfo) import GetOpt @@ -9,7 +9,7 @@ import Paths_plutus_core qualified as Paths runHelp :: IO () runHelp = do - putStr $ GetOpt.usageInfo usageHeader GetOpt.optDescrs + putStr $ GetOpt.usageInfo usageHeader GetOpt.optDescrs usageHeader :: String usageHeader = "USAGE: plutus [--compile|--run|--bench|--debug] FILES..." diff --git a/plutus-core/executables/plutus/Mode/ListExamples.hs b/plutus-core/executables/plutus/Mode/ListExamples.hs index 553caff7990..556c97b6a79 100644 --- a/plutus-core/executables/plutus/Mode/ListExamples.hs +++ b/plutus-core/executables/plutus/Mode/ListExamples.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-} -module Mode.ListExamples - ( runListExamples - ) where + +module Mode.ListExamples ( + runListExamples, +) where import AnyProgram.Example import Common import GetOpt -runListExamples :: (?opts :: Opts) - => IO () +runListExamples :: + (?opts :: Opts) => + IO () runListExamples = do - printE "List of available example names:" - -- the names go to stdout - putStr $ unlines $ - (fst <$> termExamples) ++ (fst <$> typeExamples) - printE "Use --example=NAME to include them as input." + printE "List of available example names:" + -- the names go to stdout + putStr $ + unlines $ + (fst <$> termExamples) ++ (fst <$> typeExamples) + printE "Use --example=NAME to include them as input." diff --git a/plutus-core/executables/plutus/Mode/PrintBuiltins.hs b/plutus-core/executables/plutus/Mode/PrintBuiltins.hs index 21c04089b82..0592a3c4425 100644 --- a/plutus-core/executables/plutus/Mode/PrintBuiltins.hs +++ b/plutus-core/executables/plutus/Mode/PrintBuiltins.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} -module Mode.PrintBuiltins - ( runPrintBuiltins - ) where + +module Mode.PrintBuiltins ( + runPrintBuiltins, +) where import PlutusCore qualified as PLC import PlutusCore.Builtin qualified as PLC @@ -23,58 +24,59 @@ runPrintBuiltins = portedImpl portedImpl :: IO () portedImpl = do - -- MAYBE: categorize the builtins by Plutus Version introduced. Would require dependency - -- upon plutus-ledger-api - let builtins = enumerate @PLC.DefaultFun - mapM_ - (\x -> putStr (printf "%-35s: %s\n" (show $ PP.pretty x) (show $ getSignature x))) - builtins + -- MAYBE: categorize the builtins by Plutus Version introduced. Would require dependency + -- upon plutus-ledger-api + let builtins = enumerate @PLC.DefaultFun + mapM_ + (\x -> putStr (printf "%-35s: %s\n" (show $ PP.pretty x) (show $ getSignature x))) + builtins where getSignature (PLC.toBuiltinMeaning @_ @_ @PlcTerm def -> PLC.BuiltinMeaning sch _ _) = - typeSchemeToSignature sch + typeSchemeToSignature sch typeSchemeToSignature :: PLC.TypeScheme PlcTerm args res -> Signature typeSchemeToSignature = toSig [] where toSig :: [QVarOrType] -> PLC.TypeScheme PlcTerm args res -> Signature toSig acc = - \case - pR@PLC.TypeSchemeResult -> Signature acc (PLC.toTypeAst pR) - arr@(PLC.TypeSchemeArrow schB) -> - toSig (acc ++ [Type $ PLC.toTypeAst $ PLC.argProxy arr]) schB - PLC.TypeSchemeAll proxy schK -> - case proxy of - (_ :: Proxy '(text, uniq, kind)) -> - toSig (acc ++ [QVar $ symbolVal @text Proxy]) schK + \case + pR@PLC.TypeSchemeResult -> Signature acc (PLC.toTypeAst pR) + arr@(PLC.TypeSchemeArrow schB) -> + toSig (acc ++ [Type $ PLC.toTypeAst $ PLC.argProxy arr]) schB + PLC.TypeSchemeAll proxy schK -> + case proxy of + (_ :: Proxy '(text, uniq, kind)) -> + toSig (acc ++ [QVar $ symbolVal @text Proxy]) schK type PlcTerm = PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () + -- Some types to represent signatures of built-in functions type PlcType = PLC.Type PLC.TyName PLC.DefaultUni () data QVarOrType = QVar String | Type PlcType -- Quantified type variable or actual type data Signature = Signature [QVarOrType] PlcType -- Argument types, return type instance Show Signature where - show (Signature args res) = - "[ " ++ (intercalate ", " $ map showQT args) ++ " ] -> " ++ showTy (normTy res) - where - showQT = - \case - QVar tv -> "forall " ++ tv - Type ty -> showTy (normTy ty) - normTy :: PlcType -> PlcType - normTy ty = PLC.runQuote $ PLC.unNormalized <$> normalizeType ty - showTy ty = - case ty of - PLC.TyBuiltin _ t -> show $ PP.pretty t - PLC.TyApp{} -> showMultiTyApp $ unwrapTyApp ty - _ -> show $ PP.pretty ty - unwrapTyApp ty = - case ty of - PLC.TyApp _ t1 t2 -> unwrapTyApp t1 ++ [t2] - -- Assumes iterated built-in type applications all associate to the left; - -- if not, we'll just get some odd formatting. - _ -> [ty] - showMultiTyApp = - \case - [] -> "" -- Should never happen - op : tys -> showTy op ++ "(" ++ intercalate ", " (map showTy tys) ++ ")" + show (Signature args res) = + "[ " ++ (intercalate ", " $ map showQT args) ++ " ] -> " ++ showTy (normTy res) + where + showQT = + \case + QVar tv -> "forall " ++ tv + Type ty -> showTy (normTy ty) + normTy :: PlcType -> PlcType + normTy ty = PLC.runQuote $ PLC.unNormalized <$> normalizeType ty + showTy ty = + case ty of + PLC.TyBuiltin _ t -> show $ PP.pretty t + PLC.TyApp {} -> showMultiTyApp $ unwrapTyApp ty + _ -> show $ PP.pretty ty + unwrapTyApp ty = + case ty of + PLC.TyApp _ t1 t2 -> unwrapTyApp t1 ++ [t2] + -- Assumes iterated built-in type applications all associate to the left; + -- if not, we'll just get some odd formatting. + _ -> [ty] + showMultiTyApp = + \case + [] -> "" -- Should never happen + op : tys -> showTy op ++ "(" ++ intercalate ", " (map showTy tys) ++ ")" diff --git a/plutus-core/executables/plutus/Mode/PrintCostModel.hs b/plutus-core/executables/plutus/Mode/PrintCostModel.hs index c3ef3368fcc..c1eb836e96c 100644 --- a/plutus-core/executables/plutus/Mode/PrintCostModel.hs +++ b/plutus-core/executables/plutus/Mode/PrintCostModel.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ImplicitParams #-} -module Mode.PrintCostModel - ( runPrintCostModel - ) where + +module Mode.PrintCostModel ( + runPrintCostModel, +) where import Common import GetOpt @@ -13,10 +14,10 @@ import Data.Maybe runPrintCostModel :: (?opts :: Opts) => IO () runPrintCostModel = do - -- MAYBE: move to print-cost-model executable impl. which is much prettier - printE "Cost model of latest plutus version:" - -- TODO: add a semantic variant here to get the right machine parameters - let params = fromJust PLC.defaultCostModelParamsForTesting + -- MAYBE: move to print-cost-model executable impl. which is much prettier + printE "Cost model of latest plutus version:" + -- TODO: add a semantic variant here to get the right machine parameters + let params = fromJust PLC.defaultCostModelParamsForTesting - BSL.putStr $ Aeson.encodePretty params - putStrLn "" -- just for reading clarity + BSL.putStr $ Aeson.encodePretty params + putStrLn "" -- just for reading clarity diff --git a/plutus-core/executables/plutus/Types.hs b/plutus-core/executables/plutus/Types.hs index ab012b7c067..ed16199e91f 100644 --- a/plutus-core/executables/plutus/Types.hs +++ b/plutus-core/executables/plutus/Types.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} -- all following needed for singletons-th {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} + module Types where import PlutusCore qualified as PLC @@ -19,57 +20,57 @@ import Data.Singletons.TH import Prettyprinter data Naming - = Name - | DeBruijn - | NamedDeBruijn - deriving stock (Eq, Show) + = Name + | DeBruijn + | NamedDeBruijn + deriving stock (Eq, Show) data Ann - = Unit - | TxSrcSpans - -- MAYBE: | Coverage - -- MAYBE: | Provenance - deriving stock (Eq, Show) + = Unit + | TxSrcSpans + -- MAYBE: | Coverage + -- MAYBE: | Provenance + deriving stock (Eq, Show) data Lang - = Pir { _naming :: Naming, _ann :: Ann } - | Plc { _naming :: Naming, _ann :: Ann } - | Uplc { _naming :: Naming, _ann :: Ann } - | Data -- FIXME: naming,ann partial for data - deriving stock (Eq, Show) + = Pir {_naming :: Naming, _ann :: Ann} + | Plc {_naming :: Naming, _ann :: Ann} + | Uplc {_naming :: Naming, _ann :: Ann} + | Data -- FIXME: naming,ann partial for data + deriving stock (Eq, Show) makeLenses ''Lang data Format - = Text - | Flat_ - | Cbor - | Json - deriving stock (Show) + = Text + | Flat_ + | Cbor + | Json + deriving stock (Show) -- untyped data FileType = FileType - { _fFormat :: Format - , _fLang :: Lang - } - deriving stock (Show) + { _fFormat :: Format + , _fLang :: Lang + } + deriving stock (Show) makeLenses ''FileType -- TODO: in-filenames should be typed separately than out-filenames data FileName - = AbsolutePath FilePath - | Example ExampleName - | StdIn - | StdOut - deriving stock (Eq, Show) + = AbsolutePath FilePath + | Example ExampleName + | StdIn + | StdOut + deriving stock (Eq, Show) type ExampleName = String -- tagged by the lang data File (l :: Lang) = File - { _fType :: FileType - , _fName :: Maybe FileName - } - deriving stock (Show) + { _fType :: FileType + , _fName :: Maybe FileName + } + deriving stock (Show) makeLenses ''File -- | Try to mimick the behaviour of GHC , which is: @@ -78,47 +79,48 @@ makeLenses ''File -- -O2 Enable level 2 optimisations -- -O⟨n⟩ Any -On where n > 2 is the same as -O2 data OptimiseLvl - = NoOptimise -- -O0 , default - | SafeOptimise -- -O, -O1 , safe - | UnsafeOptimise -- -O>=2, unsafe - deriving stock (Show) + = NoOptimise -- -O0 , default + | SafeOptimise -- -O, -O1 , safe + | UnsafeOptimise -- -O>=2, unsafe + deriving stock (Show) data Mode - = Help - | Version - | Compile AfterCompile - | PrintBuiltins - | PrintCostModel - | ListExamples - deriving stock (Show) + = Help + | Version + | Compile AfterCompile + | PrintBuiltins + | PrintCostModel + | ListExamples + deriving stock (Show) data AfterCompile - = Exit - | Run - | Bench Secs - | Debug DebugInterface -- ^ the tx dir - deriving stock (Show) + = Exit + | Run + | Bench Secs + | -- | the tx dir + Debug DebugInterface + deriving stock (Show) type Secs = Int data DebugInterface - = TUI - | CLI - deriving stock (Show) + = TUI + | CLI + deriving stock (Show) -- | ONLY applicable for Text output. data PrettyStyle - = Classic - | ClassicSimple - | Readable - | ReadableSimple - deriving stock (Show) + = Classic + | ClassicSimple + | Readable + | ReadableSimple + deriving stock (Show) data Verbosity - = VQuiet - | VStandard - | VDebug - deriving stock (Eq, Show) + = VQuiet + | VStandard + | VDebug + deriving stock (Eq, Show) -- SINGLETONS-related --------------------- @@ -133,39 +135,39 @@ data SomeAst = forall s. SomeAst (SLang s) (FromLang s) -- the way to go from a runtime value to the dependent pair mkSomeFile :: FileType -> Maybe FileName -> SomeFile mkSomeFile ft fn = - -- Note to self: beware of let bindings here because of - -- MonomorphismRestriction + MonoLocalBinds (implied by GADTs/TypeFamilies) - case toSing (ft^.fLang) of - SomeSing sng -> SomeFile sng (File ft fn) + -- Note to self: beware of let bindings here because of + -- MonomorphismRestriction + MonoLocalBinds (implied by GADTs/TypeFamilies) + case toSing (ft ^. fLang) of + SomeSing sng -> SomeFile sng (File ft fn) type family FromLang (lang :: Lang) = result | result -> lang where - FromLang ('Pir n a) = PIR.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) - FromLang ('Plc n a) = PLC.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) - FromLang ('Uplc n a) = UPLC.UnrestrictedProgram (FromName n) DefaultUni DefaultFun (FromAnn a) - FromLang 'Data = PLC.Data + FromLang ('Pir n a) = PIR.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) + FromLang ('Plc n a) = PLC.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) + FromLang ('Uplc n a) = UPLC.UnrestrictedProgram (FromName n) DefaultUni DefaultFun (FromAnn a) + FromLang 'Data = PLC.Data type family FromName (naming :: Naming) = result | result -> naming where - FromName 'Name = PLC.Name - FromName 'DeBruijn = PLC.DeBruijn - FromName 'NamedDeBruijn = PLC.NamedDeBruijn + FromName 'Name = PLC.Name + FromName 'DeBruijn = PLC.DeBruijn + FromName 'NamedDeBruijn = PLC.NamedDeBruijn type family FromNameTy (naming :: Naming) = result | result -> naming where - FromNameTy 'Name = PLC.TyName - FromNameTy 'DeBruijn = PLC.TyDeBruijn - FromNameTy 'NamedDeBruijn = PLC.NamedTyDeBruijn + FromNameTy 'Name = PLC.TyName + FromNameTy 'DeBruijn = PLC.TyDeBruijn + FromNameTy 'NamedDeBruijn = PLC.NamedTyDeBruijn type family FromAnn (ann :: Ann) = result | result -> ann where - FromAnn 'Unit = () - FromAnn 'TxSrcSpans = PLC.SrcSpans + FromAnn 'Unit = () + FromAnn 'TxSrcSpans = PLC.SrcSpans instance Show SomeFile where - show (SomeFile _ f) = show f + show (SomeFile _ f) = show f instance Pretty SomeFile where - pretty = viaShow + pretty = viaShow instance Pretty (File l) where - pretty = viaShow + pretty = viaShow instance Pretty Lang where - pretty = viaShow + pretty = viaShow diff --git a/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs b/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs index c70677bc24c..59cc4235be0 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs @@ -1,30 +1,34 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -- | Reading and writing ASTs with various name types in flat format. - -module PlutusCore.Executable.AstIO - ( serialisePirProgramFlat - , serialisePlcProgramFlat - , serialiseUplcProgramFlat - , loadPirASTfromFlat - , loadPlcASTfromFlat - , loadUplcASTfromFlat - , fromNamedDeBruijnUPLC - , toDeBruijnTermPLC - , toDeBruijnTermUPLC - , toDeBruijnTypePLC - , toNamedDeBruijnUPLC - ) +module PlutusCore.Executable.AstIO ( + serialisePirProgramFlat, + serialisePlcProgramFlat, + serialiseUplcProgramFlat, + loadPirASTfromFlat, + loadPlcASTfromFlat, + loadUplcASTfromFlat, + fromNamedDeBruijnUPLC, + toDeBruijnTermPLC, + toDeBruijnTermUPLC, + toDeBruijnTypePLC, + toNamedDeBruijnUPLC, +) where import PlutusCore.Executable.Types import PlutusPrelude import PlutusCore qualified as PLC -import PlutusCore.DeBruijn (deBruijnTy, fakeNameDeBruijn, fakeTyNameDeBruijn, unNameDeBruijn, - unNameTyDeBruijn) +import PlutusCore.DeBruijn ( + deBruijnTy, + fakeNameDeBruijn, + fakeTyNameDeBruijn, + unNameDeBruijn, + unNameTyDeBruijn, + ) import PlutusIR.Core.Instance.Pretty () @@ -61,6 +65,7 @@ unsupportedNameTypeError nameType = error $ "ASTs with " ++ show nameType ++ " n ---------------- Name conversions ---------------- -- Untyped terms and programs + -- | Convert an untyped term to one where the 'name' type is textual names -- with de Bruijn indices. toNamedDeBruijnTermUPLC :: UplcTerm ann -> UplcTermNDB ann @@ -83,8 +88,10 @@ toDeBruijnUPLC (UPLC.Program ann ver term) = -- | Convert an untyped program with named de Bruijn indices to one with textual names. fromNamedDeBruijnUPLC :: UplcProgNDB ann -> UplcProg ann -fromNamedDeBruijnUPLC = unsafeFromRight @PLC.FreeVariableError - . PLC.runQuoteT . traverseOf UPLC.progTerm UPLC.unDeBruijnTerm +fromNamedDeBruijnUPLC = + unsafeFromRight @PLC.FreeVariableError + . PLC.runQuoteT + . traverseOf UPLC.progTerm UPLC.unDeBruijnTerm -- | Convert an untyped program with de Bruijn indices to one with textual names. fromDeBruijnUPLC :: UplcProgDB ann -> UplcProg ann @@ -118,12 +125,14 @@ toNamedDeBruijnTypePLC = unsafeFromRight @PLC.FreeVariableError . deBruijnTy -- | Convert a type to one where the 'tyname' type is de Bruijn indices. toDeBruijnTypePLC :: PlcType ann -> PlcTypeDB ann -toDeBruijnTypePLC = PLC.typeMapNames unNameTyDeBruijn. toNamedDeBruijnTypePLC +toDeBruijnTypePLC = PLC.typeMapNames unNameTyDeBruijn . toNamedDeBruijnTypePLC -- | Convert a typed program with named de Bruijn indices to one with textual names. fromNamedDeBruijnPLC :: PlcProgNDB ann -> PlcProg ann -fromNamedDeBruijnPLC = unsafeFromRight @PLC.FreeVariableError - . PLC.runQuoteT . traverseOf PLC.progTerm PLC.unDeBruijnTerm +fromNamedDeBruijnPLC = + unsafeFromRight @PLC.FreeVariableError + . PLC.runQuoteT + . traverseOf PLC.progTerm PLC.unDeBruijnTerm -- | Convert a typed program with de Bruijn indices to one with textual names. fromDeBruijnPLC :: PlcProgDB ann -> PlcProg ann @@ -131,85 +140,85 @@ fromDeBruijnPLC = fromNamedDeBruijnPLC . PLC.programMapNames fakeTyNameDeBruijn -- Flat serialisation in various formats. -serialisePirProgramFlat - :: Flat ann - => AstNameType - -> PirProg ann - -> BSL.ByteString +serialisePirProgramFlat :: + Flat ann => + AstNameType -> + PirProg ann -> + BSL.ByteString serialisePirProgramFlat = - \case - Named -> BSL.fromStrict . flat - DeBruijn -> unsupportedNameTypeError DeBruijn - NamedDeBruijn -> unsupportedNameTypeError NamedDeBruijn - -serialisePlcProgramFlat - :: Flat ann - => AstNameType - -> PlcProg ann - -> BSL.ByteString + \case + Named -> BSL.fromStrict . flat + DeBruijn -> unsupportedNameTypeError DeBruijn + NamedDeBruijn -> unsupportedNameTypeError NamedDeBruijn + +serialisePlcProgramFlat :: + Flat ann => + AstNameType -> + PlcProg ann -> + BSL.ByteString serialisePlcProgramFlat = - \case - Named -> BSL.fromStrict . flat - DeBruijn -> BSL.fromStrict . flat . toDeBruijnPLC - NamedDeBruijn -> BSL.fromStrict . flat . toNamedDeBruijnPLC - -serialiseUplcProgramFlat - :: Flat ann - => AstNameType - -> UplcProg ann - -> BSL.ByteString + \case + Named -> BSL.fromStrict . flat + DeBruijn -> BSL.fromStrict . flat . toDeBruijnPLC + NamedDeBruijn -> BSL.fromStrict . flat . toNamedDeBruijnPLC + +serialiseUplcProgramFlat :: + Flat ann => + AstNameType -> + UplcProg ann -> + BSL.ByteString serialiseUplcProgramFlat = - \case - Named -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram - DeBruijn -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram . toDeBruijnUPLC - NamedDeBruijn -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram . toNamedDeBruijnUPLC + \case + Named -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram + DeBruijn -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram . toDeBruijnUPLC + NamedDeBruijn -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram . toNamedDeBruijnUPLC -- Deserialising ASTs from Flat -- Read a binary-encoded file (eg, Flat-encoded PLC) getBinaryInput :: Input -> IO BSL.ByteString -getBinaryInput StdInput = BSL.getContents +getBinaryInput StdInput = BSL.getContents getBinaryInput (FileInput file) = BSL.readFile file unflatOrFail :: Flat a => BSL.ByteString -> a unflatOrFail input = - case unflat input of - Left e -> error $ "Flat deserialisation failure: " ++ show e - Right r -> r - -loadPirASTfromFlat - :: Flat a - => AstNameType - -> Input - -> IO (PirProg a) + case unflat input of + Left e -> error $ "Flat deserialisation failure: " ++ show e + Right r -> r + +loadPirASTfromFlat :: + Flat a => + AstNameType -> + Input -> + IO (PirProg a) loadPirASTfromFlat flatMode inp = - getBinaryInput inp <&> - case flatMode of + getBinaryInput inp + <&> case flatMode of Named -> unflatOrFail - _ -> unsupportedNameTypeError flatMode + _ -> unsupportedNameTypeError flatMode -- | Read and deserialise a Flat-encoded PIR/PLC AST -loadPlcASTfromFlat - :: Flat a - => AstNameType - -> Input - -> IO (PlcProg a) +loadPlcASTfromFlat :: + Flat a => + AstNameType -> + Input -> + IO (PlcProg a) loadPlcASTfromFlat flatMode inp = - getBinaryInput inp <&> - case flatMode of - Named -> unflatOrFail - DeBruijn -> unflatOrFail <&> fromDeBruijnPLC + getBinaryInput inp + <&> case flatMode of + Named -> unflatOrFail + DeBruijn -> unflatOrFail <&> fromDeBruijnPLC NamedDeBruijn -> unflatOrFail <&> fromNamedDeBruijnPLC -- | Read and deserialise a Flat-encoded UPLC AST -loadUplcASTfromFlat - :: Flat ann - => AstNameType - -> Input - -> IO (UplcProg ann) +loadUplcASTfromFlat :: + Flat ann => + AstNameType -> + Input -> + IO (UplcProg ann) loadUplcASTfromFlat flatMode inp = - getBinaryInput inp <&> - case flatMode of - Named -> unflatOrFail <&> UPLC.unUnrestrictedProgram - DeBruijn -> unflatOrFail <&> UPLC.unUnrestrictedProgram <&> fromDeBruijnUPLC + getBinaryInput inp + <&> case flatMode of + Named -> unflatOrFail <&> UPLC.unUnrestrictedProgram + DeBruijn -> unflatOrFail <&> UPLC.unUnrestrictedProgram <&> fromDeBruijnUPLC NamedDeBruijn -> unflatOrFail <&> UPLC.unUnrestrictedProgram <&> fromNamedDeBruijnUPLC diff --git a/plutus-core/executables/src/PlutusCore/Executable/Common.hs b/plutus-core/executables/src/PlutusCore/Executable/Common.hs index 3e39fbca0f1..43aa97df937 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Common.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Common.hs @@ -1,36 +1,36 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module PlutusCore.Executable.Common - ( module PlutusCore.Executable.Types - , PrintBudgetState - , getInput - , getInteresting - , getPlcExamples - , prettyPrintByMode - , getUplcExamples - , helpText - , loadASTfromFlat - , parseInput - , parseNamedProgram - , printBudgetState - , readProgram - , runConvert - , runDumpModel - , runPrint - , runPrintBuiltinSignatures - , runPrintExample - , topSrcSpan - , writeFlat - , writePrettyToOutput - , writeProgram - , writeToOutput - ) where +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module PlutusCore.Executable.Common ( + module PlutusCore.Executable.Types, + PrintBudgetState, + getInput, + getInteresting, + getPlcExamples, + prettyPrintByMode, + getUplcExamples, + helpText, + loadASTfromFlat, + parseInput, + parseNamedProgram, + printBudgetState, + readProgram, + runConvert, + runDumpModel, + runPrint, + runPrintBuiltinSignatures, + runPrintExample, + topSrcSpan, + writeFlat, + writePrettyToOutput, + writeProgram, + writeToOutput, +) where import PlutusPrelude @@ -88,124 +88,125 @@ import Text.Printf (printf) ----------- ProgramLike type class ----------- class ProgramLike p where - -- | Parse a program. The first argument (normally the file path) describes - -- the input stream, the second is the program text. - parseNamedProgram :: - String -> T.Text -> Either ParserErrorBundle (p PLC.SrcSpan) - - -- | Check a program for unique names. - -- Throws a @UniqueError@ when not all names are unique. - checkUniques :: - ( Ord ann - , MonadError (PLC.UniqueError ann) m - ) => - p ann -> - m () - - -- | Convert names to de Bruijn indices and then serialise - serialiseProgramFlat :: (Flat ann, PP.Pretty ann) => AstNameType -> p ann -> BSL.ByteString - - -- | Read and deserialise a Flat-encoded AST - loadASTfromFlat :: Flat ann => AstNameType -> Input -> IO (p ann) + -- | Parse a program. The first argument (normally the file path) describes + -- the input stream, the second is the program text. + parseNamedProgram :: + String -> T.Text -> Either ParserErrorBundle (p PLC.SrcSpan) + + -- | Check a program for unique names. + -- Throws a @UniqueError@ when not all names are unique. + checkUniques :: + ( Ord ann + , MonadError (PLC.UniqueError ann) m + ) => + p ann -> + m () + + -- | Convert names to de Bruijn indices and then serialise + serialiseProgramFlat :: (Flat ann, PP.Pretty ann) => AstNameType -> p ann -> BSL.ByteString + + -- | Read and deserialise a Flat-encoded AST + loadASTfromFlat :: Flat ann => AstNameType -> Input -> IO (p ann) -- | Instance for PIR program. instance ProgramLike PirProg where - parseNamedProgram inputName = PLC.runQuoteT . PIR.parse PIR.program inputName - checkUniques = PIR.checkProgram (const True) - serialiseProgramFlat = serialisePirProgramFlat - loadASTfromFlat = loadPirASTfromFlat + parseNamedProgram inputName = PLC.runQuoteT . PIR.parse PIR.program inputName + checkUniques = PIR.checkProgram (const True) + serialiseProgramFlat = serialisePirProgramFlat + loadASTfromFlat = loadPirASTfromFlat -- | Instance for PLC program. instance ProgramLike PlcProg where - parseNamedProgram inputName = PLC.runQuoteT . UPLC.parse PLC.program inputName - checkUniques = PLC.checkProgram (const True) - serialiseProgramFlat = serialisePlcProgramFlat - loadASTfromFlat = loadPlcASTfromFlat + parseNamedProgram inputName = PLC.runQuoteT . UPLC.parse PLC.program inputName + checkUniques = PLC.checkProgram (const True) + serialiseProgramFlat = serialisePlcProgramFlat + loadASTfromFlat = loadPlcASTfromFlat -- | Instance for UPLC program. instance ProgramLike UplcProg where - parseNamedProgram inputName = PLC.runQuoteT . UPLC.parse UPLC.program inputName - checkUniques = UPLC.checkProgram (const True) - serialiseProgramFlat = serialiseUplcProgramFlat - loadASTfromFlat = loadUplcASTfromFlat - + parseNamedProgram inputName = PLC.runQuoteT . UPLC.parse UPLC.program inputName + checkUniques = UPLC.checkProgram (const True) + serialiseProgramFlat = serialiseUplcProgramFlat + loadASTfromFlat = loadUplcASTfromFlat ---------------- Printing budgets and costs ---------------- -- Convert a time in picoseconds into a readable format with appropriate units formatTimePicoseconds :: Double -> String formatTimePicoseconds t - | t >= 1e12 = printf "%.3f s" (t / 1e12) - | t >= 1e9 = printf "%.3f ms" (t / 1e9) - | t >= 1e6 = printf "%.3f μs" (t / 1e6) - | t >= 1e3 = printf "%.3f ns" (t / 1e3) - | otherwise = printf "%f ps" t + | t >= 1e12 = printf "%.3f s" (t / 1e12) + | t >= 1e9 = printf "%.3f ms" (t / 1e9) + | t >= 1e6 = printf "%.3f μs" (t / 1e6) + | t >= 1e3 = printf "%.3f ns" (t / 1e3) + | otherwise = printf "%f ps" t printBudgetStateBudget :: CekModel -> ExBudget -> IO () printBudgetStateBudget model b = - case model of - Unit -> pure () - _ -> - let ExCPU cpu = exBudgetCPU b - ExMemory mem = exBudgetMemory b - in do - putStrLn $ "CPU budget: " ++ show cpu - putStrLn $ "Memory budget: " ++ show mem + case model of + Unit -> pure () + _ -> + let ExCPU cpu = exBudgetCPU b + ExMemory mem = exBudgetMemory b + in do + putStrLn $ "CPU budget: " ++ show cpu + putStrLn $ "Memory budget: " ++ show mem printBudgetStateTally :: - (Cek.Hashable fun, Show fun) => - UplcTerm () -> - CekModel -> - Cek.CekExTally fun -> - IO () + (Cek.Hashable fun, Show fun) => + UplcTerm () -> + CekModel -> + Cek.CekExTally fun -> + IO () printBudgetStateTally term model (Cek.CekExTally costs) = do - traverse_ printStepCost allStepKinds - putStrLn "" - putStrLn $ "startup " ++ (budgetToString $ getSpent Cek.BStartup) - putStrLn $ "compute " ++ budgetToString totalComputeCost - putStrLn $ "AST nodes " ++ printf "%15d" (UPLC.unAstSize $ UPLC.termAstSize term) - putStrLn "" - case model of - Default -> - do - putStrLn "" - traverse_ - ( \(b, cost) -> - putStrLn $ printf "%-22s %s" (show b) (budgetToString cost :: String) - ) - builtinsAndCosts - putStrLn "" - putStrLn $ "Total builtin costs: " ++ budgetToString totalBuiltinCosts - printf "Time spent executing builtins: %4.2f%%\n" - (100 * getCPU totalBuiltinCosts / getCPU totalCost) - putStrLn "" - putStrLn $ "Total budget spent: " ++ printf (budgetToString totalCost) - putStrLn $ "Predicted execution time: " - ++ (formatTimePicoseconds $ getCPU totalCost) - Unit -> do - putStrLn "" - traverse_ - ( \(b, cost) -> - putStrLn $ printf "%-22s %s" (show b) (budgetToString cost :: String) - ) - builtinsAndCosts + traverse_ printStepCost allStepKinds + putStrLn "" + putStrLn $ "startup " ++ (budgetToString $ getSpent Cek.BStartup) + putStrLn $ "compute " ++ budgetToString totalComputeCost + putStrLn $ "AST nodes " ++ printf "%15d" (UPLC.unAstSize $ UPLC.termAstSize term) + putStrLn "" + case model of + Default -> + do + putStrLn "" + traverse_ + ( \(b, cost) -> + putStrLn $ printf "%-22s %s" (show b) (budgetToString cost :: String) + ) + builtinsAndCosts + putStrLn "" + putStrLn $ "Total builtin costs: " ++ budgetToString totalBuiltinCosts + printf + "Time spent executing builtins: %4.2f%%\n" + (100 * getCPU totalBuiltinCosts / getCPU totalCost) + putStrLn "" + putStrLn $ "Total budget spent: " ++ printf (budgetToString totalCost) + putStrLn $ + "Predicted execution time: " + ++ (formatTimePicoseconds $ getCPU totalCost) + Unit -> do + putStrLn "" + traverse_ + ( \(b, cost) -> + putStrLn $ printf "%-22s %s" (show b) (budgetToString cost :: String) + ) + builtinsAndCosts where - allStepKinds = [minBound..maxBound] :: [Cek.StepKind] + allStepKinds = [minBound .. maxBound] :: [Cek.StepKind] getSpent k = - case H.lookup k costs of - Just v -> v - Nothing -> ExBudget 0 0 + case H.lookup k costs of + Just v -> v + Nothing -> ExBudget 0 0 totalComputeCost = - -- For unitCekCosts this will be the total number of compute steps - foldMap (getSpent . Cek.BStep) allStepKinds + -- For unitCekCosts this will be the total number of compute steps + foldMap (getSpent . Cek.BStep) allStepKinds budgetToString (ExBudget (ExCPU cpu) (ExMemory mem)) = - case model of - -- Not %d: doesn't work when CostingInteger is SatInt. - Default -> printf "%15s %15s" (show cpu) (show mem) :: String - -- Memory usage figures are meaningless in this case - Unit -> printf "%15s" (show cpu) :: String + case model of + -- Not %d: doesn't work when CostingInteger is SatInt. + Default -> printf "%15s %15s" (show cpu) (show mem) :: String + -- Memory usage figures are meaningless in this case + Unit -> printf "%15s" (show cpu) :: String printStepCost constr = - printf "%-10s %20s\n" (tail $ show constr) (budgetToString . getSpent $ Cek.BStep constr) + printf "%-10s %20s\n" (tail $ show constr) (budgetToString . getSpent $ Cek.BStep constr) getBuiltinCost l e = case e of (Cek.BBuiltinApp b, cost) -> (b, cost) : l; _ -> l builtinsAndCosts = List.foldl getBuiltinCost [] (H.toList costs) totalBuiltinCosts = mconcat (map snd builtinsAndCosts) @@ -213,11 +214,11 @@ printBudgetStateTally term model (Cek.CekExTally costs) = do totalCost = getSpent Cek.BStartup <> totalComputeCost <> totalBuiltinCosts :: ExBudget class PrintBudgetState cost where - printBudgetState :: - UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () -> - CekModel -> - cost -> - IO () + printBudgetState :: + UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () -> + CekModel -> + cost -> + IO () -- TODO: Tidy this up. We're passing in the term and the CEK cost model -- here, but we only need them in tallying mode (where we need the term so @@ -225,82 +226,82 @@ class PrintBudgetState cost where -- much information we're going to print out). instance PrintBudgetState Cek.CountingSt where - printBudgetState _term model (Cek.CountingSt budget) = printBudgetStateBudget model budget + printBudgetState _term model (Cek.CountingSt budget) = printBudgetStateBudget model budget instance (Cek.Hashable fun, Show fun) => PrintBudgetState (Cek.TallyingSt fun) where - printBudgetState term model (Cek.TallyingSt tally budget) = do - printBudgetStateBudget model budget - putStrLn "" - printBudgetStateTally term model tally + printBudgetState term model (Cek.TallyingSt tally budget) = do + printBudgetStateBudget model budget + putStrLn "" + printBudgetStateTally term model tally instance PrintBudgetState Cek.RestrictingSt where - printBudgetState _term model (Cek.RestrictingSt (ExRestrictingBudget budget)) = - printBudgetStateBudget model budget + printBudgetState _term model (Cek.RestrictingSt (ExRestrictingBudget budget)) = + printBudgetStateBudget model budget helpText :: - -- | Either "Untyped Plutus Core" or "Typed Plutus Core" - String -> - String + -- | Either "Untyped Plutus Core" or "Typed Plutus Core" + String -> + String helpText lang = - "This program provides a number of utilities for dealing with " - ++ lang - ++ " programs, including application, evaluation, and conversion between a " - ++ "number of different formats. The program also provides a number of example " - ++ "programs. Some commands read or write Plutus Core abstract " - ++ "syntax trees serialised in Flat format: ASTs are always written with " - ++ "unit annotations, and any Flat-encoded AST supplied as input must also be " - ++ "equipped with unit annotations. Attempting to read a serialised AST with any " - ++ "non-unit annotation type will cause an error." - + "This program provides a number of utilities for dealing with " + ++ lang + ++ " programs, including application, evaluation, and conversion between a " + ++ "number of different formats. The program also provides a number of example " + ++ "programs. Some commands read or write Plutus Core abstract " + ++ "syntax trees serialised in Flat format: ASTs are always written with " + ++ "unit annotations, and any Flat-encoded AST supplied as input must also be " + ++ "equipped with unit annotations. Attempting to read a serialised AST with any " + ++ "non-unit annotation type will cause an error." ---------------- Reading programs from files ---------------- -- Read a source program getInput :: Input -> IO T.Text getInput (FileInput file) = T.readFile file -getInput StdInput = T.getContents +getInput StdInput = T.getContents -- | Read and parse and check the program for @UniqueError@'s. parseInput :: - (ProgramLike p, PLC.Rename (p PLC.SrcSpan)) => - -- | The source program - Input -> - -- | The output is a program with annotation - IO (T.Text, p PLC.SrcSpan) + (ProgramLike p, PLC.Rename (p PLC.SrcSpan)) => + -- | The source program + Input -> + -- | The output is a program with annotation + IO (T.Text, p PLC.SrcSpan) parseInput inp = do - contents <- getInput inp - -- parse the program - case parseNamedProgram (show inp) contents of - -- when fail, pretty print the parse errors. - Left (ParseErrorB err) -> - error $ errorBundlePretty err - -- otherwise, - Right p -> do - -- run @rename@ through the program - renamed <- PLC.runQuoteT $ rename p - -- check the program for @UniqueError@'s - let checked = through PlutusCore.Executable.Common.checkUniques renamed - case checked of - -- pretty print the error - Left (err :: PLC.UniqueError PLC.SrcSpan) -> - error $ PP.render $ pretty err - Right _ -> pure (contents, p) + contents <- getInput inp + -- parse the program + case parseNamedProgram (show inp) contents of + -- when fail, pretty print the parse errors. + Left (ParseErrorB err) -> + error $ errorBundlePretty err + -- otherwise, + Right p -> do + -- run @rename@ through the program + renamed <- PLC.runQuoteT $ rename p + -- check the program for @UniqueError@'s + let checked = through PlutusCore.Executable.Common.checkUniques renamed + case checked of + -- pretty print the error + Left (err :: PLC.UniqueError PLC.SrcSpan) -> + error $ PP.render $ pretty err + Right _ -> pure (contents, p) -- Read UPLC/PLC/PIR code in either textual or Flat format, depending on 'fmt' -readProgram :: forall p. - ( ProgramLike p - , Functor p - , PLC.Rename (p PLC.SrcSpan) - ) => - Format -> - Input -> - IO (p PLC.SrcSpan) +readProgram :: + forall p. + ( ProgramLike p + , Functor p + , PLC.Rename (p PLC.SrcSpan) + ) => + Format -> + Input -> + IO (p PLC.SrcSpan) readProgram fmt inp = - case fmt of - Textual -> snd <$> parseInput inp - Flat flatMode -> do - prog <- loadASTfromFlat @p @() flatMode inp - return $ topSrcSpan <$ prog + case fmt of + Textual -> snd <$> parseInput inp + Flat flatMode -> do + prog <- loadASTfromFlat @p @() flatMode inp + return $ topSrcSpan <$ prog -- | A made-up `SrcSpan` since there's no source locations in Flat. topSrcSpan :: PLC.SrcSpan @@ -309,182 +310,180 @@ topSrcSpan = PLC.SrcSpan "top" 1 1 1 2 ---------------- Serialise a program using Flat and write it to a given output ---------------- writeFlat :: - (ProgramLike p, Functor p) => Output -> AstNameType -> p ann -> IO () + (ProgramLike p, Functor p) => Output -> AstNameType -> p ann -> IO () writeFlat outp flatMode prog = do - -- ASTs are always serialised with unit annotations to save space: `flat` - -- does not need any space to serialise (). - let flatProg = serialiseProgramFlat flatMode (void prog) - case outp of - FileOutput file -> BSL.writeFile file flatProg - StdOutput -> BSL.putStr flatProg - NoOutput -> pure () + -- ASTs are always serialised with unit annotations to save space: `flat` + -- does not need any space to serialise (). + let flatProg = serialiseProgramFlat flatMode (void prog) + case outp of + FileOutput file -> BSL.writeFile file flatProg + StdOutput -> BSL.putStr flatProg + NoOutput -> pure () ---------------- Write an AST as PLC source ---------------- prettyPrintByMode :: - PP.PrettyPlc a => PrintMode -> (a -> Doc a) + PP.PrettyPlc a => PrintMode -> (a -> Doc a) prettyPrintByMode = \case - Classic -> PP.prettyPlcClassic - Simple -> PP.prettyPlcClassicSimple - Readable -> PP.prettyPlcReadable + Classic -> PP.prettyPlcClassic + Simple -> PP.prettyPlcClassicSimple + Readable -> PP.prettyPlcReadable ReadableSimple -> PP.prettyPlcReadableSimple writeProgram :: - ( ProgramLike p - , Functor p - , PP.PrettyBy PP.PrettyConfigPlc (p ann) - ) => - Output -> - Format -> - PrintMode -> - p ann -> - IO () -writeProgram outp Textual mode prog = writePrettyToOutput outp mode prog + ( ProgramLike p + , Functor p + , PP.PrettyBy PP.PrettyConfigPlc (p ann) + ) => + Output -> + Format -> + PrintMode -> + p ann -> + IO () +writeProgram outp Textual mode prog = writePrettyToOutput outp mode prog writeProgram outp (Flat flatMode) _ prog = writeFlat outp flatMode prog writePrettyToOutput :: - (PP.PrettyBy PP.PrettyConfigPlc (p ann)) => Output -> PrintMode -> p ann -> IO () + PP.PrettyBy PP.PrettyConfigPlc (p ann) => Output -> PrintMode -> p ann -> IO () writePrettyToOutput outp mode prog = do - let printMethod = prettyPrintByMode mode - case outp of - FileOutput file -> writeFile file . Prelude.show . printMethod $ prog - StdOutput -> print . printMethod $ prog - NoOutput -> pure () + let printMethod = prettyPrintByMode mode + case outp of + FileOutput file -> writeFile file . Prelude.show . printMethod $ prog + StdOutput -> print . printMethod $ prog + NoOutput -> pure () writeToOutput :: - Show a => Output -> a -> IO () + Show a => Output -> a -> IO () writeToOutput outp v = do - case outp of - FileOutput file -> writeFile file $ show v - StdOutput -> putStrLn $ show v - NoOutput -> pure () + case outp of + FileOutput file -> writeFile file $ show v + StdOutput -> putStrLn $ show v + NoOutput -> pure () ---------------- Examples ---------------- data TypeExample = TypeExample (PLC.Kind ()) (PLC.Type PLC.TyName PLC.DefaultUni ()) data TypedTermExample - = TypedTermExample - (PLC.Type PLC.TyName PLC.DefaultUni ()) - (PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun ()) + = TypedTermExample + (PLC.Type PLC.TyName PLC.DefaultUni ()) + (PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun ()) data SomeTypedExample = SomeTypeExample TypeExample | SomeTypedTermExample TypedTermExample newtype UntypedTermExample - = UntypedTermExample - (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) + = UntypedTermExample + (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) newtype SomeUntypedExample = SomeUntypedTermExample UntypedTermExample data SomeExample = SomeTypedExample SomeTypedExample | SomeUntypedExample SomeUntypedExample prettySignature :: ExampleName -> SomeExample -> Doc ann prettySignature name (SomeTypedExample (SomeTypeExample (TypeExample kind _))) = - pretty name <+> "::" <+> PP.prettyPlc kind + pretty name <+> "::" <+> PP.prettyPlc kind prettySignature name (SomeTypedExample (SomeTypedTermExample (TypedTermExample ty _))) = - pretty name <+> ":" <+> PP.prettyPlc ty + pretty name <+> ":" <+> PP.prettyPlc ty prettySignature name (SomeUntypedExample _) = - pretty name + pretty name prettyExample :: SomeExample -> Doc ann prettyExample = - \case - SomeTypedExample (SomeTypeExample (TypeExample _ ty)) -> PP.prettyPlc ty - SomeTypedExample (SomeTypedTermExample (TypedTermExample _ term)) -> - PP.prettyPlc $ PLC.Program () PLC.latestVersion term - SomeUntypedExample (SomeUntypedTermExample (UntypedTermExample term)) -> - PP.prettyPlc $ UPLC.Program () PLC.latestVersion term + \case + SomeTypedExample (SomeTypeExample (TypeExample _ ty)) -> PP.prettyPlc ty + SomeTypedExample (SomeTypedTermExample (TypedTermExample _ term)) -> + PP.prettyPlc $ PLC.Program () PLC.latestVersion term + SomeUntypedExample (SomeUntypedTermExample (UntypedTermExample term)) -> + PP.prettyPlc $ UPLC.Program () PLC.latestVersion term toTypedTermExample :: - PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () -> TypedTermExample + PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () -> TypedTermExample toTypedTermExample term = TypedTermExample ty term where program = PLC.Program () PLC.latestVersion term errOrTy = PLC.runQuote . runExceptT $ do - tcConfig <- modifyError PLC.TypeErrorE $ PLC.getDefTypeCheckConfig () - modifyError PLC.TypeErrorE $ PLC.inferTypeOfProgram tcConfig program + tcConfig <- modifyError PLC.TypeErrorE $ PLC.getDefTypeCheckConfig () + modifyError PLC.TypeErrorE $ PLC.inferTypeOfProgram tcConfig program ty = case errOrTy of - Left (err :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) -> - error $ PP.displayPlc err - Right vTy -> PLC.unNormalized vTy + Left (err :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) -> + error $ PP.displayPlc err + Right vTy -> PLC.unNormalized vTy getInteresting :: IO [(ExampleName, PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun ())] getInteresting = - sequence $ Gen.fromInterestingTermGens $ \name gen -> do - Gen.TermOf term _ <- Gen.getSampleTermValue gen - pure (T.pack name, term) + sequence $ Gen.fromInterestingTermGens $ \name gen -> do + Gen.TermOf term _ <- Gen.getSampleTermValue gen + pure (T.pack name, term) simpleExamples :: [(ExampleName, SomeTypedExample)] simpleExamples = - [ ("succInteger", SomeTypedTermExample $ toTypedTermExample StdLib.succInteger) - , ("unit", SomeTypeExample $ TypeExample (PLC.Type ()) StdLib.unit) - , ("unitval", SomeTypedTermExample $ toTypedTermExample StdLib.unitval) - , ("bool", SomeTypeExample $ TypeExample (PLC.Type ()) StdLib.bool) - , ("true", SomeTypedTermExample $ toTypedTermExample StdLib.true) - , ("false", SomeTypedTermExample $ toTypedTermExample StdLib.false) - , ("churchNat", SomeTypeExample $ TypeExample (PLC.Type ()) StdLib.churchNat) - , ("churchZero", SomeTypedTermExample $ toTypedTermExample StdLib.churchZero) - , ("churchSucc", SomeTypedTermExample $ toTypedTermExample StdLib.churchSucc) - ] + [ ("succInteger", SomeTypedTermExample $ toTypedTermExample StdLib.succInteger) + , ("unit", SomeTypeExample $ TypeExample (PLC.Type ()) StdLib.unit) + , ("unitval", SomeTypedTermExample $ toTypedTermExample StdLib.unitval) + , ("bool", SomeTypeExample $ TypeExample (PLC.Type ()) StdLib.bool) + , ("true", SomeTypedTermExample $ toTypedTermExample StdLib.true) + , ("false", SomeTypedTermExample $ toTypedTermExample StdLib.false) + , ("churchNat", SomeTypeExample $ TypeExample (PLC.Type ()) StdLib.churchNat) + , ("churchZero", SomeTypedTermExample $ toTypedTermExample StdLib.churchZero) + , ("churchSucc", SomeTypedTermExample $ toTypedTermExample StdLib.churchSucc) + ] getInterestingExamples :: - ([(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)]) -> - IO [(ExampleName, SomeExample)] + ([(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)]) -> + IO [(ExampleName, SomeExample)] getInterestingExamples res = do - interesting <- getInteresting - let examples = - simpleExamples - ++ map (second $ SomeTypedTermExample . toTypedTermExample) interesting - pure $ res examples + interesting <- getInteresting + let examples = + simpleExamples + ++ map (second $ SomeTypedTermExample . toTypedTermExample) interesting + pure $ res examples -- | Get available typed examples. getPlcExamples :: IO [(ExampleName, SomeExample)] getPlcExamples = getInterestingExamples $ map (fmap SomeTypedExample) -{- | Get available untyped examples. Currently the untyped - examples are obtained by erasing typed ones, but it might be useful to have - some untyped ones that can't be obtained by erasure. --} +-- | Get available untyped examples. Currently the untyped +-- examples are obtained by erasing typed ones, but it might be useful to have +-- some untyped ones that can't be obtained by erasure. getUplcExamples :: IO [(ExampleName, SomeExample)] getUplcExamples = - getInterestingExamples $ - mapMaybeSnd convert + getInterestingExamples $ + mapMaybeSnd convert where convert = - \case - SomeTypeExample _ -> Nothing - SomeTypedTermExample (TypedTermExample _ e) -> - Just . SomeUntypedExample . SomeUntypedTermExample . UntypedTermExample $ - PLC.eraseTerm e + \case + SomeTypeExample _ -> Nothing + SomeTypedTermExample (TypedTermExample _ e) -> + Just . SomeUntypedExample . SomeUntypedTermExample . UntypedTermExample $ + PLC.eraseTerm e mapMaybeSnd _ [] = [] mapMaybeSnd f ((a, b) : r) = - case f b of - Nothing -> mapMaybeSnd f r - Just b' -> (a, b') : mapMaybeSnd f r + case f b of + Nothing -> mapMaybeSnd f r + Just b' -> (a, b') : mapMaybeSnd f r -- The implementation is a little hacky: we generate interesting examples when the list of examples -- is requested and at each lookup of a particular example. I.e. each time we generate distinct -- terms. But types of those terms must not change across requests, so we're safe. - ----------------- Print examples ----------------------- runPrintExample :: - IO [(ExampleName, SomeExample)] -> - ExampleOptions -> - IO () + IO [(ExampleName, SomeExample)] -> + ExampleOptions -> + IO () runPrintExample getFn (ExampleOptions ExampleAvailable) = do - examples <- getFn - traverse_ (T.putStrLn . PP.render . uncurry prettySignature) examples + examples <- getFn + traverse_ (T.putStrLn . PP.render . uncurry prettySignature) examples runPrintExample getFn (ExampleOptions (ExampleSingle name)) = do - examples <- getFn - T.putStrLn $ case lookup name examples of - Nothing -> "Unknown name: " <> name - Just ex -> PP.render $ prettyExample ex + examples <- getFn + T.putStrLn $ case lookup name examples of + Nothing -> "Unknown name: " <> name + Just ex -> PP.render $ prettyExample ex ---------------- Print the cost model parameters ---------------- runDumpModel :: PLC.BuiltinSemanticsVariant PLC.DefaultFun -> IO () runDumpModel semvar = do - let params = fromJust $ PLC.defaultCostModelParamsForVariant semvar - BSL.putStr $ Aeson.encode params + let params = fromJust $ PLC.defaultCostModelParamsForVariant semvar + BSL.putStr $ Aeson.encode params ---------------- Print the type signatures of the default builtins ---------------- @@ -494,54 +493,54 @@ data QVarOrType = QVar String | Type PlcType -- Quantified type variable or actu data Signature = Signature [QVarOrType] PlcType -- Argument types, return type instance Show Signature where - show (Signature args res) = - "[ " ++ (intercalate ", " $ map showQT args) ++ " ] -> " ++ showTy (normTy res) - where - showQT = - \case - QVar tv -> "forall " ++ tv - Type ty -> showTy (normTy ty) - normTy :: PlcType -> PlcType - normTy ty = PLC.runQuote $ PLC.unNormalized <$> normalizeType ty - showTy ty = - case ty of - PLC.TyBuiltin _ t -> show $ PP.pretty t - PLC.TyApp{} -> showMultiTyApp $ unwrapTyApp ty - -- prettyPlcClassicSimple -> omit indices in type variables. - _ -> show $ PP.prettyPlcClassicSimple ty - -- We may want more cases here if more complex types (eg function types) - -- are allowed for builtin arguments. - unwrapTyApp ty = - case ty of - PLC.TyApp _ t1 t2 -> unwrapTyApp t1 ++ [t2] - -- Assumes iterated built-in type applications all associate to the left; - -- if not, we'll just get some odd formatting. - _ -> [ty] - showMultiTyApp = - \case - [] -> "" -- Should never happen - op : tys -> showTy op ++ "(" ++ intercalate ", " (map showTy tys) ++ ")" + show (Signature args res) = + "[ " ++ (intercalate ", " $ map showQT args) ++ " ] -> " ++ showTy (normTy res) + where + showQT = + \case + QVar tv -> "forall " ++ tv + Type ty -> showTy (normTy ty) + normTy :: PlcType -> PlcType + normTy ty = PLC.runQuote $ PLC.unNormalized <$> normalizeType ty + showTy ty = + case ty of + PLC.TyBuiltin _ t -> show $ PP.pretty t + PLC.TyApp {} -> showMultiTyApp $ unwrapTyApp ty + -- prettyPlcClassicSimple -> omit indices in type variables. + _ -> show $ PP.prettyPlcClassicSimple ty + -- We may want more cases here if more complex types (eg function types) + -- are allowed for builtin arguments. + unwrapTyApp ty = + case ty of + PLC.TyApp _ t1 t2 -> unwrapTyApp t1 ++ [t2] + -- Assumes iterated built-in type applications all associate to the left; + -- if not, we'll just get some odd formatting. + _ -> [ty] + showMultiTyApp = + \case + [] -> "" -- Should never happen + op : tys -> showTy op ++ "(" ++ intercalate ", " (map showTy tys) ++ ")" typeSchemeToSignature :: PLC.TypeScheme (PlcTerm ()) args res -> Signature typeSchemeToSignature = toSig [] where toSig :: [QVarOrType] -> PLC.TypeScheme (PlcTerm ()) args res -> Signature toSig acc = - \case - pR@PLC.TypeSchemeResult -> Signature acc (PLC.toTypeAst pR) - arr@(PLC.TypeSchemeArrow schB) -> - toSig (acc ++ [Type $ PLC.toTypeAst $ PLC.argProxy arr]) schB - PLC.TypeSchemeAll proxy schK -> - case proxy of - (_ :: Proxy '(text, uniq, kind)) -> - toSig (acc ++ [QVar $ symbolVal @text Proxy]) schK + \case + pR@PLC.TypeSchemeResult -> Signature acc (PLC.toTypeAst pR) + arr@(PLC.TypeSchemeArrow schB) -> + toSig (acc ++ [Type $ PLC.toTypeAst $ PLC.argProxy arr]) schB + PLC.TypeSchemeAll proxy schK -> + case proxy of + (_ :: Proxy '(text, uniq, kind)) -> + toSig (acc ++ [QVar $ symbolVal @text Proxy]) schK runPrintBuiltinSignatures :: IO () runPrintBuiltinSignatures = do - let builtins = enumerate @PLC.DefaultFun - mapM_ - (\x -> putStr (printf "%-35s: %s\n" (show $ PP.pretty x) (show $ getSignature x))) - builtins + let builtins = enumerate @PLC.DefaultFun + mapM_ + (\x -> putStr (printf "%-35s: %s\n" (show $ PP.pretty x) (show $ getSignature x))) + builtins where getSignature b = case PLC.toBuiltinMeaning @PLC.DefaultUni @PLC.DefaultFun @(PlcTerm ()) def b of @@ -549,33 +548,34 @@ runPrintBuiltinSignatures = do ---------------- Parse and print a PLC/UPLC source file ---------------- -runPrint - :: forall p . - ( ProgramLike p - , PLC.Rename (p PLC.SrcSpan) - , PrettyBy PP.PrettyConfigPlc (p PLC.SrcSpan) - ) - => PrintOptions - -> IO () +runPrint :: + forall p. + ( ProgramLike p + , PLC.Rename (p PLC.SrcSpan) + , PrettyBy PP.PrettyConfigPlc (p PLC.SrcSpan) + ) => + PrintOptions -> + IO () runPrint (PrintOptions inp outp mode) = do - parsed <- (snd <$> parseInput inp :: IO (p PLC.SrcSpan)) - let printed = show $ prettyPrintByMode mode parsed - case outp of - FileOutput path -> writeFile path printed - StdOutput -> putStrLn printed - NoOutput -> pure () + parsed <- (snd <$> parseInput inp :: IO (p PLC.SrcSpan)) + let printed = show $ prettyPrintByMode mode parsed + case outp of + FileOutput path -> writeFile path printed + StdOutput -> putStrLn printed + NoOutput -> pure () ---------------- Conversions ---------------- -- | Convert between textual and FLAT representations. -runConvert - :: forall (p :: Type -> Type). - ( ProgramLike p - , Functor p - , PLC.Rename (p PLC.SrcSpan) - , PP.PrettyBy PP.PrettyConfigPlc (p PLC.SrcSpan)) - => ConvertOptions - -> IO () +runConvert :: + forall (p :: Type -> Type). + ( ProgramLike p + , Functor p + , PLC.Rename (p PLC.SrcSpan) + , PP.PrettyBy PP.PrettyConfigPlc (p PLC.SrcSpan) + ) => + ConvertOptions -> + IO () runConvert (ConvertOptions inp ifmt outp ofmt mode) = do - program :: p PLC.SrcSpan <- readProgram ifmt inp - writeProgram outp ofmt mode program + program :: p PLC.SrcSpan <- readProgram ifmt inp + writeProgram outp ofmt mode program diff --git a/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs b/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs index 40992bd3aae..d35169d795b 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs @@ -1,7 +1,6 @@ {-# LANGUAGE LambdaCase #-} -- | Common option parsers for executables - module PlutusCore.Executable.Parsers where import PlutusCore.Default (BuiltinSemanticsVariant (..), DefaultFun) @@ -15,16 +14,22 @@ input :: Parser Input input = fileInput <|> stdInput <|> pure StdInput fileInput :: Parser Input -fileInput = FileInput <$> strOption - ( long "input" - <> short 'i' - <> metavar "FILENAME" - <> help "Input file" ) +fileInput = + FileInput + <$> strOption + ( long "input" + <> short 'i' + <> metavar "FILENAME" + <> help "Input file" + ) stdInput :: Parser Input -stdInput = flag' StdInput - ( long "stdin" - <> help "Read from stdin (default)" ) +stdInput = + flag' + StdInput + ( long "stdin" + <> help "Read from stdin (default)" + ) -- | Parser for an output stream. If none is specified, -- default to stdout for ease of use in pipeline. @@ -32,99 +37,124 @@ output :: Parser Output output = fileOutput <|> stdOutput <|> noOutput <|> pure StdOutput fileOutput :: Parser Output -fileOutput = FileOutput <$> strOption - ( long "output" - <> short 'o' - <> metavar "FILENAME" - <> help "Output file" ) +fileOutput = + FileOutput + <$> strOption + ( long "output" + <> short 'o' + <> metavar "FILENAME" + <> help "Output file" + ) stdOutput :: Parser Output -stdOutput = flag' StdOutput - ( long "stdout" - <> help "Write to stdout (default)" ) +stdOutput = + flag' + StdOutput + ( long "stdout" + <> help "Write to stdout (default)" + ) noOutput :: Parser Output -noOutput = flag' NoOutput - ( long "silent" - <> short 's' - <> help "Don't output the evaluation result" ) +noOutput = + flag' + NoOutput + ( long "silent" + <> short 's' + <> help "Don't output the evaluation result" + ) formatHelp :: String formatHelp = "textual, flat-named (names), flat (de Bruijn indices), " - <> "or flat-namedDeBruijn (names and de Bruijn indices)" + <> "or flat-namedDeBruijn (names and de Bruijn indices)" formatReader :: String -> Maybe Format formatReader = - \case - "textual" -> Just Textual - "flat-named" -> Just (Flat Named) - "flat" -> Just (Flat DeBruijn) - "flat-deBruijn" -> Just (Flat DeBruijn) - "flat-namedDeBruijn" -> Just (Flat NamedDeBruijn) - _ -> Nothing + \case + "textual" -> Just Textual + "flat-named" -> Just (Flat Named) + "flat" -> Just (Flat DeBruijn) + "flat-deBruijn" -> Just (Flat DeBruijn) + "flat-namedDeBruijn" -> Just (Flat NamedDeBruijn) + _ -> Nothing inputformat :: Parser Format -inputformat = option (maybeReader formatReader) - ( long "if" - <> long "input-format" - <> metavar "FORMAT" - <> value Textual - <> showDefault - <> help ("Input format: " ++ formatHelp)) +inputformat = + option + (maybeReader formatReader) + ( long "if" + <> long "input-format" + <> metavar "FORMAT" + <> value Textual + <> showDefault + <> help ("Input format: " ++ formatHelp) + ) outputformat :: Parser Format -outputformat = option (maybeReader formatReader) - ( long "of" - <> long "output-format" - <> metavar "FORMAT" - <> value Textual - <> showDefault - <> help ("Output format: " ++ formatHelp)) +outputformat = + option + (maybeReader formatReader) + ( long "of" + <> long "output-format" + <> metavar "FORMAT" + <> value Textual + <> showDefault + <> help ("Output format: " ++ formatHelp) + ) tracemode :: Parser TraceMode -tracemode = option auto - ( long "trace-mode" - <> metavar "MODE" - <> value None - <> showDefault - <> help "Mode for trace output.") +tracemode = + option + auto + ( long "trace-mode" + <> metavar "MODE" + <> value None + <> showDefault + <> help "Mode for trace output." + ) files :: Parser Files files = some (argument str (metavar "[FILES...]")) applyOpts :: Parser ApplyOptions -applyOpts = ApplyOptions <$> files <*> inputformat <*> output <*> outputformat <*> printmode +applyOpts = ApplyOptions <$> files <*> inputformat <*> output <*> outputformat <*> printmode printmode :: Parser PrintMode -printmode = option auto - ( long "print-mode" - <> metavar "MODE" - <> value Classic - <> showDefault - <> help - ("Print mode for textual output (ignored elsewhere): Classic -> plcPrettyClassic, " - <> "Simple -> plcPrettyClassicSimple, " - <> "Readable -> prettyPlcReadable, ReadableSimple -> prettyPlcReadableSimple" )) +printmode = + option + auto + ( long "print-mode" + <> metavar "MODE" + <> value Classic + <> showDefault + <> help + ( "Print mode for textual output (ignored elsewhere): Classic -> plcPrettyClassic, " + <> "Simple -> plcPrettyClassicSimple, " + <> "Readable -> prettyPlcReadable, ReadableSimple -> prettyPlcReadableSimple" + ) + ) nameformat :: Parser NameFormat nameformat = - flag IdNames DeBruijnNames - (long "debruijn" - <> short 'j' - <> help "Output evaluation result with de Bruijn indices (default: show textual names)") + flag + IdNames + DeBruijnNames + ( long "debruijn" + <> short 'j' + <> help "Output evaluation result with de Bruijn indices (default: show textual names)" + ) certifier :: Parser Certifier certifier = - optional - $ strOption - (long "certify" - <> help - ("[EXPERIMENTAL] Produce a certificate ARG.agda proving that the program" - <> " transformaton is correct; the certificate is an Agda proof object, which" - <> " can be checked using the Agda proof assistant" - ) - ) + optional $ + strOption + ( long "certify" + <> help + ( "[EXPERIMENTAL] Produce a certificate ARG.agda proving that the program" + <> " transformaton is correct; the certificate is an Agda proof object, which" + <> " can be checked using the Agda proof assistant" + ) + ) printOpts :: Parser PrintOptions printOpts = PrintOptions <$> input <*> output <*> printmode @@ -135,23 +165,33 @@ convertOpts = ConvertOptions <$> input <*> inputformat <*> output <*> outputform optimiseOpts :: Parser OptimiseOptions optimiseOpts = OptimiseOptions - <$> input <*> inputformat <*> output <*> outputformat <*> printmode <*> certifier + <$> input + <*> inputformat + <*> output + <*> outputformat + <*> printmode + <*> certifier exampleMode :: Parser ExampleMode exampleMode = exampleAvailable <|> exampleSingle exampleAvailable :: Parser ExampleMode -exampleAvailable = flag' ExampleAvailable - ( long "available" - <> short 'a' - <> help "Show available examples") +exampleAvailable = + flag' + ExampleAvailable + ( long "available" + <> short 'a' + <> help "Show available examples" + ) exampleName :: Parser ExampleName -exampleName = strOption - ( long "single" - <> metavar "NAME" - <> short 's' - <> help "Show a single example") +exampleName = + strOption + ( long "single" + <> metavar "NAME" + <> short 's' + <> help "Show a single example" + ) exampleSingle :: Parser ExampleMode exampleSingle = ExampleSingle <$> exampleName @@ -161,33 +201,35 @@ exampleOpts = ExampleOptions <$> exampleMode builtinSemanticsVariantReader :: String -> Maybe (BuiltinSemanticsVariant DefaultFun) builtinSemanticsVariantReader = - \case - "A" -> Just DefaultFunSemanticsVariantA - "B" -> Just DefaultFunSemanticsVariantB - "C" -> Just DefaultFunSemanticsVariantC - _ -> Nothing + \case + "A" -> Just DefaultFunSemanticsVariantA + "B" -> Just DefaultFunSemanticsVariantB + "C" -> Just DefaultFunSemanticsVariantC + _ -> Nothing -- This is used to make the help message show you what you actually need to type. showBuiltinSemanticsVariant :: BuiltinSemanticsVariant DefaultFun -> String showBuiltinSemanticsVariant = - \case - DefaultFunSemanticsVariantA -> "A" - DefaultFunSemanticsVariantB -> "B" - DefaultFunSemanticsVariantC -> "C" + \case + DefaultFunSemanticsVariantA -> "A" + DefaultFunSemanticsVariantB -> "B" + DefaultFunSemanticsVariantC -> "C" builtinSemanticsVariant :: Parser (BuiltinSemanticsVariant DefaultFun) -builtinSemanticsVariant = option (maybeReader builtinSemanticsVariantReader) - ( long "builtin-semantics-variant" - <> short 'S' - <> metavar "VARIANT" - <> value DefaultFunSemanticsVariantC - <> showDefaultWith showBuiltinSemanticsVariant - <> help - ("Builtin semantics variant: A -> DefaultFunSemanticsVariantA, " - <> "B -> DefaultFunSemanticsVariantB, " - <> "C -> DefaultFunSemanticsVariantC" +builtinSemanticsVariant = + option + (maybeReader builtinSemanticsVariantReader) + ( long "builtin-semantics-variant" + <> short 'S' + <> metavar "VARIANT" + <> value DefaultFunSemanticsVariantC + <> showDefaultWith showBuiltinSemanticsVariant + <> help + ( "Builtin semantics variant: A -> DefaultFunSemanticsVariantA, " + <> "B -> DefaultFunSemanticsVariantB, " + <> "C -> DefaultFunSemanticsVariantC" + ) ) - ) -- Specialised parsers for PIR, which only supports ASTs over the Textual and -- Named types. @@ -198,45 +240,52 @@ pirFormatHelp = pirFormatReader :: String -> Maybe PirFormat pirFormatReader = - \case - "textual" -> Just TextualPir - "flat-named" -> Just FlatNamed - _ -> Nothing + \case + "textual" -> Just TextualPir + "flat-named" -> Just FlatNamed + _ -> Nothing pPirInputFormat :: Parser PirFormat -pPirInputFormat = option (maybeReader pirFormatReader) - ( long "if" - <> long "input-format" - <> metavar "PIR-FORMAT" - <> value TextualPir - <> showDefault - <> help ("Input format: " ++ pirFormatHelp)) +pPirInputFormat = + option + (maybeReader pirFormatReader) + ( long "if" + <> long "input-format" + <> metavar "PIR-FORMAT" + <> value TextualPir + <> showDefault + <> help ("Input format: " ++ pirFormatHelp) + ) pPirOutputFormat :: Parser PirFormat -pPirOutputFormat = option (maybeReader pirFormatReader) - ( long "of" - <> long "output-format" - <> metavar "PIR-FORMAT" - <> value TextualPir - <> showDefault - <> help ("Output format: " ++ pirFormatHelp)) +pPirOutputFormat = + option + (maybeReader pirFormatReader) + ( long "of" + <> long "output-format" + <> metavar "PIR-FORMAT" + <> value TextualPir + <> showDefault + <> help ("Output format: " ++ pirFormatHelp) + ) -- Which language: PLC or UPLC? languageReader :: String -> Maybe Language languageReader = - \case - "plc" -> Just PLC - "uplc" -> Just UPLC - _ -> Nothing + \case + "plc" -> Just PLC + "uplc" -> Just UPLC + _ -> Nothing pLanguage :: Parser Language -pLanguage = option (maybeReader languageReader) - ( long "language" - <> short 'l' - <> metavar "LANGUAGE" - <> value UPLC - <> showDefaultWith ( \case PLC -> "plc" ; UPLC -> "uplc" ) - <> help ("Target language: plc or uplc") - ) - +pLanguage = + option + (maybeReader languageReader) + ( long "language" + <> short 'l' + <> metavar "LANGUAGE" + <> value UPLC + <> showDefaultWith (\case PLC -> "plc"; UPLC -> "uplc") + <> help ("Target language: plc or uplc") + ) diff --git a/plutus-core/executables/src/PlutusCore/Executable/Types.hs b/plutus-core/executables/src/PlutusCore/Executable/Types.hs index f677954dc30..29715d43a2f 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Types.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Types.hs @@ -14,41 +14,40 @@ import Data.Text qualified as T -- | PIR program type. type PirProg = - PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun + PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun -- | PIR term type. type PirTerm = - PIR.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun + PIR.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun -- | PLC program type. type PlcProg = - PLC.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun + PLC.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun -- | PLC term type. type PlcTerm = - PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun + PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun -- | UPLC program type. type UplcProg = - UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun + UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun -- | UPLC term type. type UplcTerm = - UPLC.Term UPLC.Name PLC.DefaultUni PLC.DefaultFun - + UPLC.Term UPLC.Name PLC.DefaultUni PLC.DefaultFun ---------------- Types for commands and arguments ---------------- data AstNameType - = Named - | DeBruijn - | NamedDeBruijn - deriving stock Show + = Named + | DeBruijn + | NamedDeBruijn + deriving stock (Show) data Input = FileInput FilePath | StdInput instance Show Input where - show (FileInput path) = show path - show StdInput = "" + show (FileInput path) = show path + show StdInput = "" data Output = FileOutput FilePath | StdOutput | NoOutput data TimingMode = NoTiming | Timing Integer deriving stock (Eq) -- Report program execution time? @@ -69,14 +68,14 @@ type Files = [FilePath] -- | Input/output format for programs data Format - = Textual - | Flat AstNameType + = Textual + | Flat AstNameType instance Show Format where - show Textual = "textual" - show (Flat Named) = "flat-named" - show (Flat DeBruijn) = "flat-deBruijn" - show (Flat NamedDeBruijn) = "flat-namedDeBruijn" + show Textual = "textual" + show (Flat Named) = "flat-named" + show (Flat DeBruijn) = "flat-deBruijn" + show (Flat NamedDeBruijn) = "flat-namedDeBruijn" type Certifier = Maybe String @@ -86,18 +85,17 @@ data PrintOptions = PrintOptions Input Output PrintMode newtype ExampleOptions = ExampleOptions ExampleMode data ApplyOptions = ApplyOptions Files Format Output Format PrintMode - -- | Specialised types for PIR, which doesn't support deBruijn names in ASTs -- | A specialised format type for PIR. We don't support deBruijn or named deBruijn for PIR. - data PirFormat = TextualPir | FlatNamed -instance Show PirFormat - where show = \case { TextualPir -> "textual"; FlatNamed -> "flat-named" } + +instance Show PirFormat where + show = \case TextualPir -> "textual"; FlatNamed -> "flat-named" -- | Convert the PIR format type to the general format type. pirFormatToFormat :: PirFormat -> Format pirFormatToFormat TextualPir = Textual -pirFormatToFormat FlatNamed = Flat Named +pirFormatToFormat FlatNamed = Flat Named -- | Output types for some pir commands data Language = PLC | UPLC diff --git a/plutus-core/executables/traceToStacks/Common.hs b/plutus-core/executables/traceToStacks/Common.hs index 6e0cef1d11d..81a28c15497 100644 --- a/plutus-core/executables/traceToStacks/Common.hs +++ b/plutus-core/executables/traceToStacks/Common.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -Wno-name-shadowing #-} module Common where @@ -14,25 +13,25 @@ import Data.Vector qualified as V data StackFrame = MkStackFrame - { -- | The variable name. - varName :: T.Text, - -- | The resource value when it starts to be evaluated. - startVal :: Integer, - -- | The resource spent on evaluating the functions it called. - valSpentCalledFun :: Integer + { varName :: T.Text + -- ^ The variable name. + , startVal :: Integer + -- ^ The resource value when it starts to be evaluated. + , valSpentCalledFun :: Integer + -- ^ The resource spent on evaluating the functions it called. } deriving stock (Show) -data ProfileEvent = - MkProfileEvent Integer Transition T.Text +data ProfileEvent + = MkProfileEvent Integer Transition T.Text -data Transition = - Enter +data Transition + = Enter | Exit -- | Represent one of the "folded" flamegraph lines, which include fns it's in and resource spent. -data StackVal = - MkStackVal [T.Text] Integer +data StackVal + = MkStackVal [T.Text] Integer deriving stock (Eq) instance Show StackVal where @@ -41,39 +40,42 @@ instance Show StackVal where "; " -- reverse to make the functions in the order correct for flamegraphs. (reverse (map T.unpack fns)) - <>" " - <>show duration + <> " " + <> show duration data LogRow = LogRow String [Integer] instance CSV.FromRecord LogRow where - parseRecord v | V.length v == 0 = fail "empty" - parseRecord v = - LogRow <$> - CSV.parseField (V.unsafeHead v) <*> traverse CSV.parseField (V.toList $ V.unsafeTail v) + parseRecord v | V.length v == 0 = fail "empty" + parseRecord v = + LogRow + <$> CSV.parseField (V.unsafeHead v) + <*> traverse CSV.parseField (V.toList $ V.unsafeTail v) processLog :: Int -> BSL.ByteString -> [StackVal] processLog valIx content = let lEvents = case CSV.decode CSV.NoHeader content of - Left e -> error e + Left e -> error e Right es -> es - in getStacks (map (parseProfileEvent valIx) $ toList lEvents) + in getStacks (map (parseProfileEvent valIx) $ toList lEvents) parseProfileEvent :: Int -> LogRow -> ProfileEvent parseProfileEvent valIx (LogRow str vals) = - let val = vals !! (valIx-1) - in case words str of - [transition,var] -> - -- See Note [Profiling Marker] - case transition of - "->" -> MkProfileEvent val Enter (T.pack var) - "<-" -> MkProfileEvent val Exit (T.pack var) - badLog -> error $ - "parseProfileEvent: expecting \"entering\" or \"exiting\" but got " - <> show badLog - invalid -> error $ - "parseProfileEvent: invalid log, expecting a form of [t1,t2,t3,transition,var] but got " - <> show invalid + let val = vals !! (valIx - 1) + in case words str of + [transition, var] -> + -- See Note [Profiling Marker] + case transition of + "->" -> MkProfileEvent val Enter (T.pack var) + "<-" -> MkProfileEvent val Exit (T.pack var) + badLog -> + error $ + "parseProfileEvent: expecting \"entering\" or \"exiting\" but got " + <> show badLog + invalid -> + error $ + "parseProfileEvent: invalid log, expecting a form of [t1,t2,t3,transition,var] but got " + <> show invalid getStacks :: [ProfileEvent] -> [StackVal] getStacks = go [] @@ -82,27 +84,28 @@ getStacks = go [] [StackFrame] -> [ProfileEvent] -> [StackVal] - go curStack ((MkProfileEvent startVal Enter varName):tl) = - go - (MkStackFrame{varName, startVal, valSpentCalledFun = 0}:curStack) - tl - go (MkStackFrame {varName=curTopVar, startVal, valSpentCalledFun}:poppedStack) - ((MkProfileEvent exitVal Exit var):tl) - | curTopVar == var = - let diffVal = exitVal - startVal - updateValSpent (hd@MkStackFrame{valSpentCalledFun}:tl) = - hd {valSpentCalledFun = valSpentCalledFun + diffVal}:tl - updateValSpent [] = [] - updatedStack = updateValSpent poppedStack - -- this is quadratic but it's fine because we have to do quadratic - -- work anyway for fg and the input sizes are small. - fnsEntered = map varName updatedStack - in - -- resource spent on this function is the total resource spent - -- minus the resource spent on the function(s) it called. - MkStackVal (var:fnsEntered) (diffVal - valSpentCalledFun):go updatedStack tl - go _ ((MkProfileEvent _ Exit _):_) = + go curStack ((MkProfileEvent startVal Enter varName) : tl) = + go + (MkStackFrame {varName, startVal, valSpentCalledFun = 0} : curStack) + tl + go + (MkStackFrame {varName = curTopVar, startVal, valSpentCalledFun} : poppedStack) + ((MkProfileEvent exitVal Exit var) : tl) + | curTopVar == var = + let diffVal = exitVal - startVal + updateValSpent (hd@MkStackFrame {valSpentCalledFun} : tl) = + hd {valSpentCalledFun = valSpentCalledFun + diffVal} : tl + updateValSpent [] = [] + updatedStack = updateValSpent poppedStack + -- this is quadratic but it's fine because we have to do quadratic + -- work anyway for fg and the input sizes are small. + fnsEntered = map varName updatedStack + in -- resource spent on this function is the total resource spent + -- minus the resource spent on the function(s) it called. + MkStackVal (var : fnsEntered) (diffVal - valSpentCalledFun) : go updatedStack tl + go _ ((MkProfileEvent _ Exit _) : _) = error "getStacks; go: tried to exit but couldn't." go [] [] = [] - go stacks [] = error $ - "getStacks; go: stack " <> show stacks <> " isn't empty but the log is." + go stacks [] = + error $ + "getStacks; go: stack " <> show stacks <> " isn't empty but the log is." diff --git a/plutus-core/executables/traceToStacks/Main.hs b/plutus-core/executables/traceToStacks/Main.hs index 809e5e0d156..a8b6ae5ad7a 100644 --- a/plutus-core/executables/traceToStacks/Main.hs +++ b/plutus-core/executables/traceToStacks/Main.hs @@ -1,7 +1,5 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} -{- | Executable for profiling. See Note [Profiling instructions]-} - {- Note [Profiling instructions] Workflow for profiling evaluation time: 1. Compile your program with the Plutus Tx plugin option profile-all @@ -18,6 +16,7 @@ will use the first numeric column (CPU), so will give you a CPU flamegraph, but control this with the '--column' argument. -} +-- | Executable for profiling. See Note [Profiling instructions] module Main where import Common @@ -26,24 +25,30 @@ import Data.List (intercalate) import Options.Applicative column :: Parser Int -column = option auto - ( long "column" - <> short 'c' - <> metavar "COL" - <> value 1 - <> showDefault - <> help "Column to take profiling values from.") +column = + option + auto + ( long "column" + <> short 'c' + <> metavar "COL" + <> value 1 + <> showDefault + <> help "Column to take profiling values from." + ) data Input = FileInput FilePath | StdInput fileInput :: Parser Input -fileInput = FileInput <$> strOption - ( long "file" - <> short 'f' - <> metavar "FILENAME" - <> help "Input file" ) +fileInput = + FileInput + <$> strOption + ( long "file" + <> short 'f' + <> metavar "FILENAME" + <> help "Input file" + ) input :: Parser Input input = fileInput <|> pure StdInput @@ -51,14 +56,16 @@ input = fileInput <|> pure StdInput data Opts = Opts Input Int opts :: ParserInfo Opts -opts = info ((Opts <$> input <*> column) <**> helper) - (fullDesc <> progDesc "Turn PLC log output into flamegraph stacks output") +opts = + info + ((Opts <$> input <*> column) <**> helper) + (fullDesc <> progDesc "Turn PLC log output into flamegraph stacks output") main :: IO () main = do Opts inp valIx <- execParser opts input <- case inp of - FileInput fp -> BSL.readFile fp - StdInput -> BSL.getContents + FileInput fp -> BSL.readFile fp + StdInput -> BSL.getContents let processed = processLog valIx input putStrLn (intercalate "\n" (map show processed)) diff --git a/plutus-core/executables/traceToStacks/TestGetStacks.hs b/plutus-core/executables/traceToStacks/TestGetStacks.hs index 5d18ab86a7e..ecdf05a79b9 100644 --- a/plutus-core/executables/traceToStacks/TestGetStacks.hs +++ b/plutus-core/executables/traceToStacks/TestGetStacks.hs @@ -6,79 +6,82 @@ import Test.Tasty.HUnit (testCase, (@?=)) -- | A list of @ProfileEvent@ simulating a function @x@ using 1 resource. xEvent :: [ProfileEvent] -xEvent = [ - MkProfileEvent 0 Enter "x", - MkProfileEvent 1 Exit "x" - ] +xEvent = + [ MkProfileEvent 0 Enter "x" + , MkProfileEvent 1 Exit "x" + ] -- | The list of @StackVal@ that corresponds to @xEvent@. xStackVal :: [StackVal] -xStackVal = [MkStackVal [ "x"] 1] +xStackVal = [MkStackVal ["x"] 1] -- | A list of @ProfileEvent@ simulating function @x@ calling @y@ calling @z@. zInyInxEvent :: [ProfileEvent] -zInyInxEvent = [ - MkProfileEvent 0 Enter "x", - MkProfileEvent 1 Enter "y", - MkProfileEvent 10 Enter "z", - MkProfileEvent 100 Exit "z", - MkProfileEvent 1000 Exit "y", - MkProfileEvent 10000 Exit "x" - ] +zInyInxEvent = + [ MkProfileEvent 0 Enter "x" + , MkProfileEvent 1 Enter "y" + , MkProfileEvent 10 Enter "z" + , MkProfileEvent 100 Exit "z" + , MkProfileEvent 1000 Exit "y" + , MkProfileEvent 10000 Exit "x" + ] -- | The list of @StackVal@ that corresponds to @zInyInxEvent@. zInyInxStackVals :: [StackVal] -zInyInxStackVals = [ - MkStackVal [ "z", "y", "x"] 90, - MkStackVal [ "y", "x"] 909, - MkStackVal [ "x"] 9001 - ] +zInyInxStackVals = + [ MkStackVal ["z", "y", "x"] 90 + , MkStackVal ["y", "x"] 909 + , MkStackVal ["x"] 9001 + ] -- | A list of @ProfileEvent@ simulating function @x@ calling @y@ and @z@. yzInxEvent :: [ProfileEvent] -yzInxEvent = [ - MkProfileEvent 0 Enter "x", - MkProfileEvent 1 Enter "y", - MkProfileEvent 10 Exit "y", - MkProfileEvent 100 Enter "z", - MkProfileEvent 1000 Exit "z", - MkProfileEvent 10000 Exit "x" - ] +yzInxEvent = + [ MkProfileEvent 0 Enter "x" + , MkProfileEvent 1 Enter "y" + , MkProfileEvent 10 Exit "y" + , MkProfileEvent 100 Enter "z" + , MkProfileEvent 1000 Exit "z" + , MkProfileEvent 10000 Exit "x" + ] -- | The list of @StackVal@ that corresponds to @yzInxEvent@. yzInxStackVals :: [StackVal] -yzInxStackVals = [ - MkStackVal [ "y", "x"] 9, - MkStackVal [ "z", "x"] 900, - MkStackVal [ "x"] 9091 - ] +yzInxStackVals = + [ MkStackVal ["y", "x"] 9 + , MkStackVal ["z", "x"] 900 + , MkStackVal ["x"] 9091 + ] -- | A list of @ProfileEvent@ simulating a function @x@ calling @y@ and @z@, with @y@ calling @k@. kInyzInxEvent :: [ProfileEvent] -kInyzInxEvent = [ - MkProfileEvent 0 Enter "x", - MkProfileEvent 1 Enter "y", - MkProfileEvent 10 Enter "k", - MkProfileEvent 100 Exit "k", - MkProfileEvent 1000 Exit "y", - MkProfileEvent 10000 Enter "z", - MkProfileEvent 100000 Exit "z", - MkProfileEvent 1000000 Exit "x" - ] +kInyzInxEvent = + [ MkProfileEvent 0 Enter "x" + , MkProfileEvent 1 Enter "y" + , MkProfileEvent 10 Enter "k" + , MkProfileEvent 100 Exit "k" + , MkProfileEvent 1000 Exit "y" + , MkProfileEvent 10000 Enter "z" + , MkProfileEvent 100000 Exit "z" + , MkProfileEvent 1000000 Exit "x" + ] -- | The list of @StackVal@ that corresponds to @kInyzInxEvent@. kInyzInxStackVals :: [StackVal] -kInyzInxStackVals = [ - MkStackVal [ "k", "y", "x"] 90, - MkStackVal [ "y", "x"] 909, - MkStackVal [ "z", "x"] 90000, - MkStackVal [ "x"] 909001 - ] +kInyzInxStackVals = + [ MkStackVal ["k", "y", "x"] 90 + , MkStackVal ["y", "x"] 909 + , MkStackVal ["z", "x"] 90000 + , MkStackVal ["x"] 909001 + ] main :: IO () -main = defaultMain $ testGroup "getStacks tests" [ - testCase "x only" (getStacks xEvent @?= xStackVal), - testCase "x calls y calling z" (getStacks zInyInxEvent @?= zInyInxStackVals), - testCase "x calls y and z" (getStacks yzInxEvent @?= yzInxStackVals), - testCase "x calls y and z with y calling k" (getStacks kInyzInxEvent @?= kInyzInxStackVals) - ] +main = + defaultMain $ + testGroup + "getStacks tests" + [ testCase "x only" (getStacks xEvent @?= xStackVal) + , testCase "x calls y calling z" (getStacks zInyInxEvent @?= zInyInxStackVals) + , testCase "x calls y and z" (getStacks yzInxEvent @?= yzInxStackVals) + , testCase "x calls y and z with y calling k" (getStacks kInyzInxEvent @?= kInyzInxStackVals) + ] diff --git a/plutus-core/flat/src/PlutusCore/Flat.hs b/plutus-core/flat/src/PlutusCore/Flat.hs index 92872f9fdb8..0b7f3468387 100644 --- a/plutus-core/flat/src/PlutusCore/Flat.hs +++ b/plutus-core/flat/src/PlutusCore/Flat.hs @@ -1,14 +1,12 @@ -{-| -Haskell implementation of , a principled, portable and efficient binary data format. - --} -module PlutusCore.Flat - ( module PlutusCore.Flat.Class - , module PlutusCore.Flat.Filler - , module X - , Decoded - , DecodeException(..) - ) +-- | +-- Haskell implementation of , a principled, portable and efficient binary data format. +module PlutusCore.Flat ( + module PlutusCore.Flat.Class, + module PlutusCore.Flat.Filler, + module X, + Decoded, + DecodeException (..), +) where import PlutusCore.Flat.AsBin as X diff --git a/plutus-core/flat/src/PlutusCore/Flat/AsBin.hs b/plutus-core/flat/src/PlutusCore/Flat/AsBin.hs index 627464ccf6a..d0fa499332f 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/AsBin.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/AsBin.hs @@ -1,26 +1,28 @@ -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{- | Wrapper type to decode a value to its flat serialisation. - -See <../test/Big.hs> for an example of use. - -See also 'Flat.Decoder.listTDecoder' and "Flat.AsSize" for other ways to handle large decoded values. - -In 0.5.X this type was called @Repr@. - -@since 0.6 --} -module PlutusCore.Flat.AsBin(AsBin,unbin) where +-- | Wrapper type to decode a value to its flat serialisation. +-- +-- See <../test/Big.hs> for an example of use. +-- +-- See also 'Flat.Decoder.listTDecoder' and "Flat.AsSize" for other ways to handle large decoded values. +-- +-- In 0.5.X this type was called @Repr@. +-- +-- @since 0.6 +module PlutusCore.Flat.AsBin (AsBin, unbin) where import Data.ByteString qualified as B import Foreign (plusPtr) import PlutusCore.Flat.Bits (bits, fromBools, toBools) import PlutusCore.Flat.Class (Flat (..)) import PlutusCore.Flat.Decoder.Prim (binOf) -import PlutusCore.Flat.Decoder.Types (Get (Get, runGet), GetResult (GetResult), - S (S, currPtr, usedBits)) +import PlutusCore.Flat.Decoder.Types ( + Get (Get, runGet), + GetResult (GetResult), + S (S, currPtr, usedBits), + ) import PlutusCore.Flat.Run (unflatRawWithOffset) import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), prettyShow, text) @@ -35,84 +37,85 @@ import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), prettyShow, text) -- >>> import qualified Data.Text as T -- >>> import Text.PrettyPrint.HughesPJClass -{- | - -When the flat serialisation of a value takes a lot less memory than the value itself, it can be convenient to keep the value in its encoded representation and decode it on demand. - -To do so, just decode a value `a` as a `AsBin a`. - -Examples: - -Encode a list of Ints and then decode it to a list of AsBin Int: - ->>> unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int]) -Right [AsBin {repr = "\129A", offsetBits = 1},AsBin {repr = "A ", offsetBits = 2},AsBin {repr = " \193", offsetBits = 3}] - -To decode an `AsBin a` to an `a`, use `unbin`: - ->>> unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char)) -Right 'a' - -Keep the values of a list of Ints encoded and decode just one on demand: - ->>> let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l !! 2) -3 - -Show exactly how values are encoded: - ->>> let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t -"(0, _0000001 1, _1)" - -Ten bits in total spread over two bytes: - -@ -0 -_0000001 1 - _1 -= -00000001 11 -@ - -Tests: - ->>> unflat (flat ()) :: Decoded (AsBin ()) -Right (AsBin {repr = "", offsetBits = 0}) - ->>> unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool) -Right (False,AsBin {repr = "A", offsetBits = 1}) - ->>> unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8) -Right (False,False,AsBin {repr = "?\193", offsetBits = 2}) - ->>> let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3) -(False,False,255,True) --} - -data AsBin a = AsBin { - repr :: B.ByteString -- ^ Flat encoding of the value (encoding starts after offset bits in the first byte and ends in an unspecified position in the last byte) - ,offsetBits :: Int -- ^ First byte offset: number of unused most significant bits in the first byte - } deriving Show +-- | +-- +-- When the flat serialisation of a value takes a lot less memory than the value itself, it can be convenient to keep the value in its encoded representation and decode it on demand. +-- +-- To do so, just decode a value `a` as a `AsBin a`. +-- +-- Examples: +-- +-- Encode a list of Ints and then decode it to a list of AsBin Int: +-- +-- >>> unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int]) +-- Right [AsBin {repr = "\129A", offsetBits = 1},AsBin {repr = "A ", offsetBits = 2},AsBin {repr = " \193", offsetBits = 3}] +-- +-- To decode an `AsBin a` to an `a`, use `unbin`: +-- +-- >>> unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char)) +-- Right 'a' +-- +-- Keep the values of a list of Ints encoded and decode just one on demand: +-- +-- >>> let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l !! 2) +-- 3 +-- +-- Show exactly how values are encoded: +-- +-- >>> let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t +-- "(0, _0000001 1, _1)" +-- +-- Ten bits in total spread over two bytes: +-- +-- @ +-- 0 +-- _0000001 1 +-- _1 +-- = +-- 00000001 11 +-- @ +-- +-- Tests: +-- +-- >>> unflat (flat ()) :: Decoded (AsBin ()) +-- Right (AsBin {repr = "", offsetBits = 0}) +-- +-- >>> unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool) +-- Right (False,AsBin {repr = "A", offsetBits = 1}) +-- +-- >>> unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8) +-- Right (False,False,AsBin {repr = "?\193", offsetBits = 2}) +-- +-- >>> let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3) +-- (False,False,255,True) +data AsBin a = AsBin + { repr :: B.ByteString + -- ^ Flat encoding of the value (encoding starts after offset bits in the first byte and ends in an unspecified position in the last byte) + , offsetBits :: Int + -- ^ First byte offset: number of unused most significant bits in the first byte + } + deriving (Show) instance Flat a => Pretty (AsBin a) where - pPrint :: AsBin a -> Doc - pPrint r = let n = replicate (offsetBits r) in text $ n '_' ++ (drop (offsetBits r) . prettyShow . fromBools . (n False ++) . toBools . bits $ unbin r) + pPrint :: AsBin a -> Doc + pPrint r = let n = replicate (offsetBits r) in text $ n '_' ++ (drop (offsetBits r) . prettyShow . fromBools . (n False ++) . toBools . bits $ unbin r) -- | Decode a value unbin :: Flat a => AsBin a -> a unbin a = - case unflatRawWithOffset dec (repr a) (offsetBits a) of - Right a -> a - Left e -> error (show e) -- impossible, as it is a valid encoding - where - dec = Get $ \end s -> do - GetResult s' a <- runGet decode end s - let s'' = S (currPtr s' `plusPtr` if usedBits s' == 0 then 0 else 1) 0 - return $ GetResult s'' a + case unflatRawWithOffset dec (repr a) (offsetBits a) of + Right a -> a + Left e -> error (show e) -- impossible, as it is a valid encoding + where + dec = Get $ \end s -> do + GetResult s' a <- runGet decode end s + let s'' = S (currPtr s' `plusPtr` if usedBits s' == 0 then 0 else 1) 0 + return $ GetResult s'' a instance Flat a => Flat (AsBin a) where - size = error "unused" + size = error "unused" - encode = error "unused" + encode = error "unused" - decode :: Flat a => Get (AsBin a) - decode = uncurry AsBin <$> binOf (decode :: Get a) + decode :: Flat a => Get (AsBin a) + decode = uncurry AsBin <$> binOf (decode :: Get a) diff --git a/plutus-core/flat/src/PlutusCore/Flat/AsSize.hs b/plutus-core/flat/src/PlutusCore/Flat/AsSize.hs index 79403b5feeb..772820df743 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/AsSize.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/AsSize.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{- | -Wrapper type to decode a value to its size in bits. - -See also "Flat.AsBin". - -In 0.5.X this type was called @SizeOf@. - -@since 0.6 --} -module PlutusCore.Flat.AsSize(AsSize(..)) where +-- | +-- Wrapper type to decode a value to its size in bits. +-- +-- See also "Flat.AsBin". +-- +-- In 0.5.X this type was called @SizeOf@. +-- +-- @since 0.6 +module PlutusCore.Flat.AsSize (AsSize (..)) where import PlutusCore.Flat.Class (Flat (..)) import PlutusCore.Flat.Decoder.Prim (sizeOf) @@ -28,38 +27,37 @@ import PlutusCore.Flat.Types (NumBits) -- >>> import Data.Word -- >>> import qualified Data.Text as T -{- | -Useful to skip unnecessary values and to check encoding sizes. - -Examples: - -Ignore the second and fourth component of a tuple: - ->>> let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,AsSize String,Char,AsSize Bool) -Right ('a',AsSize 28,'z',AsSize 1) - -Notice the variable size encoding of Words: - ->>> unflat (flat (1::Word16,1::Word64)) :: Decoded (AsSize Word16,AsSize Word64) -Right (AsSize 8,AsSize 8) - -Text: - ->>> unflat (flat (T.pack "",T.pack "a",T.pack "主",UTF8Text $ T.pack "主",UTF16Text $ T.pack "主",UTF16Text $ T.pack "a")) :: Decoded (AsSize T.Text,AsSize T.Text,AsSize T.Text,AsSize UTF8Text,AsSize UTF16Text,AsSize UTF16Text) -Right (AsSize 16,AsSize 32,AsSize 48,AsSize 48,AsSize 40,AsSize 40) - -Various encodings: - ->>> unflat (flat (False,[T.pack "",T.pack "a",T.pack "主"],'a')) :: Decoded (AsSize Bool,AsSize [T.Text],AsSize Char) -Right (AsSize 1,AsSize 96,AsSize 8) --} -newtype AsSize a = AsSize NumBits deriving (Eq,Ord,Show) +-- | +-- Useful to skip unnecessary values and to check encoding sizes. +-- +-- Examples: +-- +-- Ignore the second and fourth component of a tuple: +-- +-- >>> let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,AsSize String,Char,AsSize Bool) +-- Right ('a',AsSize 28,'z',AsSize 1) +-- +-- Notice the variable size encoding of Words: +-- +-- >>> unflat (flat (1::Word16,1::Word64)) :: Decoded (AsSize Word16,AsSize Word64) +-- Right (AsSize 8,AsSize 8) +-- +-- Text: +-- +-- >>> unflat (flat (T.pack "",T.pack "a",T.pack "主",UTF8Text $ T.pack "主",UTF16Text $ T.pack "主",UTF16Text $ T.pack "a")) :: Decoded (AsSize T.Text,AsSize T.Text,AsSize T.Text,AsSize UTF8Text,AsSize UTF16Text,AsSize UTF16Text) +-- Right (AsSize 16,AsSize 32,AsSize 48,AsSize 48,AsSize 40,AsSize 40) +-- +-- Various encodings: +-- +-- >>> unflat (flat (False,[T.pack "",T.pack "a",T.pack "主"],'a')) :: Decoded (AsSize Bool,AsSize [T.Text],AsSize Char) +-- Right (AsSize 1,AsSize 96,AsSize 8) +newtype AsSize a = AsSize NumBits deriving (Eq, Ord, Show) instance Flat a => Flat (AsSize a) where - size :: Flat a => AsSize a -> NumBits -> NumBits - size = error "unused" + size :: Flat a => AsSize a -> NumBits -> NumBits + size = error "unused" - encode = error "unused" + encode = error "unused" - decode :: Flat a => Get (AsSize a) - decode = AsSize <$> sizeOf (decode :: Get a) + decode :: Flat a => Get (AsSize a) + decode = AsSize <$> sizeOf (decode :: Get a) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Bits.hs b/plutus-core/flat/src/PlutusCore/Flat/Bits.hs index acb003c9889..bfd7eeac09e 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Bits.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Bits.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} - --- |Utilities to represent and display bit sequences +-- | Utilities to represent and display bit sequences module PlutusCore.Flat.Bits ( - Bits, - toBools, - fromBools, - bits, - paddedBits, - asBytes, - asBits, - takeBits, - takeAllBits, + Bits, + toBools, + fromBools, + bits, + paddedBits, + asBytes, + asBits, + takeBits, + takeAllBits, ) where + -- TODO: AsBits Class? import Data.Bits (FiniteBits (finiteBitSize), testBit) @@ -27,7 +27,7 @@ import PlutusCore.Flat.Filler (PostAligned (PostAligned), fillerLength) import PlutusCore.Flat.Run (flat, unflatRaw) import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), hsep, text) --- |A sequence of bits +-- | A sequence of bits type Bits = V.Vector Bool toBools :: Bits -> [Bool] @@ -36,76 +36,70 @@ toBools = V.toList fromBools :: [Bool] -> Bits fromBools = V.fromList -{- $setup ->>> import Data.Word ->>> import PlutusCore.Flat.Instances.Base ->>> import PlutusCore.Flat.Instances.Test(tst,prettyShow) --} - -{- |The sequence of bits corresponding to the serialization of the passed value (without any final byte padding) +-- $setup +-- >>> import Data.Word +-- >>> import PlutusCore.Flat.Instances.Base +-- >>> import PlutusCore.Flat.Instances.Test(tst,prettyShow) ->>> bits True -[True] --} +-- | The sequence of bits corresponding to the serialization of the passed value (without any final byte padding) +-- +-- >>> bits True +-- [True] bits :: forall a. Flat a => a -> Bits bits v = - let lbs = flat v - in case unflatRaw lbs :: Decoded (PostAligned a) of - Right (PostAligned _ f) -> takeBits (8 * B.length lbs - fillerLength f) lbs - Left _ -> error "incorrect coding or decoding, please inform the maintainer of this package" - -{- |The sequence of bits corresponding to the byte-padded serialization of the passed value - ->>> paddedBits True -[True,False,False,False,False,False,False,True] --} + let lbs = flat v + in case unflatRaw lbs :: Decoded (PostAligned a) of + Right (PostAligned _ f) -> takeBits (8 * B.length lbs - fillerLength f) lbs + Left _ -> error "incorrect coding or decoding, please inform the maintainer of this package" + +-- | The sequence of bits corresponding to the byte-padded serialization of the passed value +-- +-- >>> paddedBits True +-- [True,False,False,False,False,False,False,True] paddedBits :: forall a. Flat a => a -> Bits paddedBits v = let lbs = flat v in takeAllBits lbs takeAllBits :: B.ByteString -> Bits -takeAllBits lbs= takeBits (8 * B.length lbs) lbs +takeAllBits lbs = takeBits (8 * B.length lbs) lbs takeBits :: Int -> B.ByteString -> Bits takeBits numBits lbs = - V.generate - (fromIntegral numBits) - ( \n -> - let (bb, b) = n `divMod` 8 - in testBit (B.index lbs (fromIntegral bb)) (7 - b) - ) - -{- |Convert an integral value to its equivalent bit representation - ->>> asBits (5::Word8) -[False,False,False,False,False,True,False,True] --} + V.generate + (fromIntegral numBits) + ( \n -> + let (bb, b) = n `divMod` 8 + in testBit (B.index lbs (fromIntegral bb)) (7 - b) + ) + +-- | Convert an integral value to its equivalent bit representation +-- +-- >>> asBits (5::Word8) +-- [False,False,False,False,False,True,False,True] asBits :: FiniteBits a => a -> Bits asBits w = let s = finiteBitSize w in V.generate s (testBit w . (s - 1 -)) -{- |Convert a sequence of bits to the corresponding list of bytes - ->>> asBytes $ asBits (256+3::Word16) -[1,3] --} +-- | Convert a sequence of bits to the corresponding list of bytes +-- +-- >>> asBytes $ asBits (256+3::Word16) +-- [1,3] asBytes :: Bits -> [Word8] asBytes = map byteVal . bytes . V.toList --- |Convert to the corresponding value (most significant bit first) +-- | Convert to the corresponding value (most significant bit first) byteVal :: [Bool] -> Word8 -byteVal = sum . zipWith (\ e b -> (if b then e else 0)) ([2 ^ n | n <- [7 :: Int, 6 .. 0]]) +byteVal = sum . zipWith (\e b -> (if b then e else 0)) ([2 ^ n | n <- [7 :: Int, 6 .. 0]]) --- |Split a list in groups of 8 elements or less +-- | Split a list in groups of 8 elements or less bytes :: [t] -> [[t]] bytes [] = [] -bytes l = let (w, r) = splitAt 8 l in w : bytes r +bytes l = let (w, r) = splitAt 8 l in w : bytes r -{- | ->>> prettyShow $ asBits (256+3::Word16) -"00000001 00000011" --} +-- | +-- >>> prettyShow $ asBits (256+3::Word16) +-- "00000001 00000011" instance Pretty Bits where - pPrint = hsep . map prettyBits . bytes . V.toList + pPrint = hsep . map prettyBits . bytes . V.toList prettyBits :: Foldable t => t Bool -> Doc prettyBits l = - text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l + text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l diff --git a/plutus-core/flat/src/PlutusCore/Flat/Data/ByteString/Convert.hs b/plutus-core/flat/src/PlutusCore/Flat/Data/ByteString/Convert.hs index 3e66012c686..15a3086ad6a 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Data/ByteString/Convert.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Data/ByteString/Convert.hs @@ -1,28 +1,27 @@ {-# LANGUAGE FlexibleInstances #-} -module PlutusCore.Flat.Data.ByteString.Convert - ( AsByteString(..) - ) +module PlutusCore.Flat.Data.ByteString.Convert ( + AsByteString (..), +) where import Data.ByteString qualified as B import Data.ByteString.Lazy qualified as L import Data.Word --- |Convert to/from strict ByteStrings +-- | Convert to/from strict ByteStrings class AsByteString a where toByteString :: a -> B.ByteString fromByteString :: B.ByteString -> a instance AsByteString B.ByteString where - toByteString = id + toByteString = id fromByteString = id instance AsByteString L.ByteString where - toByteString = L.toStrict + toByteString = L.toStrict fromByteString = L.fromStrict instance AsByteString [Word8] where - toByteString = B.pack + toByteString = B.pack fromByteString = B.unpack - diff --git a/plutus-core/flat/src/PlutusCore/Flat/Data/FloatCast.hs b/plutus-core/flat/src/PlutusCore/Flat/Data/FloatCast.hs index e5742e9a201..ea2922786fa 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Data/FloatCast.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Data/FloatCast.hs @@ -1,49 +1,45 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{- | Primitives to convert between Float\/Double and Word32\/Word64. - -Code copied from . - -Based on: .. - -Implements casting via a 1-element STUArray, as described in . --} -module PlutusCore.Flat.Data.FloatCast - ( floatToWord - , wordToFloat - , doubleToWord - , wordToDouble - , runST - , cast - ) +-- | Primitives to convert between Float\/Double and Word32\/Word64. +-- +-- Code copied from . +-- +-- Based on: .. +-- +-- Implements casting via a 1-element STUArray, as described in . +module PlutusCore.Flat.Data.FloatCast ( + floatToWord, + wordToFloat, + doubleToWord, + wordToDouble, + runST, + cast, +) where import Data.Array.ST (MArray, STUArray, newArray, readArray) import Data.Array.Unsafe (castSTUArray) import Data.Word (Word32, Word64) import GHC.ST (ST, runST) --- import Flat.Endian - - +-- import Flat.Endian -{- | Reinterpret-casts a `Word32` to a `Float`. - -prop> \f -> wordToFloat (floatToWord f ) == f -+++ OK, passed 100 tests. - ->>> floatToWord (-0.15625) -3189768192 - ->>> wordToFloat 3189768192 --0.15625 - ->>> floatToWord (-5.828125) == 0xC0BA8000 -True --} +-- | Reinterpret-casts a `Word32` to a `Float`. +-- +-- prop> \f -> wordToFloat (floatToWord f ) == f +-- +++ OK, passed 100 tests. +-- +-- >>> floatToWord (-0.15625) +-- 3189768192 +-- +-- >>> wordToFloat 3189768192 +-- -0.15625 +-- +-- >>> floatToWord (-5.828125) == 0xC0BA8000 +-- True wordToFloat :: Word32 -> Float wordToFloat x = runST (cast x) {-# INLINE wordToFloat #-} @@ -57,39 +53,40 @@ floatToWord x = runST (cast x) -- >>> import Numeric (showHex) -- >>> import Data.Word -{-| -Reinterpret-casts a `Double` to a `Word64`. - -prop> \f -> wordToDouble (doubleToWord f ) == f -+++ OK, passed 100 tests. - ->>> showHex (doubleToWord 1.0000000000000004) "" -"3ff0000000000002" - ->>> doubleToWord 1.0000000000000004 == 0x3FF0000000000002 -True - ->>> showHex (doubleToWord (-0.15625)) "" -"bfc4000000000000" - ->>> wordToDouble 0xbfc4000000000000 --0.15625 --} +-- | +-- Reinterpret-casts a `Double` to a `Word64`. +-- +-- prop> \f -> wordToDouble (doubleToWord f ) == f +-- +++ OK, passed 100 tests. +-- +-- >>> showHex (doubleToWord 1.0000000000000004) "" +-- "3ff0000000000002" +-- +-- >>> doubleToWord 1.0000000000000004 == 0x3FF0000000000002 +-- True +-- +-- >>> showHex (doubleToWord (-0.15625)) "" +-- "bfc4000000000000" +-- +-- >>> wordToDouble 0xbfc4000000000000 +-- -0.15625 {-# INLINE doubleToWord #-} doubleToWord :: Double -> Word64 doubleToWord x = runST (cast x) + -- doubleToWord x = fix64 $ runST (cast x) -- | Reinterpret-casts a `Word64` to a `Double`. {-# INLINE wordToDouble #-} wordToDouble :: Word64 -> Double wordToDouble x = runST (cast x) + -- wordToDouble x = runST (cast $ fix64 x) -- | -- >>> runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) -- True -cast - :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b +cast :: + (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 {-# INLINE cast #-} diff --git a/plutus-core/flat/src/PlutusCore/Flat/Data/ZigZag.hs b/plutus-core/flat/src/PlutusCore/Flat/Data/ZigZag.hs index 6d5b5fbc5ae..94b238284df 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Data/ZigZag.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Data/ZigZag.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} --- | of signed integrals. -module PlutusCore.Flat.Data.ZigZag (ZigZag(..)) where +-- | of signed integrals. +module PlutusCore.Flat.Data.ZigZag (ZigZag (..)) where import Data.Bits (Bits (shiftL, shiftR, xor, (.&.)), FiniteBits (finiteBitSize)) import Data.Int (Int16, Int32, Int64, Int8) @@ -19,92 +19,94 @@ import Numeric.Natural (Natural) -- >>> import Test.QuickCheck.Arbitrary -- >>> instance Arbitrary Natural where arbitrary = arbitrarySizedNatural; shrink = shrinkIntegral -{-| -Convert between a signed integral and the corresponding ZigZag encoded unsigned integral (e.g. between Int8 and Word8 or Integral and Natural). - -Allow conversion only between compatible types, invalid conversions produce a type error: - -@ -zigZag (-1::Int64) :: Word32 -... -... Couldn't match type ... -... -@ ->>> zigZag (0::Int8) -0 - ->>> zigZag (-1::Int16) -1 - ->>> zigZag (1::Int32) -2 - ->>> zigZag (-2::Int16) -3 - ->>> zigZag (-50::Integer) -99 - ->>> zigZag (50::Integer) -100 - ->>> zigZag (64::Integer) -128 - ->>> zigZag (-256::Integer) -511 - ->>> zigZag (256::Integer) -512 - ->>> map zigZag [-3..3::Integer] -[5,3,1,0,2,4,6] - ->>> map zagZig [0..6::Word8] -[0,-1,1,-2,2,-3,3] - -prop> \(f::Integer) -> zagZig (zigZag f) == f -+++ OK, passed 100 tests. - -prop> \(f::Natural) -> zigZag (zagZig f) == f -+++ OK, passed 100 tests. - -prop> \(f::Int8) -> zagZig (zigZag f) == f -+++ OK, passed 100 tests. - -prop> \(f::Word8) -> zigZag (zagZig f) == f -+++ OK, passed 100 tests. - -prop> \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) -+++ OK, passed 100 tests. - -prop> \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) -+++ OK, passed 100 tests. - -prop> \(f::Int64) -> zagZig (zigZag f) == f -+++ OK, passed 100 tests. - -prop> \(f::Word64) -> zigZag (zagZig f) == f -+++ OK, passed 100 tests. - -prop> \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) -+++ OK, passed 100 tests. - -prop> \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) -+++ OK, passed 100 tests. --} -class (Integral signed, Integral unsigned) - => ZigZag signed unsigned | unsigned -> signed, signed -> unsigned where +-- | +-- Convert between a signed integral and the corresponding ZigZag encoded unsigned integral (e.g. between Int8 and Word8 or Integral and Natural). +-- +-- Allow conversion only between compatible types, invalid conversions produce a type error: +-- +-- @ +-- zigZag (-1::Int64) :: Word32 +-- ... +-- ... Couldn't match type ... +-- ... +-- @ +-- >>> zigZag (0::Int8) +-- 0 +-- +-- >>> zigZag (-1::Int16) +-- 1 +-- +-- >>> zigZag (1::Int32) +-- 2 +-- +-- >>> zigZag (-2::Int16) +-- 3 +-- +-- >>> zigZag (-50::Integer) +-- 99 +-- +-- >>> zigZag (50::Integer) +-- 100 +-- +-- >>> zigZag (64::Integer) +-- 128 +-- +-- >>> zigZag (-256::Integer) +-- 511 +-- +-- >>> zigZag (256::Integer) +-- 512 +-- +-- >>> map zigZag [-3..3::Integer] +-- [5,3,1,0,2,4,6] +-- +-- >>> map zagZig [0..6::Word8] +-- [0,-1,1,-2,2,-3,3] +-- +-- prop> \(f::Integer) -> zagZig (zigZag f) == f +-- +++ OK, passed 100 tests. +-- +-- prop> \(f::Natural) -> zigZag (zagZig f) == f +-- +++ OK, passed 100 tests. +-- +-- prop> \(f::Int8) -> zagZig (zigZag f) == f +-- +++ OK, passed 100 tests. +-- +-- prop> \(f::Word8) -> zigZag (zagZig f) == f +-- +++ OK, passed 100 tests. +-- +-- prop> \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) +-- +++ OK, passed 100 tests. +-- +-- prop> \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) +-- +++ OK, passed 100 tests. +-- +-- prop> \(f::Int64) -> zagZig (zigZag f) == f +-- +++ OK, passed 100 tests. +-- +-- prop> \(f::Word64) -> zigZag (zagZig f) == f +-- +++ OK, passed 100 tests. +-- +-- prop> \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) +-- +++ OK, passed 100 tests. +-- +-- prop> \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) +-- +++ OK, passed 100 tests. +class + (Integral signed, Integral unsigned) => + ZigZag signed unsigned + | unsigned -> signed + , signed -> unsigned + where zigZag :: signed -> unsigned default zigZag :: FiniteBits signed => signed -> unsigned - zigZag s = fromIntegral - ((s `shiftL` 1) `xor` (s `shiftR` (finiteBitSize s - 1))) - + zigZag s = + fromIntegral + ((s `shiftL` 1) `xor` (s `shiftR` (finiteBitSize s - 1))) {-# INLINE zigZag #-} zagZig :: unsigned -> signed - default zagZig :: (Bits unsigned) => unsigned -> signed + default zagZig :: Bits unsigned => unsigned -> signed zagZig u = fromIntegral ((u `shiftR` 1) `xor` negate (u .&. 1)) - -- default zagZig :: (Bits signed) => unsigned -> signed -- zagZig u = let (s::signed) = fromIntegral u in ((s `shiftR` 1) `xor` (negate (s .&. 1))) {-# INLINE zagZig #-} @@ -122,5 +124,6 @@ instance ZigZag Integer Natural where | x >= 0 = fromIntegral $ x `shiftL` 1 | otherwise = fromIntegral $ negate (x `shiftL` 1) - 1 - zagZig u = let s = fromIntegral u - in ((s `shiftR` 1) `xor` negate (s .&. 1)) + zagZig u = + let s = fromIntegral u + in ((s `shiftR` 1) `xor` negate (s .&. 1)) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Prim.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Prim.hs index 4a11c5d85d1..b1878e07d69 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Prim.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Prim.hs @@ -1,45 +1,66 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} --- |Strict Decoder Primitives +-- | Strict Decoder Primitives module PlutusCore.Flat.Decoder.Prim ( - dBool, - dWord8, - dBE8, - dBE16, - dBE32, - dBE64, - dBEBits8, - dBEBits16, - dBEBits32, - dBEBits64, - dropBits, - dFloat, - dDouble, - getChunksInfo, - dByteString_, - dLazyByteString_, - dByteArray_, - - ConsState(..),consOpen,consClose,consBool,consBits, - - sizeOf,binOf - ) where + dBool, + dWord8, + dBE8, + dBE16, + dBE32, + dBE64, + dBEBits8, + dBEBits16, + dBEBits32, + dBEBits64, + dropBits, + dFloat, + dDouble, + getChunksInfo, + dByteString_, + dLazyByteString_, + dByteArray_, + ConsState (..), + consOpen, + consClose, + consBool, + consBits, + sizeOf, + binOf, +) where import Control.Monad (when) import Data.ByteString qualified as B import Data.ByteString.Lazy qualified as L import Data.Word (Word16, Word32, Word64, Word8) -import Foreign (Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)), FiniteBits (finiteBitSize), Ptr, - Storable (peek), castPtr, plusPtr, ptrToIntPtr) +import Foreign ( + Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)), + FiniteBits (finiteBitSize), + Ptr, + Storable (peek), + castPtr, + plusPtr, + ptrToIntPtr, + ) import PlutusCore.Flat.Data.FloatCast (wordToDouble, wordToFloat) -import PlutusCore.Flat.Decoder.Types (Get (Get, runGet), GetResult (..), S (..), badEncoding, badOp, - notEnoughSpace) +import PlutusCore.Flat.Decoder.Types ( + Get (Get, runGet), + GetResult (..), + S (..), + badEncoding, + badOp, + notEnoughSpace, + ) import PlutusCore.Flat.Endian (toBE16, toBE32, toBE64) -import PlutusCore.Flat.Memory (ByteArray, chunksToByteArray, chunksToByteString, minusPtr, - peekByteString) +import PlutusCore.Flat.Memory ( + ByteArray, + chunksToByteArray, + chunksToByteString, + minusPtr, + peekByteString, + ) -- $setup -- >>> :set -XBinaryLiterals @@ -49,70 +70,76 @@ import PlutusCore.Flat.Memory (ByteArray, chunksToByteArray, chunksToByteString, -- >>> import PlutusCore.Flat.Bits -- >>> import Text.PrettyPrint.HughesPJClass (Pretty (pPrint)) -{- |A special state, optimised for constructor decoding. - -It consists of: - -* The bits to parse, the top bit being the first to parse (could use a Word16 instead, no difference in performance) - -* The number of decoded bits - -Supports up to 512 constructors (9 bits). --} -data ConsState = - ConsState {-# UNPACK #-} !Word !Int +-- | A special state, optimised for constructor decoding. +-- +-- It consists of: +-- +-- * The bits to parse, the top bit being the first to parse (could use a Word16 instead, no difference in performance) +-- +-- * The number of decoded bits +-- +-- Supports up to 512 constructors (9 bits). +data ConsState + = ConsState {-# UNPACK #-} !Word !Int --- |Switch to constructor decoding --- {-# INLINE consOpen #-} +-- | Switch to constructor decoding +-- {-# INLINE consOpen #-} consOpen :: Get ConsState consOpen = Get $ \endPtr s -> do let u = usedBits s let d = ptrToIntPtr endPtr - ptrToIntPtr (currPtr s) - w <- if d > 1 then do -- two different bytes - w16::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) - return $ fromIntegral w16 `unsafeShiftL` (u+(wordSize-16)) - else if d == 1 then do -- single last byte left - w8 :: Word8 <- peek (currPtr s) - return $ fromIntegral w8 `unsafeShiftL` (u+(wordSize-8)) - else notEnoughSpace endPtr s + w <- + if d > 1 + then do + -- two different bytes + w16 :: Word16 <- toBE16 <$> peek (castPtr $ currPtr s) + return $ fromIntegral w16 `unsafeShiftL` (u + (wordSize - 16)) + else + if d == 1 + then do + -- single last byte left + w8 :: Word8 <- peek (currPtr s) + return $ fromIntegral w8 `unsafeShiftL` (u + (wordSize - 8)) + else notEnoughSpace endPtr s return $ GetResult s (ConsState w 0) --- |Switch back to normal decoding --- {-# NOINLINE consClose #-} +-- | Switch back to normal decoding +-- {-# NOINLINE consClose #-} consClose :: Int -> Get () -consClose n = Get $ \endPtr s -> do - let u' = n+usedBits s +consClose n = Get $ \endPtr s -> do + let u' = n + usedBits s if u' < 8 - then return $ GetResult (s {usedBits=u'}) () - else if currPtr s >= endPtr - then notEnoughSpace endPtr s - else return $ GetResult (s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}) () - - {- ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s - dropBits8 s n = - let u' = n+usedBits s - in if u' < 8 - then s {usedBits=u'} - else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8} - -} - - --ensureBits endPtr s n - --return $ GetResult (dropBits8 s n) () - --- |Decode a single bit -consBool :: ConsState -> (ConsState,Bool) -consBool cs = (0/=) <$> consBits cs 1 + then return $ GetResult (s {usedBits = u'}) () + else + if currPtr s >= endPtr + then notEnoughSpace endPtr s + else return $ GetResult (s {currPtr = currPtr s `plusPtr` 1, usedBits = u' - 8}) () + +{- ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s +dropBits8 s n = + let u' = n+usedBits s + in if u' < 8 + then s {usedBits=u'} + else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8} +-} + +-- ensureBits endPtr s n +-- return $ GetResult (dropBits8 s n) () + +-- | Decode a single bit +consBool :: ConsState -> (ConsState, Bool) +consBool cs = (0 /=) <$> consBits cs 1 -- consBool (ConsState w usedBits) = (ConsState (w `unsafeShiftL` 1) (1+usedBits),0 /= 32768 .&. w) --- |Decode from 1 to 3 bits +-- | Decode from 1 to 3 bits -- --- It could read more bits that are available, but it doesn't matter, errors will be checked in consClose. +-- It could read more bits that are available, but it doesn't matter, errors will be checked in consClose. consBits :: ConsState -> Int -> (ConsState, Word) consBits cs 3 = consBits_ cs 3 7 consBits cs 2 = consBits_ cs 2 3 consBits cs 1 = consBits_ cs 1 1 -consBits _ _ = error "unsupported" +consBits _ _ = error "unsupported" consBits_ :: ConsState -> Int -> Word -> (ConsState, Word) @@ -146,34 +173,38 @@ wordSize :: Int wordSize = finiteBitSize (0 :: Word) {-# INLINE ensureBits #-} --- |Ensure that the specified number of bits is available + +-- | Ensure that the specified number of bits is available ensureBits :: Ptr Word8 -> S -> Int -> IO () ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s {-# INLINE dropBits #-} --- |Drop the specified number of bits + +-- | Drop the specified number of bits dropBits :: Int -> Get () dropBits n | n > 0 = Get $ \endPtr s -> do ensureBits endPtr s n return $ GetResult (dropBits_ s n) () | n == 0 = return () - | otherwise = error $ unwords ["dropBits",show n] + | otherwise = error $ unwords ["dropBits", show n] {-# INLINE dropBits_ #-} dropBits_ :: S -> Int -> S dropBits_ s n = - let (bytes,bits) = (n+usedBits s) `divMod` 8 - -- let - -- n' = n+usedBits s - -- bytes = n' `unsafeShiftR` 3 - -- bits = n' .|. 7 - in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits} + let (bytes, bits) = (n + usedBits s) `divMod` 8 + in -- let + -- n' = n+usedBits s + -- bytes = n' `unsafeShiftR` 3 + -- bits = n' .|. 7 + S {currPtr = currPtr s `plusPtr` bytes, usedBits = bits} {-# INLINE dBool #-} + -- Inlining dBool massively increases compilation time but decreases run time by a third -- TODO: test dBool inlining for ghc >= 8.8.4 --- |Decode a boolean + +-- | Decode a boolean dBool :: Get Bool dBool = Get $ \endPtr s -> if currPtr s >= endPtr @@ -181,61 +212,63 @@ dBool = Get $ \endPtr s -> else do !w <- peek (currPtr s) let !b = 0 /= (w .&. (128 `unsafeShiftR` usedBits s)) - let !s' = if usedBits s == 7 - then s { currPtr = currPtr s `plusPtr` 1, usedBits = 0 } - else s { usedBits = usedBits s + 1 } + let !s' = + if usedBits s == 7 + then s {currPtr = currPtr s `plusPtr` 1, usedBits = 0} + else s {usedBits = usedBits s + 1} return $ GetResult s' b +{-# INLINE dBEBits8 #-} -{-# INLINE dBEBits8 #-} -{- | Return the n most significant bits (up to maximum of 8) - -The bits are returned right shifted: - ->>> unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 -True - ->>> unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] -Left (BadOp "read8: cannot read 9 bits") --} +-- | Return the n most significant bits (up to maximum of 8) +-- +-- The bits are returned right shifted: +-- +-- >>> unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 +-- True +-- +-- >>> unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] +-- Left (BadOp "read8: cannot read 9 bits") dBEBits8 :: Int -> Get Word8 dBEBits8 n = Get $ \endPtr s -> do - ensureBits endPtr s n - take8 s n - -{-# INLINE dBEBits16 #-} -{- | Return the n most significant bits (up to maximum of 16) - -The bits are returned right shifted: + ensureBits endPtr s n + take8 s n ->>> pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] -Right 00000101 10111111 +{-# INLINE dBEBits16 #-} -If more than 16 bits are requested, only the last 16 are returned: - ->>> pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] -Right 00000111 11111111 --} +-- | Return the n most significant bits (up to maximum of 16) +-- +-- The bits are returned right shifted: +-- +-- >>> pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] +-- Right 00000101 10111111 +-- +-- If more than 16 bits are requested, only the last 16 are returned: +-- +-- >>> pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] +-- Right 00000111 11111111 dBEBits16 :: Int -> Get Word16 dBEBits16 n = Get $ \endPtr s -> do - ensureBits endPtr s n - takeN n s + ensureBits endPtr s n + takeN n s + +{-# INLINE dBEBits32 #-} -{-# INLINE dBEBits32 #-} --- |Return the n most significant bits (up to maximum of 32) --- The bits are returned right shifted. +-- | Return the n most significant bits (up to maximum of 32) +-- The bits are returned right shifted. dBEBits32 :: Int -> Get Word32 dBEBits32 n = Get $ \endPtr s -> do - ensureBits endPtr s n - takeN n s + ensureBits endPtr s n + takeN n s + +{-# INLINE dBEBits64 #-} -{-# INLINE dBEBits64 #-} --- |Return the n most significant bits (up to maximum of 64) --- The bits are returned right shifted. +-- | Return the n most significant bits (up to maximum of 64) +-- The bits are returned right shifted. dBEBits64 :: Int -> Get Word64 dBEBits64 n = Get $ \endPtr s -> do - ensureBits endPtr s n - takeN n s + ensureBits endPtr s n + takeN n s -- {-# INLINE take8 #-} -- take8 :: Int -> S -> IO (GetResult Word8) @@ -260,36 +293,39 @@ take8 :: S -> Int -> IO (GetResult Word8) -- take8 s n = GetResult (dropBits_ s n) <$> read8 s n take8 s n = GetResult (dropBits8 s n) <$> read8 s n where - --{-# INLINE read8 #-} + -- {-# INLINE read8 #-} read8 :: S -> Int -> IO Word8 - read8 s n | n >=0 && n <=8 = - if n <= 8 - usedBits s - then do -- all bits in the same byte - w <- peek (currPtr s) - return $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n) - else do -- two different bytes - w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) - return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n) - | otherwise = badOp $ unwords ["read8: cannot read",show n,"bits"] + read8 s n + | n >= 0 && n <= 8 = + if n <= 8 - usedBits s + then do + -- all bits in the same byte + w <- peek (currPtr s) + return $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n) + else do + -- two different bytes + w :: Word16 <- toBE16 <$> peek (castPtr $ currPtr s) + return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n) + | otherwise = badOp $ unwords ["read8: cannot read", show n, "bits"] -- {-# INLINE dropBits8 #-} -- -- Assume n <= 8 dropBits8 :: S -> Int -> S dropBits8 s n = - let u' = n+usedBits s - in if u' < 8 - then s {usedBits=u'} - else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8} - + let u' = n + usedBits s + in if u' < 8 + then s {usedBits = u'} + else s {currPtr = currPtr s `plusPtr` 1, usedBits = u' - 8} {-# INLINE takeN #-} takeN :: (Num a, Bits a) => Int -> S -> IO (GetResult a) takeN n s = read s 0 (n - (n `min` 8)) n - where - read s r sh n | n <=0 = return $ GetResult s r - | otherwise = do - let m = n `min` 8 - GetResult s' b <- take8 s m - read s' (r .|. (fromIntegral b `unsafeShiftL` sh)) ((sh-8) `max` 0) (n-8) + where + read s r sh n + | n <= 0 = return $ GetResult s r + | otherwise = do + let m = n `min` 8 + GetResult s' b <- take8 s m + read s' (r .|. (fromIntegral b `unsafeShiftL` sh)) ((sh - 8) `max` 0) (n - 8) -- takeN n = Get $ \endPtr s -> do -- ensureBits endPtr s n @@ -311,126 +347,133 @@ takeN n s = read s 0 (n - (n `min` 8)) n -- r8 s = peek (currPtr s) -- r16 s = toBE16 <$> peek (castPtr $ currPtr s) --- |Return the 8 most significant bits (same as dBE8) +-- | Return the 8 most significant bits (same as dBE8) dWord8 :: Get Word8 dWord8 = dBE8 -{-# INLINE dBE8 #-} --- |Return the 8 most significant bits +{-# INLINE dBE8 #-} + +-- | Return the 8 most significant bits dBE8 :: Get Word8 dBE8 = Get $ \endPtr s -> do - ensureBits endPtr s 8 - !w1 <- peek (currPtr s) - !w <- if usedBits s == 0 - then return w1 - else do - !w2 <- peek (currPtr s `plusPtr` 1) - return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `unsafeShiftR` (8-usedBits s)) - return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w + ensureBits endPtr s 8 + !w1 <- peek (currPtr s) + !w <- + if usedBits s == 0 + then return w1 + else do + !w2 <- peek (currPtr s `plusPtr` 1) + return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `unsafeShiftR` (8 - usedBits s)) + return $ GetResult (s {currPtr = currPtr s `plusPtr` 1}) w {-# INLINE dBE16 #-} --- |Return the 16 most significant bits + +-- | Return the 16 most significant bits dBE16 :: Get Word16 dBE16 = Get $ \endPtr s -> do ensureBits endPtr s 16 !w1 <- toBE16 <$> peek (castPtr $ currPtr s) - !w <- if usedBits s == 0 - then return w1 - else do - !(w2::Word8) <- peek (currPtr s `plusPtr` 2) - return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s)) - return $ GetResult (s {currPtr=currPtr s `plusPtr` 2}) w + !w <- + if usedBits s == 0 + then return w1 + else do + !(w2 :: Word8) <- peek (currPtr s `plusPtr` 2) + return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8 - usedBits s)) + return $ GetResult (s {currPtr = currPtr s `plusPtr` 2}) w {-# INLINE dBE32 #-} --- |Return the 32 most significant bits + +-- | Return the 32 most significant bits dBE32 :: Get Word32 dBE32 = Get $ \endPtr s -> do ensureBits endPtr s 32 !w1 <- toBE32 <$> peek (castPtr $ currPtr s) - !w <- if usedBits s == 0 - then return w1 - else do - !(w2::Word8) <- peek (currPtr s `plusPtr` 4) - return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s)) - return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) w + !w <- + if usedBits s == 0 + then return w1 + else do + !(w2 :: Word8) <- peek (currPtr s `plusPtr` 4) + return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8 - usedBits s)) + return $ GetResult (s {currPtr = currPtr s `plusPtr` 4}) w {-# INLINE dBE64 #-} --- |Return the 64 most significant bits + +-- | Return the 64 most significant bits dBE64 :: Get Word64 dBE64 = Get $ \endPtr s -> do ensureBits endPtr s 64 -- !w1 <- toBE64 <$> peek (castPtr $ currPtr s) !w1 <- toBE64 <$> peek64 (castPtr $ currPtr s) - !w <- if usedBits s == 0 - then return w1 - else do - !(w2::Word8) <- peek (currPtr s `plusPtr` 8) - return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s)) - return $ GetResult (s {currPtr=currPtr s `plusPtr` 8}) w - where - -- {-# INLINE peek64 #-} - peek64 :: Ptr Word64 -> IO Word64 - peek64 = peek - -- peek64 ptr = fix64 <$> peek ptr + !w <- + if usedBits s == 0 + then return w1 + else do + !(w2 :: Word8) <- peek (currPtr s `plusPtr` 8) + return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8 - usedBits s)) + return $ GetResult (s {currPtr = currPtr s `plusPtr` 8}) w + where + -- {-# INLINE peek64 #-} + peek64 :: Ptr Word64 -> IO Word64 + peek64 = peek + +-- peek64 ptr = fix64 <$> peek ptr {-# INLINE dFloat #-} --- |Decode a Float + +-- | Decode a Float dFloat :: Get Float dFloat = wordToFloat <$> dBE32 {-# INLINE dDouble #-} --- |Decode a Double + +-- | Decode a Double dDouble :: Get Double dDouble = wordToDouble <$> dBE64 --- |Decode a Lazy ByteString +-- | Decode a Lazy ByteString dLazyByteString_ :: Get L.ByteString dLazyByteString_ = L.fromStrict <$> dByteString_ --- |Decode a ByteString +-- | Decode a ByteString dByteString_ :: Get B.ByteString dByteString_ = chunksToByteString <$> getChunksInfo --- |Decode a ByteArray and its length -dByteArray_ :: Get (ByteArray,Int) +-- | Decode a ByteArray and its length +dByteArray_ :: Get (ByteArray, Int) dByteArray_ = chunksToByteArray <$> getChunksInfo --- |Decode an Array (a list of chunks up to 255 bytes long) returning the pointer to the first data byte and a list of chunk sizes +-- | Decode an Array (a list of chunks up to 255 bytes long) returning the pointer to the first data byte and a list of chunk sizes getChunksInfo :: Get (Ptr Word8, [Int]) getChunksInfo = Get $ \endPtr s -> do - - let getChunks srcPtr l = do - ensureBits endPtr s 8 - !n <- fromIntegral <$> peek srcPtr - if n==0 - then return (srcPtr `plusPtr` 1,l []) - else do - ensureBits endPtr s ((n+1)*8) - getChunks (srcPtr `plusPtr` (n+1)) (l . (n:)) -- ETA: stack overflow (missing tail call optimisation) - - when (usedBits s /=0) $ badEncoding endPtr s "usedBits /= 0" - (currPtr',ns) <- getChunks (currPtr s) id - return $ GetResult (s {currPtr=currPtr'}) (currPtr s `plusPtr` 1,ns) - -{- | Given a value's decoder, returns the size in bits of the encoded value - -@since 0.6 --} + let getChunks srcPtr l = do + ensureBits endPtr s 8 + !n <- fromIntegral <$> peek srcPtr + if n == 0 + then return (srcPtr `plusPtr` 1, l []) + else do + ensureBits endPtr s ((n + 1) * 8) + getChunks (srcPtr `plusPtr` (n + 1)) (l . (n :)) -- ETA: stack overflow (missing tail call optimisation) + when (usedBits s /= 0) $ badEncoding endPtr s "usedBits /= 0" + (currPtr', ns) <- getChunks (currPtr s) id + return $ GetResult (s {currPtr = currPtr'}) (currPtr s `plusPtr` 1, ns) + +-- | Given a value's decoder, returns the size in bits of the encoded value +-- +-- @since 0.6 sizeOf :: Get a -> Get Int sizeOf g = - Get $ \end s -> do - GetResult s' _ <- runGet g end s - return $ GetResult s' $ (currPtr s' `minusPtr` currPtr s) * 8 - usedBits s + usedBits s' - -{- | Given a value's decoder, returns the value's bit encoding. - -The encoding starts at the returned bit position in the return bytestring's first byte -and ends in an unspecified bit position in its final byte + Get $ \end s -> do + GetResult s' _ <- runGet g end s + return $ GetResult s' $ (currPtr s' `minusPtr` currPtr s) * 8 - usedBits s + usedBits s' -@since 0.6 --} -binOf :: Get a -> Get (B.ByteString,Int) +-- | Given a value's decoder, returns the value's bit encoding. +-- +-- The encoding starts at the returned bit position in the return bytestring's first byte +-- and ends in an unspecified bit position in its final byte +-- +-- @since 0.6 +binOf :: Get a -> Get (B.ByteString, Int) binOf g = - Get $ \end s -> do - GetResult s' _ <- runGet g end s - return $ GetResult s' (peekByteString (currPtr s) (currPtr s' `minusPtr` currPtr s + if usedBits s' == 0 then 0 else 1),usedBits s) + Get $ \end s -> do + GetResult s' _ <- runGet g end s + return $ GetResult s' (peekByteString (currPtr s) (currPtr s' `minusPtr` currPtr s + if usedBits s' == 0 then 0 else 1), usedBits s) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Run.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Run.hs index e12dd5f5ed9..8678eff5146 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Run.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Run.hs @@ -1,5 +1,4 @@ - -module PlutusCore.Flat.Decoder.Run(strictDecoder,listTDecoder) where +module PlutusCore.Flat.Decoder.Run (strictDecoder, listTDecoder) where import Control.Exception (Exception, try) import Data.ByteString qualified as B @@ -7,35 +6,40 @@ import Data.ByteString.Internal qualified as BS import Foreign (Ptr, plusPtr, withForeignPtr) import ListT (ListT (..)) import PlutusCore.Flat.Decoder.Prim (dBool) -import PlutusCore.Flat.Decoder.Types (DecodeException, Get (runGet), GetResult (..), S (S), - tooMuchSpace) +import PlutusCore.Flat.Decoder.Types ( + DecodeException, + Get (runGet), + GetResult (..), + S (S), + tooMuchSpace, + ) import System.IO.Unsafe (unsafePerformIO) -- | Given a decoder and an input buffer returns either the decoded value or an error (if the input buffer is not fully consumed) strictDecoder :: Get a -> B.ByteString -> Int -> Either DecodeException a -strictDecoder get bs usedBits= +strictDecoder get bs usedBits = strictDecoder_ get bs usedBits $ \(GetResult s'@(S ptr' o') a) endPtr -> if ptr' /= endPtr || o' /= 0 then tooMuchSpace endPtr s' else return a strictDecoder_ :: - Exception e - => Get a1 - -> BS.ByteString - -> Int - -> (GetResult a1 -> Ptr b -> IO a) - -> Either e a + Exception e => + Get a1 -> + BS.ByteString -> + Int -> + (GetResult a1 -> Ptr b -> IO a) -> + Either e a strictDecoder_ get (BS.PS base off len) usedBits check = unsafePerformIO . try $ - withForeignPtr base $ \base0 -> - let ptr = base0 `plusPtr` off - endPtr = ptr `plusPtr` len - in do res <- runGet get endPtr (S ptr usedBits) - check res endPtr + withForeignPtr base $ \base0 -> + let ptr = base0 `plusPtr` off + endPtr = ptr `plusPtr` len + in do + res <- runGet get endPtr (S ptr usedBits) + check res endPtr {-# NOINLINE strictDecoder_ #-} - -- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits) -- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $ -- withForeignPtr base $ \base0 -> @@ -45,28 +49,27 @@ strictDecoder_ get (BS.PS base off len) usedBits check = -- GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0) -- return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o') -{-| -Decode a list of values, one value at a time. - -Useful in case that the decoded values takes a lot more memory than the encoded ones. - -See <../test/Big.hs> for a test and an example of use. - -See also "Flat.AsBin". - -@since 0.5 --} +-- | +-- Decode a list of values, one value at a time. +-- +-- Useful in case that the decoded values takes a lot more memory than the encoded ones. +-- +-- See <../test/Big.hs> for a test and an example of use. +-- +-- See also "Flat.AsBin". +-- +-- @since 0.5 listTDecoder :: Get a -> BS.ByteString -> IO (ListT IO a) listTDecoder get (BS.PS base off len) = - withForeignPtr base $ \base0 -> do - let ptr = base0 `plusPtr` off - endPtr = ptr `plusPtr` len - s = S ptr 0 - go s = do - GetResult s' b <- runGet dBool endPtr s - if b - then do - GetResult s'' a <- runGet get endPtr s' - return $ Just (a, ListT $ go s'') - else return Nothing - return $ ListT (go s) + withForeignPtr base $ \base0 -> do + let ptr = base0 `plusPtr` off + endPtr = ptr `plusPtr` len + s = S ptr 0 + go s = do + GetResult s' b <- runGet dBool endPtr s + if b + then do + GetResult s'' a <- runGet get endPtr s' + return $ Just (a, ListT $ go s'') + else return Nothing + return $ ListT (go s) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Types.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Types.hs index 9ffb57cb698..ce5ff1558d5 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Types.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Types.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} --- |Strict Decoder Types -module PlutusCore.Flat.Decoder.Types - ( - Get(..) - , S(..) - , GetResult(..) - , Decoded - , DecodeException(..) - , notEnoughSpace - , tooMuchSpace - , badEncoding - , badOp - ) where +-- | Strict Decoder Types +module PlutusCore.Flat.Decoder.Types ( + Get (..), + S (..), + GetResult (..), + Decoded, + DecodeException (..), + notEnoughSpace, + tooMuchSpace, + badEncoding, + badOp, +) where import Control.DeepSeq (NFData (..)) import Control.Exception (Exception, throwIO) @@ -25,28 +24,27 @@ import Foreign (Ptr) import Control.Monad.Fail qualified as Fail #endif -{- | -A decoder. - -Given: - -* end of input buffer - -* current position in input buffer - -Returns: - -* decoded value - -* new position in input buffer --} -newtype Get a = - Get - { runGet :: - Ptr Word8 - -> S - -> IO (GetResult a) - } +-- | +-- A decoder. +-- +-- Given: +-- +-- * end of input buffer +-- +-- * current position in input buffer +-- +-- Returns: +-- +-- * decoded value +-- +-- * new position in input buffer +newtype Get a + = Get + { runGet :: + Ptr Word8 -> + S -> + IO (GetResult a) + } -- Seems to give better performance than the derived version instance Functor Get where @@ -100,22 +98,22 @@ instance Fail.MonadFail Get where failGet :: String -> Get a failGet msg = Get $ \end s -> badEncoding end s msg --- |Decoder state -data S = - S - { currPtr :: {-# UNPACK #-}!(Ptr Word8) - , usedBits :: {-# UNPACK #-}!Int - } +-- | Decoder state +data S + = S + { currPtr :: {-# UNPACK #-} !(Ptr Word8) + , usedBits :: {-# UNPACK #-} !Int + } deriving (Show, Eq, Ord) -data GetResult a = - GetResult {-# UNPACK #-}!S !a +data GetResult a + = GetResult {-# UNPACK #-} !S !a deriving (Functor) --- |A decoded value +-- | A decoded value type Decoded a = Either DecodeException a --- |An exception during decoding +-- | An exception during decoding data DecodeException = NotEnoughSpace Env | TooMuchSpace Env diff --git a/plutus-core/flat/src/PlutusCore/Flat/Encoder/Types.hs b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Types.hs index 0bb167501f5..d9ed71c9e86 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Encoder/Types.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Types.hs @@ -1,25 +1,25 @@ --- |Encoder Types -module PlutusCore.Flat.Encoder.Types( +-- | Encoder Types +module PlutusCore.Flat.Encoder.Types ( Size, NumBits, Prim, - S(..) + S (..), ) where import GHC.Ptr (Ptr (..)) import PlutusCore.Flat.Types --- |Add the maximum size in bits of the encoding of value a to a NumBits +-- | Add the maximum size in bits of the encoding of value a to a NumBits type Size a = a -> NumBits -> NumBits --- |Strict encoder state -data S = - S - { nextPtr :: {-# UNPACK #-} !(Ptr Word8) - , currByte :: {-# UNPACK #-} !Word8 - , usedBits :: {-# UNPACK #-} !NumBits - } deriving Show +-- | Strict encoder state +data S + = S + { nextPtr :: {-# UNPACK #-} !(Ptr Word8) + , currByte :: {-# UNPACK #-} !Word8 + , usedBits :: {-# UNPACK #-} !NumBits + } + deriving (Show) --- |A basic encoder +-- | A basic encoder type Prim = S -> IO S - diff --git a/plutus-core/flat/src/PlutusCore/Flat/Filler.hs b/plutus-core/flat/src/PlutusCore/Flat/Filler.hs index 5052b73d5eb..45d1ce5f2c9 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Filler.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Filler.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} --- |Pre-value and post-value byte alignments +-- | Pre-value and post-value byte alignments module PlutusCore.Flat.Filler ( - Filler(..), - fillerLength, - PreAligned(..), - preAligned, - PostAligned(..), - postAligned, - preAlignedDecoder, - postAlignedDecoder - ) where + Filler (..), + fillerLength, + PreAligned (..), + preAligned, + PostAligned (..), + postAligned, + preAlignedDecoder, + postAlignedDecoder, +) where import Control.DeepSeq (NFData) import Data.Typeable (Typeable) @@ -21,22 +21,24 @@ import PlutusCore.Flat.Class (Flat (..), Generic) import PlutusCore.Flat.Decoder.Types (Get) import PlutusCore.Flat.Encoder.Strict (eFiller, sFillerMax) --- |A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse) +-- | A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse) -- --- Used to align encoded values at byte/word boundaries. -data Filler = FillerBit !Filler - | FillerEnd +-- Used to align encoded values at byte/word boundaries. +data Filler + = FillerBit !Filler + | FillerEnd deriving (Show, Eq, Ord, Generic, NFData) --- |Use a special encoding for the filler +-- | Use a special encoding for the filler instance Flat Filler where encode _ = eFiller size = sFillerMax - -- use generated decode --- |A Post aligned value, a value followed by a filler +-- use generated decode + +-- | A Post aligned value, a value followed by a filler -- --- Useful to complete the encoding of a top-level value +-- Useful to complete the encoding of a top-level value #ifdef ETA_VERSION data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler } @@ -52,36 +54,36 @@ data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler } #endif --- |A Pre aligned value, a value preceded by a filler +-- | A Pre aligned value, a value preceded by a filler -- --- Useful to prealign ByteArrays, Texts and any structure that can be encoded more efficiently when byte aligned. -data PreAligned a = PreAligned { preFiller :: Filler, preValue :: a } +-- Useful to prealign ByteArrays, Texts and any structure that can be encoded more efficiently when byte aligned. +data PreAligned a = PreAligned {preFiller :: Filler, preValue :: a} deriving (Show, Eq, Ord, Generic, NFData, Flat) --- |Length of a filler in bits +-- | Length of a filler in bits fillerLength :: Num a => Filler -> a -fillerLength FillerEnd = 1 +fillerLength FillerEnd = 1 fillerLength (FillerBit f) = 1 + fillerLength f --- |Post align a value +-- | Post align a value postAligned :: a -> PostAligned a postAligned a = PostAligned a FillerEnd --- |Pre align a value +-- | Pre align a value preAligned :: a -> PreAligned a preAligned = PreAligned FillerEnd --- |Decode a value assuming that is PostAligned +-- | Decode a value assuming that is PostAligned postAlignedDecoder :: Get b -> Get b postAlignedDecoder dec = do v <- dec - _::Filler <- decode + _ :: Filler <- decode return v --- |Decode a value assuming that is PreAligned +-- | Decode a value assuming that is PreAligned -- --- @since 0.5 +-- @since 0.5 preAlignedDecoder :: Get b -> Get b preAlignedDecoder dec = do - _::Filler <- decode + _ :: Filler <- decode dec diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances.hs index b0b3be035dc..f0e602f943b 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances.hs @@ -1,8 +1,7 @@ - --- |Flat Instances for common data types from the packages on which `flat` has a dependency. -module PlutusCore.Flat.Instances - ( module X - ) +-- | Flat Instances for common data types from the packages on which `flat` has a dependency. +module PlutusCore.Flat.Instances ( + module X, +) where import PlutusCore.Flat.Instances.Array () diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Array.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Array.hs index a27c0bb98f1..2ca1b07233b 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Array.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Array.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -- | Flat instances for the `array` package -module PlutusCore.Flat.Instances.Array - () +module PlutusCore.Flat.Instances.Array () where import Data.Array qualified as A @@ -13,6 +12,7 @@ import PlutusCore.Flat.Class import PlutusCore.Flat.Decoder import PlutusCore.Flat.Encoder import PlutusCore.Flat.Instances.Base () + -- import PlutusCore.Flat.Instances.Util import PlutusCore.Flat.Instances.Mono @@ -25,34 +25,33 @@ import PlutusCore.Flat.Instances.Mono -- >>> import Data.Array.IArray -- >>> import Data.Word -{-| -Array is encoded as (lowBound,highBound,AsArray (elems array)): - ->>> let arr = A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] in tst (bounds arr,AsArray(elems arr)) == tst arr -True - -As it's easy to see: - ->>> tst $ A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] -(True,80,[1,4,2,5,4,11,22,33,44,0]) - ->>> tst $ A.array ((1,4),(2,5)) [((1,4),"1.4"),((1,5),"1.5"),((2,4),"2.4"),((2,5),"2.5")] -(True,160,[2,8,4,10,4,152,203,166,137,140,186,106,153,75,166,137,148,186,106,0]) - -Arrays and Unboxed Arrays are encoded in the same way: - ->>> let bounds = ((1::Word,4::Word),(2,5));elems=[11::Word,22,33,44] in tst (U.listArray bounds elems :: U.UArray (Word,Word) Word) == tst (A.listArray bounds elems) -True --} +-- | +-- Array is encoded as (lowBound,highBound,AsArray (elems array)): +-- +-- >>> let arr = A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] in tst (bounds arr,AsArray(elems arr)) == tst arr +-- True +-- +-- As it's easy to see: +-- +-- >>> tst $ A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] +-- (True,80,[1,4,2,5,4,11,22,33,44,0]) +-- +-- >>> tst $ A.array ((1,4),(2,5)) [((1,4),"1.4"),((1,5),"1.5"),((2,4),"2.4"),((2,5),"2.5")] +-- (True,160,[2,8,4,10,4,152,203,166,137,140,186,106,153,75,166,137,148,186,106,0]) +-- +-- Arrays and Unboxed Arrays are encoded in the same way: +-- +-- >>> let bounds = ((1::Word,4::Word),(2,5));elems=[11::Word,22,33,44] in tst (U.listArray bounds elems :: U.UArray (Word,Word) Word) == tst (A.listArray bounds elems) +-- True instance (Flat i, Flat e, Ix i) => Flat (A.Array i e) where - size = sizeIArray + size = sizeIArray encode = encodeIArray decode = decodeIArray instance (Flat i, Flat e, Ix i, IArray U.UArray e) => Flat (U.UArray i e) where - size = sizeIArray + size = sizeIArray encode = encodeIArray diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/ByteString.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/ByteString.hs index 439b0d7e8ff..3fd68dd5dc7 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/ByteString.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/ByteString.hs @@ -1,8 +1,7 @@ --- | Flat instances for the bytestring library {-# LANGUAGE NoMonomorphismRestriction #-} -module PlutusCore.Flat.Instances.ByteString - () +-- | Flat instances for the bytestring library +module PlutusCore.Flat.Instances.ByteString () where import Data.ByteString qualified as B @@ -19,70 +18,66 @@ import PlutusCore.Flat.Encoder -- >>> import qualified Data.ByteString.Lazy as L -- >>> import qualified Data.ByteString.Short as SBS -{-| -ByteString, ByteString.Lazy and ByteString.Short are all encoded as Prealigned Arrays: - -@ -PreAligned a ≡ PreAligned {preFiller :: Filler, preValue :: a} - -Filler ≡ FillerBit Filler - | FillerEnd - -Array v = A0 - | A1 v (Array v) - | A2 v v (Array v) - ... - | A255 ... (Array v) -@ - -That's to say as a byte-aligned sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. - ->>> tst (B.pack [11,22,33]) -(True,48,[1,3,11,22,33,0]) - -where: - -1= PreAlignment (takes a byte if we are already on a byte boundary) - -3= Number of bytes in ByteString - -11,22,33= Bytes - -0= End of Array - ->>> tst (B.pack []) -(True,16,[1,0]) - -Pre-alignment ensures that a ByteString always starts at a byte boundary: - ->>> tst ((False,True,False,B.pack [11,22,33])) -(True,51,[65,3,11,22,33,0]) - -All ByteStrings are encoded in the same way: - ->>> all (tst (B.pack [55]) ==) [tst (L.pack [55]),tst (SBS.pack [55])] -True --} +-- | +-- ByteString, ByteString.Lazy and ByteString.Short are all encoded as Prealigned Arrays: +-- +-- @ +-- PreAligned a ≡ PreAligned {preFiller :: Filler, preValue :: a} +-- +-- Filler ≡ FillerBit Filler +-- | FillerEnd +-- +-- Array v = A0 +-- | A1 v (Array v) +-- | A2 v v (Array v) +-- ... +-- | A255 ... (Array v) +-- @ +-- +-- That's to say as a byte-aligned sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. +-- +-- >>> tst (B.pack [11,22,33]) +-- (True,48,[1,3,11,22,33,0]) +-- +-- where: +-- +-- 1= PreAlignment (takes a byte if we are already on a byte boundary) +-- +-- 3= Number of bytes in ByteString +-- +-- 11,22,33= Bytes +-- +-- 0= End of Array +-- +-- >>> tst (B.pack []) +-- (True,16,[1,0]) +-- +-- Pre-alignment ensures that a ByteString always starts at a byte boundary: +-- +-- >>> tst ((False,True,False,B.pack [11,22,33])) +-- (True,51,[65,3,11,22,33,0]) +-- +-- All ByteStrings are encoded in the same way: +-- +-- >>> all (tst (B.pack [55]) ==) [tst (L.pack [55]),tst (SBS.pack [55])] +-- True instance Flat B.ByteString where encode = eBytes - size = sBytes + size = sBytes decode = dByteString -{- | ->>> tst ((False,True,False,L.pack [11,22,33])) -(True,51,[65,3,11,22,33,0]) --} +-- | +-- >>> tst ((False,True,False,L.pack [11,22,33])) +-- (True,51,[65,3,11,22,33,0]) instance Flat L.ByteString where encode = eLazyBytes - size = sLazyBytes + size = sLazyBytes decode = dLazyByteString -{- | ->>> tst ((False,True,False,SBS.pack [11,22,33])) -(True,51,[65,3,11,22,33,0]) --} +-- | +-- >>> tst ((False,True,False,SBS.pack [11,22,33])) +-- (True,51,[65,3,11,22,33,0]) instance Flat SBS.ShortByteString where encode = eShortBytes - size = sShortBytes + size = sShortBytes decode = dShortByteString - diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Containers.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Containers.hs index 81fc9de71e3..bc8284da897 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Containers.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Containers.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE CPP #-} --- |Instances for the containers library -module PlutusCore.Flat.Instances.Containers (sizeMap - , encodeMap - , decodeMap +-- | Instances for the containers library +module PlutusCore.Flat.Instances.Containers ( + sizeMap, + encodeMap, + decodeMap, ) where import Data.IntMap @@ -32,90 +33,84 @@ import PlutusCore.Flat.Instances.Util -- >>> import Data.Tree -- >>> import PlutusCore.Flat.Instances.Mono -{-| -Maps are defined as a list of (Key,Value) tuples: - -@ -Map = List (Key,Value) - -List a = Nil | Cons a (List a) -@ --} - -{-| ->>> tst (Data.IntMap.empty :: IntMap ()) -(True,1,[0]) - ->>> asList Data.IntMap.fromList [(1,"a"),(2,"b")] -True --} +-- | +-- Maps are defined as a list of (Key,Value) tuples: +-- +-- @ +-- Map = List (Key,Value) +-- +-- List a = Nil | Cons a (List a) +-- @ + +-- | +-- >>> tst (Data.IntMap.empty :: IntMap ()) +-- (True,1,[0]) +-- +-- >>> asList Data.IntMap.fromList [(1,"a"),(2,"b")] +-- True instance Flat a => Flat (IntMap a) where size = sizeMap encode = encodeMap decode = decodeMap -{-| -Maps are encoded as lists: - ->>> tst (Data.Map.empty :: Map () ()) -(True,1,[0]) - ->>> asList Data.Map.fromList [("a","aa"),("b","bb")] -True - -Key/Values are encoded in order: - ->>> let l = [("a","aa"),("b","bb")] in tst (Data.Map.fromList l) == tst (Data.Map.fromList $ Prelude.reverse l) -True - -IntMap and Map are encoded in the same way: - ->>> let l = [(2::Int,"b"),(1,"a")] in tst (Data.IntMap.fromList l) == tst (Data.Map.fromList l) -True --} +-- | +-- Maps are encoded as lists: +-- +-- >>> tst (Data.Map.empty :: Map () ()) +-- (True,1,[0]) +-- +-- >>> asList Data.Map.fromList [("a","aa"),("b","bb")] +-- True +-- +-- Key/Values are encoded in order: +-- +-- >>> let l = [("a","aa"),("b","bb")] in tst (Data.Map.fromList l) == tst (Data.Map.fromList $ Prelude.reverse l) +-- True +-- +-- IntMap and Map are encoded in the same way: +-- +-- >>> let l = [(2::Int,"b"),(1,"a")] in tst (Data.IntMap.fromList l) == tst (Data.Map.fromList l) +-- True instance (Flat a, Flat b, Ord a) => Flat (Map a b) where size = sizeMap encode = encodeMap decode = decodeMap -{-| -Data.Sequence.Seq is encoded as a list. - ->>> asList Data.Sequence.fromList [3::Word8,4,7] -True - -In flat <0.4, it was encoded as an Array. - -If you want to restore the previous behaviour, use AsArray: - ->>> tst $ AsArray (Data.Sequence.fromList [11::Word8,22,33]) -(True,40,[3,11,22,33,0]) - ->>> tst $ Data.Sequence.fromList [11::Word8,22,33] -(True,28,[133,197,164,32]) --} +-- | +-- Data.Sequence.Seq is encoded as a list. +-- +-- >>> asList Data.Sequence.fromList [3::Word8,4,7] +-- True +-- +-- In flat <0.4, it was encoded as an Array. +-- +-- If you want to restore the previous behaviour, use AsArray: +-- +-- >>> tst $ AsArray (Data.Sequence.fromList [11::Word8,22,33]) +-- (True,40,[3,11,22,33,0]) +-- +-- >>> tst $ Data.Sequence.fromList [11::Word8,22,33] +-- (True,28,[133,197,164,32]) instance Flat a => Flat (Seq a) where - size = sizeList -- . toList - encode = encodeList -- . Data.Sequence.toList - decode = Data.Sequence.fromList <$> decodeList - -{-| -Data.Set is encoded as a list - ->>> asList Data.Set.fromList [3::Word8,4,7] -True --} -instance (Flat a,Ord a) => Flat (Set a) where + size = sizeList -- . toList + encode = encodeList -- . Data.Sequence.toList + decode = Data.Sequence.fromList <$> decodeList + +-- | +-- Data.Set is encoded as a list +-- +-- >>> asList Data.Set.fromList [3::Word8,4,7] +-- True +instance (Flat a, Ord a) => Flat (Set a) where size = sizeSet encode = encodeSet decode = decodeSet -{-| ->>> tst (Node (1::Word8) [Node 2 [Node 3 []], Node 4 []]) -(True,39,[1,129,64,200,32]) --} +-- | +-- >>> tst (Node (1::Word8) [Node 2 [Node 3 []], Node 4 []]) +-- (True,39,[1,129,64,200,32]) #if ! MIN_VERSION_containers(0,5,8) deriving instance Generic (Tree a) #endif -instance (Flat a) => Flat (Tree a) +instance Flat a => Flat (Tree a) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/DList.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/DList.hs index 45c381467b0..a00f2d276d9 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/DList.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/DList.hs @@ -1,5 +1,4 @@ -module PlutusCore.Flat.Instances.DList - () +module PlutusCore.Flat.Instances.DList () where import Data.DList (DList, fromList, toList) @@ -13,15 +12,13 @@ import PlutusCore.Flat.Instances.Mono (decodeList, encodeList, sizeList) -- >>> import Data.DList -- >>> let test = tstBits -{-| ->>> test (Data.DList.fromList [7::Word,7]) -(True,19,"10000011 11000001 110") - ->>> let l = [7::Word,7] in flat (Data.DList.fromList l) == flat l -True --} - +-- | +-- >>> test (Data.DList.fromList [7::Word,7]) +-- (True,19,"10000011 11000001 110") +-- +-- >>> let l = [7::Word,7] in flat (Data.DList.fromList l) == flat l +-- True instance Flat a => Flat (DList a) where - size = sizeList . toList + size = sizeList . toList encode = encodeList . toList decode = fromList <$> decodeList diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Extra.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Extra.hs index 4eb63dd4ae0..1286480258f 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Extra.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Extra.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} + module PlutusCore.Flat.Instances.Extra where import PlutusCore.Flat.Class (Flat) @@ -7,14 +8,12 @@ import PlutusCore.Flat.Instances.Base () -- $setup -- >>> import PlutusCore.Flat.Instances.Test -{- | -For better encoding/decoding performance, it is useful to declare instances of concrete list types, such as [Char]. - ->>> tstBits "" -(True,1,"0") - ->>> tstBits "aaa" -(True,28,"10110000 11011000 01101100 0010") --} +-- | +-- For better encoding/decoding performance, it is useful to declare instances of concrete list types, such as [Char]. +-- +-- >>> tstBits "" +-- (True,1,"0") +-- +-- >>> tstBits "aaa" +-- (True,28,"10110000 11011000 01101100 0010") instance {-# OVERLAPPING #-} Flat [Char] - diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Mono.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Mono.hs index ac0530ab1da..8a57e49cfbb 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Mono.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Mono.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Flat.Instances.Mono - ( sizeSequence - , encodeSequence - , decodeSequence - , sizeList - , encodeList - , decodeList - , sizeSet - , encodeSet - , decodeSet - , sizeMap - , encodeMap - , decodeMap - , AsArray(..) - , AsList(..) - , AsSet(..) - , AsMap(..) - ) + +module PlutusCore.Flat.Instances.Mono ( + sizeSequence, + encodeSequence, + decodeSequence, + sizeList, + encodeList, + decodeList, + sizeSet, + encodeSet, + decodeSet, + sizeMap, + encodeMap, + decodeMap, + AsArray (..), + AsList (..), + AsSet (..), + AsMap (..), +) where import Data.Containers @@ -30,135 +30,134 @@ import Data.Sequences (IsSequence) import Data.Sequences qualified as S import PlutusCore.Flat.Instances.Util -{- $setup ->>> import PlutusCore.Flat.Instances.Base() ->>> import PlutusCore.Flat.Instances.Test ->>> import Data.Word ->>> import qualified Data.Set ->>> import qualified Data.Map --} - -{-| -Sequences are defined as Arrays: - -Array v = A0 - | A1 v (Array v) - | A2 v v (Array v) - ... - | A255 ... (Array v) - -In practice, this means that the sequence is encoded as a sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. - -Lists are defined as: - -List a ≡ Nil - | Cons a (List a) - -In practice, this means that the list elements will be prefixed with a 1 bit and followed by a final 0 bit. - -The AsList/AsArray wrappers can be used to serialise sequences as Lists or Arrays. - -Let's see some examples. - ->>> flatBits $ AsList [True,True,True] -"1111110" - -So we have Cons True (11) repeated three times, followed by a final Nil (0). - -The list encoding is the default one for lists so AsList is in this case unnecessary: - ->>> flatBits $ [True,True,True] -"1111110" - -We can force a list to be encoded as an Array with AsArray: - ->>> flatBits $ AsArray [True,True,True] -"00000011 11100000 000" - -We have the initial block with a count of 3 (3 == 00000011) followed by the elements True True True (111) and then the final block of 0 elements ("00000 000"). - ->>> flatBits $ [AsArray [True,True,True]] -"10000001 11110000 00000" - ->>> flatBits $ (True,True,True,AsArray $ replicate 7 True) -"11100000 11111111 11000000 00" - ->>> flatBits $ AsArray ([]::[()]) -"00000000" - ->>> flatBits $ AsList ([]::[()]) -"0" - ->>> tst (AsList [11::Word8,22,33]) -(True,28,[133,197,164,32]) - ->>> tst (AsSet (Data.Set.fromList [11::Word8,22,33])) -(True,28,[133,197,164,32]) - ->>> tst [AsArray [1..3], AsArray [4..8]] -(True,99,[129,129,2,3,0,65,66,2,131,3,132,0,0]) - ->>> tst $ [AsArray [(1::Word8)..3], AsArray [4..8]] -(True,99,[129,128,129,1,128,65,65,1,65,129,194,0,0]) - ->>> tst $ [AsArray [(1::Int)..3]] -(True,42,[129,129,2,3,0,0]) --} -newtype AsArray a = - AsArray - { unArray :: a - } deriving (Show,Eq,Ord) +-- $setup +-- >>> import PlutusCore.Flat.Instances.Base() +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import Data.Word +-- >>> import qualified Data.Set +-- >>> import qualified Data.Map + +-- | +-- Sequences are defined as Arrays: +-- +-- Array v = A0 +-- | A1 v (Array v) +-- | A2 v v (Array v) +-- ... +-- | A255 ... (Array v) +-- +-- In practice, this means that the sequence is encoded as a sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. +-- +-- Lists are defined as: +-- +-- List a ≡ Nil +-- | Cons a (List a) +-- +-- In practice, this means that the list elements will be prefixed with a 1 bit and followed by a final 0 bit. +-- +-- The AsList/AsArray wrappers can be used to serialise sequences as Lists or Arrays. +-- +-- Let's see some examples. +-- +-- >>> flatBits $ AsList [True,True,True] +-- "1111110" +-- +-- So we have Cons True (11) repeated three times, followed by a final Nil (0). +-- +-- The list encoding is the default one for lists so AsList is in this case unnecessary: +-- +-- >>> flatBits $ [True,True,True] +-- "1111110" +-- +-- We can force a list to be encoded as an Array with AsArray: +-- +-- >>> flatBits $ AsArray [True,True,True] +-- "00000011 11100000 000" +-- +-- We have the initial block with a count of 3 (3 == 00000011) followed by the elements True True True (111) and then the final block of 0 elements ("00000 000"). +-- +-- >>> flatBits $ [AsArray [True,True,True]] +-- "10000001 11110000 00000" +-- +-- >>> flatBits $ (True,True,True,AsArray $ replicate 7 True) +-- "11100000 11111111 11000000 00" +-- +-- >>> flatBits $ AsArray ([]::[()]) +-- "00000000" +-- +-- >>> flatBits $ AsList ([]::[()]) +-- "0" +-- +-- >>> tst (AsList [11::Word8,22,33]) +-- (True,28,[133,197,164,32]) +-- +-- >>> tst (AsSet (Data.Set.fromList [11::Word8,22,33])) +-- (True,28,[133,197,164,32]) +-- +-- >>> tst [AsArray [1..3], AsArray [4..8]] +-- (True,99,[129,129,2,3,0,65,66,2,131,3,132,0,0]) +-- +-- >>> tst $ [AsArray [(1::Word8)..3], AsArray [4..8]] +-- (True,99,[129,128,129,1,128,65,65,1,65,129,194,0,0]) +-- +-- >>> tst $ [AsArray [(1::Int)..3]] +-- (True,42,[129,129,2,3,0,0]) +newtype AsArray a + = AsArray + { unArray :: a + } + deriving (Show, Eq, Ord) instance (IsSequence r, Flat (Element r)) => Flat (AsArray r) where size (AsArray a) = sizeSequence a encode (AsArray a) = encodeSequence a decode = AsArray <$> decodeSequence -{- | -Calculate size of an instance of IsSequence as the sum: - -* of the size of all the elements - -* plus the size of the array constructors (1 byte every 255 elements plus one final byte) --} -sizeSequence - :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits +-- | +-- Calculate size of an instance of IsSequence as the sum: +-- +-- * of the size of all the elements +-- +-- * plus the size of the array constructors (1 byte every 255 elements plus one final byte) +sizeSequence :: + (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits sizeSequence s acc = let (sz, len) = - ofoldl' (\(acc, l) e -> (size e acc, l + 1)) (acc, 0 :: NumBits) s - in sz + arrayBits len + ofoldl' (\(acc, l) e -> (size e acc, l + 1)) (acc, 0 :: NumBits) s + in sz + arrayBits len {-# INLINE sizeSequence #-} -- TODO: check which one is faster -- sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s) --- |Encode an instance of IsSequence, as an array +-- | Encode an instance of IsSequence, as an array encodeSequence :: (Flat (Element mono), MonoFoldable mono) => mono -> Encoding encodeSequence = encodeArray . otoList {-# INLINE encodeSequence #-} --- |Decode an instance of IsSequence, as an array +-- | Decode an instance of IsSequence, as an array decodeSequence :: (Flat (Element b), IsSequence b) => Get b decodeSequence = S.fromList <$> decodeArrayWith decode {-# INLINE decodeSequence #-} -newtype AsList a = - AsList - { unList :: a - } deriving (Show,Eq,Ord) +newtype AsList a + = AsList + { unList :: a + } + deriving (Show, Eq, Ord) instance (IsSequence l, Flat (Element l)) => Flat (AsList l) where -- size = sizeList . S.unpack . unList -- encode = encodeList . S.unpack . unList -- decode = AsList . S.fromList <$> decodeListotoList - size = sizeList . unList + size = sizeList . unList encode = encodeList . unList decode = AsList <$> decodeList {-# INLINE sizeList #-} -sizeList - :: (MonoFoldable mono, Flat (Element mono)) => mono -> NumBits -> NumBits +sizeList :: + (MonoFoldable mono, Flat (Element mono)) => mono -> NumBits -> NumBits sizeList l sz = ofoldl' (\s e -> size e (s + 1)) (sz + 1) l {-# INLINE encodeList #-} @@ -169,19 +168,19 @@ encodeList = encodeListWith encode . otoList decodeList :: (IsSequence b, Flat (Element b)) => Get b decodeList = S.fromList <$> decodeListWith decode -{-| -Sets are saved as lists of values. - ->>> tstBits $ AsSet (Data.Set.fromList ([False,True,False]::[Bool])) -(True,5,"10110") --} -newtype AsSet a = - AsSet - { unSet :: a - } deriving (Show,Eq,Ord) +-- | +-- Sets are saved as lists of values. +-- +-- >>> tstBits $ AsSet (Data.Set.fromList ([False,True,False]::[Bool])) +-- (True,5,"10110") +newtype AsSet a + = AsSet + { unSet :: a + } + deriving (Show, Eq, Ord) instance (IsSet set, Flat (Element set)) => Flat (AsSet set) where - size = sizeSet . unSet + size = sizeSet . unSet encode = encodeSet . unSet decode = AsSet <$> decodeSet @@ -197,22 +196,22 @@ decodeSet :: (IsSet set, Flat (Element set)) => Get set decodeSet = setFromList <$> decodeList {-# INLINE decodeSet #-} -{-| -Maps are saved as lists of (key,value) tuples. - ->>> tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) -(True,1,[0]) - ->>> tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) -(True,18,[129,132,128]) --} -newtype AsMap a = - AsMap - { unMap :: a - } deriving (Show,Eq,Ord) +-- | +-- Maps are saved as lists of (key,value) tuples. +-- +-- >>> tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) +-- (True,1,[0]) +-- +-- >>> tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) +-- (True,18,[129,132,128]) +newtype AsMap a + = AsMap + { unMap :: a + } + deriving (Show, Eq, Ord) instance (IsMap map, Flat (ContainerKey map), Flat (MapValue map)) => Flat (AsMap map) where - size = sizeMap . unMap + size = sizeMap . unMap encode = encodeMap . unMap decode = AsMap <$> decodeMap @@ -222,19 +221,21 @@ sizeMap m acc = F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1) . mapToList $ m + -- sizeMap l sz = ofoldl' (\s (k, v) -> size k (size v (s + 1))) (sz + 1) l {-# INLINE encodeMap #-} --- |Encode an instance of IsMap, as a list of (Key,Value) tuples -encodeMap - :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) - => map - -> Encoding + +-- | Encode an instance of IsMap, as a list of (Key,Value) tuples +encodeMap :: + (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => + map -> + Encoding encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList {-# INLINE decodeMap #-} --- |Decode an instance of IsMap, as a list of (Key,Value) tuples -decodeMap - :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map -decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode) +-- | Decode an instance of IsMap, as a list of (Key,Value) tuples +decodeMap :: + (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map +decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Test.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Test.hs index d8f56405736..15ae529cec9 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Test.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Test.hs @@ -1,13 +1,13 @@ -- | doctest utilities module PlutusCore.Flat.Instances.Test ( - tst, - tstBits, - asList, - flatBits, - allBits, - encBits, - prettyShow, - module Data.Word, + tst, + tstBits, + asList, + flatBits, + allBits, + encBits, + prettyShow, + module Data.Word, ) where import Control.Monad ((>=>)) @@ -38,7 +38,7 @@ flatBits = prettyShow . bits allBits :: Flat a => a -> String allBits = prettyShow . paddedBits --- |@since 0.5 +-- | @since 0.5 encBits :: NumBits -> Encoding -> Bits encBits maxNumBits e@(Encoding enc) = takeBits (numEncodedBits maxNumBits e) (strictEncoder maxNumBits (Encoding $ enc >=> eFillerF)) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Unordered.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Unordered.hs index 494b9688f07..99feed12f14 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Unordered.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Unordered.hs @@ -1,11 +1,9 @@ - -module PlutusCore.Flat.Instances.Unordered - () +module PlutusCore.Flat.Instances.Unordered () where -import Data.Hashable import Data.HashMap.Strict qualified as MS import Data.HashSet +import Data.Hashable import PlutusCore.Flat.Instances.Mono import PlutusCore.Flat.Instances.Util @@ -18,26 +16,22 @@ import PlutusCore.Flat.Instances.Util -- >>> import qualified Data.HashSet -- >>> let test = tstBits -{-| ->>> test (Data.HashSet.fromList [1..3::Word]) -(True,28,"10000000 11000000 10100000 0110") --} - -instance (Hashable a, Eq a,Flat a) => Flat (HashSet a) where - size = sizeSet +-- | +-- >>> test (Data.HashSet.fromList [1..3::Word]) +-- (True,28,"10000000 11000000 10100000 0110") +instance (Hashable a, Eq a, Flat a) => Flat (HashSet a) where + size = sizeSet encode = encodeSet decode = decodeSet -{-| ->>> test (Data.HashMap.Strict.fromList [(1,11),(2,22)]) -(True,35,"10000001 00001011 01000001 00001011 000") - ->>> test (Data.HashMap.Lazy.fromList [(1,11),(2,22)]) -(True,35,"10000001 00001011 01000001 00001011 000") - --} -instance (Hashable k,Eq k,Flat k,Flat v) => Flat (MS.HashMap k v) where - size = sizeMap +-- | +-- >>> test (Data.HashMap.Strict.fromList [(1,11),(2,22)]) +-- (True,35,"10000001 00001011 01000001 00001011 000") +-- +-- >>> test (Data.HashMap.Lazy.fromList [(1,11),(2,22)]) +-- (True,35,"10000001 00001011 01000001 00001011 000") +instance (Hashable k, Eq k, Flat k, Flat v) => Flat (MS.HashMap k v) where + size = sizeMap encode = encodeMap decode = decodeMap @@ -45,4 +39,3 @@ instance (Hashable k,Eq k,Flat k,Flat v) => Flat (MS.HashMap k v) where -- size = sizeMap -- encode = encodeMap -- decode = decodeMap - diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Util.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Util.hs index 0d6da4cb1d1..492e5dd7e06 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Util.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Util.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -module PlutusCore.Flat.Instances.Util - ( module F - -- sizeList - -- , decodeList - -- , encodeList - , encodeArray - ) + +module PlutusCore.Flat.Instances.Util ( + module F, + -- sizeList + -- , decodeList + -- , encodeList + encodeArray, +) where import PlutusCore.Flat.Class as F import PlutusCore.Flat.Decoder as F import PlutusCore.Flat.Encoder as F import PlutusCore.Flat.Types as F + -- import Data.List -- import GHC.Exts(IsList) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Vector.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Vector.hs index 97f41b7064f..55bf053fd34 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Instances/Vector.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Vector.hs @@ -1,7 +1,5 @@ - -- | Flat instances for the vector package. -module PlutusCore.Flat.Instances.Vector - () +module PlutusCore.Flat.Instances.Vector () where import PlutusCore.Flat.Instances.Mono @@ -18,29 +16,27 @@ import Data.Vector.Unboxed qualified as U -- >>> import qualified Data.Vector.Unboxed as U -- >>> import qualified Data.Vector.Storable as S -{-| -Vectors are encoded as arrays. - ->>> tst (V.fromList [11::Word8,22,33]) -(True,40,[3,11,22,33,0]) - -All Vectors are encoded in the same way: - ->>> let l = [11::Word8,22,33] in all (tst (V.fromList l) ==) [tst (U.fromList l),tst (S.fromList l)] -True --} - +-- | +-- Vectors are encoded as arrays. +-- +-- >>> tst (V.fromList [11::Word8,22,33]) +-- (True,40,[3,11,22,33,0]) +-- +-- All Vectors are encoded in the same way: +-- +-- >>> let l = [11::Word8,22,33] in all (tst (V.fromList l) ==) [tst (U.fromList l),tst (S.fromList l)] +-- True instance Flat a => Flat (V.Vector a) where - size = sizeSequence + size = sizeSequence encode = encodeSequence decode = decodeSequence -instance (U.Unbox a,Flat a) => Flat (U.Vector a) where - size = sizeSequence +instance (U.Unbox a, Flat a) => Flat (U.Vector a) where + size = sizeSequence encode = encodeSequence decode = decodeSequence -instance (S.Storable a,Flat a) => Flat (S.Vector a) where - size = sizeSequence +instance (S.Storable a, Flat a) => Flat (S.Vector a) where + size = sizeSequence encode = encodeSequence decode = decodeSequence diff --git a/plutus-core/flat/src/PlutusCore/Flat/Memory.hs b/plutus-core/flat/src/PlutusCore/Flat/Memory.hs index 2467dab703c..f4416ffc1d7 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Memory.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Memory.hs @@ -1,31 +1,35 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -{- | -Memory access primitives. - -Includes code from the [store-core](https://hackage.haskell.org/package/store-core) package. --} -module PlutusCore.Flat.Memory - ( chunksToByteString - , chunksToByteArray - , ByteArray - , pokeByteArray - , pokeByteString - , unsafeCreateUptoN' - , minusPtr - , peekByteString - ) +-- | +-- Memory access primitives. +-- +-- Includes code from the [store-core](https://hackage.haskell.org/package/store-core) package. +module PlutusCore.Flat.Memory ( + chunksToByteString, + chunksToByteArray, + ByteArray, + pokeByteArray, + pokeByteString, + unsafeCreateUptoN', + minusPtr, + peekByteString, +) where import Control.Monad (foldM_, when) import Control.Monad.Primitive (PrimMonad (..)) import Data.ByteString qualified as B import Data.ByteString.Internal qualified as BS -import Data.Primitive.ByteArray (ByteArray, ByteArray#, MutableByteArray (..), newByteArray, - unsafeFreezeByteArray) +import Data.Primitive.ByteArray ( + ByteArray, + ByteArray#, + MutableByteArray (..), + newByteArray, + unsafeFreezeByteArray, + ) import Foreign (Ptr, Word8, minusPtr, plusPtr, withForeignPtr) import Foreign.Marshal.Utils (copyBytes) import GHC.Prim (copyAddrToByteArray#, copyByteArrayToAddr#) @@ -39,37 +43,40 @@ unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f) createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (BS.ByteString, a) createUptoN' l f = do - fp <- BS.mallocByteString l + fp <- BS.mallocByteString l (l', res) <- withForeignPtr fp $ \p -> f p - --print (unwords ["Buffer allocated:",show l,"bytes, used:",show l',"bytes"]) - when (l' > l) $ error - (unwords - ["Buffer overflow, allocated:", show l, "bytes, used:", show l', "bytes"] - ) + -- print (unwords ["Buffer allocated:",show l,"bytes, used:",show l',"bytes"]) + when (l' > l) $ + error + ( unwords + ["Buffer overflow, allocated:", show l, "bytes, used:", show l', "bytes"] + ) return (BS.PS fp 0 l', res) -- , minusPtr l') {-# INLINE createUptoN' #-} --- |Copy bytestring to given pointer, returns new pointer +-- | Copy bytestring to given pointer, returns new pointer pokeByteString :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8) pokeByteString (BS.PS foreignPointer sourceOffset sourceLength) destPointer = do - withForeignPtr foreignPointer $ \sourcePointer -> copyBytes - destPointer - (sourcePointer `plusPtr` sourceOffset) - sourceLength + withForeignPtr foreignPointer $ \sourcePointer -> + copyBytes + destPointer + (sourcePointer `plusPtr` sourceOffset) + sourceLength return (destPointer `plusPtr` sourceLength) -{-| Create a new bytestring, copying sourceLen bytes from sourcePtr - -@since 0.6 --} +-- | Create a new bytestring, copying sourceLen bytes from sourcePtr +-- +-- @since 0.6 peekByteString :: - Ptr Word8 -- ^ sourcePtr - -> Int -- ^ sourceLen - -> BS.ByteString + -- | sourcePtr + Ptr Word8 -> + -- | sourceLen + Int -> + BS.ByteString peekByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> copyBytes destPointer sourcePtr sourceLength --- |Copy ByteArray to given pointer, returns new pointer +-- | Copy ByteArray to given pointer, returns new pointer pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8) pokeByteArray sourceArr sourceOffset len dest = do copyByteArrayToAddr sourceArr sourceOffset dest len @@ -77,7 +84,6 @@ pokeByteArray sourceArr sourceOffset len dest = do return dest' {-# INLINE pokeByteArray #-} - -- | Wrapper around @copyByteArrayToAddr#@ primop. -- -- Copied from the store-core package @@ -88,37 +94,38 @@ copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) = chunksToByteString :: (Ptr Word8, [Int]) -> BS.ByteString chunksToByteString (sourcePtr0, lens) = - BS.unsafeCreate (sum lens) $ \destPtr0 -> foldM_ - (\(destPtr, sourcePtr) sourceLength -> - copyBytes destPtr sourcePtr sourceLength - >> return - ( destPtr `plusPtr` sourceLength - , sourcePtr `plusPtr` (sourceLength + 1) - ) - ) - (destPtr0, sourcePtr0) - lens + BS.unsafeCreate (sum lens) $ \destPtr0 -> + foldM_ + ( \(destPtr, sourcePtr) sourceLength -> + copyBytes destPtr sourcePtr sourceLength + >> return + ( destPtr `plusPtr` sourceLength + , sourcePtr `plusPtr` (sourceLength + 1) + ) + ) + (destPtr0, sourcePtr0) + lens chunksToByteArray :: (Ptr Word8, [Int]) -> (ByteArray, Int) chunksToByteArray (sourcePtr0, lens) = unsafePerformIO $ do let len = sum lens arr <- newByteArray len foldM_ - (\(destOff, sourcePtr) sourceLength -> - copyAddrToByteArray sourcePtr arr destOff sourceLength >> return - (destOff + sourceLength, sourcePtr `plusPtr` (sourceLength + 1)) + ( \(destOff, sourcePtr) sourceLength -> + copyAddrToByteArray sourcePtr arr destOff sourceLength + >> return + (destOff + sourceLength, sourcePtr `plusPtr` (sourceLength + 1)) ) (0, sourcePtr0) lens farr <- unsafeFreezeByteArray arr return (farr, len) - -- | Wrapper around @copyAddrToByteArray#@ primop. -- -- Copied from the store-core package -copyAddrToByteArray - :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () +copyAddrToByteArray :: + Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) = IO (\s -> (# copyAddrToByteArray# addr arr offset len s, () #)) {-# INLINE copyAddrToByteArray #-} diff --git a/plutus-core/flat/src/PlutusCore/Flat/Run.hs b/plutus-core/flat/src/PlutusCore/Flat/Run.hs index e462da1e1bb..7eca14f311b 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Run.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Run.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} --- |Encoding and decoding functions +-- | Encoding and decoding functions module PlutusCore.Flat.Run ( - flat, - flatRaw, - unflat, - unflatWith, - unflatRaw, - unflatRawWith, - unflatRawWithOffset, + flat, + flatRaw, + unflat, + unflatWith, + unflatRaw, + unflatRawWith, + unflatRawWithOffset, ) where import Data.ByteString qualified as B @@ -22,23 +22,23 @@ import PlutusCore.Flat.Encoder (NumBits) import PlutusCore.Flat.Encoder qualified as E import PlutusCore.Flat.Filler (postAligned, postAlignedDecoder) --- |Encode padded value. +-- | Encode padded value. flat :: Flat a => a -> B.ByteString flat = flatRaw . postAligned --- |Decode padded value. +-- | Decode padded value. unflat :: (Flat a, AsByteString b) => b -> Decoded a unflat = unflatWith decode --- |Decode padded value, using the provided unpadded decoder. +-- | Decode padded value, using the provided unpadded decoder. unflatWith :: AsByteString b => Get a -> b -> Decoded a unflatWith dec = unflatRawWith (postAlignedDecoder dec) --- |Decode unpadded value. +-- | Decode unpadded value. unflatRaw :: (Flat a, AsByteString b) => b -> Decoded a unflatRaw = unflatRawWith decode --- |Unflat unpadded value, using provided decoder +-- | Unflat unpadded value, using provided decoder unflatRawWith :: AsByteString b => Get a -> b -> Decoded a unflatRawWith dec bs = unflatRawWithOffset dec bs 0 @@ -51,12 +51,12 @@ unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs) -- unflatRawWithOffset :: AsByteString b => Get a -> b -> Int -> Decoded a -- unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs) --- |Encode unpadded value +-- | Encode unpadded value flatRaw :: (Flat a, AsByteString b) => a -> b flatRaw a = - fromByteString $ - E.strictEncoder - (getSize a) + fromByteString $ + E.strictEncoder + (getSize a) #ifdef ETA_VERSION (E.trampolineEncoding (encode a)) diff --git a/plutus-core/flat/src/PlutusCore/Flat/TestMemory.hs b/plutus-core/flat/src/PlutusCore/Flat/TestMemory.hs index 64c663e3cca..9416844224a 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/TestMemory.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/TestMemory.hs @@ -1,13 +1,11 @@ -{- | -Represent a data type in memory using the flat representation. - -Access it as normal using pattern synonyms (https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pattern_synonyms.html) or lenses? - -This should: -* massively reduce memory usage (without requiring any manual specialisation) -* possibly reduce traversal times (via better caching) - --} +-- | +-- Represent a data type in memory using the flat representation. +-- +-- Access it as normal using pattern synonyms (https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pattern_synonyms.html) or lenses? +-- +-- This should: +-- * massively reduce memory usage (without requiring any manual specialisation) +-- * possibly reduce traversal times (via better caching) module PlutusCore.Flat.TestMemory where import Data.ByteString @@ -19,8 +17,8 @@ import PlutusCore.Flat 3 * fact fact 2 = 3 * 2 * 1 -} -- x :: Int -> Int -x n = fact (fact n) +x n = fact (fact n) fact :: (Int -> Int) -> Int -> Int fact _ 1 = 1 -fact k n = n * k (n-1) +fact k n = n * k (n - 1) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Tutorial.hs b/plutus-core/flat/src/PlutusCore/Flat/Tutorial.hs index e0a52b013df..fc3e99189d7 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Tutorial.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Tutorial.hs @@ -1,116 +1,108 @@ -module PlutusCore.Flat.Tutorial - ( - -- $setup - - -- $main - ) +module PlutusCore.Flat.Tutorial ( + -- $setup + -- $main +) where - -{- $setup -To (de)serialise a data type, make it an instance of the 'Flat.Class.Flat' class. - -There is based support to automatically derive a correct instance. - -Let’s see some code. - -We need a couple of extensions: - ->>> :set -XDeriveGeneric -XDeriveAnyClass - -The @Flat@ top module: - ->>> import PlutusCore.Flat - -And, just for fun, a couple of functions to display an encoded value as a sequence of bits: - ->>> import PlutusCore.Flat.Instances.Test (flatBits,allBits) - -Define a few custom data types, deriving @Generic@ and @Flat@: - ->>> data Result = Bad | Good deriving (Show,Generic,Flat) - ->>> data Direction = North | South | Center | East | West deriving (Show,Generic,Flat) - ->>> data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat) --} - -{- $main -Now we can encode a List of Directions using 'Flat.Run.flat': - ->>> flat $ Cons North (Cons South Nil) -"\149" - -The result is a strict . - -And decode it back using 'Flat.Run.unflat': - ->>> unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction) -Right (Cons North (Cons South Nil)) - -The result is a 'Flat.Decoded' value: 'Either' a 'Flat.DecodeException' or the actual value. - -=== Optimal Bit-Encoding -#optimal-bit-encoding# - -A pecularity of Flat is that it uses an optimal bit-encoding rather than -the usual byte-oriented one. - -One bit is sufficient to encode a 'Result' or an empty 'List': - ->>> flatBits Good -"1" - ->>> flatBits (Nil::List Direction) -"0" - -Two or three bits suffice for a 'Direction': - ->>> flatBits South -"01" - ->>> flatBits West -"111" - -For the serialisation to work with byte-oriented devices or storage, we need to add some padding. - -To do so, rather than encoding a plain value, 'Flat.Run.flat' encodes a 'Flat.Filler.PostAligned' value, that's to say a value followed by a 'Flat.Filler.Filler' that stretches till the next byte boundary. - -In practice, the padding is a, possibly empty, sequence of 0s followed by a 1. - -For example, this list encodes as 7 bits: - ->>> flatBits $ Cons North (Cons South Nil) -"1001010" - -And, with the added padding of a final "1", will snugly fit in a single byte: - ->>> allBits $ Cons North (Cons South Nil) -"10010101" - -But .. you don't need to worry about these details as byte-padding is automatically added by the function 'Flat.Run.flat' and removed by 'Flat.Run.unflat'. - -=== Pre-defined Instances - -Flat instances are already defined for relevant types of some common packages: array, base, bytestring, containers, dlist, mono-traversable, text, unordered-containers, vector. - -They are automatically imported by the "Flat" module. - -For example: - ->>> flatBits $ Just True -"11" - -=== Wrapper Types - -There are a few wrapper types that modify the way encoding and/or decoding occur. - -* "Flat.AsBin" and "Flat.AsSize" decode to a value's flat binary representation or size in bits respectively. - -* 'Flat.Instances.Mono.AsArray' and 'Flat.Instances.Mono.AsList' encode/decode a sequence as a List or Array respectively, see "Flat.Instances.Mono" for details. - -* 'Flat.Instances.Text.UTF8Text' and 'Flat.Instances.Text.UTF16Text' encode/decode a Text as UTF8 or UTF16 respectively. - --} - - +-- $setup +-- To (de)serialise a data type, make it an instance of the 'Flat.Class.Flat' class. +-- +-- There is based support to automatically derive a correct instance. +-- +-- Let’s see some code. +-- +-- We need a couple of extensions: +-- +-- >>> :set -XDeriveGeneric -XDeriveAnyClass +-- +-- The @Flat@ top module: +-- +-- >>> import PlutusCore.Flat +-- +-- And, just for fun, a couple of functions to display an encoded value as a sequence of bits: +-- +-- >>> import PlutusCore.Flat.Instances.Test (flatBits,allBits) +-- +-- Define a few custom data types, deriving @Generic@ and @Flat@: +-- +-- >>> data Result = Bad | Good deriving (Show,Generic,Flat) +-- +-- >>> data Direction = North | South | Center | East | West deriving (Show,Generic,Flat) +-- +-- >>> data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat) + +-- $main +-- Now we can encode a List of Directions using 'Flat.Run.flat': +-- +-- >>> flat $ Cons North (Cons South Nil) +-- "\149" +-- +-- The result is a strict . +-- +-- And decode it back using 'Flat.Run.unflat': +-- +-- >>> unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction) +-- Right (Cons North (Cons South Nil)) +-- +-- The result is a 'Flat.Decoded' value: 'Either' a 'Flat.DecodeException' or the actual value. +-- +-- === Optimal Bit-Encoding +-- #optimal-bit-encoding# +-- +-- A pecularity of Flat is that it uses an optimal bit-encoding rather than +-- the usual byte-oriented one. +-- +-- One bit is sufficient to encode a 'Result' or an empty 'List': +-- +-- >>> flatBits Good +-- "1" +-- +-- >>> flatBits (Nil::List Direction) +-- "0" +-- +-- Two or three bits suffice for a 'Direction': +-- +-- >>> flatBits South +-- "01" +-- +-- >>> flatBits West +-- "111" +-- +-- For the serialisation to work with byte-oriented devices or storage, we need to add some padding. +-- +-- To do so, rather than encoding a plain value, 'Flat.Run.flat' encodes a 'Flat.Filler.PostAligned' value, that's to say a value followed by a 'Flat.Filler.Filler' that stretches till the next byte boundary. +-- +-- In practice, the padding is a, possibly empty, sequence of 0s followed by a 1. +-- +-- For example, this list encodes as 7 bits: +-- +-- >>> flatBits $ Cons North (Cons South Nil) +-- "1001010" +-- +-- And, with the added padding of a final "1", will snugly fit in a single byte: +-- +-- >>> allBits $ Cons North (Cons South Nil) +-- "10010101" +-- +-- But .. you don't need to worry about these details as byte-padding is automatically added by the function 'Flat.Run.flat' and removed by 'Flat.Run.unflat'. +-- +-- === Pre-defined Instances +-- +-- Flat instances are already defined for relevant types of some common packages: array, base, bytestring, containers, dlist, mono-traversable, text, unordered-containers, vector. +-- +-- They are automatically imported by the "Flat" module. +-- +-- For example: +-- +-- >>> flatBits $ Just True +-- "11" +-- +-- === Wrapper Types +-- +-- There are a few wrapper types that modify the way encoding and/or decoding occur. +-- +-- * "Flat.AsBin" and "Flat.AsSize" decode to a value's flat binary representation or size in bits respectively. +-- +-- * 'Flat.Instances.Mono.AsArray' and 'Flat.Instances.Mono.AsList' encode/decode a sequence as a List or Array respectively, see "Flat.Instances.Mono" for details. +-- +-- * 'Flat.Instances.Text.UTF8Text' and 'Flat.Instances.Text.UTF16Text' encode/decode a Text as UTF8 or UTF16 respectively. diff --git a/plutus-core/flat/src/PlutusCore/Flat/Types.hs b/plutus-core/flat/src/PlutusCore/Flat/Types.hs index ec17bdcb0ec..e7bbc93d729 100644 --- a/plutus-core/flat/src/PlutusCore/Flat/Types.hs +++ b/plutus-core/flat/src/PlutusCore/Flat/Types.hs @@ -1,13 +1,14 @@ {-# LANGUAGE FlexibleInstances #-} --- |Common Types + +-- | Common Types module PlutusCore.Flat.Types ( - NumBits, - module Data.Word, - module Data.Int, - Natural, - SBS.ShortByteString, - T.Text, - ) where + NumBits, + module Data.Word, + module Data.Int, + Natural, + SBS.ShortByteString, + T.Text, +) where import Data.ByteString.Short.Internal qualified as SBS import Data.Int @@ -15,6 +16,5 @@ import Data.Text qualified as T import Data.Word import Numeric.Natural --- |Number of bits +-- | Number of bits type NumBits = Int - diff --git a/plutus-core/flat/test/Big.hs b/plutus-core/flat/test/Big.hs index add042dc85f..42e5043453c 100644 --- a/plutus-core/flat/test/Big.hs +++ b/plutus-core/flat/test/Big.hs @@ -22,7 +22,7 @@ import System.TimeIt (timeIt) newtype Big = Big B.ByteString newBig :: Int -> Big -newBig gigas = Big $ B.replicate (gigas*giga) 0 +newBig gigas = Big $ B.replicate (gigas * giga) 0 -- length of Big in gigas gigas :: Big -> Int @@ -34,57 +34,57 @@ giga = 1000000000 instance Show Big where show b = "Big of " ++ show (gigas b) ++ "Gbytes" instance Flat Big where - -- The encoded form is just the number of giga zeros (e.g. 5 for 5Giga zeros) - size big = size (gigas big) - encode big = encode (gigas big) + -- The encoded form is just the number of giga zeros (e.g. 5 for 5Giga zeros) + size big = size (gigas big) + encode big = encode (gigas big) - -- The decoded form is massive - decode = newBig <$> decode + -- The decoded form is massive + decode = newBig <$> decode main :: IO () main = tbig tbig = do - let numOfBigs = 5 + let numOfBigs = 5 - -- A serialised list of Big values - let bigsFile = flat $ replicate numOfBigs $ newBig 1 - print "Encoding Time" - timeIt $ print $ B.length bigsFile + -- A serialised list of Big values + let bigsFile = flat $ replicate numOfBigs $ newBig 1 + print "Encoding Time" + timeIt $ print $ B.length bigsFile - tstAsSize bigsFile + tstAsSize bigsFile - tstAsBin bigsFile + tstAsBin bigsFile - tstListT bigsFile + tstListT bigsFile - tstBig bigsFile + tstBig bigsFile -- If we unserialise a list of Bigs and then process them (e.g. print them out) we end up in trouble, too much memory is required. tstBig :: B.ByteString -> IO () tstBig bigsFile = timeIt $ do - print "Decode to [Big]:" - let Right (bs :: [Big]) = unflat bigsFile - mapM_ print bs + print "Decode to [Big]:" + let Right (bs :: [Big]) = unflat bigsFile + mapM_ print bs -- So instead we unserialise them to a list of their flat representations, to be unflatted on demand later on tstAsBin :: B.ByteString -> IO () tstAsBin bigsFile = timeIt $ do - print "Decode to [AsBin Big]:" - let Right (bsR :: [AsBin Big]) = unflat bigsFile - let bs = map unbin bsR - mapM_ print bs + print "Decode to [AsBin Big]:" + let Right (bsR :: [AsBin Big]) = unflat bigsFile + let bs = map unbin bsR + mapM_ print bs tstAsSize :: B.ByteString -> IO () tstAsSize bigsFile = timeIt $ do - print "Decode to [AsSize Big]:" - let Right (bs :: [AsSize Big]) = unflat bigsFile - mapM_ print bs + print "Decode to [AsSize Big]:" + let Right (bs :: [AsSize Big]) = unflat bigsFile + mapM_ print bs -- Or: we extract one element at the time via a ListT -- See http://hackage.haskell.org/package/list-t-1.0.4/docs/ListT.html tstListT :: B.ByteString -> IO () tstListT bigsFile = timeIt $ do - print "Decode to ListT IO Big:" - stream :: L.ListT IO Big <- listTDecoder decode bigsFile - L.traverse_ print stream + print "Decode to ListT IO Big:" + stream :: L.ListT IO Big <- listTDecoder decode bigsFile + L.traverse_ print stream diff --git a/plutus-core/flat/test/Core.hs b/plutus-core/flat/test/Core.hs index 1f651bafea0..42ae839bd74 100644 --- a/plutus-core/flat/test/Core.hs +++ b/plutus-core/flat/test/Core.hs @@ -1,8 +1,7 @@ --- |Test the code generated by the Generics implementation of Flat -{-# LANGUAGE DeriveAnyClass #-} +-- \|Test the code generated by the Generics implementation of Flat +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -O2 -fplugin Test.Inspection.Plugin #-} import Control.Monad @@ -19,7 +18,6 @@ import Test.E import Test.E.Flat import Test.Inspection - -- deriving instance Flat E2 -- deriving instance Flat E3 -- deriving instance Flat E4 @@ -120,7 +118,7 @@ size17Code :: E17 -> NumBits size17Code b = case b of E17_16 -> 5 E17_17 -> 5 - __ -> 4 + __ -> 4 size8 :: E8 -> NumBits size8 b = size b 0 @@ -203,7 +201,6 @@ inspect $ 'sz32 === 'v5 -- inspect $ 'sz2 === 'add2 -- inspect $ 'ft === 'ff - -- d8 = zzDecode8 -- d8s = zzDecode :: Word8 -> Int8 @@ -231,6 +228,5 @@ u = undefined -- dec1 = zzDecode1 -- inspect $ 'dec === 'dec1 - main :: IO () main = return () -- print (sz, sz0) diff --git a/plutus-core/flat/test/GenEnum.hs b/plutus-core/flat/test/GenEnum.hs index 469bd3ce662..66358046bee 100644 --- a/plutus-core/flat/test/GenEnum.hs +++ b/plutus-core/flat/test/GenEnum.hs @@ -1,11 +1,9 @@ -- generate test enumerations g = - let n = 256 - in unwords - [ "data E" ++ show n - , "=" - , intercalate " | " $ map (("N" ++) . show) [1 .. n] - , "deriving (Show,Generic,Flat)" - ] - - + let n = 256 + in unwords + [ "data E" ++ show n + , "=" + , intercalate " | " $ map (("N" ++) . show) [1 .. n] + , "deriving (Show,Generic,Flat)" + ] diff --git a/plutus-core/flat/test/ListTest.hs b/plutus-core/flat/test/ListTest.hs index 2fd3e92ffbc..cf97c909874 100644 --- a/plutus-core/flat/test/ListTest.hs +++ b/plutus-core/flat/test/ListTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module PlutusCore.Flat.Test.Main where import PlutusCore.Flat @@ -11,9 +12,8 @@ trampoline = id trampolineIO = id #endif - longBools = replicate 1000000 False main = do - print $ length longBools - print $ (flat longBools) + print $ length longBools + print $ (flat longBools) diff --git a/plutus-core/flat/test/Test/Data.hs b/plutus-core/flat/test/Test/Data.hs index 484a770b875..63aafd527af 100644 --- a/plutus-core/flat/test/Test/Data.hs +++ b/plutus-core/flat/test/Test/Data.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} {- A collection of data types used for testing. @@ -24,15 +24,15 @@ import Test.Data2 qualified as D2 -- import Test.Tasty.QuickCheck data Void - deriving Generic + deriving (Generic) data X = X X - deriving Generic + deriving (Generic) data Unit = Unit deriving (Eq, Ord, Read, Show, Data, Generic) -data Un = Un { un :: Bool } +data Un = Un {un :: Bool} deriving (Eq, Ord, Read, Show, Data, Generic) data D2 = D2 Bool N @@ -42,16 +42,18 @@ data D4 = D4 Bool N Unit N3 deriving (Eq, Ord, Read, Show, Data, Generic) -- Enumeration -data N3 = N1 - | N2 - | N3 +data N3 + = N1 + | N2 + | N3 deriving (Eq, Ord, Read, Show, Data, Generic, Enum) -data N = One - | Two - | Three - | Four - | Five +data N + = One + | Two + | Three + | Four + | Five deriving (Eq, Ord, Read, Show, Data, Generic, Enum, Bounded) -- toForestD :: Forest a -> ForestD (Tr2 a) @@ -94,13 +96,14 @@ data Ints = Ints Int8 Int16 Int32 Int64 deriving (Eq, Ord, Read, Show, Data, Generic) -- non-recursive data type -data Various = V1 (Maybe Bool) - -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N) - | V2 Bool (Either Bool (Maybe Bool)) - | VF Float Double Double - | VW Word Word8 Word16 Word32 Word64 - | VI Int Int8 Int16 Int32 Int64 - | VII Integer Integer Integer +data Various + = V1 (Maybe Bool) + | -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N) + V2 Bool (Either Bool (Maybe Bool)) + | VF Float Double Double + | VW Word Word8 Word16 Word32 Word64 + | VI Int Int8 Int16 Int32 Int64 + | VII Integer Integer Integer deriving (Eq, Ord, Read, Show, Data, Generic) -- Phantom type @@ -108,43 +111,71 @@ data Phantom a = Phantom deriving (Eq, Ord, Read, Show, Data, Generic) -- Recursive data types -data RR a b c = RN { rna :: a, rnb :: b, rnc :: c } - | RA a (RR a a c) b - | RAB a (RR c b a) b - deriving (Eq, Ord, Read, Show, Data, Generic) - -data Expr = ValB Bool - | Or Expr Expr - | If Expr Expr Expr - deriving (Eq, Ord, Read, Show, Data, Generic) - -data List a = C a (List a) - | N - deriving (Eq, Ord, Read, Show, Traversable, Data, Generic, Generic1 - , Functor, Foldable) - -data ListS a = Nil - | Cons a (ListS a) - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data - , Generic, Generic1) +data RR a b c + = RN {rna :: a, rnb :: b, rnc :: c} + | RA a (RR a a c) b + | RAB a (RR c b a) b + deriving (Eq, Ord, Read, Show, Data, Generic) + +data Expr + = ValB Bool + | Or Expr Expr + | If Expr Expr Expr + deriving (Eq, Ord, Read, Show, Data, Generic) + +data List a + = C a (List a) + | N + deriving + ( Eq + , Ord + , Read + , Show + , Traversable + , Data + , Generic + , Generic1 + , Functor + , Foldable + ) + +data ListS a + = Nil + | Cons a (ListS a) + deriving + ( Eq + , Ord + , Read + , Show + , Functor + , Foldable + , Traversable + , Data + , Generic + , Generic1 + ) -- non-regular Haskell datatypes like: -- Binary instances but no Model -data Nest a = NilN - | ConsN (a, Nest (a, a)) +data Nest a + = NilN + | ConsN (a, Nest (a, a)) deriving (Eq, Ord, Read, Show, Data, Generic) -data TN a = LeafT a - | BranchT (TN (a, a)) +data TN a + = LeafT a + | BranchT (TN (a, a)) deriving (Eq, Ord, Read, Show, Data, Generic) -data Bush a = NilB - | ConsB (a, Bush (Bush a)) +data Bush a + = NilB + | ConsB (a, Bush (Bush a)) deriving (Eq, Ord, Read, Show, Data, Generic) -- Perfectly balanced binary tree -data Perfect a = ZeroP a - | SuccP (Perfect (Fork a)) +data Perfect a + = ZeroP a + | SuccP (Perfect (Fork a)) deriving (Eq, Ord, Read, Show, Data, Generic) data Fork a = Fork a a @@ -152,8 +183,9 @@ data Fork a = Fork a a -- non regular with higher-order kind parameters -- no Binary/Model instances -data PerfectF f α = NilP - | ConsP α (PerfectF f (f α)) +data PerfectF f α + = NilP + | ConsP α (PerfectF f (f α)) deriving (Generic) -- No Data data Pr f g a = Pr (f a (g a)) @@ -162,17 +194,20 @@ data Higher f a = Higher (f a) deriving (Generic, Data) -- data Pr2 (f :: * -> *) a = Pr2 (f ) -data Free f a = Pure a - | Roll (f (Free f a)) +data Free f a + = Pure a + | Roll (f (Free f a)) deriving (Generic) -- mutual references -data A = A B - | AA Int +data A + = A B + | AA Int deriving (Eq, Ord, Read, Show, Data, Generic) -data B = B A - | BB Char +data B + = B A + | BB Char deriving (Eq, Ord, Read, Show, Data, Generic) -- recursive sets: @@ -184,28 +219,34 @@ data B = B A -- data MM4 = MM4 MM4 MM2 MM5 deriving (Eq, Ord, Read, Show, Data, Generic) -- data MM5 = MM5 Unit MM6 deriving (Eq, Ord, Read, Show, Data, Generic) -- data MM6 = MM6 MM5 deriving (Eq, Ord, Read, Show, Data, Generic) -data A0 = A0 B0 B0 D0 Bool - | A1 (List Bool) (List Unit) (D2.List Bool) (D2.List Bool) +data A0 + = A0 B0 B0 D0 Bool + | A1 (List Bool) (List Unit) (D2.List Bool) (D2.List Bool) deriving (Eq, Ord, Read, Show, Data, Generic) -data B0 = B0 C0 - | B1 +data B0 + = B0 C0 + | B1 deriving (Eq, Ord, Read, Show, Data, Generic) -data C0 = C0 A0 - | C1 +data C0 + = C0 A0 + | C1 deriving (Eq, Ord, Read, Show, Data, Generic) -data D0 = D0 E0 - | D1 +data D0 + = D0 E0 + | D1 deriving (Eq, Ord, Read, Show, Data, Generic) -data E0 = E0 D0 - | E1 +data E0 + = E0 D0 + | E1 deriving (Eq, Ord, Read, Show, Data, Generic) -data Even = Zero - | SuccE Odd +data Even + = Zero + | SuccE Odd data Odd = SuccO Even @@ -215,61 +256,75 @@ data Odd = SuccO Even -- Some :: f a -> Some f -- data Dict (c :: Constraint) where -- Dict :: c => Dict c -data Direction = North - | South - | Center - | East - | West +data Direction + = North + | South + | Center + | East + | West deriving (Eq, Ord, Read, Show, Data, Generic) data Stream a = Stream a (Stream a) - deriving (Eq, Ord, Read, Show, Data, Generic, Functor, Foldable - , Traversable) - -data Tree a = Node (Tree a) (Tree a) - | Leaf a + deriving + ( Eq + , Ord + , Read + , Show + , Data + , Generic + , Functor + , Foldable + , Traversable + ) + +data Tree a + = Node (Tree a) (Tree a) + | Leaf a deriving (Eq, Ord, Read, Show, Data, Generic, Foldable) -- Example schema from: http://mechanical-sympathy.blogspot.co.uk/2014/05/simple-binary-encoding.html -data Car = - Car { serialNumber :: Word64 - , modelYear :: Word16 - , available :: Bool - , code :: CarModel - , someNumbers :: [Int32] - , vehicleCode :: String - , extras :: [OptionalExtra] - , engine :: Engine - , fuelFigures :: [Consumption] - , performanceFigures :: [(OctaneRating, [Acceleration])] - , make :: String - , carModel :: String - } - deriving (Eq, Ord, Read, Show, Data, Generic) - -data Acceleration = Acceleration { mph :: Word16, seconds :: Float } +data Car + = Car + { serialNumber :: Word64 + , modelYear :: Word16 + , available :: Bool + , code :: CarModel + , someNumbers :: [Int32] + , vehicleCode :: String + , extras :: [OptionalExtra] + , engine :: Engine + , fuelFigures :: [Consumption] + , performanceFigures :: [(OctaneRating, [Acceleration])] + , make :: String + , carModel :: String + } + deriving (Eq, Ord, Read, Show, Data, Generic) + +data Acceleration = Acceleration {mph :: Word16, seconds :: Float} deriving (Eq, Ord, Read, Show, Data, Generic) type OctaneRating = Word8 -- minValue="90" maxValue="110" -data Consumption = Consumption { cSpeed :: Word16, cMpg :: Float } +data Consumption = Consumption {cSpeed :: Word16, cMpg :: Float} deriving (Eq, Ord, Read, Show, Data, Generic) -data CarModel = ModelA - | ModelB - | ModelC +data CarModel + = ModelA + | ModelB + | ModelC deriving (Eq, Ord, Read, Show, Data, Generic) -data OptionalExtra = SunRoof - | SportsPack - | CruiseControl +data OptionalExtra + = SunRoof + | SportsPack + | CruiseControl deriving (Eq, Ord, Read, Show, Data, Generic) -data Engine = Engine { capacity :: Word16 - , numCylinders :: Word8 - , maxRpm :: Word16 -- constant 9000 - , manufacturerCode :: String - , fuel :: String -- constant Petrol - } +data Engine = Engine + { capacity :: Word16 + , numCylinders :: Word8 + , maxRpm :: Word16 -- constant 9000 + , manufacturerCode :: String + , fuel :: String -- constant Petrol + } deriving (Eq, Ord, Read, Show, Data, Generic) - diff --git a/plutus-core/flat/test/Test/Data/Arbitrary.hs b/plutus-core/flat/test/Test/Data/Arbitrary.hs index 36f7543c519..121f96de0a5 100644 --- a/plutus-core/flat/test/Test/Data/Arbitrary.hs +++ b/plutus-core/flat/test/Test/Data/Arbitrary.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Data.Arbitrary where + import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.ByteString.Short qualified as SBS @@ -9,10 +10,12 @@ import Data.Text qualified as TS import Data.Text.Lazy qualified as TL import Test.Data import Test.Tasty.QuickCheck + -- import Data.DeriveTH -- #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty qualified as BI + -- #endif import Numeric.Natural (Natural) @@ -91,7 +94,7 @@ instance () => Arbitrary N where 4 -> return Five _ -> error "FATAL ERROR: Arbitrary instance, logic bug" -instance (Arbitrary a) => Arbitrary (Tree a) where +instance Arbitrary a => Arbitrary (Tree a) where arbitrary = do x <- choose (0 :: Int, 1) case x of @@ -102,7 +105,7 @@ instance (Arbitrary a) => Arbitrary (Tree a) where 1 -> Leaf <$> arbitrary _ -> error "FATAL ERROR: Arbitrary instance, logic bug" -instance (Arbitrary a) => Arbitrary (List a) where +instance Arbitrary a => Arbitrary (List a) where arbitrary = do x <- choose (0 :: Int, 1) case x of @@ -134,4 +137,5 @@ instance () => Arbitrary B where 0 -> B <$> arbitrary 1 -> BB <$> arbitrary _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + -- GENERATED STOP diff --git a/plutus-core/flat/test/Test/Data/Flat.hs b/plutus-core/flat/test/Test/Data/Flat.hs index ca6b406f7e9..f34cbce30d1 100644 --- a/plutus-core/flat/test/Test/Data/Flat.hs +++ b/plutus-core/flat/test/Test/Data/Flat.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -module Test.Data.Flat - ( module Test.Data - ) +module Test.Data.Flat ( + module Test.Data, +) where import PlutusCore.Flat + -- import Flat.Encoder -- import Flat.Decoder import Test.Data import Test.Data2.Flat () + -- import Data.Word -- import Data.Foldable -- import Data.Int @@ -23,12 +25,12 @@ import Test.Data2.Flat () {- Compilation times: encoderS specials cases | -| 7.10.3 | NO | 0:44 | -| 7.10.3 | YES | 0:39 | -| 8.0.1 | NO | 1:30 | -| 8.0.1 | YES | 1:30 | -| 8.0.2 | NO | 4:18 | -| 8.0.2 | YES | 4:18 | +\| 7.10.3 | NO | 0:44 | +\| 7.10.3 | YES | 0:39 | +\| 8.0.1 | NO | 1:30 | +\| 8.0.1 | YES | 1:30 | +\| 8.0.2 | NO | 4:18 | +\| 8.0.2 | YES | 4:18 | -} -- GHC 8.0.2 chokes on this -- instance Flat A0 @@ -42,24 +44,32 @@ deriving instance Generic (a, b, c, d, e, f, g, h) deriving instance Generic (a, b, c, d, e, f, g, h, i) #endif -instance {-# OVERLAPPABLE #-}( Flat a - , Flat b - , Flat c - , Flat d - , Flat e - , Flat f - , Flat g - , Flat h) => Flat (a, b, c, d, e, f, g, h) - -instance {-# OVERLAPPABLE #-}( Flat a - , Flat b - , Flat c - , Flat d - , Flat e - , Flat f - , Flat g - , Flat h - , Flat i) => Flat (a, b, c, d, e, f, g, h, i) +instance + {-# OVERLAPPABLE #-} + ( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + , Flat h + ) => + Flat (a, b, c, d, e, f, g, h) + +instance + {-# OVERLAPPABLE #-} + ( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + , Flat h + , Flat i + ) => + Flat (a, b, c, d, e, f, g, h, i) instance Flat N @@ -95,6 +105,7 @@ instance Flat a => Flat (Phantom a) -- Slow to compile instance Flat Various + -- Custom instances -- instance {-# OVERLAPPING #-} Flat (Tree (N,N,N)) --where -- size (Node t1 t2) = 1 + size t1 + size t2 @@ -119,9 +130,9 @@ instance Flat Various -- instance Flat a => Flat (Perfect a) -- instance Flat a => Flat (Fork a) -- instance Flat a => Flat (Nest a) ---instance Flat a => Flat (Stream a) where decode = Stream <$> decode <*> decode +-- instance Flat a => Flat (Stream a) where decode = Stream <$> decode <*> decode -- instance Flat Expr ---instance (Flat a,Flat (f a),Flat (f (f a))) => Flat (PerfectF f a) +-- instance (Flat a,Flat (f a),Flat (f (f a))) => Flat (PerfectF f a) -- instance Flat a => Flat (Stream a) {- | @@ -193,7 +204,4 @@ One Two | -- runWriter (encode a) s1 -- size (Node t1 t2) = 1 + size t1 + size t2 -- size (Leaf a) = 1 + size a ---instance Flat N - - - +-- instance Flat N diff --git a/plutus-core/flat/test/Test/Data/Values.hs b/plutus-core/flat/test/Test/Data/Values.hs index efb54b6261c..0380a9b4be7 100644 --- a/plutus-core/flat/test/Test/Data/Values.hs +++ b/plutus-core/flat/test/Test/Data/Values.hs @@ -1,8 +1,8 @@ - -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} + module Test.Data.Values where import Control.DeepSeq @@ -15,6 +15,7 @@ import Data.Foldable import Data.Int import Data.IntMap qualified as IM import PlutusCore.Flat + -- import qualified Data.IntSet as IS -- import Data.List import Data.Map qualified as M @@ -23,8 +24,8 @@ import Data.Text qualified as T import Data.Word import Test.Data import Test.Data2 qualified as D2 --- import Data.Array as A +-- import Data.Array as A instance NFData Various instance NFData a => NFData (List a) @@ -40,10 +41,10 @@ instance NFData CarModel instance NFData Consumption instance NFData Acceleration -floatT = ("float",-234.123123::Float) -doubleT = ("double",-1.91237::Double) +floatT = ("float", -234.123123 :: Float) +doubleT = ("double", -1.91237 :: Double) -a01 = A0 B1 (B0 (C0 (A1 N N D2.Nil2 D2.Nil2))) (D0 E1) +a01 = A0 B1 (B0 (C0 (A1 N N D2.Nil2 D2.Nil2))) (D0 E1) ab0 = A (B (A (BB 'g'))) @@ -52,10 +53,10 @@ pe1 = ConsP True (ConsP (Just False) (ConsP (Just (Just True)) NilP)) pr1 :: Pr Either List Int pr1 = Pr (Right (C 3 N)) -f1,f2,f3:: Free [] Int +f1, f2, f3 :: Free [] Int f1 = Pure 1 -f2 = Roll [Pure 1,Pure 2] -f3 = Roll [Roll [Pure 3],Pure 4] +f2 = Roll [Pure 1, Pure 2] +f3 = Roll [Roll [Pure 3], Pure 4] rr1 :: RR Char () Int8 rr1 = RAB 'a' (RN 11 () 'b') () @@ -64,44 +65,43 @@ rr1 = RAB 'a' (RN 11 () 'b') () infList :: List Bool infList = C True infList -hl1 = [1,3..111::Word] -hl2 = [1,3..111::Int] -hl3 = [False,True,True,False,True,True,True,True,False,True,True,True,True,False,True,False] +hl1 = [1, 3 .. 111 :: Word] +hl2 = [1, 3 .. 111 :: Int] +hl3 = [False, True, True, False, True, True, True, True, False, True, True, True, True, False, True, False] -b1 = B.pack [99,173,186,44,187,124,87,186,104,99,138,202,53,137,22,5,44,244,234,7,159,119,22,234] -b2 = B.pack . concat . replicate 100 $ [235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236,235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236,235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236] +b1 = B.pack [99, 173, 186, 44, 187, 124, 87, 186, 104, 99, 138, 202, 53, 137, 22, 5, 44, 244, 234, 7, 159, 119, 22, 234] +b2 = B.pack . concat . replicate 100 $ [235, 7, 135, 117, 255, 69, 100, 113, 113, 82, 128, 181, 200, 146, 155, 228, 144, 65, 83, 162, 130, 236, 235, 7, 135, 117, 255, 69, 100, 113, 113, 82, 128, 181, 200, 146, 155, 228, 144, 65, 83, 162, 130, 236, 235, 7, 135, 117, 255, 69, 100, 113, 113, 82, 128, 181, 200, 146, 155, 228, 144, 65, 83, 162, 130, 236] lb1 = L.pack . B.unpack $ b1 lb2 = L.fromChunks $ replicate 100 $ B.replicate 400 33 s1 = "a" s2 = "中文版本" -s3 = ['A'..'z'] +s3 = ['A' .. 'z'] s4 :: [Char] -s4 = Prelude.concatMap show [1::Int ..400] +s4 = Prelude.concatMap show [1 :: Int .. 400] t1 = T.pack s1 t2 = T.pack s2 t3 = T.pack s3 t4 = T.pack s4 - p1 :: Phantom Char p1 = Phantom ---toList N = [] ---toList (C h t) = h : (toList t) +-- toList N = [] +-- toList (C h t) = h : (toList t) -l2L [] = N -l2L (x:xs) = C x (l2L xs) +l2L [] = N +l2L (x : xs) = C x (l2L xs) -l1 = l2L $ take 11 [11::Word8,22..33] +l1 = l2L $ take 11 [11 :: Word8, 22 .. 33] lBool :: List Bool -lBool = l2L $ map odd [1::Int ..99] +lBool = l2L $ map odd [1 :: Int .. 99] lBool2 :: List Bool -lBool2 = l2L $ map odd [1::Int ..1000] +lBool2 = l2L $ map odd [1 :: Int .. 1000] lBool0 = C False (C True (C True (C False (C False (C False (C True (C False (C True (C False (C True (C True (C False (C False (C False N)))))))))))))) @@ -112,17 +112,17 @@ lN = C Three (C Three (C One (C One (C Three (C Four (C One (C Five (C Two (C Th largeSize = 1000000 -- couples :: [(Word32,N)] -couples :: [(Int,N)] -couples = zip [1..] $ ns 1000 +couples :: [(Int, N)] +couples = zip [1 ..] $ ns 1000 lN2 :: List N lN2 = lnx 1000 -lN3 = lnx (largeSize*5) +lN3 = lnx (largeSize * 5) lnx = l2L . ns -ns n = map asN [1..n] +ns n = map asN [1 .. n] asN :: Int -> N asN = toEnum . (`mod` 5) @@ -137,39 +137,41 @@ asN = toEnum . (`mod` 5) -- toN _ = Five asN3 = toN3 . (`mod` 5) -toN3 :: Integer -> (N,N,N) -toN3 1 = (One,Two,Three) -toN3 2 = (Two,Three,Four) -toN3 3 = (Three,Four,Five) -toN3 4 = (Four,Five,One) -toN3 _ = (Four,Five,Two) - -t33T =("Tuple of Tuple",t33) +toN3 :: Integer -> (N, N, N) +toN3 1 = (One, Two, Three) +toN3 2 = (Two, Three, Four) +toN3 3 = (Three, Four, Five) +toN3 4 = (Four, Five, One) +toN3 _ = (Four, Five, Two) + +t33T = ("Tuple of Tuple", t33) t33 = asN33 4 asN33 :: Integer -> ((N, N, N), (N, N, N), (N, N, N)) -asN33 n = (asN3 n,asN3 (n+1),asN3 (n+2)) +asN33 n = (asN3 n, asN3 (n + 1), asN3 (n + 2)) treeNLarge :: Tree N treeNLarge = mkTree asN largeSize -treeNNNLarge :: Tree (N,N,N) +treeNNNLarge :: Tree (N, N, N) treeNNNLarge = mkTree asN3 largeSize -treeN33Large :: Tree ((N,N,N),(N,N,N),(N,N,N)) +treeN33Large :: Tree ((N, N, N), (N, N, N), (N, N, N)) treeN33Large = mkTree asN33 largeSize -treeVarious = mkTree (const v2) (100::Int) +treeVarious = mkTree (const v2) (100 :: Int) -mkTreeOf :: forall a. (Enum a ,Bounded a)=> Int -> Tree a -mkTreeOf = let l = fromEnum (maxBound :: a) +1 - in mkTree ((toEnum :: (Int -> a)) . (`mod` l)) +mkTreeOf :: forall a. (Enum a, Bounded a) => Int -> Tree a +mkTreeOf = + let l = fromEnum (maxBound :: a) + 1 + in mkTree ((toEnum :: (Int -> a)) . (`mod` l)) mkTree mk = mkTree_ 1 where mkTree_ p 1 = Leaf $ mk p - mkTree_ p n = let (d,m) = n `divMod` 2 - in Node (mkTree_ p d) (mkTree_ (p+d) (d+m)) + mkTree_ p n = + let (d, m) = n `divMod` 2 + in Node (mkTree_ p d) (mkTree_ (p + d) (d + m)) tree1 :: Tree String tree1 = Node (Leaf "a leaf") (Node (Leaf "and") (Leaf "more")) @@ -181,17 +183,17 @@ tree2 = Node (Leaf 17) (Node (Leaf 23) (Leaf 45)) -- stream1 = Stream True stream1 -car1 = Car 2343 1965 True ModelB [18,234] "1234" [SunRoof,CruiseControl] (Engine 1200 3 9000 "Fiat" "Petrol") [Consumption 40 18,Consumption 60 23,Consumption 80 25] [(90,[Acceleration 40 12]),(110,[Acceleration 50 11])] "Fiat" "500" +car1 = Car 2343 1965 True ModelB [18, 234] "1234" [SunRoof, CruiseControl] (Engine 1200 3 9000 "Fiat" "Petrol") [Consumption 40 18, Consumption 60 23, Consumption 80 25] [(90, [Acceleration 40 12]), (110, [Acceleration 50 11])] "Fiat" "500" treeN = mkTree asN3 1 -longAsciiStrT = ("asciiStr", longS english ) +longAsciiStrT = ("asciiStr", longS english) -asciiTextT = ("asciiText", T.pack $ longS english ) +asciiTextT = ("asciiText", T.pack $ longS english) -unicodeTextUTF8T = ("unicodeTextUTF8",UTF8Text unicodeText) +unicodeTextUTF8T = ("unicodeTextUTF8", UTF8Text unicodeText) -chineseTextUTF8T = ("chineseTextUTF8",UTF8Text chineseText) +chineseTextUTF8T = ("chineseTextUTF8", UTF8Text chineseText) #if ! defined (ETA_VERSION) unicodeTextUTF16T = ("unicodeTextUTF16",UTF16Text unicodeText) @@ -201,18 +203,17 @@ chineseTextUTF16T = ("chineseTextUTF16",UTF16Text chineseText) -- chineseTextT = ("chineseText",chinesText) chineseText = T.pack $ longS chinese - -unicodeTextT = ("unicodeText",unicodeText) +unicodeTextT = ("unicodeText", unicodeText) unicodeText = T.pack unicodeStr -unicodeStrT = ("unicodeStr",unicodeStr) +unicodeStrT = ("unicodeStr", unicodeStr) unicodeStr = notLongS uniSS - -- uniSS = "\x1F600\&\x1F600\&\x1F600\&I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1].维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" -uniSS = concat [special,latin,chinese] +uniSS = concat [special, latin, chinese] special = "∀\&" + -- Crashes eta -- emoji = "\x1F600" @@ -220,76 +221,78 @@ english = "To hike, or not to hike? US Federal Reserve chair Janet Yellen faces latin = "I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1]." chinese = "维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" -longS = take 1000000 . concat . repeat +longS = take 1000000 . concat . repeat -notLongS = take 1000 . concat . repeat +notLongS = take 1000 . concat . repeat -longBoolListT = ("Long [Bool]",map (odd . ord) (longS uniSS) :: [Bool]) +longBoolListT = ("Long [Bool]", map (odd . ord) (longS uniSS) :: [Bool]) -arr0 = ("[Bool]",map (odd . ord) unicodeStr :: [Bool]) +arr0 = ("[Bool]", map (odd . ord) unicodeStr :: [Bool]) -arr1 = ("[Word]",map (fromIntegral . ord) unicodeStr :: [Word]) +arr1 = ("[Word]", map (fromIntegral . ord) unicodeStr :: [Word]) -arr2 = ("ByteString from String",B.pack . map (fromIntegral . ord) $ unicodeStr) -sbs = ("StrictByteString",b2) -lbs = ("LazyByteString",lb2) -shortbs = ("ShortByteString",SBS.toShort b2) +arr2 = ("ByteString from String", B.pack . map (fromIntegral . ord) $ unicodeStr) +sbs = ("StrictByteString", b2) +lbs = ("LazyByteString", lb2) +shortbs = ("ShortByteString", SBS.toShort b2) -- array package -- arrayT = ("Array", - -intMapT = ("IntMap",intMap) -mapT = ("map",dataMap) -mapListT = ("mapList",listMap) +intMapT = ("IntMap", intMap) +mapT = ("map", dataMap) +mapListT = ("mapList", listMap) intMap = IM.fromList couples dataMap = M.fromList couples listMap = couples -lN2T = ("List N",lN2) -lN3T = ("Large List N",lN3) -nativeListT = ("Large [N]",nativeList) +lN2T = ("List N", lN2) +lN3T = ("Large List N", lN3) +nativeListT = ("Large [N]", nativeList) nativeList = toList lN3 -seqNT = ("Seq N",Seq.fromList . toList $ lN2) -- nativeList) -treeNT = ("treeN",treeN) -treeNLargeT = ("treeNLarge",treeNLarge) -treeNNNLargeT = ("treeNNNLarge",treeNNNLarge) -treeN33LargeT = ("treeN33Large",treeN33Large) -treeVariousT = ("Tree Various",treeVarious) -tuple0T = ("block-tuple",(False,(),(3::Word64,33::Word,(True,(),False)))) -tupleT = ("tuple",(Two,One,(Five,Three,(Three,(),Two)))) -tupleBools = ("tupleBools",(False,(True,False),((True,False,True),(True,False,True)))) -oneT = ("One",One) -tupleWords = ("tupleWord",(18::Word,623723::Word,(8888::Word,823::Word))) -word8T = ("Word8",34::Word8) -word64T = ("Word64",34723823923::Word64) -carT = ("car",car1) -wordsT = ("words",wordsV) -wordsV = (18::Word,33::Word8,1230::Word16,9990::Word32,1231232::Word64) -words0T = ("words0",words0V) -words0V = (0::Word,0::Word8,0::Word16,0::Word32,0::Word64) -intsT = ("ints",(444::Int,123::Int8,-8999::Int16,-123823::Int32,-34723823923::Int64)) -floatsT = ("floats",floats) -floatsUnaT = ("floats unaligned",(Three,floats)) -floats = (3.43::Float,44.23E+23::Double,0.1::Double) -int8T = ("Int8",-34::Int8) -int64T = ("Int64",-34723823923::Int64) -integerT = ("Integer",-3472382392399239230123123::Integer) -charT = ("Char",'a') +seqNT = ("Seq N", Seq.fromList . toList $ lN2) -- nativeList) +treeNT = ("treeN", treeN) +treeNLargeT = ("treeNLarge", treeNLarge) +treeNNNLargeT = ("treeNNNLarge", treeNNNLarge) +treeN33LargeT = ("treeN33Large", treeN33Large) +treeVariousT = ("Tree Various", treeVarious) +tuple0T = ("block-tuple", (False, (), (3 :: Word64, 33 :: Word, (True, (), False)))) +tupleT = ("tuple", (Two, One, (Five, Three, (Three, (), Two)))) +tupleBools = ("tupleBools", (False, (True, False), ((True, False, True), (True, False, True)))) +oneT = ("One", One) +tupleWords = ("tupleWord", (18 :: Word, 623723 :: Word, (8888 :: Word, 823 :: Word))) +word8T = ("Word8", 34 :: Word8) +word64T = ("Word64", 34723823923 :: Word64) +carT = ("car", car1) +wordsT = ("words", wordsV) +wordsV = (18 :: Word, 33 :: Word8, 1230 :: Word16, 9990 :: Word32, 1231232 :: Word64) +words0T = ("words0", words0V) +words0V = (0 :: Word, 0 :: Word8, 0 :: Word16, 0 :: Word32, 0 :: Word64) +intsT = ("ints", (444 :: Int, 123 :: Int8, -8999 :: Int16, -123823 :: Int32, -34723823923 :: Int64)) +floatsT = ("floats", floats) +floatsUnaT = ("floats unaligned", (Three, floats)) +floats = (3.43 :: Float, 44.23E+23 :: Double, 0.1 :: Double) +int8T = ("Int8", -34 :: Int8) +int64T = ("Int64", -34723823923 :: Int64) +integerT = ("Integer", -3472382392399239230123123 :: Integer) +charT = ("Char", 'a') unicharT = ("Unicode char", '世') -v1T = ("V1",v1) +v1T = ("V1", v1) v1 = V1 (Just False) -v2T = ("V2",v2) ---v2 = V2 True (Right Nothing) (One,Two,Three) +v2T = ("V2", v2) + +-- v2 = V2 True (Right Nothing) (One,Two,Three) v2 = V2 True (Right Nothing) -vfT = ("v floats",VF 3.43 44.23E+23 0.1) -vwT = ("v words",vw) +vfT = ("v floats", VF 3.43 44.23E+23 0.1) +vwT = ("v words", vw) vw = VW 18 33 1230 9990 1231232 + -- vw = VW 0 0 0 0 0 -viT = ("v ints",VI 444 123 (-8999) (-123823) (-34723823923)) -viiT = ("v integers",VII 444 8888 (-34723823923)) +viT = ("v ints", VI 444 123 (-8999) (-123823) (-34723823923)) +viiT = ("v integers", VII 444 8888 (-34723823923)) -- Copied from binary-typed-0.3/benchmark/Criterion.hs + -- | Data with a normal form. data NF = forall a. NFData a => NF a @@ -303,49 +306,49 @@ forceCafs = mapM_ (evaluate . force') cafs -- | List of all data that should be fully evaluated before a benchmark is -- run. cafs :: [NF] -cafs = [ - NF carT - , NF charT - , NF unicharT - , NF wordsT - , NF words0T - , NF intsT - , NF floatT - , NF doubleT - , NF floatsT - , NF floatsUnaT - , NF tupleT - , NF tuple0T - , NF treeNLargeT - , NF treeNNNLargeT - , NF treeN33LargeT - , NF treeNT - , NF lN2T - , NF lN3T - , NF mapT - , NF mapListT - , NF nativeListT - , NF seqNT - , NF arr1 - , NF arr0 - , NF longS - , NF unicodeStr - , NF longBoolListT - , NF longAsciiStrT - , NF asciiTextT - , NF unicodeStrT - , NF unicodeTextT - --, NF unicodeTextUTF8T - --, NF unicodeTextUTF16T - , NF couples - , NF v1T - , NF v2T - , NF vfT - , NF vwT - , NF viT - , NF viiT - , NF treeVariousT - , NF sbs - , NF lbs - , NF shortbs - ] +cafs = + [ NF carT + , NF charT + , NF unicharT + , NF wordsT + , NF words0T + , NF intsT + , NF floatT + , NF doubleT + , NF floatsT + , NF floatsUnaT + , NF tupleT + , NF tuple0T + , NF treeNLargeT + , NF treeNNNLargeT + , NF treeN33LargeT + , NF treeNT + , NF lN2T + , NF lN3T + , NF mapT + , NF mapListT + , NF nativeListT + , NF seqNT + , NF arr1 + , NF arr0 + , NF longS + , NF unicodeStr + , NF longBoolListT + , NF longAsciiStrT + , NF asciiTextT + , NF unicodeStrT + , NF unicodeTextT + , -- , NF unicodeTextUTF8T + -- , NF unicodeTextUTF16T + NF couples + , NF v1T + , NF v2T + , NF vfT + , NF vwT + , NF viT + , NF viiT + , NF treeVariousT + , NF sbs + , NF lbs + , NF shortbs + ] diff --git a/plutus-core/flat/test/Test/Data2.hs b/plutus-core/flat/test/Test/Data2.hs index 1f08d1f832c..5ac8a74111c 100644 --- a/plutus-core/flat/test/Test/Data2.hs +++ b/plutus-core/flat/test/Test/Data2.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} + module Test.Data2 where import Data.Data @@ -17,7 +18,7 @@ import Data.Typeable import GHC.Generics -- A definition with the same name of a definition in Test.Data, used to test for name clashes.a -data List a = Cons2 a (List a) - | Nil2 - deriving (Eq, Ord, Read, Show, Data, Generic ,Generic1) - +data List a + = Cons2 a (List a) + | Nil2 + deriving (Eq, Ord, Read, Show, Data, Generic, Generic1) diff --git a/plutus-core/flat/test/Test/Data2/Flat.hs b/plutus-core/flat/test/Test/Data2/Flat.hs index 2ad0e884134..9b85dcb4702 100644 --- a/plutus-core/flat/test/Test/Data2/Flat.hs +++ b/plutus-core/flat/test/Test/Data2/Flat.hs @@ -1,4 +1,5 @@ -module Test.Data2.Flat(module Test.Data2) where +module Test.Data2.Flat (module Test.Data2) where + import PlutusCore.Flat import Test.Data2 diff --git a/plutus-core/flat/test/Test/E.hs b/plutus-core/flat/test/Test/E.hs index a025095131a..7e1bee089b4 100644 --- a/plutus-core/flat/test/Test/E.hs +++ b/plutus-core/flat/test/Test/E.hs @@ -1,42 +1,43 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Test.E where import Control.DeepSeq import Data.List import PlutusCore.Flat --- import Data.Proxy -data S3 = S_1 | S_2 Bool | S_3 Char deriving (Show,Generic,Eq,NFData) +-- import Data.Proxy +data S3 = S_1 | S_2 Bool | S_3 Char deriving (Show, Generic, Eq, NFData) g :: (Num a, Enum a, Show a) => a -> String g n = - let dt = "E" ++ show n - in unwords - [ "data" - , dt - , "=" - , intercalate " | " $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n] - , "deriving (Show,Generic,Eq,NFData,Enum,Bounded)" - ] + let dt = "E" ++ show n + in unwords + [ "data" + , dt + , "=" + , intercalate " | " $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n] + , "deriving (Show,Generic,Eq,NFData,Enum,Bounded)" + ] -data E1 = E1 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E1 = E1 deriving (Show, Generic, Eq, NFData, Enum, Bounded) -data E2 = E2_1 | E2_2 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E2 = E2_1 | E2_2 deriving (Show, Generic, Eq, NFData, Enum, Bounded) -data E3 = E3_1 | E3_2 | E3_3 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E3 = E3_1 | E3_2 | E3_3 deriving (Show, Generic, Eq, NFData, Enum, Bounded) -data E4 = E4_1 | E4_2 | E4_3 | E4_4 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E4 = E4_1 | E4_2 | E4_3 | E4_4 deriving (Show, Generic, Eq, NFData, Enum, Bounded) -data E8 = E8_1 | E8_2 | E8_3 | E8_4 | E8_5 | E8_6 | E8_7 | E8_8 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E8 = E8_1 | E8_2 | E8_3 | E8_4 | E8_5 | E8_6 | E8_7 | E8_8 deriving (Show, Generic, Eq, NFData, Enum, Bounded) -data E16 = E16_1 | E16_2 | E16_3 | E16_4 | E16_5 | E16_6 | E16_7 | E16_8 | E16_9 | E16_10 | E16_11 | E16_12 | E16_13 | E16_14 | E16_15 | E16_16 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E16 = E16_1 | E16_2 | E16_3 | E16_4 | E16_5 | E16_6 | E16_7 | E16_8 | E16_9 | E16_10 | E16_11 | E16_12 | E16_13 | E16_14 | E16_15 | E16_16 deriving (Show, Generic, Eq, NFData, Enum, Bounded) -data E17 = E17_1 | E17_2 | E17_3 | E17_4 | E17_5 | E17_6 | E17_7 | E17_8 | E17_9 | E17_10 | E17_11 | E17_12 | E17_13 | E17_14 | E17_15 | E17_16 | E17_17 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E17 = E17_1 | E17_2 | E17_3 | E17_4 | E17_5 | E17_6 | E17_7 | E17_8 | E17_9 | E17_10 | E17_11 | E17_12 | E17_13 | E17_14 | E17_15 | E17_16 | E17_17 deriving (Show, Generic, Eq, NFData, Enum, Bounded) -data E32 = E32_1 | E32_2 | E32_3 | E32_4 | E32_5 | E32_6 | E32_7 | E32_8 | E32_9 | E32_10 | E32_11 | E32_12 | E32_13 | E32_14 | E32_15 | E32_16 | E32_17 | E32_18 | E32_19 | E32_20 | E32_21 | E32_22 | E32_23 | E32_24 | E32_25 | E32_26 | E32_27 | E32_28 | E32_29 | E32_30 | E32_31 | E32_32 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E32 = E32_1 | E32_2 | E32_3 | E32_4 | E32_5 | E32_6 | E32_7 | E32_8 | E32_9 | E32_10 | E32_11 | E32_12 | E32_13 | E32_14 | E32_15 | E32_16 | E32_17 | E32_18 | E32_19 | E32_20 | E32_21 | E32_22 | E32_23 | E32_24 | E32_25 | E32_26 | E32_27 | E32_28 | E32_29 | E32_30 | E32_31 | E32_32 deriving (Show, Generic, Eq, NFData, Enum, Bounded) #ifdef ENUM_LARGE data E256 = E256_1 | E256_2 | E256_3 | E256_4 | E256_5 | E256_6 | E256_7 | E256_8 | E256_9 | E256_10 | E256_11 | E256_12 | E256_13 | E256_14 | E256_15 | E256_16 | E256_17 | E256_18 | E256_19 | E256_20 | E256_21 | E256_22 | E256_23 | E256_24 | E256_25 | E256_26 | E256_27 | E256_28 | E256_29 | E256_30 | E256_31 | E256_32 | E256_33 | E256_34 | E256_35 | E256_36 | E256_37 | E256_38 | E256_39 | E256_40 | E256_41 | E256_42 | E256_43 | E256_44 | E256_45 | E256_46 | E256_47 | E256_48 | E256_49 | E256_50 | E256_51 | E256_52 | E256_53 | E256_54 | E256_55 | E256_56 | E256_57 | E256_58 | E256_59 | E256_60 | E256_61 | E256_62 | E256_63 | E256_64 | E256_65 | E256_66 | E256_67 | E256_68 | E256_69 | E256_70 | E256_71 | E256_72 | E256_73 | E256_74 | E256_75 | E256_76 | E256_77 | E256_78 | E256_79 | E256_80 | E256_81 | E256_82 | E256_83 | E256_84 | E256_85 | E256_86 | E256_87 | E256_88 | E256_89 | E256_90 | E256_91 | E256_92 | E256_93 | E256_94 | E256_95 | E256_96 | E256_97 | E256_98 | E256_99 | E256_100 | E256_101 | E256_102 | E256_103 | E256_104 | E256_105 | E256_106 | E256_107 | E256_108 | E256_109 | E256_110 | E256_111 | E256_112 | E256_113 | E256_114 | E256_115 | E256_116 | E256_117 | E256_118 | E256_119 | E256_120 | E256_121 | E256_122 | E256_123 | E256_124 | E256_125 | E256_126 | E256_127 | E256_128 | E256_129 | E256_130 | E256_131 | E256_132 | E256_133 | E256_134 | E256_135 | E256_136 | E256_137 | E256_138 | E256_139 | E256_140 | E256_141 | E256_142 | E256_143 | E256_144 | E256_145 | E256_146 | E256_147 | E256_148 | E256_149 | E256_150 | E256_151 | E256_152 | E256_153 | E256_154 | E256_155 | E256_156 | E256_157 | E256_158 | E256_159 | E256_160 | E256_161 | E256_162 | E256_163 | E256_164 | E256_165 | E256_166 | E256_167 | E256_168 | E256_169 | E256_170 | E256_171 | E256_172 | E256_173 | E256_174 | E256_175 | E256_176 | E256_177 | E256_178 | E256_179 | E256_180 | E256_181 | E256_182 | E256_183 | E256_184 | E256_185 | E256_186 | E256_187 | E256_188 | E256_189 | E256_190 | E256_191 | E256_192 | E256_193 | E256_194 | E256_195 | E256_196 | E256_197 | E256_198 | E256_199 | E256_200 | E256_201 | E256_202 | E256_203 | E256_204 | E256_205 | E256_206 | E256_207 | E256_208 | E256_209 | E256_210 | E256_211 | E256_212 | E256_213 | E256_214 | E256_215| E256_216 | E256_217 | E256_218 | E256_219 | E256_220 | E256_221 | E256_222 | E256_223 | E256_224 | E256_225 | E256_226 | E256_227 | E256_228 | E256_229 | E256_230 | E256_231 | E256_232 |E256_233 | E256_234 | E256_235 | E256_236 | E256_237 | E256_238 | E256_239 | E256_240 | E256_241 | E256_242 | E256_243 | E256_244 | E256_245 | E256_246 | E256_247 | E256_248 | E256_249 | E256_250 | E256_251 | E256_252 | E256_253 | E256_254 | E256_255 | E256_256 deriving (Show,Generic,Eq,NFData,Enum,Bounded) diff --git a/plutus-core/flat/test/Test/E/Arbitrary.hs b/plutus-core/flat/test/Test/E/Arbitrary.hs index 0a013c49836..af3244b606f 100644 --- a/plutus-core/flat/test/Test/E/Arbitrary.hs +++ b/plutus-core/flat/test/Test/E/Arbitrary.hs @@ -1,133 +1,142 @@ {-# LANGUAGE CPP #-} + module Test.E.Arbitrary where + import Test.E import Test.Tasty.QuickCheck -- GENERATED START instance () => Arbitrary E2 where - arbitrary - = do x <- choose (0 :: Int, 1) - case x of - 0 -> return E2_1 - 1 -> return E2_2 - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + arbitrary = + do + x <- choose (0 :: Int, 1) + case x of + 0 -> return E2_1 + 1 -> return E2_2 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" instance () => Arbitrary E3 where - arbitrary - = do x <- choose (0 :: Int, 2) - case x of - 0 -> return E3_1 - 1 -> return E3_2 - 2 -> return E3_3 - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + arbitrary = + do + x <- choose (0 :: Int, 2) + case x of + 0 -> return E3_1 + 1 -> return E3_2 + 2 -> return E3_3 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" instance () => Arbitrary E4 where - arbitrary - = do x <- choose (0 :: Int, 3) - case x of - 0 -> return E4_1 - 1 -> return E4_2 - 2 -> return E4_3 - 3 -> return E4_4 - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + arbitrary = + do + x <- choose (0 :: Int, 3) + case x of + 0 -> return E4_1 + 1 -> return E4_2 + 2 -> return E4_3 + 3 -> return E4_4 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" instance () => Arbitrary E8 where - arbitrary - = do x <- choose (0 :: Int, 7) - case x of - 0 -> return E8_1 - 1 -> return E8_2 - 2 -> return E8_3 - 3 -> return E8_4 - 4 -> return E8_5 - 5 -> return E8_6 - 6 -> return E8_7 - 7 -> return E8_8 - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + arbitrary = + do + x <- choose (0 :: Int, 7) + case x of + 0 -> return E8_1 + 1 -> return E8_2 + 2 -> return E8_3 + 3 -> return E8_4 + 4 -> return E8_5 + 5 -> return E8_6 + 6 -> return E8_7 + 7 -> return E8_8 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" instance () => Arbitrary E16 where - arbitrary - = do x <- choose (0 :: Int, 15) - case x of - 0 -> return E16_1 - 1 -> return E16_2 - 2 -> return E16_3 - 3 -> return E16_4 - 4 -> return E16_5 - 5 -> return E16_6 - 6 -> return E16_7 - 7 -> return E16_8 - 8 -> return E16_9 - 9 -> return E16_10 - 10 -> return E16_11 - 11 -> return E16_12 - 12 -> return E16_13 - 13 -> return E16_14 - 14 -> return E16_15 - 15 -> return E16_16 - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + arbitrary = + do + x <- choose (0 :: Int, 15) + case x of + 0 -> return E16_1 + 1 -> return E16_2 + 2 -> return E16_3 + 3 -> return E16_4 + 4 -> return E16_5 + 5 -> return E16_6 + 6 -> return E16_7 + 7 -> return E16_8 + 8 -> return E16_9 + 9 -> return E16_10 + 10 -> return E16_11 + 11 -> return E16_12 + 12 -> return E16_13 + 13 -> return E16_14 + 14 -> return E16_15 + 15 -> return E16_16 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" instance () => Arbitrary E17 where - arbitrary - = do x <- choose (0 :: Int, 16) - case x of - 0 -> return E17_1 - 1 -> return E17_2 - 2 -> return E17_3 - 3 -> return E17_4 - 4 -> return E17_5 - 5 -> return E17_6 - 6 -> return E17_7 - 7 -> return E17_8 - 8 -> return E17_9 - 9 -> return E17_10 - 10 -> return E17_11 - 11 -> return E17_12 - 12 -> return E17_13 - 13 -> return E17_14 - 14 -> return E17_15 - 15 -> return E17_16 - 16 -> return E17_17 - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + arbitrary = + do + x <- choose (0 :: Int, 16) + case x of + 0 -> return E17_1 + 1 -> return E17_2 + 2 -> return E17_3 + 3 -> return E17_4 + 4 -> return E17_5 + 5 -> return E17_6 + 6 -> return E17_7 + 7 -> return E17_8 + 8 -> return E17_9 + 9 -> return E17_10 + 10 -> return E17_11 + 11 -> return E17_12 + 12 -> return E17_13 + 13 -> return E17_14 + 14 -> return E17_15 + 15 -> return E17_16 + 16 -> return E17_17 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" instance () => Arbitrary E32 where - arbitrary - = do x <- choose (0 :: Int, 31) - case x of - 0 -> return E32_1 - 1 -> return E32_2 - 2 -> return E32_3 - 3 -> return E32_4 - 4 -> return E32_5 - 5 -> return E32_6 - 6 -> return E32_7 - 7 -> return E32_8 - 8 -> return E32_9 - 9 -> return E32_10 - 10 -> return E32_11 - 11 -> return E32_12 - 12 -> return E32_13 - 13 -> return E32_14 - 14 -> return E32_15 - 15 -> return E32_16 - 16 -> return E32_17 - 17 -> return E32_18 - 18 -> return E32_19 - 19 -> return E32_20 - 20 -> return E32_21 - 21 -> return E32_22 - 22 -> return E32_23 - 23 -> return E32_24 - 24 -> return E32_25 - 25 -> return E32_26 - 26 -> return E32_27 - 27 -> return E32_28 - 28 -> return E32_29 - 29 -> return E32_30 - 30 -> return E32_31 - 31 -> return E32_32 - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + arbitrary = + do + x <- choose (0 :: Int, 31) + case x of + 0 -> return E32_1 + 1 -> return E32_2 + 2 -> return E32_3 + 3 -> return E32_4 + 4 -> return E32_5 + 5 -> return E32_6 + 6 -> return E32_7 + 7 -> return E32_8 + 8 -> return E32_9 + 9 -> return E32_10 + 10 -> return E32_11 + 11 -> return E32_12 + 12 -> return E32_13 + 13 -> return E32_14 + 14 -> return E32_15 + 15 -> return E32_16 + 16 -> return E32_17 + 17 -> return E32_18 + 18 -> return E32_19 + 19 -> return E32_20 + 20 -> return E32_21 + 21 -> return E32_22 + 22 -> return E32_23 + 23 -> return E32_24 + 24 -> return E32_25 + 25 -> return E32_26 + 26 -> return E32_27 + 27 -> return E32_28 + 28 -> return E32_29 + 29 -> return E32_30 + 30 -> return E32_31 + 31 -> return E32_32 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" #ifdef ENUM_LARGE instance () => Arbitrary E256 where diff --git a/plutus-core/flat/test/Test/E/Binary.hs b/plutus-core/flat/test/Test/E/Binary.hs index b75eb6fe6f1..595ab339716 100644 --- a/plutus-core/flat/test/Test/E/Binary.hs +++ b/plutus-core/flat/test/Test/E/Binary.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} + module Test.E.Binary where import Data.Binary @@ -21,5 +22,3 @@ deriving instance Binary E258 -- , Binary E256_253 -- , Binary E256_256 -- ] - - diff --git a/plutus-core/flat/test/Test/E/Flat.hs b/plutus-core/flat/test/Test/E/Flat.hs index 90dd9815454..6d117abd615 100644 --- a/plutus-core/flat/test/Test/E/Flat.hs +++ b/plutus-core/flat/test/Test/E/Flat.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} -module Test.E.Flat() where + +module Test.E.Flat () where import PlutusCore.Flat import PlutusCore.Flat.Decoder () @@ -14,23 +15,22 @@ import Test.E -- Not faster than generated ones (at least up to E16) gen :: Int -> String gen numBits = - let dt = "E"++show n - n = 2 ^ numBits - cs = zip [1..] $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n] - dec n c = unwords [" ",n,"-> return",c] - in unlines [ - unwords ["instance Flat",dt,"where"] - ," size _ n = n+"++ show numBits - ," encode a = case a of" - ,unlines $ map (\(n,c) -> unwords [" ",c,"-> eBits16",show numBits,show n]) cs - ," decode = do" - ," tag <- dBEBits8 " ++ show numBits - ," case tag of" - ,unlines $ map (\(n,c) -> dec (show n) c) cs - ,dec "_" (snd $ last cs) + let dt = "E" ++ show n + n = 2 ^ numBits + cs = zip [1 ..] $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n] + dec n c = unwords [" ", n, "-> return", c] + in unlines + [ unwords ["instance Flat", dt, "where"] + , " size _ n = n+" ++ show numBits + , " encode a = case a of" + , unlines $ map (\(n, c) -> unwords [" ", c, "-> eBits16", show numBits, show n]) cs + , " decode = do" + , " tag <- dBEBits8 " ++ show numBits + , " case tag of" + , unlines $ map (\(n, c) -> dec (show n) c) cs + , dec "_" (snd $ last cs) ] - deriving instance Flat S3 deriving instance Flat E2 deriving instance Flat E3 @@ -56,5 +56,3 @@ deriving instance Flat E258 -- , flat E256_253 -- , flat E256_256 -- ] - - diff --git a/plutus-core/index-envs/bench/Main.hs b/plutus-core/index-envs/bench/Main.hs index d8937663e98..a28f3611db6 100644 --- a/plutus-core/index-envs/bench/Main.hs +++ b/plutus-core/index-envs/bench/Main.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + module Main where import Criterion.Main @@ -19,34 +20,34 @@ import Data.RandomAccessList.SkewBinarySlab qualified as BS import Data.Vector.NonEmpty qualified as NEV import Data.Word -ralWorkloads :: forall e . (RandomAccessList e, Element e ~ ()) => Proxy e -> [Benchmark] +ralWorkloads :: forall e. (RandomAccessList e, Element e ~ ()) => Proxy e -> [Benchmark] ralWorkloads _ = - [ bgroup "cons" $ workloads (consN @e) - , bgroup "consSlab" $ workloads (consNSlab @e) - ] - where - workloads :: (Word64 -> e -> e) -> [Benchmark] - workloads creator = - [ bgroup "create" $ flip fmap [100, 250] $ \sz -> - bench (show sz) $ whnf (creator sz) empty - , bgroup "query-front" $ flip fmap [100, 250] $ \sz -> - bench (show sz) $ whnf (query [0..100]) (creator sz empty) - , bgroup "query-back" $ flip fmap [100, 250] $ \sz -> - bench (show sz) $ whnf (query [sz - 100..sz]) (creator sz empty) - , bgroup "query-rand" $ flip fmap [100, 250] $ \sz -> - let ws = randWords sz - in bench (show sz) $ whnf (query ws) (creator sz empty) - , bgroup "create/front100/cons100/back100/cons100/rand" $ flip fmap [100, 250] $ \sz -> - let qsize = 100 - ws = randWords sz - in bench (show sz) $ whnf (mix sz qsize qsize qsize qsize ws) (creator sz empty) - ] + [ bgroup "cons" $ workloads (consN @e) + , bgroup "consSlab" $ workloads (consNSlab @e) + ] + where + workloads :: (Word64 -> e -> e) -> [Benchmark] + workloads creator = + [ bgroup "create" $ flip fmap [100, 250] $ \sz -> + bench (show sz) $ whnf (creator sz) empty + , bgroup "query-front" $ flip fmap [100, 250] $ \sz -> + bench (show sz) $ whnf (query [0 .. 100]) (creator sz empty) + , bgroup "query-back" $ flip fmap [100, 250] $ \sz -> + bench (show sz) $ whnf (query [sz - 100 .. sz]) (creator sz empty) + , bgroup "query-rand" $ flip fmap [100, 250] $ \sz -> + let ws = randWords sz + in bench (show sz) $ whnf (query ws) (creator sz empty) + , bgroup "create/front100/cons100/back100/cons100/rand" $ flip fmap [100, 250] $ \sz -> + let qsize = 100 + ws = randWords sz + in bench (show sz) $ whnf (mix sz qsize qsize qsize qsize ws) (creator sz empty) + ] - randWords :: Word64 -> [Word64] - randWords sz = take (fromIntegral sz) $ randomRs (1, sz-1) g + randWords :: Word64 -> [Word64] + randWords sz = take (fromIntegral sz) $ randomRs (1, sz - 1) g - -- note: fixed rand-seed to make benchmarks deterministic - g = mkStdGen 59950 + -- note: fixed rand-seed to make benchmarks deterministic + g = mkStdGen 59950 applyN :: Integral b => b -> (a -> a) -> a -> a applyN n f = appEndo (stimes n $ Endo f) @@ -62,28 +63,29 @@ consNSlab n = consNSlabM (n `div` 10) 10 -- | Conses on 'n' slabs of size 'm' consNSlabM :: (RandomAccessList e, Element e ~ ()) => Word64 -> Word64 -> e -> e consNSlabM slabNo slabSize = applyN slabNo (consSlab slab) - where slab = fromJust $ NEV.replicate (fromIntegral slabSize) () + where + slab = fromJust $ NEV.replicate (fromIntegral slabSize) () {-# INLINE consNSlabM #-} -- | Accesses the given indices. query :: (RandomAccessList e, Element e ~ ()) => [Word64] -> e -> Element e -query [] _ = () -query (i:is) d = indexZero d i `seq` query is d +query [] _ = () +query (i : is) d = indexZero d i `seq` query is d -- | A mixed worload. -mix :: (RandomAccessList e, Element e ~ ()) => - Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> [Word64] -> e -> Element e +mix :: + (RandomAccessList e, Element e ~ ()) => + Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> [Word64] -> e -> Element e mix sz front cons1 back cons2 rand d = - query [0..front] d - `seq` + query [0 .. front] d `seq` let d1 = consN cons1 d - in query [(sz - back)..sz] d1 - `seq` - let d2 = consN cons2 d1 - in query rand d2 + in query [(sz - back) .. sz] d1 `seq` + let d2 = consN cons2 d1 + in query rand d2 main :: IO () -main = defaultMain +main = + defaultMain [ bgroup "SkewBinary" (ralWorkloads (Proxy :: Proxy (B.RAList ()))) , bgroup "SkewBinarySlab" (ralWorkloads (Proxy :: Proxy (BS.RAList ()))) , bgroup "RelativizedMap" (ralWorkloads (Proxy :: Proxy (RM.RelativizedMap ()))) diff --git a/plutus-core/index-envs/src/Data/RandomAccessList/Class.hs b/plutus-core/index-envs/src/Data/RandomAccessList/Class.hs index c4313cf8c5c..2ef318a6d5f 100644 --- a/plutus-core/index-envs/src/Data/RandomAccessList/Class.hs +++ b/plutus-core/index-envs/src/Data/RandomAccessList/Class.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Data.RandomAccessList.Class - ( RandomAccessList (..) - , Data.RandomAccessList.Class.head - , Data.RandomAccessList.Class.tail - , AsRAL (..) - ) where +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Data.RandomAccessList.Class ( + RandomAccessList (..), + Data.RandomAccessList.Class.head, + Data.RandomAccessList.Class.tail, + AsRAL (..), +) where import Data.Kind import Data.List qualified as List @@ -29,89 +30,94 @@ import GHC.Exts -- but for convenience we also provide implementations for e.g. '[a]', which has bad -- lookup performance. class RandomAccessList e where - -- | The type of elements in the list. - type Element e :: Type + -- | The type of elements in the list. + type Element e :: Type + + -- | The empty list. + empty :: e + + -- | Prepend an element to the list. + cons :: Element e -> e -> e + + -- | Un-prepend an element to the list. + uncons :: e -> Maybe (Element e, e) + + -- | Get the length of the list. May have linear complexity, but useful. + length :: e -> Word64 + + {-# INLINEABLE consSlab #-} - -- | The empty list. - empty :: e + -- | Prepend many elements to the list. Has a default implementation, but + -- implementations can provide more efficient ones. + consSlab :: NEV.NonEmptyVector (Element e) -> e -> e + consSlab vec e = NEV.foldr cons e vec - -- | Prepend an element to the list. - cons :: Element e -> e -> e + {-# INLINEABLE indexZero #-} - -- | Un-prepend an element to the list. - uncons :: e -> Maybe (Element e, e) + -- | Lookup an element in the list. 0-based index. + indexZero :: e -> Word64 -> Maybe (Element e) + indexZero e i = indexOne e (i + 1) - -- | Get the length of the list. May have linear complexity, but useful. - length :: e -> Word64 + {-# INLINEABLE indexOne #-} - {-# INLINABLE consSlab #-} - -- | Prepend many elements to the list. Has a default implementation, but - -- implementations can provide more efficient ones. - consSlab :: NEV.NonEmptyVector (Element e) -> e -> e - consSlab vec e = NEV.foldr cons e vec + -- | Lookup an element in the list. 1-based index. + indexOne :: e -> Word64 -> Maybe (Element e) + indexOne _ 0 = Nothing + indexOne e i = indexZero e (i - 1) - {-# INLINABLE indexZero #-} - -- | Lookup an element in the list. 0-based index. - indexZero :: e -> Word64 -> Maybe (Element e) - indexZero e i = indexOne e (i+1) + {-# INLINEABLE unsafeIndexZero #-} - {-# INLINABLE indexOne #-} - -- | Lookup an element in the list. 1-based index. - indexOne :: e -> Word64 -> Maybe (Element e) - indexOne _ 0 = Nothing - indexOne e i = indexZero e (i-1) + -- | Lookup an element in the list, partially. + unsafeIndexZero :: e -> Word64 -> Element e + unsafeIndexZero e = fromJust . indexZero e - {-# INLINABLE unsafeIndexZero #-} - -- | Lookup an element in the list, partially. - unsafeIndexZero :: e -> Word64 -> Element e - unsafeIndexZero e = fromJust . indexZero e + {-# INLINEABLE unsafeIndexOne #-} - {-# INLINABLE unsafeIndexOne #-} - -- | Lookup an element in the list, partially. - unsafeIndexOne :: e -> Word64 -> Element e - unsafeIndexOne e = fromJust . indexOne e + -- | Lookup an element in the list, partially. + unsafeIndexOne :: e -> Word64 -> Element e + unsafeIndexOne e = fromJust . indexOne e -- O(1) worst-case head :: (RandomAccessList e, a ~ Element e) => e -> a head = fst . fromMaybe (error "empty list") . uncons -{-# INLINABLE head #-} +{-# INLINEABLE head #-} -- O(1) worst-case -tail :: (RandomAccessList e) => e -> e +tail :: RandomAccessList e => e -> e tail = snd . fromMaybe (error "empty list") . uncons -{-# INLINABLE tail #-} +{-# INLINEABLE tail #-} instance RandomAccessList [a] where - type Element [a] = a - - {-# INLINABLE empty #-} - empty = [] - {-# INLINABLE cons #-} - cons = (:) - {-# INLINABLE uncons #-} - uncons = List.uncons - {-# INLINABLE length #-} - length = fromIntegral . List.length - {-# INLINABLE indexZero #-} - indexZero l w = l List.!? fromIntegral w - -instance RandomAccessList (RAL.RAList a) where - type Element (RAL.RAList a) = a - - {-# INLINABLE empty #-} - empty = mempty - {-# INLINABLE cons #-} - cons = RAL.cons - {-# INLINABLE uncons #-} - uncons = RAL.uncons - {-# INLINABLE length #-} - length = fromIntegral . RAL.length - {-# INLINABLE indexZero #-} - indexZero l w = l RAL.!? fromIntegral w + type Element [a] = a + + {-# INLINEABLE empty #-} + empty = [] + {-# INLINEABLE cons #-} + cons = (:) + {-# INLINEABLE uncons #-} + uncons = List.uncons + {-# INLINEABLE length #-} + length = fromIntegral . List.length + {-# INLINEABLE indexZero #-} + indexZero l w = l List.!? fromIntegral w + +instance RandomAccessList (RAL.RAList a) where + type Element (RAL.RAList a) = a + + {-# INLINEABLE empty #-} + empty = mempty + {-# INLINEABLE cons #-} + cons = RAL.cons + {-# INLINEABLE uncons #-} + uncons = RAL.uncons + {-# INLINEABLE length #-} + length = fromIntegral . RAL.length + {-# INLINEABLE indexZero #-} + indexZero l w = l RAL.!? fromIntegral w newtype AsRAL a = AsRAL a instance RandomAccessList e => IsList (AsRAL e) where - type Item (AsRAL e) = Element e - fromList l = AsRAL $ foldr cons empty l - toList (AsRAL e) = List.unfoldr uncons e + type Item (AsRAL e) = Element e + fromList l = AsRAL $ foldr cons empty l + toList (AsRAL e) = List.unfoldr uncons e diff --git a/plutus-core/index-envs/src/Data/RandomAccessList/RelativizedMap.hs b/plutus-core/index-envs/src/Data/RandomAccessList/RelativizedMap.hs index 3e6aa05ace1..c3e6aa34ac0 100644 --- a/plutus-core/index-envs/src/Data/RandomAccessList/RelativizedMap.hs +++ b/plutus-core/index-envs/src/Data/RandomAccessList/RelativizedMap.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Data.RandomAccessList.RelativizedMap (RelativizedMap (..))where + +module Data.RandomAccessList.RelativizedMap (RelativizedMap (..)) where import Data.Word @@ -12,25 +13,25 @@ import GHC.Exts (IsList) -- | A sequence implemented by a map from "levels" to values and a counter giving the "current" -- level. data RelativizedMap a = RelativizedMap (IM.IntMap a) {-# UNPACK #-} !Word64 - deriving stock (Show, Eq) - deriving (IsList) via RAL.AsRAL (RelativizedMap a) + deriving stock (Show, Eq) + deriving (IsList) via RAL.AsRAL (RelativizedMap a) instance RAL.RandomAccessList (RelativizedMap a) where - type Element (RelativizedMap a) = a + type Element (RelativizedMap a) = a - {-# INLINABLE empty #-} - empty = RelativizedMap mempty 0 - {-# INLINABLE cons #-} - cons a (RelativizedMap im l) = RelativizedMap (IM.insert (fromIntegral l) a im) (l+1) - {-# INLINABLE uncons #-} - uncons (RelativizedMap _ 0) = Nothing - uncons (RelativizedMap im l) = case IM.maxViewWithKey im of - Nothing -> Nothing - Just ((_, a), res) -> Just (a, RelativizedMap res (l-1)) - {-# INLINABLE length #-} - length (RelativizedMap _ l) = l - {-# INLINABLE indexZero #-} - indexZero (RelativizedMap _ 0) _ = Nothing - indexZero (RelativizedMap im l) w = - let maxIndex = l-1 in - if w > maxIndex then Nothing else IM.lookup (fromIntegral maxIndex - fromIntegral w) im + {-# INLINEABLE empty #-} + empty = RelativizedMap mempty 0 + {-# INLINEABLE cons #-} + cons a (RelativizedMap im l) = RelativizedMap (IM.insert (fromIntegral l) a im) (l + 1) + {-# INLINEABLE uncons #-} + uncons (RelativizedMap _ 0) = Nothing + uncons (RelativizedMap im l) = case IM.maxViewWithKey im of + Nothing -> Nothing + Just ((_, a), res) -> Just (a, RelativizedMap res (l - 1)) + {-# INLINEABLE length #-} + length (RelativizedMap _ l) = l + {-# INLINEABLE indexZero #-} + indexZero (RelativizedMap _ 0) _ = Nothing + indexZero (RelativizedMap im l) w = + let maxIndex = l - 1 + in if w > maxIndex then Nothing else IM.lookup (fromIntegral maxIndex - fromIntegral w) im diff --git a/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinary.hs b/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinary.hs index dd3e41464d2..b00c536e1cc 100644 --- a/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinary.hs +++ b/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinary.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -module Data.RandomAccessList.SkewBinary - ( RAList(Cons,Nil) - , contIndexZero - , contIndexOne - , safeIndexZero - , unsafeIndexZero - , safeIndexOne - , unsafeIndexOne - , Data.RandomAccessList.SkewBinary.null - , uncons - ) where +{-# LANGUAGE ViewPatterns #-} + +module Data.RandomAccessList.SkewBinary ( + RAList (Cons, Nil), + contIndexZero, + contIndexOne, + safeIndexZero, + unsafeIndexZero, + safeIndexOne, + unsafeIndexOne, + Data.RandomAccessList.SkewBinary.null, + uncons, +) where import Data.Bits (setBit, unsafeShiftL, unsafeShiftR) import Data.Word @@ -25,30 +26,36 @@ import Data.RandomAccessList.Class qualified as RAL -- 'Node' appears first to make it more likely for GHC to reorder pattern matches to make the 'Node' -- one appear first (which makes it more efficient). + -- | A complete binary tree. -- Note: the size of the tree is not stored/cached, -- unless it appears as a root tree in 'RAList', which the size is stored inside the Cons. -data Tree a = Node a !(Tree a) !(Tree a) - | Leaf a - deriving stock (Eq, Show) +data Tree a + = Node a !(Tree a) !(Tree a) + | Leaf a + deriving stock (Eq, Show) -- | A strict list of complete binary trees accompanied by their size. -- The trees appear in >=-size order. -- Note: this list is strict in its spine, unlike the Prelude list -data RAList a = BHead - {-# UNPACK #-} !Word64 -- ^ the size of the head tree - !(Tree a) -- ^ the head tree - !(RAList a) -- ^ the tail trees - | Nil - -- the derived Eq instance is correct, - -- because binary skew numbers have unique representation - -- and hence all trees of the same size will have the same structure - deriving stock (Eq, Show) - deriving (IsList) via RAL.AsRAL (RAList a) +data RAList a + = BHead + -- | the size of the head tree + {-# UNPACK #-} !Word64 + -- | the head tree + !(Tree a) + -- | the tail trees + !(RAList a) + | Nil + -- the derived Eq instance is correct, + -- because binary skew numbers have unique representation + -- and hence all trees of the same size will have the same structure + deriving stock (Eq, Show) + deriving (IsList) via RAL.AsRAL (RAList a) null :: RAList a -> Bool null Nil = True -null _ = False +null _ = False {-# INLINE null #-} {-# COMPLETE Cons, Nil #-} @@ -56,28 +63,30 @@ null _ = False -- /O(1)/ pattern Cons :: a -> RAList a -> RAList a -pattern Cons x xs <- (uncons -> Just (x, xs)) where - Cons x xs = cons x xs +pattern Cons x xs <- (uncons -> Just (x, xs)) + where + Cons x xs = cons x xs -- O(1) worst-case cons :: a -> RAList a -> RAList a cons x = \case - (BHead w1 t1 (BHead w2 t2 ts')) | w1 == w2 -> + (BHead w1 t1 (BHead w2 t2 ts')) + | w1 == w2 -> -- 'unsafeShiftL w1 1 `setBit`0' is supposed to be a faster version of '(2*w1)+1' BHead (unsafeShiftL w1 1 `setBit` 0) (Node x t1 t2) ts' - ts -> BHead 1 (Leaf x) ts + ts -> BHead 1 (Leaf x) ts {-# INLINE cons #-} -- /O(1)/ uncons :: RAList a -> Maybe (a, RAList a) uncons = \case - BHead _ (Leaf x) ts -> Just (x, ts) - BHead treeSize (Node x t1 t2) ts -> - -- probably faster than `div w 2` - let halfSize = unsafeShiftR treeSize 1 - -- split the node in two) - in Just (x, BHead halfSize t1 $ BHead halfSize t2 ts) - Nil -> Nothing + BHead _ (Leaf x) ts -> Just (x, ts) + BHead treeSize (Node x t1 t2) ts -> + -- probably faster than `div w 2` + let halfSize = unsafeShiftR treeSize 1 + in -- split the node in two) + Just (x, BHead halfSize t1 $ BHead halfSize t2 ts) + Nil -> Nothing {-# INLINE uncons #-} {- Note [Optimizations of contIndexZero] @@ -94,26 +103,27 @@ anything at all. -- See Note [Optimizations of contIndexZero]. contIndexZero :: forall a b. b -> (a -> b) -> RAList a -> Word64 -> b -contIndexZero z f = findTree where +contIndexZero z f = findTree + where findTree :: RAList a -> Word64 -> b -- See Note [Optimizations of contIndexZero]. findTree Nil !_ = z findTree (BHead w t ts) i = - if i < w + if i < w then indexTree w i t - else findTree ts (i-w) + else findTree ts (i - w) indexTree :: Word64 -> Word64 -> Tree a -> b -- See Note [Optimizations of contIndexZero]. indexTree !w 0 t = case t of - Node x _ _ -> f x - Leaf x -> if w == 1 then f x else z + Node x _ _ -> f x + Leaf x -> if w == 1 then f x else z indexTree _ _ (Leaf _) = z indexTree treeSize offset (Node _ t1 t2) = - let halfSize = unsafeShiftR treeSize 1 -- probably faster than `div w 2` - in if offset <= halfSize - then indexTree halfSize (offset - 1) t1 - else indexTree halfSize (offset - 1 - halfSize) t2 + let halfSize = unsafeShiftR treeSize 1 -- probably faster than `div w 2` + in if offset <= halfSize + then indexTree halfSize (offset - 1) t1 + else indexTree halfSize (offset - 1 - halfSize) t2 {-# INLINE contIndexZero #-} contIndexOne :: forall a b. b -> (a -> b) -> RAList a -> Word64 -> b @@ -142,30 +152,31 @@ safeIndexOne = contIndexOne Nothing Just {-# INLINE safeIndexOne #-} instance RAL.RandomAccessList (RAList a) where - type Element (RAList a) = a + type Element (RAList a) = a - empty = Nil - {-# INLINE empty #-} + empty = Nil + {-# INLINE empty #-} - cons = Cons - {-# INLINE cons #-} + cons = Cons + {-# INLINE cons #-} - uncons = uncons - {-# INLINE uncons #-} + uncons = uncons + {-# INLINE uncons #-} - length = go 0 where - go !acc Nil = acc - go !acc (BHead sz _ tl) = go (acc + sz) tl - {-# INLINE length #-} + length = go 0 + where + go !acc Nil = acc + go !acc (BHead sz _ tl) = go (acc + sz) tl + {-# INLINE length #-} - indexZero = safeIndexZero - {-# INLINE indexZero #-} + indexZero = safeIndexZero + {-# INLINE indexZero #-} - indexOne = safeIndexOne - {-# INLINE indexOne #-} + indexOne = safeIndexOne + {-# INLINE indexOne #-} - unsafeIndexZero = unsafeIndexZero - {-# INLINE unsafeIndexZero #-} + unsafeIndexZero = unsafeIndexZero + {-# INLINE unsafeIndexZero #-} - unsafeIndexOne = unsafeIndexOne - {-# INLINE unsafeIndexOne #-} + unsafeIndexOne = unsafeIndexOne + {-# INLINE unsafeIndexOne #-} diff --git a/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinarySlab.hs b/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinarySlab.hs index b49ff86d6c1..da113e948ef 100644 --- a/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinarySlab.hs +++ b/plutus-core/index-envs/src/Data/RandomAccessList/SkewBinarySlab.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -module Data.RandomAccessList.SkewBinarySlab - ( RAList(Cons,Nil) - , safeIndexZero - , unsafeIndexZero - , Data.RandomAccessList.SkewBinarySlab.null - , uncons - , consSlab - ) where +{-# LANGUAGE ViewPatterns #-} + +module Data.RandomAccessList.SkewBinarySlab ( + RAList (Cons, Nil), + safeIndexZero, + unsafeIndexZero, + Data.RandomAccessList.SkewBinarySlab.null, + uncons, + consSlab, +) where import Data.Bits (unsafeShiftR) import Data.Vector.NonEmpty qualified as NEV @@ -48,110 +49,118 @@ So it's not an unqualified win, but it may be better in some cases. -- Why not just store `NonEmptyVector`s and add singleton values by making singleton -- vectors? The answer is that using only vectors makes simple consing significantly -- slower, and doesn't obviously make the other code paths faster. + -- | The values that can be stored in a node. Either a single value, or a non-empty vector of -- values. data Values a = One a | Many {-# UNPACK #-} !(NEV.NonEmptyVector a) - deriving stock (Eq, Show) + deriving stock (Eq, Show) valuesCount :: Values a -> Word64 -valuesCount (One _) = 1 +valuesCount (One _) = 1 valuesCount (Many v) = fromIntegral $ NEV.length v unsafeIndexValues :: Word64 -> Values a -> a -unsafeIndexValues 0 (One a) = a -unsafeIndexValues _ (One _) = error "out of bounds" +unsafeIndexValues 0 (One a) = a +unsafeIndexValues _ (One _) = error "out of bounds" unsafeIndexValues i (Many v) = v NEV.! fromIntegral i safeIndexValues :: Word64 -> Values a -> Maybe a -safeIndexValues 0 (One a) = Just a -safeIndexValues _ (One _) = Nothing +safeIndexValues 0 (One a) = Just a +safeIndexValues _ (One _) = Nothing safeIndexValues i (Many v) = v NEV.!? fromIntegral i -- O(1) unconsValues :: Values a -> RAList a -> (a, RAList a) unconsValues (One x) l = (x, l) unconsValues (Many v) l = - -- unconsing vectors is actually O(1), which is important! - let (x, xs) = NEV.uncons v - remaining = case NEV.fromVector xs of - Just v' -> consSlab v' l - Nothing -> l - in (x, remaining) + -- unconsing vectors is actually O(1), which is important! + let (x, xs) = NEV.uncons v + remaining = case NEV.fromVector xs of + Just v' -> consSlab v' l + Nothing -> l + in (x, remaining) -- | A complete binary tree. -data Tree a = Leaf !(Values a) - -- Nodes track the number of elements in the tree (including those in the node) - | Node {-# UNPACK #-} !Word64 !(Values a) !(Tree a) !(Tree a) - deriving stock (Eq, Show) +data Tree a + = Leaf !(Values a) + | -- Nodes track the number of elements in the tree (including those in the node) + Node {-# UNPACK #-} !Word64 !(Values a) !(Tree a) !(Tree a) + deriving stock (Eq, Show) treeCount :: Tree a -> Word64 -treeCount (Leaf v) = valuesCount v +treeCount (Leaf v) = valuesCount v treeCount (Node s _ _ _) = s unsafeIndexTree :: Word64 -> Tree a -> a unsafeIndexTree offset (Leaf v) = unsafeIndexValues offset v unsafeIndexTree offset (Node _ v t1 t2) = - let nCount = valuesCount v - in if offset < nCount - then unsafeIndexValues offset v - else - let offset' = offset - nCount - lCount = treeCount t1 - in if offset' < lCount - then unsafeIndexTree offset' t1 - else unsafeIndexTree (offset' - lCount) t2 + let nCount = valuesCount v + in if offset < nCount + then unsafeIndexValues offset v + else + let offset' = offset - nCount + lCount = treeCount t1 + in if offset' < lCount + then unsafeIndexTree offset' t1 + else unsafeIndexTree (offset' - lCount) t2 safeIndexTree :: Word64 -> Tree a -> Maybe a safeIndexTree offset (Leaf v) = safeIndexValues offset v safeIndexTree offset (Node _ v t1 t2) = - let nCount = valuesCount v - in if offset < nCount - then safeIndexValues offset v - else - let offset' = offset - nCount - lCount = treeCount t1 - in if offset' < lCount - then safeIndexTree offset' t1 - else safeIndexTree (offset' - lCount) t2 + let nCount = valuesCount v + in if offset < nCount + then safeIndexValues offset v + else + let offset' = offset - nCount + lCount = treeCount t1 + in if offset' < lCount + then safeIndexTree offset' t1 + else safeIndexTree (offset' - lCount) t2 -- | A strict list of complete binary trees accompanied by their node size. -- The trees appear in >=-node size order. -- Note: this list is strict in its spine, unlike the Prelude list -data RAList a = BHead - {-# UNPACK #-} !Word64 -- ^ the number of nodes in the head tree - !(Tree a) -- ^ the head tree - !(RAList a) -- ^ the tail trees - | Nil - deriving stock (Show) - deriving (IsList) via RAL.AsRAL (RAList a) +data RAList a + = BHead + -- | the number of nodes in the head tree + {-# UNPACK #-} !Word64 + -- | the head tree + !(Tree a) + -- | the tail trees + !(RAList a) + | Nil + deriving stock (Show) + deriving (IsList) via RAL.AsRAL (RAList a) -- Can't use the derived instance because it's no longer the case that lists with -- the same contents have to have the same structure! Could definitely write a -- faster implementation if it matters, though. instance Eq a => Eq (RAList a) where - l == l' = toList l == toList l' + l == l' = toList l == toList l' null :: RAList a -> Bool null Nil = True -null _ = False -{-# INLINABLE null #-} +null _ = False +{-# INLINEABLE null #-} -{-# complete Cons, Nil #-} -{-# complete BHead, Nil #-} +{-# COMPLETE Cons, Nil #-} +{-# COMPLETE BHead, Nil #-} -- /O(1)/ pattern Cons :: a -> RAList a -> RAList a -pattern Cons x xs <- (uncons -> Just (x, xs)) where - Cons x xs = cons x xs +pattern Cons x xs <- (uncons -> Just (x, xs)) + where + Cons x xs = cons x xs -- O(1) worst-case consValues :: Values a -> RAList a -> RAList a consValues x l = case l of - (BHead w1 t1 (BHead w2 t2 ts')) | w1 == w2 -> + (BHead w1 t1 (BHead w2 t2 ts')) + | w1 == w2 -> let ts = w1 + w2 + 1 ec = treeCount t1 + treeCount t2 + valuesCount x - in BHead ts (Node ec x t1 t2) ts' - ts -> BHead 1 (Leaf x) ts + in BHead ts (Node ec x t1 t2) ts' + ts -> BHead 1 (Leaf x) ts -- O(1) worst-case cons :: a -> RAList a -> RAList a @@ -170,47 +179,47 @@ consSlab x = consValues (Many x) -- so it adds up to being okay. uncons :: RAList a -> Maybe (a, RAList a) uncons = \case - BHead _ (Leaf v) ts -> Just $ unconsValues v ts - BHead _ (Node treeSize x t1 t2) ts -> - -- probably faster than `div w 2` - let halfSize = unsafeShiftR treeSize 1 - -- split the node in two) - in Just $ unconsValues x (BHead halfSize t1 $ BHead halfSize t2 ts) - Nil -> Nothing + BHead _ (Leaf v) ts -> Just $ unconsValues v ts + BHead _ (Node treeSize x t1 t2) ts -> + -- probably faster than `div w 2` + let halfSize = unsafeShiftR treeSize 1 + in -- split the node in two) + Just $ unconsValues x (BHead halfSize t1 $ BHead halfSize t2 ts) + Nil -> Nothing -- 0-based unsafeIndexZero :: RAList a -> Word64 -> a -unsafeIndexZero Nil _ = error "out of bounds" -unsafeIndexZero (BHead _ t ts) !i = - let tCount = treeCount t - in if i < tCount - then unsafeIndexTree i t - else unsafeIndexZero ts (i - tCount) +unsafeIndexZero Nil _ = error "out of bounds" +unsafeIndexZero (BHead _ t ts) !i = + let tCount = treeCount t + in if i < tCount + then unsafeIndexTree i t + else unsafeIndexZero ts (i - tCount) -- 0-based safeIndexZero :: RAList a -> Word64 -> Maybe a -safeIndexZero Nil _ = Nothing -safeIndexZero (BHead _ t ts) !i = - let tCount = treeCount t - in if i < tCount - then safeIndexTree i t - else safeIndexZero ts (i - tCount) +safeIndexZero Nil _ = Nothing +safeIndexZero (BHead _ t ts) !i = + let tCount = treeCount t + in if i < tCount + then safeIndexTree i t + else safeIndexZero ts (i - tCount) instance RAL.RandomAccessList (RAList a) where - type Element (RAList a) = a - - {-# INLINABLE empty #-} - empty = Nil - {-# INLINABLE cons #-} - cons = Cons - {-# INLINABLE uncons #-} - uncons = uncons - {-# INLINABLE length #-} - length Nil = 0 - length (BHead _ t tl) = treeCount t + RAL.length tl - {-# INLINABLE consSlab #-} - consSlab = consSlab - {-# INLINABLE indexZero #-} - indexZero l i = safeIndexZero l i - {-# INLINABLE unsafeIndexZero #-} - unsafeIndexZero l i = unsafeIndexZero l i + type Element (RAList a) = a + + {-# INLINEABLE empty #-} + empty = Nil + {-# INLINEABLE cons #-} + cons = Cons + {-# INLINEABLE uncons #-} + uncons = uncons + {-# INLINEABLE length #-} + length Nil = 0 + length (BHead _ t tl) = treeCount t + RAL.length tl + {-# INLINEABLE consSlab #-} + consSlab = consSlab + {-# INLINEABLE indexZero #-} + indexZero l i = safeIndexZero l i + {-# INLINEABLE unsafeIndexZero #-} + unsafeIndexZero l i = unsafeIndexZero l i diff --git a/plutus-core/index-envs/test/RAList/Spec.hs b/plutus-core/index-envs/test/RAList/Spec.hs index 9e50fd73326..52aa0120f1b 100644 --- a/plutus-core/index-envs/test/RAList/Spec.hs +++ b/plutus-core/index-envs/test/RAList/Spec.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -Wno-orphans #-} + module RAList.Spec (tests) where import Control.Exception @@ -26,7 +26,7 @@ import Test.Tasty import Test.Tasty.QuickCheck instance (Element e ~ a, RandomAccessList e, Arbitrary a) => Arbitrary (AsRAL e) where - arbitrary = fromList <$> arbitrary + arbitrary = fromList <$> arbitrary deriving via (AsRAL (B.RAList a)) instance Arbitrary a => Arbitrary (B.RAList a) deriving via (AsRAL (RM.RelativizedMap a)) instance Arbitrary a => Arbitrary (RM.RelativizedMap a) @@ -35,124 +35,142 @@ deriving via (AsRAL (RM.RelativizedMap a)) instance Arbitrary a => Arbitrary (RM -- from equivalent lists is fine. This isn't true for the slab version! So we write -- a manual generator that appends stuff randomly as slabs or not. instance Arbitrary a => Arbitrary (BS.RAList a) where - arbitrary = sized $ \sz -> go sz empty - where - go :: Int -> BS.RAList a -> Gen (BS.RAList a) - go 0 acc = pure acc - go sz acc = do - toAdd <- choose (1, sz) - elemsToAdd <- vector toAdd - asSlab <- arbitrary - let extended = if asSlab - then RAL.consSlab (fromJust $ NEV.fromList elemsToAdd) acc - else List.foldl' (\env val -> RAL.cons val env) acc elemsToAdd - go (sz - toAdd) extended + arbitrary = sized $ \sz -> go sz empty + where + go :: Int -> BS.RAList a -> Gen (BS.RAList a) + go 0 acc = pure acc + go sz acc = do + toAdd <- choose (1, sz) + elemsToAdd <- vector toAdd + asSlab <- arbitrary + let extended = + if asSlab + then RAL.consSlab (fromJust $ NEV.fromList elemsToAdd) acc + else List.foldl' (\env val -> RAL.cons val env) acc elemsToAdd + go (sz - toAdd) extended type RALTestable e a = - (a ~ Element e, RandomAccessList e, Eq a, Eq e, Show a, Show e, Arbitrary a, Arbitrary e, - IsList e, Item e ~ a) + ( a ~ Element e + , RandomAccessList e + , Eq a + , Eq e + , Show a + , Show e + , Arbitrary a + , Arbitrary e + , IsList e + , Item e ~ a + ) sameModuloExceptions :: Eq a => IO a -> IO a -> IO Bool sameModuloExceptions a1 a2 = do - i1 <- try @SomeException $ a1 - i2 <- try @SomeException $ a2 - pure $ case (i1, i2) of - (Left _, Left _) -> False - (Right v1, Right v2) -> v1 == v2 - _ -> False - -prop_fromToList :: forall e a . (RALTestable e a) => Proxy e -> Property + i1 <- try @SomeException $ a1 + i2 <- try @SomeException $ a2 + pure $ case (i1, i2) of + (Left _, Left _) -> False + (Right v1, Right v2) -> v1 == v2 + _ -> False + +prop_fromToList :: forall e a. RALTestable e a => Proxy e -> Property prop_fromToList _ = forAll arbitrary $ \(l :: e) -> (fromList $ toList l) === l -prop_toFromList :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_toFromList :: forall e a. RALTestable e a => Proxy e -> Property prop_toFromList _ = forAll arbitrary $ \(l :: [a]) -> (toList $ fromList @e l) === l -prop_empty :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_empty :: forall e a. RALTestable e a => Proxy e -> Property prop_empty _ = fromList @e empty === empty -prop_cons :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_cons :: forall e a. RALTestable e a => Proxy e -> Property prop_cons _ = forAll arbitrary $ \(l :: e, e :: a) -> cons e (toList l) === toList (cons e l) -prop_uncons :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_uncons :: forall e a. RALTestable e a => Proxy e -> Property prop_uncons _ = - forAll arbitrary $ \(l :: e) -> uncons (toList l) === (fmap $ fmap toList) (uncons l) + forAll arbitrary $ \(l :: e) -> uncons (toList l) === (fmap $ fmap toList) (uncons l) -prop_length :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_length :: forall e a. RALTestable e a => Proxy e -> Property prop_length _ = forAll arbitrary $ \(l :: e) -> RAL.length (toList l) === RAL.length l -- Includes some out-of-range indices above the length -prop_indexZero :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_indexZero :: forall e a. RALTestable e a => Proxy e -> Property prop_indexZero _ = - forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2*(RAL.length l-1))) $ \i -> + forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2 * (RAL.length l - 1))) $ \i -> let r1 = indexZero (toList l) i r2 = indexZero l i - in cover 10 (isNothing r1) "failed lookups" $ r1 == r2 + in cover 10 (isNothing r1) "failed lookups" $ r1 == r2 -- Includes some out-of-range indices above the length -prop_unsafeIndexZero :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_unsafeIndexZero :: forall e a. RALTestable e a => Proxy e -> Property prop_unsafeIndexZero _ = - forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2*(RAL.length l-1))) $ \i -> + forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2 * (RAL.length l - 1))) $ \i -> ioProperty $ sameModuloExceptions (evaluate $ indexZero (toList l) i) (evaluate $ indexZero l i) -- Includes some out-of-range indices above the length, and 0 which is out-of-range below -prop_indexOne :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_indexOne :: forall e a. RALTestable e a => Proxy e -> Property prop_indexOne _ = - forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2*(RAL.length l-1))) $ \i -> + forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2 * (RAL.length l - 1))) $ \i -> let r1 = indexOne (toList l) i r2 = indexOne l i - in cover 10 (isNothing r1) "failed lookups" $ r1 == r2 + in cover 10 (isNothing r1) "failed lookups" $ r1 == r2 -- Includes some out-of-range indices above the length, and 0 which is out-of-range below -prop_unsafeIndexOne :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_unsafeIndexOne :: forall e a. RALTestable e a => Proxy e -> Property prop_unsafeIndexOne _ = - forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2*(RAL.length l-1))) $ \i -> - ioProperty $ - sameModuloExceptions (evaluate $ indexOne (toList l) i) (evaluate $ indexOne l i) + forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2 * (RAL.length l - 1))) $ \i -> + ioProperty $ + sameModuloExceptions (evaluate $ indexOne (toList l) i) (evaluate $ indexOne l i) -prop_consSlab :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_consSlab :: forall e a. RALTestable e a => Proxy e -> Property prop_consSlab _ = forAll arbitrary $ \(l :: e, es :: NonEmpty a) -> - let nev = NEV.fromNonEmpty es - in - cover 90 (NEV.length nev > 1) "non-trivial" $ - consSlab nev (toList l) === toList (consSlab nev l) + let nev = NEV.fromNonEmpty es + in cover 90 (NEV.length nev > 1) "non-trivial" $ + consSlab nev (toList l) === toList (consSlab nev l) -prop_indexOneZero :: forall e a . (RALTestable e a) => Proxy e -> Property +prop_indexOneZero :: forall e a. RALTestable e a => Proxy e -> Property prop_indexOneZero _ = - forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2*(RAL.length l-1))) $ \i -> - let r1 = indexZero (toList l) i - r2 = indexOne l (i+1) - in cover 10 (isNothing r1) "failed lookups" $ r1 === r2 + forAll arbitrary $ \(l :: e) -> forAll (chooseWord64 (0, 2 * (RAL.length l - 1))) $ \i -> + let r1 = indexZero (toList l) i + r2 = indexOne l (i + 1) + in cover 10 (isNothing r1) "failed lookups" $ r1 === r2 -- | These properties test the correctness of each RAL function by checking that it behaves the same -- as the canonical version of that function on lists. In combination with a test that to/fromList -- form an isomorphism, this assures us that each function is correct. -ralProps :: forall e a . (RALTestable e a) => Proxy e -> TestTree -ralProps p = localOption (QuickCheckTests 10000) $ - testGroup "RandomAccessList correctness properties" - [ testGroup "to/fromList is an isomorphism" - [ testProperty "fromList . toList == id"$ prop_fromToList p - , testProperty "toList . fromList == id"$ prop_toFromList p - ] - , testGroup "operations" - [ testProperty "empty" $ prop_empty p - , testProperty "cons" $ prop_cons p - , testProperty "uncons" $ prop_uncons p - , testProperty "length" $ prop_length p - , testProperty "indexZero" $ prop_indexZero p - , testProperty "unsafeIndexZero" $ prop_unsafeIndexZero p - , testProperty "indexOne" $ prop_indexOne p - , testProperty "unsafeIndexOne" $ prop_unsafeIndexOne p - , testProperty "consSlab" $ prop_consSlab p - ] - , testProperty "indexOne indexZero coherence" $ prop_indexOneZero p - ] +ralProps :: forall e a. RALTestable e a => Proxy e -> TestTree +ralProps p = + localOption (QuickCheckTests 10000) $ + testGroup + "RandomAccessList correctness properties" + [ testGroup + "to/fromList is an isomorphism" + [ testProperty "fromList . toList == id" $ prop_fromToList p + , testProperty "toList . fromList == id" $ prop_toFromList p + ] + , testGroup + "operations" + [ testProperty "empty" $ prop_empty p + , testProperty "cons" $ prop_cons p + , testProperty "uncons" $ prop_uncons p + , testProperty "length" $ prop_length p + , testProperty "indexZero" $ prop_indexZero p + , testProperty "unsafeIndexZero" $ prop_unsafeIndexZero p + , testProperty "indexOne" $ prop_indexOne p + , testProperty "unsafeIndexOne" $ prop_unsafeIndexOne p + , testProperty "consSlab" $ prop_consSlab p + ] + , testProperty "indexOne indexZero coherence" $ prop_indexOneZero p + ] tests :: TestTree -tests = testGroup "RandomAccessLists" - [ testGroup "SkewBinary" - [ ralProps (Proxy :: (Proxy (B.RAList Integer))) ] - , testGroup "SkewBinarySlab" - [ ralProps (Proxy :: (Proxy (BS.RAList Integer))) ] - , testGroup "RelativizedMap" - [ ralProps (Proxy :: (Proxy (RM.RelativizedMap Integer))) ] +tests = + testGroup + "RandomAccessLists" + [ testGroup + "SkewBinary" + [ralProps (Proxy :: (Proxy (B.RAList Integer)))] + , testGroup + "SkewBinarySlab" + [ralProps (Proxy :: (Proxy (BS.RAList Integer)))] + , testGroup + "RelativizedMap" + [ralProps (Proxy :: (Proxy (RM.RelativizedMap Integer)))] ] diff --git a/plutus-core/index-envs/test/Spec.hs b/plutus-core/index-envs/test/Spec.hs index 1988af0fd67..30bdbb63008 100644 --- a/plutus-core/index-envs/test/Spec.hs +++ b/plutus-core/index-envs/test/Spec.hs @@ -1,6 +1,6 @@ -module Main - ( main - ) where +module Main ( + main, +) where import RAList.Spec qualified as RAList import Test.Tasty diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs index 6debfa7a089..a7db65c1f5a 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs @@ -1,20 +1,19 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module PlutusCore.Examples.Builtins where @@ -48,8 +47,8 @@ import System.Mem (performMinorGC) import System.Mem.Weak (addFinalizer) instance (Bounded a, Bounded b) => Bounded (Either a b) where - minBound = Left minBound - maxBound = Right maxBound + minBound = Left minBound + maxBound = Right maxBound size :: forall a. (Bounded a, Enum a) => Int size = fromEnum (maxBound :: a) - fromEnum (minBound :: a) + 1 @@ -59,27 +58,28 @@ size = fromEnum (maxBound :: a) - fromEnum (minBound :: a) + 1 -- >>> map toEnum [0 .. 4] :: [Either Bool Ordering] -- [Left False,Left True,Right LT,Right EQ,Right GT] instance (Eq a, Eq b, Bounded a, Bounded b, Enum a, Enum b) => Enum (Either a b) where - succ (Left x) - | x == maxBound = Right minBound - | otherwise = Left $ succ x - succ (Right y) - | y == maxBound = error "Out of bounds" - | otherwise = Right $ succ y - - pred (Left x) - | x == minBound = error "Out of bounds" - | otherwise = Left $ pred x - pred (Right y) - | y == minBound = Left maxBound - | otherwise = Right $ pred y - - toEnum i - | i < s = Left $ toEnum i - | otherwise = Right $ toEnum (i - s) - where s = size @a - - fromEnum (Left x) = fromEnum x - fromEnum (Right y) = size @a + fromEnum y + succ (Left x) + | x == maxBound = Right minBound + | otherwise = Left $ succ x + succ (Right y) + | y == maxBound = error "Out of bounds" + | otherwise = Right $ succ y + + pred (Left x) + | x == minBound = error "Out of bounds" + | otherwise = Left $ pred x + pred (Right y) + | y == minBound = Left maxBound + | otherwise = Right $ pred y + + toEnum i + | i < s = Left $ toEnum i + | otherwise = Right $ toEnum (i - s) + where + s = size @a + + fromEnum (Left x) = fromEnum x + fromEnum (Right y) = size @a + fromEnum y -- >>> import GHC.Ix -- >>> map (unsafeIndex (Left False, Right GT)) [Left False .. Right GT] @@ -87,80 +87,87 @@ instance (Eq a, Eq b, Bounded a, Bounded b, Enum a, Enum b) => Enum (Either a b) -- >>> let bounds = (Left (False, EQ), Right (True, GT)) in map (unsafeIndex bounds) $ range bounds -- [0,1,2,3,4,5,6,7,8,9] instance (Bounded a, Bounded b, Ix a, Ix b) => Ix (Either a b) where - range (Right _, Left _) = [] - range (Right x, Right y) = map Right (range (x, y)) - range (Left x, Right y) = map Left (range (x, maxBound)) ++ map Right (range (minBound, y)) - range (Left x, Left y) = map Left (range (x, y)) + range (Right _, Left _) = [] + range (Right x, Right y) = map Right (range (x, y)) + range (Left x, Right y) = map Left (range (x, maxBound)) ++ map Right (range (minBound, y)) + range (Left x, Left y) = map Left (range (x, y)) - unsafeIndex (Right _, _) (Left _) = error "Out of bounds" - unsafeIndex (Left x, n) (Left i) = unsafeIndex (x, fromLeft maxBound n) i - unsafeIndex (Right x, n) (Right i) = unsafeIndex (x, fromRight (error "Out of bounds") n) i - unsafeIndex (Left x, n) (Right i) = - unsafeIndex (x, maxBound) maxBound + 1 + - unsafeIndex (minBound, fromRight (error "Out of bounds") n) i + unsafeIndex (Right _, _) (Left _) = error "Out of bounds" + unsafeIndex (Left x, n) (Left i) = unsafeIndex (x, fromLeft maxBound n) i + unsafeIndex (Right x, n) (Right i) = unsafeIndex (x, fromRight (error "Out of bounds") n) i + unsafeIndex (Left x, n) (Right i) = + unsafeIndex (x, maxBound) maxBound + + 1 + + unsafeIndex (minBound, fromRight (error "Out of bounds") n) i - inRange (m, n) i = m <= i && i <= n + inRange (m, n) i = m <= i && i <= n -- See Note [Representable built-in functions over polymorphic built-in types] data ExtensionFun - = Factorial - | ForallFortyTwo -- A builtin for @42 :: forall a. Integer@. - | SumInteger - | Const - | Id - | IdAssumeBool - | IdAssumeCheckBool - | IdSomeConstantBool - | IdIntegerAsBool - | IdFInteger - | IdList - | IdRank2 - | ScottToMetaUnit - -- The next four are for testing that costing always precedes actual evaluation. - | FailingSucc - | ExpensiveSucc - | FailingPlus - | ExpensivePlus - | IsConstant - | UnsafeCoerce - | UnsafeCoerceEl - | Undefined - | Absurd - | ErrorPrime -- Like 'Error', but a builtin. What do we even need 'Error' for at this point? - -- Who knows what machinery a tick could break, hence the @Prime@ part. - | Comma - | BiconstPair -- A safe version of 'Comma' as discussed in Note [Representable built-in - -- functions over polymorphic built-in types]. - | Swap -- For checking that permuting type arguments of a polymorphic built-in works correctly. - | SwapEls -- For checking that nesting polymorphic built-in types and instantiating them with - -- a mix of monomorphic types and type variables works correctly. - | ExtensionVersion -- Reflect the version of the Extension - | TrackCosts -- For checking that each cost is released and can be picked up by GC once it's - -- accounted for in the evaluator. - | IntNoIntegerNoWord -- For testing the signature dump test. - deriving stock (Show, Eq, Ord, Enum, Bounded, Ix, Generic) - deriving anyclass (Hashable) + = Factorial + | ForallFortyTwo -- A builtin for @42 :: forall a. Integer@. + | SumInteger + | Const + | Id + | IdAssumeBool + | IdAssumeCheckBool + | IdSomeConstantBool + | IdIntegerAsBool + | IdFInteger + | IdList + | IdRank2 + | ScottToMetaUnit + | -- The next four are for testing that costing always precedes actual evaluation. + FailingSucc + | ExpensiveSucc + | FailingPlus + | ExpensivePlus + | IsConstant + | UnsafeCoerce + | UnsafeCoerceEl + | Undefined + | Absurd + | ErrorPrime -- Like 'Error', but a builtin. What do we even need 'Error' for at this point? + -- Who knows what machinery a tick could break, hence the @Prime@ part. + | Comma + | BiconstPair -- A safe version of 'Comma' as discussed in Note [Representable built-in + -- functions over polymorphic built-in types]. + | Swap -- For checking that permuting type arguments of a polymorphic built-in works correctly. + | SwapEls -- For checking that nesting polymorphic built-in types and instantiating them with + -- a mix of monomorphic types and type variables works correctly. + | ExtensionVersion -- Reflect the version of the Extension + | TrackCosts -- For checking that each cost is released and can be picked up by GC once it's + -- accounted for in the evaluator. + | IntNoIntegerNoWord -- For testing the signature dump test. + deriving stock (Show, Eq, Ord, Enum, Bounded, Ix, Generic) + deriving anyclass (Hashable) instance Pretty ExtensionFun where pretty = viaShow -instance (ToBuiltinMeaning uni fun1, ToBuiltinMeaning uni fun2 - , Default (BuiltinSemanticsVariant fun1), Default (BuiltinSemanticsVariant fun2) - ) => ToBuiltinMeaning uni (Either fun1 fun2) where - - type CostingPart uni (Either fun1 fun2) = (CostingPart uni fun1, CostingPart uni fun2) - - data BuiltinSemanticsVariant (Either fun1 fun2) = - PairV (BuiltinSemanticsVariant fun1) (BuiltinSemanticsVariant fun2) - toBuiltinMeaning (PairV semvarL _) (Left fun) = case toBuiltinMeaning semvarL fun of - BuiltinMeaning tySch toF denot -> - BuiltinMeaning tySch toF (denot . fst) - toBuiltinMeaning (PairV _ semvarR) (Right fun) = case toBuiltinMeaning semvarR fun of - BuiltinMeaning tySch toF denot -> - BuiltinMeaning tySch toF (denot . snd) +instance + ( ToBuiltinMeaning uni fun1 + , ToBuiltinMeaning uni fun2 + , Default (BuiltinSemanticsVariant fun1) + , Default (BuiltinSemanticsVariant fun2) + ) => + ToBuiltinMeaning uni (Either fun1 fun2) + where + type CostingPart uni (Either fun1 fun2) = (CostingPart uni fun1, CostingPart uni fun2) + + data BuiltinSemanticsVariant (Either fun1 fun2) + = PairV (BuiltinSemanticsVariant fun1) (BuiltinSemanticsVariant fun2) + toBuiltinMeaning (PairV semvarL _) (Left fun) = case toBuiltinMeaning semvarL fun of + BuiltinMeaning tySch toF denot -> + BuiltinMeaning tySch toF (denot . fst) + toBuiltinMeaning (PairV _ semvarR) (Right fun) = case toBuiltinMeaning semvarR fun of + BuiltinMeaning tySch toF denot -> + BuiltinMeaning tySch toF (denot . snd) -instance (Default (BuiltinSemanticsVariant fun1), Default (BuiltinSemanticsVariant fun2)) - => Default (BuiltinSemanticsVariant (Either fun1 fun2)) where - def = PairV def def +instance + (Default (BuiltinSemanticsVariant fun1), Default (BuiltinSemanticsVariant fun2)) => + Default (BuiltinSemanticsVariant (Either fun1 fun2)) + where + def = PairV def def -- | Normally @forall@ in the type of a Haskell function gets detected and instantiated -- automatically, however there's no way of doing that for a @forall@ that binds a never referenced @@ -169,53 +176,62 @@ instance (Default (BuiltinSemanticsVariant fun1), Default (BuiltinSemanticsVaria -- to create an @all@ that binds a never referenced type variable in Plutus while still using -- 'makeBuiltinMeaning'. newtype MetaForall name a = MetaForall a + instance - ( name ~ 'TyNameRep @kind text uniq, KnownSymbol text, KnownNat uniq - , KnownKind kind, KnownTypeAst tyname uni a - ) => KnownTypeAst tyname uni (MetaForall name a) where - type IsBuiltin _ (MetaForall name a) = 'False - type ToHoles _ _ (MetaForall name a) = '[TypeHole a] - type ToBinds uni acc (MetaForall name a) = ToBinds uni (Insert ('GADT.Some name) acc) a - typeAst = toTypeAst $ Proxy @a + ( name ~ 'TyNameRep @kind text uniq + , KnownSymbol text + , KnownNat uniq + , KnownKind kind + , KnownTypeAst tyname uni a + ) => + KnownTypeAst tyname uni (MetaForall name a) + where + type IsBuiltin _ (MetaForall name a) = 'False + type ToHoles _ _ (MetaForall name a) = '[TypeHole a] + type ToBinds uni acc (MetaForall name a) = ToBinds uni (Insert ('GADT.Some name) acc) a + typeAst = toTypeAst $ Proxy @a instance MakeKnownIn DefaultUni term a => MakeKnownIn DefaultUni term (MetaForall name a) where - makeKnown (MetaForall x) = makeKnown x + makeKnown (MetaForall x) = makeKnown x + -- 'ReadKnownIn' doesn't make sense for 'MetaForall'. data PlcListRep (a :: GHC.Type) -instance (tyname ~ TyName, KnownTypeAst tyname uni a) => - KnownTypeAst tyname uni (PlcListRep a) where - type IsBuiltin _ (PlcListRep a) = 'False - type ToHoles _ _ (PlcListRep a) = '[RepHole a] - type ToBinds uni acc (PlcListRep a) = ToBinds uni acc a - typeAst = TyApp () Plc.listTy . toTypeAst $ Proxy @a +instance + (tyname ~ TyName, KnownTypeAst tyname uni a) => + KnownTypeAst tyname uni (PlcListRep a) + where + type IsBuiltin _ (PlcListRep a) = 'False + type ToHoles _ _ (PlcListRep a) = '[RepHole a] + type ToBinds uni acc (PlcListRep a) = ToBinds uni acc a + typeAst = TyApp () Plc.listTy . toTypeAst $ Proxy @a instance tyname ~ TyName => KnownTypeAst tyname DefaultUni Void where - type IsBuiltin _ _ = 'False - type ToHoles _ _ _ = '[] - type ToBinds _ acc _ = acc - typeAst = runQuote $ do - a <- freshTyName "a" - pure $ TyForall () a (Type ()) $ TyVar () a + type IsBuiltin _ _ = 'False + type ToHoles _ _ _ = '[] + type ToBinds _ acc _ = acc + typeAst = runQuote $ do + a <- freshTyName "a" + pure $ TyForall () a (Type ()) $ TyVar () a instance UniOf term ~ DefaultUni => MakeKnownIn DefaultUni term Void where - makeKnown = absurd + makeKnown = absurd instance UniOf term ~ DefaultUni => ReadKnownIn DefaultUni term Void where - readKnown _ = throwError $ structuralUnliftingError "Can't unlift to 'Void'" + readKnown _ = throwError $ structuralUnliftingError "Can't unlift to 'Void'" data BuiltinErrorCall = BuiltinErrorCall - deriving stock (Show, Eq) - deriving anyclass (Exception) + deriving stock (Show, Eq) + deriving anyclass (Exception) -- | For the most part we don't care about costing functions of example builtins, hence this class -- for being explicit about not caring. class Whatever a where - -- | The costing function of a builtin whose costing function doesn't matter. - whatever :: a + -- | The costing function of a builtin whose costing function doesn't matter. + whatever :: a instance Whatever b => Whatever (a -> b) where - whatever _ = whatever + whatever _ = whatever instance Whatever ExBudgetStream where - whatever = ExBudgetLast mempty + whatever = ExBudgetLast mempty -- See Note [Representable built-in functions over polymorphic built-in types]. -- We have lists in the universe and so we can define a function like @\x -> [x, x]@ that duplicates @@ -229,323 +245,301 @@ instance Whatever ExBudgetStream where -- account automatically as well: just think that having @\x -> f x x@ as a PLC term is supposed -- to be handled correctly by design instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where - type CostingPart uni ExtensionFun = () - - data BuiltinSemanticsVariant ExtensionFun = - ExtensionFunSemanticsVariant0 - | ExtensionFunSemanticsVariant1 - | ExtensionFunSemanticsVariant2 - | ExtensionFunSemanticsVariant3 - | ExtensionFunSemanticsVariant4 - deriving stock (Eq, Ord, Enum, Bounded, Show) - - toBuiltinMeaning :: forall val. HasMeaningIn uni val - => BuiltinSemanticsVariant ExtensionFun - -> ExtensionFun - -> BuiltinMeaning val () - - toBuiltinMeaning _semvar Factorial = - makeBuiltinMeaning - (\(n :: Integer) -> product [1..n]) - whatever - - toBuiltinMeaning _semvar ForallFortyTwo = - makeBuiltinMeaning - forallFortyTwo - whatever - where - forallFortyTwo :: MetaForall ('TyNameRep @GHC.Type "a" 0) Integer - forallFortyTwo = MetaForall 42 - - toBuiltinMeaning _semvar SumInteger = - makeBuiltinMeaning - (sum :: [Integer] -> Integer) - whatever - - toBuiltinMeaning _semvar Const = - makeBuiltinMeaning - const - whatever - - toBuiltinMeaning _semvar Id = - makeBuiltinMeaning - Prelude.id - whatever - - toBuiltinMeaning _semvar IdAssumeBool = - makeBuiltinMeaning - (Prelude.id :: Opaque val Bool -> Opaque val Bool) - whatever - - toBuiltinMeaning _semvar IdAssumeCheckBool = - makeBuiltinMeaning - idAssumeCheckBoolPlc - whatever - where - idAssumeCheckBoolPlc :: Opaque val Bool -> BuiltinResult Bool - idAssumeCheckBoolPlc val = - case asConstant val of - Right (Some (ValueOf DefaultUniBool b)) -> pure b - _ -> builtinResultFailure - - toBuiltinMeaning _semvar IdSomeConstantBool = - makeBuiltinMeaning - idSomeConstantBoolPlc - whatever - where - idSomeConstantBoolPlc :: SomeConstant uni Bool -> BuiltinResult Bool - idSomeConstantBoolPlc = \case - SomeConstant (Some (ValueOf DefaultUniBool b)) -> pure b - _ -> builtinResultFailure - - toBuiltinMeaning _semvar IdIntegerAsBool = - makeBuiltinMeaning - idIntegerAsBool - whatever - where - idIntegerAsBool :: SomeConstant uni Integer -> BuiltinResult (SomeConstant uni Integer) - idIntegerAsBool = \case - con@(SomeConstant (Some (ValueOf DefaultUniBool _))) -> pure con - _ -> builtinResultFailure - - toBuiltinMeaning _semvar IdFInteger = - makeBuiltinMeaning - (Prelude.id :: fi ~ Opaque val (f `TyAppRep` Integer) => fi -> fi) - whatever - - toBuiltinMeaning _semvar IdList = - makeBuiltinMeaning - (Prelude.id :: la ~ Opaque val (PlcListRep a) => la -> la) - whatever - - toBuiltinMeaning _semvar IdRank2 = - makeBuiltinMeaning - (Prelude.id - :: afa ~ Opaque val (TyForallRep @GHC.Type a (TyVarRep f `TyAppRep` TyVarRep a)) - => afa -> afa) - whatever - - toBuiltinMeaning _semvar ScottToMetaUnit = - makeBuiltinMeaning - ((\_ -> ()) - :: va ~ TyVarRep a - => Opaque val (TyForallRep a (va -> va)) -> ()) - whatever - - toBuiltinMeaning _semvar FailingSucc = - makeBuiltinMeaning - @(Integer -> Integer) - (\_ -> throw BuiltinErrorCall) - whatever - - toBuiltinMeaning _semvar ExpensiveSucc = - makeBuiltinMeaning - @(Integer -> Integer) - (\_ -> throw BuiltinErrorCall) - (\_ _ -> ExBudgetLast $ unExRestrictingBudget enormousBudget) - - toBuiltinMeaning _semvar FailingPlus = - makeBuiltinMeaning - @(Integer -> Integer -> Integer) - (\_ _ -> throw BuiltinErrorCall) - whatever - - toBuiltinMeaning _semvar ExpensivePlus = - makeBuiltinMeaning - @(Integer -> Integer -> Integer) - (\_ _ -> throw BuiltinErrorCall) - (\_ _ _ -> ExBudgetLast $ unExRestrictingBudget enormousBudget) - - toBuiltinMeaning _semvar IsConstant = - makeBuiltinMeaning - isConstantPlc - whatever - where - -- The type signature is just for clarity, it's not required. - isConstantPlc :: Opaque val a -> Bool - isConstantPlc = isRight . asConstant - - toBuiltinMeaning _semvar UnsafeCoerce = - makeBuiltinMeaning - unsafeCoercePlc - whatever - where - -- The type signature is just for clarity, it's not required. - unsafeCoercePlc :: Opaque val a -> Opaque val b - unsafeCoercePlc = Opaque . unOpaque - - toBuiltinMeaning _semvar UnsafeCoerceEl = - makeBuiltinMeaning - unsafeCoerceElPlc - whatever - where - unsafeCoerceElPlc - :: SomeConstant DefaultUni [a] -> BuiltinResult (SomeConstant DefaultUni [b]) - unsafeCoerceElPlc (SomeConstant (Some (ValueOf uniList xs))) = do - DefaultUniList _ <- pure uniList - pure $ fromValueOf uniList xs - - toBuiltinMeaning _semvar Undefined = - makeBuiltinMeaning - undefined - whatever - - toBuiltinMeaning _semvar Absurd = - makeBuiltinMeaning - absurd - whatever - - toBuiltinMeaning _semvar ErrorPrime = - makeBuiltinMeaning - (builtinResultFailure :: forall a. BuiltinResult a) - whatever - - toBuiltinMeaning _semvar Comma = - makeBuiltinMeaning - commaPlc - whatever - where - commaPlc - :: SomeConstant uni a - -> SomeConstant uni b - -> SomeConstant uni (a, b) - commaPlc (SomeConstant (Some (ValueOf uniA x))) (SomeConstant (Some (ValueOf uniB y))) = - fromValueOf (DefaultUniPair uniA uniB) (x, y) - - toBuiltinMeaning _semvar BiconstPair = - makeBuiltinMeaning - biconstPairPlc - whatever - where - biconstPairPlc - :: SomeConstant uni a - -> SomeConstant uni b - -> SomeConstant uni (a, b) - -> BuiltinResult (SomeConstant uni (a, b)) - biconstPairPlc - (SomeConstant (Some (ValueOf uniA x))) - (SomeConstant (Some (ValueOf uniB y))) - (SomeConstant (Some (ValueOf uniPairAB _))) = do - DefaultUniPair uniA' uniB' <- pure uniPairAB - Just Refl <- pure $ uniA `geq` uniA' - Just Refl <- pure $ uniB `geq` uniB' - pure $ fromValueOf uniPairAB (x, y) - - toBuiltinMeaning _semvar Swap = - makeBuiltinMeaning - swapPlc - whatever - where - swapPlc - :: SomeConstant uni (a, b) - -> BuiltinResult (SomeConstant uni (b, a)) - swapPlc (SomeConstant (Some (ValueOf uniPairAB p))) = do - DefaultUniPair uniA uniB <- pure uniPairAB - pure $ fromValueOf (DefaultUniPair uniB uniA) (snd p, fst p) - - toBuiltinMeaning _semvar SwapEls = - makeBuiltinMeaning - swapElsPlc - whatever - where - -- The type reads as @[(a, Bool)] -> [(Bool, a)]@. - swapElsPlc - :: SomeConstant uni [SomeConstant uni (a, Bool)] - -> BuiltinResult (SomeConstant uni [SomeConstant uni (Bool, a)]) - swapElsPlc (SomeConstant (Some (ValueOf uniList xs))) = do - DefaultUniList (DefaultUniPair uniA DefaultUniBool) <- pure uniList - let uniList' = DefaultUniList $ DefaultUniPair DefaultUniBool uniA - pure . fromValueOf uniList' $ map swap xs - - -- A dummy builtin to reflect the builtin-version of the 'ExtensionFun'. - -- See Note [Builtin semantics variants] - toBuiltinMeaning semvar ExtensionVersion = - makeBuiltinMeaning - @(() -> Integer) - (\_ -> case semvar of - ExtensionFunSemanticsVariant0 -> 0 - ExtensionFunSemanticsVariant1 -> 1 - ExtensionFunSemanticsVariant2 -> 2 - ExtensionFunSemanticsVariant3 -> 3 - ExtensionFunSemanticsVariant4 -> 4) - whatever - - -- We want to know if the CEK machine releases individual budgets after accounting for them and - -- one way to ensure that is to check that individual budgets are GCed in chunks rather than all - -- at once when evaluation of the builtin finishes. This builtin returns a list of the maximum - -- numbers of individual budgets retained between GC calls. If the returned list is long (for - -- some definition of "long", see the tests), then chances are individual budgets are not - -- retained unnecessarily, and if it's too short (again, see the tests), then they are. - -- - -- We track how many budgets get GCed by attaching a finalizer (see "System.Mem.Weak") to each - -- of them. - toBuiltinMeaning _ TrackCosts = unsafePerformIO $ do - -- A variable for storing the number of elements from the stream of budgets pending GC. - pendingGcVar <- newMVar 0 - -- A variable for storing all the final numbers from @pendingGcVar@ appearing there right - -- before another GC is triggered. We store the results in reverse order for fast consing - -- and then 'reverse' them in the denotation of the builtin. - numsOfGcedVar <- newMVar [] - let -- A function to run when GC picks up an individual budget. - finalize = - tryTakeMVar pendingGcVar >>= \case - -- If @pendingGcVar@ happens to be empty, we say that no budgets were released - -- and don't update @pendingGcVar@. I.e. this entire testing machinery can - -- affect how budgets are retained, but the impact of the 'MVar' business is - -- negligible, since @pendingGcVar@ is filled immediately after it's emptied. - Nothing -> pure () - -- If @pendingGcVar@ is not empty, then we cons its content to the resulting - -- list and put @0@ as the new content of the variable. - Just pendingGc -> do - _ <- modifyMVar_ numsOfGcedVar $ pure . (pendingGc :) - putMVar pendingGcVar 0 - - -- Register an element of the stream of budgets by incrementing the counter storing the - -- number of elements pending GC and attaching the @finalize@ finalizer to the element. - regBudget budget = do - pendingGc <- takeMVar pendingGcVar - let pendingGc' = succ pendingGc - putMVar pendingGcVar pendingGc' - addFinalizer budget finalize - -- We need to trigger GC occasionally (otherwise it can easily take more than 100k - -- elements before GC is triggered and the number can go much higher depending on - -- the RTS options), so we picked 100 elements as a cutoff number. Doing GC less - -- often makes tests slower, doing GC more often requires us to generate longer - -- streams in tests in order to observe meaningful results making tests slower. - when (pendingGc' >= 100) performMinorGC - - -- Call @regBudget@ over each element of the stream of budgets. - regBudgets (ExBudgetLast budget) = do - regBudget budget - -- Run @finalize@ one final time before returning the last budget. - finalize - -- Make all outstanding finalizers inert, so that we don't mix up budgets GCed - -- during spending with budgets GCed right after spending finishes. - _ <- takeMVar pendingGcVar - pure $ ExBudgetLast budget - regBudgets (ExBudgetCons budget budgets) = do - regBudget budget - -- Without 'unsafeInterleaveIO' this function would traverse the entire stream - -- before returning anything, which isn't what costing functions normally do and so - -- we don't want to have such behavior in a test. - budgets' <- unsafeInterleaveIO $ regBudgets budgets - pure $ ExBudgetCons budget budgets' - - -- Just a random model that keeps the costs coming from the 'ExMemoryUsage' instance. - linear1 = ModelOneArgumentLinearInX $ OneVariableLinearFunction 1 1 - model = CostingFun linear1 linear1 - pure $ makeBuiltinMeaning - @(Data -> [Integer]) - (\_ -> unsafePerformIO $ reverse <$> readMVar numsOfGcedVar) - (\_ -> unsafePerformIO . regBudgets . runCostingFunOneArgument model) - - toBuiltinMeaning semvar IntNoIntegerNoWord = - case semvar of - ExtensionFunSemanticsVariant0 -> makeBuiltinMeaning @(Int -> ()) mempty whatever - ExtensionFunSemanticsVariant1 -> makeBuiltinMeaning @(Integer -> ()) mempty whatever - ExtensionFunSemanticsVariant2 -> makeBuiltinMeaning @(Integer -> ()) mempty whatever - ExtensionFunSemanticsVariant3 -> makeBuiltinMeaning @(Word -> ()) mempty whatever - ExtensionFunSemanticsVariant4 -> makeBuiltinMeaning @(Word -> ()) mempty whatever + type CostingPart uni ExtensionFun = () + + data BuiltinSemanticsVariant ExtensionFun + = ExtensionFunSemanticsVariant0 + | ExtensionFunSemanticsVariant1 + | ExtensionFunSemanticsVariant2 + | ExtensionFunSemanticsVariant3 + | ExtensionFunSemanticsVariant4 + deriving stock (Eq, Ord, Enum, Bounded, Show) + + toBuiltinMeaning :: + forall val. + HasMeaningIn uni val => + BuiltinSemanticsVariant ExtensionFun -> + ExtensionFun -> + BuiltinMeaning val () + toBuiltinMeaning _semvar Factorial = + makeBuiltinMeaning + (\(n :: Integer) -> product [1 .. n]) + whatever + toBuiltinMeaning _semvar ForallFortyTwo = + makeBuiltinMeaning + forallFortyTwo + whatever + where + forallFortyTwo :: MetaForall ('TyNameRep @GHC.Type "a" 0) Integer + forallFortyTwo = MetaForall 42 + toBuiltinMeaning _semvar SumInteger = + makeBuiltinMeaning + (sum :: [Integer] -> Integer) + whatever + toBuiltinMeaning _semvar Const = + makeBuiltinMeaning + const + whatever + toBuiltinMeaning _semvar Id = + makeBuiltinMeaning + Prelude.id + whatever + toBuiltinMeaning _semvar IdAssumeBool = + makeBuiltinMeaning + (Prelude.id :: Opaque val Bool -> Opaque val Bool) + whatever + toBuiltinMeaning _semvar IdAssumeCheckBool = + makeBuiltinMeaning + idAssumeCheckBoolPlc + whatever + where + idAssumeCheckBoolPlc :: Opaque val Bool -> BuiltinResult Bool + idAssumeCheckBoolPlc val = + case asConstant val of + Right (Some (ValueOf DefaultUniBool b)) -> pure b + _ -> builtinResultFailure + toBuiltinMeaning _semvar IdSomeConstantBool = + makeBuiltinMeaning + idSomeConstantBoolPlc + whatever + where + idSomeConstantBoolPlc :: SomeConstant uni Bool -> BuiltinResult Bool + idSomeConstantBoolPlc = \case + SomeConstant (Some (ValueOf DefaultUniBool b)) -> pure b + _ -> builtinResultFailure + toBuiltinMeaning _semvar IdIntegerAsBool = + makeBuiltinMeaning + idIntegerAsBool + whatever + where + idIntegerAsBool :: SomeConstant uni Integer -> BuiltinResult (SomeConstant uni Integer) + idIntegerAsBool = \case + con@(SomeConstant (Some (ValueOf DefaultUniBool _))) -> pure con + _ -> builtinResultFailure + toBuiltinMeaning _semvar IdFInteger = + makeBuiltinMeaning + (Prelude.id :: fi ~ Opaque val (f `TyAppRep` Integer) => fi -> fi) + whatever + toBuiltinMeaning _semvar IdList = + makeBuiltinMeaning + (Prelude.id :: la ~ Opaque val (PlcListRep a) => la -> la) + whatever + toBuiltinMeaning _semvar IdRank2 = + makeBuiltinMeaning + ( Prelude.id :: + afa ~ Opaque val (TyForallRep @GHC.Type a (TyVarRep f `TyAppRep` TyVarRep a)) => + afa -> afa + ) + whatever + toBuiltinMeaning _semvar ScottToMetaUnit = + makeBuiltinMeaning + ( (\_ -> ()) :: + va ~ TyVarRep a => + Opaque val (TyForallRep a (va -> va)) -> () + ) + whatever + toBuiltinMeaning _semvar FailingSucc = + makeBuiltinMeaning + @(Integer -> Integer) + (\_ -> throw BuiltinErrorCall) + whatever + toBuiltinMeaning _semvar ExpensiveSucc = + makeBuiltinMeaning + @(Integer -> Integer) + (\_ -> throw BuiltinErrorCall) + (\_ _ -> ExBudgetLast $ unExRestrictingBudget enormousBudget) + toBuiltinMeaning _semvar FailingPlus = + makeBuiltinMeaning + @(Integer -> Integer -> Integer) + (\_ _ -> throw BuiltinErrorCall) + whatever + toBuiltinMeaning _semvar ExpensivePlus = + makeBuiltinMeaning + @(Integer -> Integer -> Integer) + (\_ _ -> throw BuiltinErrorCall) + (\_ _ _ -> ExBudgetLast $ unExRestrictingBudget enormousBudget) + toBuiltinMeaning _semvar IsConstant = + makeBuiltinMeaning + isConstantPlc + whatever + where + -- The type signature is just for clarity, it's not required. + isConstantPlc :: Opaque val a -> Bool + isConstantPlc = isRight . asConstant + toBuiltinMeaning _semvar UnsafeCoerce = + makeBuiltinMeaning + unsafeCoercePlc + whatever + where + -- The type signature is just for clarity, it's not required. + unsafeCoercePlc :: Opaque val a -> Opaque val b + unsafeCoercePlc = Opaque . unOpaque + toBuiltinMeaning _semvar UnsafeCoerceEl = + makeBuiltinMeaning + unsafeCoerceElPlc + whatever + where + unsafeCoerceElPlc :: + SomeConstant DefaultUni [a] -> BuiltinResult (SomeConstant DefaultUni [b]) + unsafeCoerceElPlc (SomeConstant (Some (ValueOf uniList xs))) = do + DefaultUniList _ <- pure uniList + pure $ fromValueOf uniList xs + toBuiltinMeaning _semvar Undefined = + makeBuiltinMeaning + undefined + whatever + toBuiltinMeaning _semvar Absurd = + makeBuiltinMeaning + absurd + whatever + toBuiltinMeaning _semvar ErrorPrime = + makeBuiltinMeaning + (builtinResultFailure :: forall a. BuiltinResult a) + whatever + toBuiltinMeaning _semvar Comma = + makeBuiltinMeaning + commaPlc + whatever + where + commaPlc :: + SomeConstant uni a -> + SomeConstant uni b -> + SomeConstant uni (a, b) + commaPlc (SomeConstant (Some (ValueOf uniA x))) (SomeConstant (Some (ValueOf uniB y))) = + fromValueOf (DefaultUniPair uniA uniB) (x, y) + toBuiltinMeaning _semvar BiconstPair = + makeBuiltinMeaning + biconstPairPlc + whatever + where + biconstPairPlc :: + SomeConstant uni a -> + SomeConstant uni b -> + SomeConstant uni (a, b) -> + BuiltinResult (SomeConstant uni (a, b)) + biconstPairPlc + (SomeConstant (Some (ValueOf uniA x))) + (SomeConstant (Some (ValueOf uniB y))) + (SomeConstant (Some (ValueOf uniPairAB _))) = do + DefaultUniPair uniA' uniB' <- pure uniPairAB + Just Refl <- pure $ uniA `geq` uniA' + Just Refl <- pure $ uniB `geq` uniB' + pure $ fromValueOf uniPairAB (x, y) + toBuiltinMeaning _semvar Swap = + makeBuiltinMeaning + swapPlc + whatever + where + swapPlc :: + SomeConstant uni (a, b) -> + BuiltinResult (SomeConstant uni (b, a)) + swapPlc (SomeConstant (Some (ValueOf uniPairAB p))) = do + DefaultUniPair uniA uniB <- pure uniPairAB + pure $ fromValueOf (DefaultUniPair uniB uniA) (snd p, fst p) + toBuiltinMeaning _semvar SwapEls = + makeBuiltinMeaning + swapElsPlc + whatever + where + -- The type reads as @[(a, Bool)] -> [(Bool, a)]@. + swapElsPlc :: + SomeConstant uni [SomeConstant uni (a, Bool)] -> + BuiltinResult (SomeConstant uni [SomeConstant uni (Bool, a)]) + swapElsPlc (SomeConstant (Some (ValueOf uniList xs))) = do + DefaultUniList (DefaultUniPair uniA DefaultUniBool) <- pure uniList + let uniList' = DefaultUniList $ DefaultUniPair DefaultUniBool uniA + pure . fromValueOf uniList' $ map swap xs + + -- A dummy builtin to reflect the builtin-version of the 'ExtensionFun'. + -- See Note [Builtin semantics variants] + toBuiltinMeaning semvar ExtensionVersion = + makeBuiltinMeaning + @(() -> Integer) + ( \_ -> case semvar of + ExtensionFunSemanticsVariant0 -> 0 + ExtensionFunSemanticsVariant1 -> 1 + ExtensionFunSemanticsVariant2 -> 2 + ExtensionFunSemanticsVariant3 -> 3 + ExtensionFunSemanticsVariant4 -> 4 + ) + whatever + -- We want to know if the CEK machine releases individual budgets after accounting for them and + -- one way to ensure that is to check that individual budgets are GCed in chunks rather than all + -- at once when evaluation of the builtin finishes. This builtin returns a list of the maximum + -- numbers of individual budgets retained between GC calls. If the returned list is long (for + -- some definition of "long", see the tests), then chances are individual budgets are not + -- retained unnecessarily, and if it's too short (again, see the tests), then they are. + -- + -- We track how many budgets get GCed by attaching a finalizer (see "System.Mem.Weak") to each + -- of them. + toBuiltinMeaning _ TrackCosts = unsafePerformIO $ do + -- A variable for storing the number of elements from the stream of budgets pending GC. + pendingGcVar <- newMVar 0 + -- A variable for storing all the final numbers from @pendingGcVar@ appearing there right + -- before another GC is triggered. We store the results in reverse order for fast consing + -- and then 'reverse' them in the denotation of the builtin. + numsOfGcedVar <- newMVar [] + let + -- A function to run when GC picks up an individual budget. + finalize = + tryTakeMVar pendingGcVar >>= \case + -- If @pendingGcVar@ happens to be empty, we say that no budgets were released + -- and don't update @pendingGcVar@. I.e. this entire testing machinery can + -- affect how budgets are retained, but the impact of the 'MVar' business is + -- negligible, since @pendingGcVar@ is filled immediately after it's emptied. + Nothing -> pure () + -- If @pendingGcVar@ is not empty, then we cons its content to the resulting + -- list and put @0@ as the new content of the variable. + Just pendingGc -> do + _ <- modifyMVar_ numsOfGcedVar $ pure . (pendingGc :) + putMVar pendingGcVar 0 + + -- Register an element of the stream of budgets by incrementing the counter storing the + -- number of elements pending GC and attaching the @finalize@ finalizer to the element. + regBudget budget = do + pendingGc <- takeMVar pendingGcVar + let pendingGc' = succ pendingGc + putMVar pendingGcVar pendingGc' + addFinalizer budget finalize + -- We need to trigger GC occasionally (otherwise it can easily take more than 100k + -- elements before GC is triggered and the number can go much higher depending on + -- the RTS options), so we picked 100 elements as a cutoff number. Doing GC less + -- often makes tests slower, doing GC more often requires us to generate longer + -- streams in tests in order to observe meaningful results making tests slower. + when (pendingGc' >= 100) performMinorGC + + -- Call @regBudget@ over each element of the stream of budgets. + regBudgets (ExBudgetLast budget) = do + regBudget budget + -- Run @finalize@ one final time before returning the last budget. + finalize + -- Make all outstanding finalizers inert, so that we don't mix up budgets GCed + -- during spending with budgets GCed right after spending finishes. + _ <- takeMVar pendingGcVar + pure $ ExBudgetLast budget + regBudgets (ExBudgetCons budget budgets) = do + regBudget budget + -- Without 'unsafeInterleaveIO' this function would traverse the entire stream + -- before returning anything, which isn't what costing functions normally do and so + -- we don't want to have such behavior in a test. + budgets' <- unsafeInterleaveIO $ regBudgets budgets + pure $ ExBudgetCons budget budgets' + + -- Just a random model that keeps the costs coming from the 'ExMemoryUsage' instance. + linear1 = ModelOneArgumentLinearInX $ OneVariableLinearFunction 1 1 + model = CostingFun linear1 linear1 + pure $ + makeBuiltinMeaning + @(Data -> [Integer]) + (\_ -> unsafePerformIO $ reverse <$> readMVar numsOfGcedVar) + (\_ -> unsafePerformIO . regBudgets . runCostingFunOneArgument model) + toBuiltinMeaning semvar IntNoIntegerNoWord = + case semvar of + ExtensionFunSemanticsVariant0 -> makeBuiltinMeaning @(Int -> ()) mempty whatever + ExtensionFunSemanticsVariant1 -> makeBuiltinMeaning @(Integer -> ()) mempty whatever + ExtensionFunSemanticsVariant2 -> makeBuiltinMeaning @(Integer -> ()) mempty whatever + ExtensionFunSemanticsVariant3 -> makeBuiltinMeaning @(Word -> ()) mempty whatever + ExtensionFunSemanticsVariant4 -> makeBuiltinMeaning @(Word -> ()) mempty whatever instance Default (BuiltinSemanticsVariant ExtensionFun) where - def = maxBound + def = maxBound diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Data.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Data.hs index 904f8d04204..210bfe4bc49 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Data.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Data.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -module PlutusCore.Examples.Data.Data - ( ofoldrData - , exampleData - ) where +module PlutusCore.Examples.Data.Data ( + ofoldrData, + exampleData, +) where import PlutusCore.Core import PlutusCore.Data as Data @@ -54,70 +54,78 @@ import Data.ByteString (ByteString) -- > fB ofoldrData :: MatchOption -> Term TyName Name DefaultUni (Either DefaultFun ExtensionFun) () ofoldrData optMatch = runQuote $ do - let r = dataTy - fConstr <- freshName "fConstr" - fMap <- freshName "fMap" - fList <- freshName "fList" - fI <- freshName "fI" - fB <- freshName "fB" - rec <- freshName "rec" - d <- freshName "d" - i <- freshName "i" - ds <- freshName "ds" - es <- freshName "es" - let listData = mkTyBuiltin @_ @[Data] () - listR = TyApp () list r - opair a = mkIterTyAppNoAnn pair [a, a] - unwrap' ann = apply ann $ mapFun Left matchData - return - . lamAbs () fConstr (TyFun () integer $ TyFun () listR r) - . lamAbs () fMap (TyFun () (TyApp () list $ opair r) r) - . lamAbs () fList (TyFun () listR r) - . lamAbs () fI (TyFun () integer r) - . lamAbs () fB (TyFun () (mkTyBuiltin @_ @ByteString ()) r) - . apply () (mkIterInstNoAnn fix [dataTy, r]) - . lamAbs () rec (TyFun () dataTy r) - . lamAbs () d dataTy - $ mkIterAppNoAnn (tyInst () (unwrap' () (var () d)) r) - [ lamAbs () i integer - . lamAbs () ds listData - $ mkIterAppNoAnn (var () fConstr) - [ var () i - , mkIterAppNoAnn (tyInst () (omapList optMatch) dataTy) - [var () rec, var () ds] - ] - , lamAbs () es (TyApp () list $ opair dataTy) - . apply () (var () fMap) - $ mkIterAppNoAnn (tyInst () (omapList optMatch) $ opair dataTy) - [ apply () (tyInst () obothPair dataTy) $ var () rec - , var () es - ] - , lamAbs () ds listData - . apply () (var () fList) - $ mkIterAppNoAnn (tyInst () (omapList optMatch) dataTy) - [ var () rec - , var () ds - ] - , var () fI - , var () fB + let r = dataTy + fConstr <- freshName "fConstr" + fMap <- freshName "fMap" + fList <- freshName "fList" + fI <- freshName "fI" + fB <- freshName "fB" + rec <- freshName "rec" + d <- freshName "d" + i <- freshName "i" + ds <- freshName "ds" + es <- freshName "es" + let listData = mkTyBuiltin @_ @[Data] () + listR = TyApp () list r + opair a = mkIterTyAppNoAnn pair [a, a] + unwrap' ann = apply ann $ mapFun Left matchData + return + . lamAbs () fConstr (TyFun () integer $ TyFun () listR r) + . lamAbs () fMap (TyFun () (TyApp () list $ opair r) r) + . lamAbs () fList (TyFun () listR r) + . lamAbs () fI (TyFun () integer r) + . lamAbs () fB (TyFun () (mkTyBuiltin @_ @ByteString ()) r) + . apply () (mkIterInstNoAnn fix [dataTy, r]) + . lamAbs () rec (TyFun () dataTy r) + . lamAbs () d dataTy + $ mkIterAppNoAnn + (tyInst () (unwrap' () (var () d)) r) + [ lamAbs () i integer + . lamAbs () ds listData + $ mkIterAppNoAnn + (var () fConstr) + [ var () i + , mkIterAppNoAnn + (tyInst () (omapList optMatch) dataTy) + [var () rec, var () ds] ] + , lamAbs () es (TyApp () list $ opair dataTy) + . apply () (var () fMap) + $ mkIterAppNoAnn + (tyInst () (omapList optMatch) $ opair dataTy) + [ apply () (tyInst () obothPair dataTy) $ var () rec + , var () es + ] + , lamAbs () ds listData + . apply () (var () fList) + $ mkIterAppNoAnn + (tyInst () (omapList optMatch) dataTy) + [ var () rec + , var () ds + ] + , var () fI + , var () fB + ] -- | Just a random 'Data' object. exampleData :: Term tyname Name DefaultUni (Either DefaultFun ExtensionFun) () exampleData = runQuote $ do - x <- freshName "x" - pure - . mkIterLamAbs (replicate 4 $ VarDecl () x unit) - . mkConstant () - $ Data.Constr 1 - [ Map - [ ( B "abcdef" - , Data.Constr 2 - [ B "" - , I 0 - ] - ) + x <- freshName "x" + pure + . mkIterLamAbs (replicate 4 $ VarDecl () x unit) + . mkConstant () + $ Data.Constr + 1 + [ Map + [ + ( B "abcdef" + , Data.Constr + 2 + [ B "" + , I 0 ] - , List [List [List [List [I 123456]], B "ffffffffffffffffffffffffffffffffffffffffff"]] - , I 42 - ] + ) + ] + , List [List [List [List [I 123456]], B "ffffffffffffffffffffffffffffffffffffffffff"]] + , I 42 + ] diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Function.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Function.hs index 3569ac8c53e..6a9e300a740 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Function.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Function.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.Examples.Data.Function - ( unsafeCoerce - ) where +module PlutusCore.Examples.Data.Function ( + unsafeCoerce, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -13,11 +13,11 @@ import PlutusCore.StdLib.Data.Function unsafeCoerce :: Term TyName Name uni fun () unsafeCoerce = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - return - . TyAbs () a (Type ()) - . TyAbs () b (Type ()) - . Apply () (mkIterInstNoAnn fix [TyVar () a, TyVar () b]) - . TyInst () idFun - $ TyFun () (TyVar () a) (TyVar () b) + a <- freshTyName "a" + b <- freshTyName "b" + return + . TyAbs () a (Type ()) + . TyAbs () b (Type ()) + . Apply () (mkIterInstNoAnn fix [TyVar () a, TyVar () b]) + . TyInst () idFun + $ TyFun () (TyVar () a) (TyVar () b) diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/InterList.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/InterList.hs index 4f03930e137..b012722ee45 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/InterList.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/InterList.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.Examples.Data.InterList - ( interListData - , interNil - , interCons - , foldrInterList - ) where +module PlutusCore.Examples.Data.InterList ( + interListData, + interNil, + interCons, + foldrInterList, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -35,135 +35,142 @@ We encode the following in this module: -- This definition is used as an example in Note [Spiney API] in "PlutusCore.StdLib.Type", -- so if you change it here, then also change it there. + -- | @InterList@ as a PLC type. -- -- > fix \(interlist :: * -> * -> *) (a :: *) (b :: *) -> -- > all (r :: *). r -> (a -> b -> interlist b a -> r) -> r interListData :: RecursiveType uni fun () interListData = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - interlist <- freshTyName "interlist" - r <- freshTyName "r" - let interlistBA = mkIterTyAppNoAnn (TyVar () interlist) [TyVar () b, TyVar () a] - makeRecursiveType () interlist [TyVarDecl () a $ Type (), TyVarDecl () b $ Type ()] - . TyForall () r (Type ()) - . TyFun () (TyVar () r) - . TyFun () (mkIterTyFun () [TyVar () a, TyVar () b, interlistBA] $ TyVar () r) - $ TyVar () r + a <- freshTyName "a" + b <- freshTyName "b" + interlist <- freshTyName "interlist" + r <- freshTyName "r" + let interlistBA = mkIterTyAppNoAnn (TyVar () interlist) [TyVar () b, TyVar () a] + makeRecursiveType () interlist [TyVarDecl () a $ Type (), TyVarDecl () b $ Type ()] + . TyForall () r (Type ()) + . TyFun () (TyVar () r) + . TyFun () (mkIterTyFun () [TyVar () a, TyVar () b, interlistBA] $ TyVar () r) + $ TyVar () r interNil :: Term TyName Name uni fun () interNil = runQuote $ do - let RecursiveType interlist wrapInterList = interListData - a <- freshTyName "a" - b <- freshTyName "b" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - let interlistBA = mkIterTyAppNoAnn interlist [TyVar () b, TyVar () a] - return - . TyAbs () a (Type ()) - . TyAbs () b (Type ()) - . wrapInterList [TyVar () a, TyVar () b] - . TyAbs () r (Type ()) - . LamAbs () z (TyVar () r) - . LamAbs () f (mkIterTyFun () [TyVar () a, TyVar () b, interlistBA] $ TyVar () r) - $ Var () z + let RecursiveType interlist wrapInterList = interListData + a <- freshTyName "a" + b <- freshTyName "b" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + let interlistBA = mkIterTyAppNoAnn interlist [TyVar () b, TyVar () a] + return + . TyAbs () a (Type ()) + . TyAbs () b (Type ()) + . wrapInterList [TyVar () a, TyVar () b] + . TyAbs () r (Type ()) + . LamAbs () z (TyVar () r) + . LamAbs () f (mkIterTyFun () [TyVar () a, TyVar () b, interlistBA] $ TyVar () r) + $ Var () z interCons :: Term TyName Name uni fun () interCons = runQuote $ do - let RecursiveType interlist wrapInterList = interListData - a <- freshTyName "a" - b <- freshTyName "b" - x <- freshName "x" - y <- freshName "y" - xs <- freshName "xs" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - let interlistBA = mkIterTyAppNoAnn interlist [TyVar () b, TyVar () a] - return - . TyAbs () a (Type ()) - . TyAbs () b (Type ()) - . LamAbs () x (TyVar () a) - . LamAbs () y (TyVar () b) - . LamAbs () xs interlistBA - . wrapInterList [TyVar () a, TyVar () b] - . TyAbs () r (Type ()) - . LamAbs () z (TyVar () r) - . LamAbs () f (mkIterTyFun () [TyVar () a, TyVar () b, interlistBA] $ TyVar () r) - $ mkIterAppNoAnn (Var () f) - [ Var () x - , Var () y - , Var () xs - ] + let RecursiveType interlist wrapInterList = interListData + a <- freshTyName "a" + b <- freshTyName "b" + x <- freshName "x" + y <- freshName "y" + xs <- freshName "xs" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + let interlistBA = mkIterTyAppNoAnn interlist [TyVar () b, TyVar () a] + return + . TyAbs () a (Type ()) + . TyAbs () b (Type ()) + . LamAbs () x (TyVar () a) + . LamAbs () y (TyVar () b) + . LamAbs () xs interlistBA + . wrapInterList [TyVar () a, TyVar () b] + . TyAbs () r (Type ()) + . LamAbs () z (TyVar () r) + . LamAbs () f (mkIterTyFun () [TyVar () a, TyVar () b, interlistBA] $ TyVar () r) + $ mkIterAppNoAnn + (Var () f) + [ Var () x + , Var () y + , Var () xs + ] foldrInterList :: uni `HasTypeAndTermLevel` () => Term TyName Name uni fun () foldrInterList = runQuote $ do - let interlist = _recursiveType interListData - a0 <- freshTyName "a0" - b0 <- freshTyName "b0" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - rec <- freshName "rec" - u <- freshName "u" - a <- freshTyName "a" - b <- freshTyName "b" - f' <- freshName "f'" - xs <- freshName "xs" - x <- freshName "x" - y <- freshName "y" - xs' <- freshName "xs'" - x' <- freshName "x'" - y' <- freshName "y'" - let interlistOf a' b' = mkIterTyAppNoAnn interlist [TyVar () a', TyVar () b'] - fTy a' b' = mkIterTyFun () [TyVar () a', TyVar () b', TyVar () r] $ TyVar () r - fixTyArg2 - = TyForall () a (Type ()) - . TyForall () b (Type ()) - . TyFun () (fTy a b) - . TyFun () (interlistOf a b) - $ TyVar () r - instedFix = mkIterInstNoAnn fix [unit, fixTyArg2] - unwrappedXs = TyInst () (Unwrap () (Var () xs)) $ TyVar () r - instedRec = mkIterInstNoAnn (Apply () (Var () rec) unitval) [TyVar () b, TyVar () a] - return - . TyAbs () a0 (Type ()) - . TyAbs () b0 (Type ()) - . TyAbs () r (Type ()) - . LamAbs () f (fTy a0 b0) - . LamAbs () z (TyVar () r) - $ mkIterInstNoAnn - ( mkIterAppNoAnn instedFix - [ LamAbs () rec (TyFun () unit fixTyArg2) - . LamAbs () u unit - . TyAbs () a (Type ()) - . TyAbs () b (Type ()) - . LamAbs () f' (fTy a b) - . LamAbs () xs (interlistOf a b) - $ mkIterAppNoAnn unwrappedXs - [ Var () z - , LamAbs () x (TyVar () a) - . LamAbs () y (TyVar () b) - . LamAbs () xs' (interlistOf b a) - $ mkIterAppNoAnn (Var () f') - [ Var () x - , Var () y - , mkIterAppNoAnn instedRec - [ LamAbs () y' (TyVar () b) - . LamAbs () x' (TyVar () a) - $ mkIterAppNoAnn (Var () f') - [ Var () x' - , Var () y' - ] - , Var () xs' - ] - ] + let interlist = _recursiveType interListData + a0 <- freshTyName "a0" + b0 <- freshTyName "b0" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + rec <- freshName "rec" + u <- freshName "u" + a <- freshTyName "a" + b <- freshTyName "b" + f' <- freshName "f'" + xs <- freshName "xs" + x <- freshName "x" + y <- freshName "y" + xs' <- freshName "xs'" + x' <- freshName "x'" + y' <- freshName "y'" + let interlistOf a' b' = mkIterTyAppNoAnn interlist [TyVar () a', TyVar () b'] + fTy a' b' = mkIterTyFun () [TyVar () a', TyVar () b', TyVar () r] $ TyVar () r + fixTyArg2 = + TyForall () a (Type ()) + . TyForall () b (Type ()) + . TyFun () (fTy a b) + . TyFun () (interlistOf a b) + $ TyVar () r + instedFix = mkIterInstNoAnn fix [unit, fixTyArg2] + unwrappedXs = TyInst () (Unwrap () (Var () xs)) $ TyVar () r + instedRec = mkIterInstNoAnn (Apply () (Var () rec) unitval) [TyVar () b, TyVar () a] + return + . TyAbs () a0 (Type ()) + . TyAbs () b0 (Type ()) + . TyAbs () r (Type ()) + . LamAbs () f (fTy a0 b0) + . LamAbs () z (TyVar () r) + $ mkIterInstNoAnn + ( mkIterAppNoAnn + instedFix + [ LamAbs () rec (TyFun () unit fixTyArg2) + . LamAbs () u unit + . TyAbs () a (Type ()) + . TyAbs () b (Type ()) + . LamAbs () f' (fTy a b) + . LamAbs () xs (interlistOf a b) + $ mkIterAppNoAnn + unwrappedXs + [ Var () z + , LamAbs () x (TyVar () a) + . LamAbs () y (TyVar () b) + . LamAbs () xs' (interlistOf b a) + $ mkIterAppNoAnn + (Var () f') + [ Var () x + , Var () y + , mkIterAppNoAnn + instedRec + [ LamAbs () y' (TyVar () b) + . LamAbs () x' (TyVar () a) + $ mkIterAppNoAnn + (Var () f') + [ Var () x' + , Var () y' + ] + , Var () xs' + ] ] - , unitval ] - ) - [ TyVar () a0 - , TyVar () b0 - ] + , unitval + ] + ) + [ TyVar () a0 + , TyVar () b0 + ] diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/List.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/List.hs index 1fea24f78ac..2eb0d6bef12 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/List.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/List.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.Examples.Data.List - ( omapList - ) where +module PlutusCore.Examples.Data.List ( + omapList, +) where import PlutusCore.Core import PlutusCore.Default @@ -22,24 +22,25 @@ import PlutusCore.Examples.Builtins -- matchList {a} xs {list a} xs \(x : a) (xs' : list a) -> cons {a} (f x) (rec xs') omapList :: MatchOption -> Term TyName Name DefaultUni (Either DefaultFun ExtensionFun) () omapList optMatch = runQuote $ do - a <- freshTyName "a" - f <- freshName "f" - rec <- freshName "rec" - xs <- freshName "xs" - x <- freshName "x" - xs' <- freshName "xs'" - let listA = TyApp () list $ TyVar () a - unwrap' ann = apply ann . tyInst () (mapFun Left (matchList optMatch)) $ TyVar () a - return - . tyAbs () a (Type ()) - . lamAbs () f (TyFun () (TyVar () a) $ TyVar () a) - . apply () (mkIterInstNoAnn fix [listA, listA]) - . lamAbs () rec (TyFun () listA listA) - . lamAbs () xs listA - . apply () (apply () (tyInst () (unwrap' () (var () xs)) listA) $ var () xs) - . lamAbs () x (TyVar () a) - . lamAbs () xs' listA - $ mkIterAppNoAnn (tyInst () (builtin () $ Left MkCons) $ TyVar () a) - [ apply () (var () f) $ var () x - , apply () (var () rec) $ var () xs' - ] + a <- freshTyName "a" + f <- freshName "f" + rec <- freshName "rec" + xs <- freshName "xs" + x <- freshName "x" + xs' <- freshName "xs'" + let listA = TyApp () list $ TyVar () a + unwrap' ann = apply ann . tyInst () (mapFun Left (matchList optMatch)) $ TyVar () a + return + . tyAbs () a (Type ()) + . lamAbs () f (TyFun () (TyVar () a) $ TyVar () a) + . apply () (mkIterInstNoAnn fix [listA, listA]) + . lamAbs () rec (TyFun () listA listA) + . lamAbs () xs listA + . apply () (apply () (tyInst () (unwrap' () (var () xs)) listA) $ var () xs) + . lamAbs () x (TyVar () a) + . lamAbs () xs' listA + $ mkIterAppNoAnn + (tyInst () (builtin () $ Left MkCons) $ TyVar () a) + [ apply () (var () f) $ var () x + , apply () (var () rec) $ var () xs' + ] diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Pair.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Pair.hs index 8bd1def64d3..eb9adc27b31 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Pair.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Pair.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.Examples.Data.Pair - ( obothPair - ) where +module PlutusCore.Examples.Data.Pair ( + obothPair, +) where import PlutusCore.Core import PlutusCore.Default @@ -20,15 +20,16 @@ import PlutusCore.Examples.Builtins -- > comma {a} {a} (f (fst {a} {a} p)) (f (snd {a} {a} p)) obothPair :: TermLike term TyName Name DefaultUni (Either DefaultFun ExtensionFun) => term () obothPair = runQuote $ do - a <- freshTyName "a" - f <- freshName "f" - p <- freshName "p" - let atAA fun = mkIterInstNoAnn (builtin () fun) [TyVar () a, TyVar () a] - return - . tyAbs () a (Type ()) - . lamAbs () f (TyFun () (TyVar () a) $ TyVar () a) - . lamAbs () p (mkIterTyAppNoAnn pair [TyVar () a, TyVar () a]) - $ mkIterAppNoAnn (atAA $ Right Comma) - [ apply () (var () f) . apply () (atAA $ Left FstPair) $ var () p - , apply () (var () f) . apply () (atAA $ Left SndPair) $ var () p - ] + a <- freshTyName "a" + f <- freshName "f" + p <- freshName "p" + let atAA fun = mkIterInstNoAnn (builtin () fun) [TyVar () a, TyVar () a] + return + . tyAbs () a (Type ()) + . lamAbs () f (TyFun () (TyVar () a) $ TyVar () a) + . lamAbs () p (mkIterTyAppNoAnn pair [TyVar () a, TyVar () a]) + $ mkIterAppNoAnn + (atAA $ Right Comma) + [ apply () (var () f) . apply () (atAA $ Left FstPair) $ var () p + , apply () (var () f) . apply () (atAA $ Left SndPair) $ var () p + ] diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Shad.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Shad.hs index 6cf66d162f5..76ef4c71772 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Shad.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Shad.hs @@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.Examples.Data.Shad - ( shad - , mkShad - , recUnit - , runRecUnit - ) where +module PlutusCore.Examples.Data.Shad ( + shad, + mkShad, + recUnit, + runRecUnit, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -19,27 +19,27 @@ import PlutusCore.Quote -- > getShadF a = \(rec :: * -> *) (i :: *) -> a -> all (a :: * -> *). a i -> integer getShadF :: uni `HasTypeLevel` Integer => TyName -> Quote (Type TyName uni ()) getShadF a = do - rec <- freshTyName "rec" - i <- freshTyName "i" - return - . TyLam () rec (KindArrow () (Type ()) $ Type ()) - . TyLam () i (Type ()) - . TyFun () (TyVar () a) - . TyForall () a (KindArrow () (Type ()) $ Type ()) - . TyFun () (TyApp () (TyVar () a) $ TyVar () i) - $ mkTyBuiltin @_ @Integer () + rec <- freshTyName "rec" + i <- freshTyName "i" + return + . TyLam () rec (KindArrow () (Type ()) $ Type ()) + . TyLam () i (Type ()) + . TyFun () (TyVar () a) + . TyForall () a (KindArrow () (Type ()) $ Type ()) + . TyFun () (TyApp () (TyVar () a) $ TyVar () i) + $ mkTyBuiltin @_ @Integer () -- | -- -- > \(a :: *) -> ifix (getShadF a) a shad :: uni `HasTypeLevel` Integer => Type TyName uni () shad = runQuote $ do - a <- freshTyName "a" - shadF <- getShadF a - return - . TyLam () a (Type ()) - . TyIFix () shadF - $ TyVar () a + a <- freshTyName "a" + shadF <- getShadF a + return + . TyLam () a (Type ()) + . TyIFix () shadF + $ TyVar () a -- | Test that shadowing does not result in variable capture. The definition is as follows: -- @@ -62,34 +62,34 @@ shad = runQuote $ do -- being distinct. mkShad :: uni `HasTypeAndTermLevel` Integer => Term TyName Name uni fun () mkShad = runQuote $ do - a <- freshTyName "a" - f <- freshTyName "f" - shadF <- getShadF a - x <- freshName "x" - y <- freshName "y" - return - . TyAbs () a (Type ()) - . IWrap () shadF (TyVar () a) - . LamAbs () x (TyVar () a) - . TyAbs () f (KindArrow () (Type ()) $ Type ()) - . LamAbs () y (TyApp () (TyVar () f) $ TyVar () a) - $ mkConstant @Integer () 0 + a <- freshTyName "a" + f <- freshTyName "f" + shadF <- getShadF a + x <- freshName "x" + y <- freshName "y" + return + . TyAbs () a (Type ()) + . IWrap () shadF (TyVar () a) + . LamAbs () x (TyVar () a) + . TyAbs () f (KindArrow () (Type ()) $ Type ()) + . LamAbs () y (TyApp () (TyVar () f) $ TyVar () a) + $ mkConstant @Integer () 0 -- | -- -- > recUnitF = \(rec :: * -> *) (i :: *) -> all (r :: *). rec i -> r -> r recUnitF :: Type TyName uni () recUnitF = runQuote $ do - rec <- freshTyName "rec" - i <- freshTyName "i" - r <- freshTyName "r" - return - . TyLam () rec (KindArrow () (Type ()) $ Type ()) - . TyLam () i (Type ()) - . TyForall () r (Type ()) - . TyFun () (TyApp () (TyVar () rec) $ TyVar () i) - . TyFun () (TyVar () r) - $ TyVar () r + rec <- freshTyName "rec" + i <- freshTyName "i" + r <- freshTyName "r" + return + . TyLam () rec (KindArrow () (Type ()) $ Type ()) + . TyLam () i (Type ()) + . TyForall () r (Type ()) + . TyFun () (TyApp () (TyVar () rec) $ TyVar () i) + . TyFun () (TyVar () r) + $ TyVar () r -- | -- @@ -117,10 +117,10 @@ recUnit = TyIFix () recUnitF $ mkTyBuiltin @_ @() () -- the inner binder and there will be no shadowing. runRecUnit :: uni `HasTypeAndTermLevel` () => Term TyName Name uni fun () runRecUnit = runQuote $ do - a <- freshTyName "a" - ru <- freshName "ru" - return - . TyAbs () a (Type ()) - . LamAbs () ru recUnit - . Apply () (TyInst () (Unwrap () $ Var () ru) $ TyVar () a) - $ Var () ru + a <- freshTyName "a" + ru <- freshName "ru" + return + . TyAbs () a (Type ()) + . LamAbs () ru recUnit + . Apply () (TyInst () (Unwrap () $ Var () ru) $ TyVar () a) + $ Var () ru diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/TreeForest.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/TreeForest.hs index 5ac92e72b15..5bd89aa6e14 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/TreeForest.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/TreeForest.hs @@ -1,16 +1,15 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -module PlutusCore.Examples.Data.TreeForest - ( treeData - , forestData - , treeNode - , forestNil - , forestCons - ) where +module PlutusCore.Examples.Data.TreeForest ( + treeData, + forestData, + treeNode, + forestNil, + forestCons, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -80,137 +79,147 @@ using this representation: infixr 5 ~~> class HasArrow a where - (~~>) :: a -> a -> a + (~~>) :: a -> a -> a instance a ~ () => HasArrow (Kind a) where - (~~>) = KindArrow () + (~~>) = KindArrow () instance a ~ () => HasArrow (Type tyname uni a) where - (~~>) = TyFun () + (~~>) = TyFun () star :: Kind () star = Type () treeTag :: Type TyName uni () treeTag = runQuote $ do - t <- freshTyName "t" - f <- freshTyName "f" - return - . TyLam () t star - . TyLam () f star - $ TyVar () t + t <- freshTyName "t" + f <- freshTyName "f" + return + . TyLam () t star + . TyLam () f star + $ TyVar () t forestTag :: Type TyName uni () forestTag = runQuote $ do - t <- freshTyName "t" - f <- freshTyName "f" - return - . TyLam () t star - . TyLam () f star - $ TyVar () f + t <- freshTyName "t" + f <- freshTyName "f" + return + . TyLam () t star + . TyLam () f star + $ TyVar () f asTree :: Type TyName uni () asTree = runQuote $ do - d <- freshTyName "d" - a <- freshTyName "a" - return - . TyLam () d (star ~~> (star ~~> star ~~> star) ~~> star) - . TyLam () a star - $ mkIterTyAppNoAnn (TyVar () d) - [ TyVar () a - , treeTag - ] + d <- freshTyName "d" + a <- freshTyName "a" + return + . TyLam () d (star ~~> (star ~~> star ~~> star) ~~> star) + . TyLam () a star + $ mkIterTyAppNoAnn + (TyVar () d) + [ TyVar () a + , treeTag + ] asForest :: Type TyName uni () asForest = runQuote $ do - d <- freshTyName "d" - a <- freshTyName "a" - return - . TyLam () d (star ~~> (star ~~> star ~~> star) ~~> star) - . TyLam () a star - $ mkIterTyAppNoAnn (TyVar () d) - [ TyVar () a - , forestTag - ] + d <- freshTyName "d" + a <- freshTyName "a" + return + . TyLam () d (star ~~> (star ~~> star ~~> star) ~~> star) + . TyLam () a star + $ mkIterTyAppNoAnn + (TyVar () d) + [ TyVar () a + , forestTag + ] treeForestData :: RecursiveType uni fun () treeForestData = runQuote $ do - treeForest <- freshTyName "treeForest" - a <- freshTyName "a" - r <- freshTyName "r" - tag <- freshTyName "tag" - let vA = TyVar () a - vR = TyVar () r - recSpine = [TyVar () treeForest, vA] - let tree = mkIterTyAppNoAnn asTree recSpine - forest = mkIterTyAppNoAnn asForest recSpine - body - = TyForall () r (Type ()) - $ mkIterTyAppNoAnn (TyVar () tag) - [ (vA ~~> forest ~~> vR) ~~> vR - , vR ~~> (tree ~~> forest ~~> vR) ~~> vR - ] - makeRecursiveType () treeForest - [TyVarDecl () a star, TyVarDecl () tag $ star ~~> star ~~> star] - body + treeForest <- freshTyName "treeForest" + a <- freshTyName "a" + r <- freshTyName "r" + tag <- freshTyName "tag" + let vA = TyVar () a + vR = TyVar () r + recSpine = [TyVar () treeForest, vA] + let tree = mkIterTyAppNoAnn asTree recSpine + forest = mkIterTyAppNoAnn asForest recSpine + body = + TyForall () r (Type ()) $ + mkIterTyAppNoAnn + (TyVar () tag) + [ (vA ~~> forest ~~> vR) ~~> vR + , vR ~~> (tree ~~> forest ~~> vR) ~~> vR + ] + makeRecursiveType + () + treeForest + [TyVarDecl () a star, TyVarDecl () tag $ star ~~> star ~~> star] + body treeData :: RecursiveType uni fun () treeData = runQuote $ do - let RecursiveType treeForest wrapTreeForest = treeForestData - tree = TyApp () asTree treeForest - return $ RecursiveType tree (\[a] -> wrapTreeForest [a, treeTag]) + let RecursiveType treeForest wrapTreeForest = treeForestData + tree = TyApp () asTree treeForest + return $ RecursiveType tree (\[a] -> wrapTreeForest [a, treeTag]) forestData :: RecursiveType uni fun () forestData = runQuote $ do - let RecursiveType treeForest wrapTreeForest = treeForestData - forest = TyApp () asForest treeForest - return $ RecursiveType forest (\[a] -> wrapTreeForest [a, forestTag]) + let RecursiveType treeForest wrapTreeForest = treeForestData + forest = TyApp () asForest treeForest + return $ RecursiveType forest (\[a] -> wrapTreeForest [a, forestTag]) -- | -- -- > /\(a :: *) -> \(x : a) (fr : forest a) -> -- > wrapTree [a] /\(r :: *) -> \(f : a -> forest a -> r) -> f x fr treeNode :: HasUniApply uni => Term TyName Name uni fun () -treeNode = runQuote $ normalizeTypesIn =<< do - let RecursiveType _ wrapTree = treeData - RecursiveType forest _ = forestData - a <- freshTyName "a" - r <- freshTyName "r" - x <- freshName "x" - fr <- freshName "fr" - f <- freshName "f" - let vA = TyVar () a - vR = TyVar () r - Normalized forestA <- normalizeType $ TyApp () forest vA - return +treeNode = + runQuote $ + normalizeTypesIn =<< do + let RecursiveType _ wrapTree = treeData + RecursiveType forest _ = forestData + a <- freshTyName "a" + r <- freshTyName "r" + x <- freshName "x" + fr <- freshName "fr" + f <- freshName "f" + let vA = TyVar () a + vR = TyVar () r + Normalized forestA <- normalizeType $ TyApp () forest vA + return . TyAbs () a (Type ()) . LamAbs () x vA . LamAbs () fr forestA . wrapTree [vA] . TyAbs () r (Type ()) . LamAbs () f (mkIterTyFun () [vA, forestA] vR) - $ mkIterAppNoAnn (Var () f) - [ Var () x - , Var () fr - ] + $ mkIterAppNoAnn + (Var () f) + [ Var () x + , Var () fr + ] -- | -- -- > /\(a :: *) -> -- > wrapForest [a] /\(r :: *) -> \(z : r) (f : tree a -> forest a -> r) -> z forestNil :: HasUniApply uni => Term TyName Name uni fun () -forestNil = runQuote $ normalizeTypesIn =<< do - let RecursiveType tree _ = treeData - RecursiveType forest wrapForest = forestData - a <- freshTyName "a" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - let vA = TyVar () a - vR = TyVar () r - Normalized treeA <- normalizeType $ TyApp () tree vA - Normalized forestA <- normalizeType $ TyApp () forest vA - return +forestNil = + runQuote $ + normalizeTypesIn =<< do + let RecursiveType tree _ = treeData + RecursiveType forest wrapForest = forestData + a <- freshTyName "a" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + let vA = TyVar () a + vR = TyVar () r + Normalized treeA <- normalizeType $ TyApp () tree vA + Normalized forestA <- normalizeType $ TyApp () forest vA + return . TyAbs () a (Type ()) . wrapForest [vA] . TyAbs () r (Type ()) @@ -223,20 +232,22 @@ forestNil = runQuote $ normalizeTypesIn =<< do -- > /\(a :: *) -> \(tr : tree a) (fr : forest a) -- > wrapForest [a] /\(r :: *) -> \(z : r) (f : tree a -> forest a -> r) -> f tr fr forestCons :: HasUniApply uni => Term TyName Name uni fun () -forestCons = runQuote $ normalizeTypesIn =<< do - let RecursiveType tree _ = treeData - RecursiveType forest wrapForest = forestData - a <- freshTyName "a" - tr <- freshName "tr" - fr <- freshName "fr" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - let vA = TyVar () a - vR = TyVar () r - Normalized treeA <- normalizeType $ TyApp () tree vA - Normalized forestA <- normalizeType $ TyApp () forest vA - return +forestCons = + runQuote $ + normalizeTypesIn =<< do + let RecursiveType tree _ = treeData + RecursiveType forest wrapForest = forestData + a <- freshTyName "a" + tr <- freshName "tr" + fr <- freshName "fr" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + let vA = TyVar () a + vR = TyVar () r + Normalized treeA <- normalizeType $ TyApp () tree vA + Normalized forestA <- normalizeType $ TyApp () forest vA + return . TyAbs () a (Type ()) . LamAbs () tr treeA . LamAbs () fr forestA @@ -244,7 +255,8 @@ forestCons = runQuote $ normalizeTypesIn =<< do . TyAbs () r (Type ()) . LamAbs () z vR . LamAbs () f (mkIterTyFun () [treeA, forestA] vR) - $ mkIterAppNoAnn (Var () f) - [ Var () tr - , Var () fr - ] + $ mkIterAppNoAnn + (Var () f) + [ Var () tr + , Var () fr + ] diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Vec.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Vec.hs index 875bcabbcaf..97492104bb8 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Vec.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Data/Vec.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- | In this module we define Church-encoded type-level natural numbers, -- Church-encoded vectors and Scott-encoded vectors. -- -- See @/docs/fomega/gadts/ScottVec.agda@ for how Scott-encoded vectors work. - module PlutusCore.Examples.Data.Vec where import PlutusCore.Core @@ -27,86 +26,91 @@ natK = KindArrow () (KindArrow () (Type ()) $ Type ()) . KindArrow () (Type ()) -- We don't have eta-equality for types, so we need to eta-expand some things manually. -- Should we have eta-equality? + -- | -- -- > getEta n = \(f :: * -> *) (z :: *) -> n f z getEta :: Type TyName uni () -> Quote (Type TyName uni ()) getEta n = do - f <- freshTyName "f" - z <- freshTyName "z" - return - . TyLam () f (KindArrow () (Type ()) $ Type ()) - . TyLam () z (Type ()) - $ mkIterTyAppNoAnn n - [ TyVar () f - , TyVar () z - ] + f <- freshTyName "f" + z <- freshTyName "z" + return + . TyLam () f (KindArrow () (Type ()) $ Type ()) + . TyLam () z (Type ()) + $ mkIterTyAppNoAnn + n + [ TyVar () f + , TyVar () z + ] -- | -- -- > zeroT = \(f :: * -> *) (z :: *) -> z zeroT :: Type TyName uni () zeroT = runQuote $ do - f <- freshTyName "f" - z <- freshTyName "z" - return - . TyLam () f (KindArrow () (Type ()) $ Type ()) - . TyLam () z (Type ()) - $ TyVar () z + f <- freshTyName "f" + z <- freshTyName "z" + return + . TyLam () f (KindArrow () (Type ()) $ Type ()) + . TyLam () z (Type ()) + $ TyVar () z -- | -- -- > succT = \(n : natK) (f :: * -> *) (z :: *) -> f (n f z) succT :: Type TyName uni () succT = runQuote $ do - n <- freshTyName "n" - f <- freshTyName "f" - z <- freshTyName "z" - return - . TyLam () n natK - . TyLam () f (KindArrow () (Type ()) $ Type ()) - . TyLam () z (Type ()) - . TyApp () (TyVar () f) - $ mkIterTyAppNoAnn (TyVar () n) - [ TyVar () f - , TyVar () z - ] + n <- freshTyName "n" + f <- freshTyName "f" + z <- freshTyName "z" + return + . TyLam () n natK + . TyLam () f (KindArrow () (Type ()) $ Type ()) + . TyLam () z (Type ()) + . TyApp () (TyVar () f) + $ mkIterTyAppNoAnn + (TyVar () n) + [ TyVar () f + , TyVar () z + ] -- | -- -- > plusT = \(n : natK) (m : natK) (f :: * -> *) (z :: *) -> n f (m f z) plusT :: Type TyName uni () plusT = runQuote $ do - n <- freshTyName "n" - m <- freshTyName "m" - f <- freshTyName "f" - z <- freshTyName "z" - return - . TyLam () n natK - . TyLam () m natK - . TyLam () f (KindArrow () (Type ()) $ Type ()) - . TyLam () z (Type ()) - $ mkIterTyAppNoAnn (TyVar () n) - [ TyVar () f - , mkIterTyAppNoAnn (TyVar () m) - [ TyVar () f - , TyVar () z - ] - ] + n <- freshTyName "n" + m <- freshTyName "m" + f <- freshTyName "f" + z <- freshTyName "z" + return + . TyLam () n natK + . TyLam () m natK + . TyLam () f (KindArrow () (Type ()) $ Type ()) + . TyLam () z (Type ()) + $ mkIterTyAppNoAnn + (TyVar () n) + [ TyVar () f + , mkIterTyAppNoAnn + (TyVar () m) + [ TyVar () f + , TyVar () z + ] + ] -- | -- -- > stepFun a r1 r2 = all (p :: natK). a -> r1 p -> r2 (succT p) getStepFun :: TyName -> Type TyName uni () -> TyName -> Quote (Type TyName uni ()) getStepFun a r1 r2 = do - p <- freshTyName "p" - return - . TyForall () p natK - . TyFun () (TyVar () a) - . TyFun () (TyApp () r1 $ TyVar () p) - . TyApp () (TyVar () r2) - . TyApp () succT - $ TyVar () p + p <- freshTyName "p" + return + . TyForall () p natK + . TyFun () (TyVar () a) + . TyFun () (TyApp () r1 $ TyVar () p) + . TyApp () (TyVar () r2) + . TyApp () succT + $ TyVar () p -- | -- @@ -115,18 +119,18 @@ getStepFun a r1 r2 = do -- > all (r :: natK -> *). (all (p :: natK). a -> r p -> r (succT p)) -> r zeroT -> r n churchVec :: Type TyName uni () churchVec = runQuote $ do - a <- freshTyName "a" - n <- freshTyName "n" - r <- freshTyName "r" - stepFun <- getStepFun a (TyVar () r) r - return - . TyLam () a (Type ()) - . TyLam () n natK - . TyForall () r (KindArrow () natK $ Type ()) - . TyFun () stepFun - . TyFun () (TyApp () (TyVar () r) zeroT) - . TyApp () (TyVar () r) - $ TyVar () n + a <- freshTyName "a" + n <- freshTyName "n" + r <- freshTyName "r" + stepFun <- getStepFun a (TyVar () r) r + return + . TyLam () a (Type ()) + . TyLam () n natK + . TyForall () r (KindArrow () natK $ Type ()) + . TyFun () stepFun + . TyFun () (TyApp () (TyVar () r) zeroT) + . TyApp () (TyVar () r) + $ TyVar () n -- | -- @@ -136,17 +140,17 @@ churchVec = runQuote $ do -- > z churchNil :: Term TyName Name uni fun () churchNil = runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - stepFun <- getStepFun a (TyVar () r) r - return - . TyAbs () a (Type ()) - . TyAbs () r (KindArrow () natK $ Type ()) - . LamAbs () f stepFun - . LamAbs () z (TyApp () (TyVar () r) zeroT) - $ Var () z + a <- freshTyName "a" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + stepFun <- getStepFun a (TyVar () r) r + return + . TyAbs () a (Type ()) + . TyAbs () r (KindArrow () natK $ Type ()) + . LamAbs () f stepFun + . LamAbs () z (TyApp () (TyVar () r) zeroT) + $ Var () z -- | -- @@ -156,29 +160,31 @@ churchNil = runQuote $ do -- > f {n} x (xs {r} f z) churchCons :: Term TyName Name uni fun () churchCons = runQuote $ do - a <- freshTyName "a" - n <- freshTyName "n" - x <- freshName "x" - xs <- freshName "xs" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - stepFun <- getStepFun a (TyVar () r) r - return - . TyAbs () a (Type ()) - . TyAbs () n natK - . LamAbs () x (TyVar () a) - . LamAbs () xs (mkIterTyAppNoAnn churchVec [TyVar () a, TyVar () n]) - . TyAbs () r (KindArrow () natK $ Type ()) - . LamAbs () f stepFun - . LamAbs () z (TyApp () (TyVar () r) zeroT) - $ mkIterAppNoAnn (TyInst () (Var () f) $ TyVar () n) - [ Var () x - , mkIterAppNoAnn (TyInst () (Var () xs) $ TyVar () r) - [ Var () f - , Var () z - ] - ] + a <- freshTyName "a" + n <- freshTyName "n" + x <- freshName "x" + xs <- freshName "xs" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + stepFun <- getStepFun a (TyVar () r) r + return + . TyAbs () a (Type ()) + . TyAbs () n natK + . LamAbs () x (TyVar () a) + . LamAbs () xs (mkIterTyAppNoAnn churchVec [TyVar () a, TyVar () n]) + . TyAbs () r (KindArrow () natK $ Type ()) + . LamAbs () f stepFun + . LamAbs () z (TyApp () (TyVar () r) zeroT) + $ mkIterAppNoAnn + (TyInst () (Var () f) $ TyVar () n) + [ Var () x + , mkIterAppNoAnn + (TyInst () (Var () xs) $ TyVar () r) + [ Var () f + , Var () z + ] + ] -- | -- @@ -191,34 +197,36 @@ churchCons = runQuote $ do -- > (ys {r} f z) churchConcat :: Term TyName Name uni fun () churchConcat = runQuote $ do - a <- freshTyName "a" - n <- freshTyName "n" - m <- freshTyName "m" - xs <- freshName "xs" - ys <- freshName "ys" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - p <- freshTyName "p" - stepFun <- getStepFun a (TyVar () r) r - mEta <- getEta $ TyVar () m - let plusTPM = mkIterTyAppNoAnn plusT [TyVar () p, TyVar () m] - return - . TyAbs () a (Type ()) - . TyAbs () n natK - . TyAbs () m natK - . LamAbs () xs (mkIterTyAppNoAnn churchVec [TyVar () a, TyVar () n]) - . LamAbs () ys (mkIterTyAppNoAnn churchVec [TyVar () a, mEta]) - . TyAbs () r (KindArrow () natK $ Type ()) - . LamAbs () f stepFun - . LamAbs () z (TyApp () (TyVar () r) zeroT) - $ mkIterAppNoAnn (TyInst () (Var () xs) . TyLam () p natK $ TyApp () (TyVar () r) plusTPM) - [ TyAbs () p natK $ TyInst () (Var () f) plusTPM - , mkIterAppNoAnn (TyInst () (Var () ys) $ TyVar () r) - [ Var () f - , Var () z - ] - ] + a <- freshTyName "a" + n <- freshTyName "n" + m <- freshTyName "m" + xs <- freshName "xs" + ys <- freshName "ys" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + p <- freshTyName "p" + stepFun <- getStepFun a (TyVar () r) r + mEta <- getEta $ TyVar () m + let plusTPM = mkIterTyAppNoAnn plusT [TyVar () p, TyVar () m] + return + . TyAbs () a (Type ()) + . TyAbs () n natK + . TyAbs () m natK + . LamAbs () xs (mkIterTyAppNoAnn churchVec [TyVar () a, TyVar () n]) + . LamAbs () ys (mkIterTyAppNoAnn churchVec [TyVar () a, mEta]) + . TyAbs () r (KindArrow () natK $ Type ()) + . LamAbs () f stepFun + . LamAbs () z (TyApp () (TyVar () r) zeroT) + $ mkIterAppNoAnn + (TyInst () (Var () xs) . TyLam () p natK $ TyApp () (TyVar () r) plusTPM) + [ TyAbs () p natK $ TyInst () (Var () f) plusTPM + , mkIterAppNoAnn + (TyInst () (Var () ys) $ TyVar () r) + [ Var () f + , Var () z + ] + ] -- | -- @@ -227,33 +235,33 @@ churchConcat = runQuote $ do -- > all (r :: natK -> *). (all (p :: natK). a -> rec p -> r (succT p)) -> r zeroT -> r n scottVecF :: Type TyName uni () scottVecF = runQuote $ do - a <- freshTyName "a" - rec <- freshTyName "rec" - n <- freshTyName "n" - r <- freshTyName "r" - stepFun <- getStepFun a (TyVar () rec) r - return - . TyLam () a (Type ()) - . TyLam () rec (KindArrow () natK $ Type ()) - . TyLam () n natK - . TyForall () r (KindArrow () natK $ Type ()) - . TyFun () stepFun - . TyFun () (TyApp () (TyVar () r) zeroT) - . TyApp () (TyVar () r) - $ TyVar () n + a <- freshTyName "a" + rec <- freshTyName "rec" + n <- freshTyName "n" + r <- freshTyName "r" + stepFun <- getStepFun a (TyVar () rec) r + return + . TyLam () a (Type ()) + . TyLam () rec (KindArrow () natK $ Type ()) + . TyLam () n natK + . TyForall () r (KindArrow () natK $ Type ()) + . TyFun () stepFun + . TyFun () (TyApp () (TyVar () r) zeroT) + . TyApp () (TyVar () r) + $ TyVar () n -- | -- -- > scottVec = \(a :: *) (n :: natK) -> ifix (scottVecF a) n scottVec :: Type TyName uni () scottVec = runQuote $ do - a <- freshTyName "a" - n <- freshTyName "n" - return - . TyLam () a (Type ()) - . TyLam () n natK - . TyIFix () (TyApp () scottVecF $ TyVar () a) - $ TyVar () n + a <- freshTyName "a" + n <- freshTyName "n" + return + . TyLam () a (Type ()) + . TyLam () n natK + . TyIFix () (TyApp () scottVecF $ TyVar () a) + $ TyVar () n -- | -- @@ -265,18 +273,18 @@ scottVec = runQuote $ do -- > z) scottNil :: Term TyName Name uni fun () scottNil = runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - stepFun <- getStepFun a (TyApp () scottVec $ TyVar () a) r - return - . TyAbs () a (Type ()) - . IWrap () (TyApp () scottVecF $ TyVar () a) zeroT - . TyAbs () r (KindArrow () natK $ Type ()) - . LamAbs () f stepFun - . LamAbs () z (TyApp () (TyVar () r) zeroT) - $ Var () z + a <- freshTyName "a" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + stepFun <- getStepFun a (TyApp () scottVec $ TyVar () a) r + return + . TyAbs () a (Type ()) + . IWrap () (TyApp () scottVecF $ TyVar () a) zeroT + . TyAbs () r (KindArrow () natK $ Type ()) + . LamAbs () f stepFun + . LamAbs () z (TyApp () (TyVar () r) zeroT) + $ Var () z -- | -- @@ -288,27 +296,28 @@ scottNil = runQuote $ do -- > f {n} x xs) scottCons :: Term TyName Name uni fun () scottCons = runQuote $ do - a <- freshTyName "a" - n <- freshTyName "n" - x <- freshName "x" - xs <- freshName "xs" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - stepFun <- getStepFun a (TyApp () scottVec $ TyVar () a) r - return - . TyAbs () a (Type ()) - . TyAbs () n natK - . LamAbs () x (TyVar () a) - . LamAbs () xs (mkIterTyAppNoAnn scottVec [TyVar () a, TyVar () n]) - . IWrap () (TyApp () scottVecF $ TyVar () a) (TyApp () succT $ TyVar () n) - . TyAbs () r (KindArrow () natK $ Type ()) - . LamAbs () f stepFun - . LamAbs () z (TyApp () (TyVar () r) zeroT) - $ mkIterAppNoAnn (TyInst () (Var () f) $ TyVar () n) - [ Var () x - , Var () xs - ] + a <- freshTyName "a" + n <- freshTyName "n" + x <- freshName "x" + xs <- freshName "xs" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + stepFun <- getStepFun a (TyApp () scottVec $ TyVar () a) r + return + . TyAbs () a (Type ()) + . TyAbs () n natK + . LamAbs () x (TyVar () a) + . LamAbs () xs (mkIterTyAppNoAnn scottVec [TyVar () a, TyVar () n]) + . IWrap () (TyApp () scottVecF $ TyVar () a) (TyApp () succT $ TyVar () n) + . TyAbs () r (KindArrow () natK $ Type ()) + . LamAbs () f stepFun + . LamAbs () z (TyApp () (TyVar () r) zeroT) + $ mkIterAppNoAnn + (TyInst () (Var () f) $ TyVar () n) + [ Var () x + , Var () xs + ] -- | -- @@ -321,30 +330,32 @@ scottCons = runQuote $ do -- > unitval scottHead :: uni `HasTypeAndTermLevel` () => Term TyName Name uni fun () scottHead = runQuote $ do - a <- freshTyName "a" - n <- freshTyName "n" - p <- freshTyName "p" - z <- freshTyName "z" - x <- freshName "x" - xs <- freshName "xs" - xs' <- freshName "xs'" - return - . TyAbs () a (Type ()) - . TyAbs () n natK - . LamAbs () xs (mkIterTyAppNoAnn scottVec [TyVar () a, TyApp () succT $ TyVar () n]) - $ mkIterAppNoAnn - ( TyInst () (Unwrap () $ Var () xs) - . TyLam () p natK - $ mkIterTyAppNoAnn (TyVar () p) - [ TyLam () z (Type ()) $ TyVar () a - , unit - ]) - [ TyAbs () p natK - . LamAbs () x (TyVar () a) - . LamAbs () xs' (mkIterTyAppNoAnn scottVec [TyVar () a, TyVar () p]) - $ Var () x - , unitval + a <- freshTyName "a" + n <- freshTyName "n" + p <- freshTyName "p" + z <- freshTyName "z" + x <- freshName "x" + xs <- freshName "xs" + xs' <- freshName "xs'" + return + . TyAbs () a (Type ()) + . TyAbs () n natK + . LamAbs () xs (mkIterTyAppNoAnn scottVec [TyVar () a, TyApp () succT $ TyVar () n]) + $ mkIterAppNoAnn + ( TyInst () (Unwrap () $ Var () xs) + . TyLam () p natK + $ mkIterTyAppNoAnn + (TyVar () p) + [ TyLam () z (Type ()) $ TyVar () a + , unit ] + ) + [ TyAbs () p natK + . LamAbs () x (TyVar () a) + . LamAbs () xs' (mkIterTyAppNoAnn scottVec [TyVar () a, TyVar () p]) + $ Var () x + , unitval + ] -- | -- @@ -358,40 +369,43 @@ scottHead = runQuote $ do -- > x + scottHead {integer} {p} (coe ys)) -- > (\(coe : scottVec Integer n -> scottVec integer zero) -> 0) -- > (/\(xs' :: scottVec Integer n) -> xs') -scottSumHeadsOr0 - :: (uni `HasTypeAndTermLevel` Integer, uni `HasTypeAndTermLevel` ()) - => Term TyName Name uni DefaultFun () +scottSumHeadsOr0 :: + (uni `HasTypeAndTermLevel` Integer, uni `HasTypeAndTermLevel` ()) => + Term TyName Name uni DefaultFun () scottSumHeadsOr0 = runQuote $ do - n <- freshTyName "n" - p <- freshTyName "p" - x <- freshName "x" - xs <- freshName "xs" - ys <- freshName "ys" - xs' <- freshName "xs'" - coe <- freshName "coe" - let vecInteger l = mkIterTyAppNoAnn scottVec [integer, l] - return - . TyAbs () n natK - . LamAbs () xs (vecInteger $ TyVar () n) - . LamAbs () ys (vecInteger $ TyVar () n) - $ mkIterAppNoAnn - ( TyInst () (Unwrap () $ Var () xs) - . TyLam () p natK - . TyFun () (TyFun () (vecInteger $ TyVar () n) $ vecInteger (TyVar () p)) - $ integer - ) - [ TyAbs () p natK - . LamAbs () x integer - . LamAbs () xs' (vecInteger $ TyVar () p) - . LamAbs () coe - (TyFun () (vecInteger $ TyVar () n) $ vecInteger (TyApp () succT $ TyVar () p)) - $ mkIterAppNoAnn (builtin () AddInteger) - [ Var () x - , Apply () (mkIterInstNoAnn scottHead [integer, TyVar () p]) - . Apply () (Var () coe) - $ Var () ys - ] - , LamAbs () coe (TyFun () (vecInteger $ TyVar () n) $ vecInteger zeroT) - $ mkConstant @Integer () 0 - , LamAbs () xs' (vecInteger $ TyVar () n) $ Var () xs' + n <- freshTyName "n" + p <- freshTyName "p" + x <- freshName "x" + xs <- freshName "xs" + ys <- freshName "ys" + xs' <- freshName "xs'" + coe <- freshName "coe" + let vecInteger l = mkIterTyAppNoAnn scottVec [integer, l] + return + . TyAbs () n natK + . LamAbs () xs (vecInteger $ TyVar () n) + . LamAbs () ys (vecInteger $ TyVar () n) + $ mkIterAppNoAnn + ( TyInst () (Unwrap () $ Var () xs) + . TyLam () p natK + . TyFun () (TyFun () (vecInteger $ TyVar () n) $ vecInteger (TyVar () p)) + $ integer + ) + [ TyAbs () p natK + . LamAbs () x integer + . LamAbs () xs' (vecInteger $ TyVar () p) + . LamAbs + () + coe + (TyFun () (vecInteger $ TyVar () n) $ vecInteger (TyApp () succT $ TyVar () p)) + $ mkIterAppNoAnn + (builtin () AddInteger) + [ Var () x + , Apply () (mkIterInstNoAnn scottHead [integer, TyVar () p]) + . Apply () (Var () coe) + $ Var () ys ] + , LamAbs () coe (TyFun () (vecInteger $ TyVar () n) $ vecInteger zeroT) $ + mkConstant @Integer () 0 + , LamAbs () xs' (vecInteger $ TyVar () n) $ Var () xs' + ] diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Everything.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Everything.hs index 1a0b0741f33..b3542a4d697 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Everything.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Everything.hs @@ -1,15 +1,14 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | This module exports all available examples via a data type which allows to test -- various procedures (pretty-printing, type checking, etc) over the entire set of examples -- in a convenient way: each time a function / data type is added to examples, none of the -- tests is required to be adapted, instead you just add the new definition to 'examples' -- defined below and all the tests see it automatically. - -{-# LANGUAGE ScopedTypeVariables #-} - -module PlutusCore.Examples.Everything - ( examples - , builtins - ) where +module PlutusCore.Examples.Everything ( + examples, + builtins, +) where import PlutusPrelude @@ -33,66 +32,75 @@ import PlutusCore.Examples.Data.Vec -- | All examples exported as a single value. examples :: PlcFolderContents DefaultUni (Either DefaultFun ExtensionFun) examples = - FolderContents - [ treeFolderContents "Examples" - [ treeFolderContents "Data" - $ plcTermFile "exampleData" exampleData + FolderContents + [ treeFolderContents + "Examples" + [ treeFolderContents "Data" $ + plcTermFile "exampleData" exampleData : [ plcTermFile (name ++ show optMatch) $ f optMatch | optMatch <- enumerate , (name, f) <- [("ofoldrData", ofoldrData)] ] - , treeFolderContents "Function" - [ plcTermFile "unsafeCoerce" unsafeCoerce - ] - , treeFolderContents "InterList" - [ plcTypeFile "InterList" $ _recursiveType interListData - , plcTermFile "InterNil" interNil - , plcTermFile "InterCons" interCons - , plcTermFile "FoldrInterList" foldrInterList - ] - , treeFolderContents "List" - [ plcTermFile (name ++ show optMatch) $ f optMatch - | optMatch <- enumerate - , (name, f) <- [("omapList", omapList)] - ] - , treeFolderContents "Pair" - [ plcTermFile "obothPair" obothPair - ] - , treeFolderContents "TreeForest" - [ plcTypeFile "Tree" $ _recursiveType treeData - , plcTypeFile "Forest" $ _recursiveType forestData - , plcTermFile "TreeNode" treeNode - , plcTermFile "ForestNil" forestNil - , plcTermFile "ForestCons" forestCons - ] - , treeFolderContents "Vec" - [ plcTypeFile "zeroT" zeroT - , plcTypeFile "succT" succT - , plcTypeFile "plusT" plusT - , plcTypeFile "churchVec" churchVec - , plcTermFile "churchNil" churchNil - , plcTermFile "churchCons" churchCons - , plcTermFile "churchConcat" churchConcat - , plcTypeFile "scottVec" scottVec - , plcTermFile "scottNil" scottNil - , plcTermFile "scottCons" scottCons - , plcTermFile "scottHead" scottHead - , plcTermFile "scottSumHeadsOr0" $ mapFun Left scottSumHeadsOr0 - ] - , treeFolderContents "Shad" - [ plcTypeFile "shad" shad - , plcTermFile "mkShad" mkShad - ] - , treeFolderContents "RecUnit" - [ plcTypeFile "recUnit" recUnit - , plcTermFile "runRecUnit" runRecUnit - ] - ] - ] + , treeFolderContents + "Function" + [ plcTermFile "unsafeCoerce" unsafeCoerce + ] + , treeFolderContents + "InterList" + [ plcTypeFile "InterList" $ _recursiveType interListData + , plcTermFile "InterNil" interNil + , plcTermFile "InterCons" interCons + , plcTermFile "FoldrInterList" foldrInterList + ] + , treeFolderContents + "List" + [ plcTermFile (name ++ show optMatch) $ f optMatch + | optMatch <- enumerate + , (name, f) <- [("omapList", omapList)] + ] + , treeFolderContents + "Pair" + [ plcTermFile "obothPair" obothPair + ] + , treeFolderContents + "TreeForest" + [ plcTypeFile "Tree" $ _recursiveType treeData + , plcTypeFile "Forest" $ _recursiveType forestData + , plcTermFile "TreeNode" treeNode + , plcTermFile "ForestNil" forestNil + , plcTermFile "ForestCons" forestCons + ] + , treeFolderContents + "Vec" + [ plcTypeFile "zeroT" zeroT + , plcTypeFile "succT" succT + , plcTypeFile "plusT" plusT + , plcTypeFile "churchVec" churchVec + , plcTermFile "churchNil" churchNil + , plcTermFile "churchCons" churchCons + , plcTermFile "churchConcat" churchConcat + , plcTypeFile "scottVec" scottVec + , plcTermFile "scottNil" scottNil + , plcTermFile "scottCons" scottCons + , plcTermFile "scottHead" scottHead + , plcTermFile "scottSumHeadsOr0" $ mapFun Left scottSumHeadsOr0 + ] + , treeFolderContents + "Shad" + [ plcTypeFile "shad" shad + , plcTermFile "mkShad" mkShad + ] + , treeFolderContents + "RecUnit" + [ plcTypeFile "recUnit" recUnit + , plcTermFile "runRecUnit" runRecUnit + ] + ] + ] builtins :: PlcFolderContents DefaultUni ExtensionFun builtins = - FolderContents - [ treeFolderContents "Builtins" $ - map (\fun -> plcTermFile (show fun) $ builtin () fun) enumerate - ] + FolderContents + [ treeFolderContents "Builtins" $ + map (\fun -> plcTermFile (show fun) $ builtin () fun) enumerate + ] diff --git a/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs b/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs index 56dd0296df2..dcfc98b1ea8 100644 --- a/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs +++ b/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs @@ -1,6 +1,6 @@ -module Codec.Extras.FlatViaSerialise - ( FlatViaSerialise (..) - ) where +module Codec.Extras.FlatViaSerialise ( + FlatViaSerialise (..), +) where import Codec.Serialise (Serialise, deserialiseOrFail, serialise) import Data.ByteString.Lazy qualified as BSL (toStrict) @@ -27,14 +27,14 @@ convert `Data` objects to bytestrings on the chain using the `serialiseData` bui performs CBOR serialisation and the result is always in a canonical form. -} -- | For deriving 'Flat' instances via 'Serialize'. -newtype FlatViaSerialise a = FlatViaSerialise { unFlatViaSerialise :: a } +newtype FlatViaSerialise a = FlatViaSerialise {unFlatViaSerialise :: a} instance Serialise a => Flat (FlatViaSerialise a) where - -- See Note [Flat serialisation for strict and lazy bytestrings] - encode = encode . BSL.toStrict . serialise . unFlatViaSerialise - decode = do - errOrX <- deserialiseOrFail <$> decode - case errOrX of - Left err -> fail $ show err -- Here we embed a 'Serialise' error into a 'Flat' one. - Right x -> pure $ FlatViaSerialise x - size = size . BSL.toStrict . serialise . unFlatViaSerialise + -- See Note [Flat serialisation for strict and lazy bytestrings] + encode = encode . BSL.toStrict . serialise . unFlatViaSerialise + decode = do + errOrX <- deserialiseOrFail <$> decode + case errOrX of + Left err -> fail $ show err -- Here we embed a 'Serialise' error into a 'Flat' one. + Right x -> pure $ FlatViaSerialise x + size = size . BSL.toStrict . serialise . unFlatViaSerialise diff --git a/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs b/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs index 832f3d50760..d489709566c 100644 --- a/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs +++ b/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Codec.Extras.SerialiseViaFlat - ( SerialiseViaFlat (..) - , decodeViaFlatWith - , DeserialiseFailureInfo (..) - , DeserialiseFailureReason (..) - , readDeserialiseFailureInfo - ) where + +module Codec.Extras.SerialiseViaFlat ( + SerialiseViaFlat (..), + decodeViaFlatWith, + DeserialiseFailureInfo (..), + DeserialiseFailureReason (..), + readDeserialiseFailureInfo, +) where import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR @@ -16,12 +17,11 @@ import PlutusCore.Flat qualified as Flat import PlutusCore.Flat.Decoder qualified as Flat import Prettyprinter (Pretty (pretty), (<+>)) -{- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance - that just encodes the flat-serialized value as a CBOR bytestring --} -newtype SerialiseViaFlat a = SerialiseViaFlat { unSerialiseViaFlat :: a } +-- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance +-- that just encodes the flat-serialized value as a CBOR bytestring +newtype SerialiseViaFlat a = SerialiseViaFlat {unSerialiseViaFlat :: a} -instance (Flat.Flat a) => Serialise (SerialiseViaFlat a) where +instance Flat.Flat a => Serialise (SerialiseViaFlat a) where encode = encode . Flat.flat . unSerialiseViaFlat decode = SerialiseViaFlat <$> decodeViaFlatWith Flat.decode @@ -31,35 +31,33 @@ decodeViaFlatWith decoder = do -- lift any flat's failures to be cborg failures (MonadFail) fromRightM (fail . show) $ Flat.unflatWith decoder bs -{- | The errors returned by `cborg` are plain strings (untyped). With this -function we try to map onto datatypes, those cborg error messages that we are -interested in. - -Currently we are only interested in error messages returned by the -`CBOR.decodeBytes` decoder; -see `PlutusLedgerApi.Common.SerialisedScript.scriptCBORDecoder`. --} +-- | The errors returned by `cborg` are plain strings (untyped). With this +-- function we try to map onto datatypes, those cborg error messages that we are +-- interested in. +-- +-- Currently we are only interested in error messages returned by the +-- `CBOR.decodeBytes` decoder; +-- see `PlutusLedgerApi.Common.SerialisedScript.scriptCBORDecoder`. readDeserialiseFailureInfo :: CBOR.DeserialiseFailure -> DeserialiseFailureInfo readDeserialiseFailureInfo (CBOR.DeserialiseFailure byteOffset reason) = DeserialiseFailureInfo byteOffset $ interpretReason reason - where - -- Note that this is subject to change if `cborg` dependency changes. - -- Currently: cborg-0.2.10.0 - interpretReason :: String -> DeserialiseFailureReason - interpretReason = \case - -- Relevant Sources: - -- - -- - -- - "end of input" -> EndOfInput - -- Relevant Sources: - -- - "expected bytes" -> ExpectedBytes - msg -> OtherReason msg + where + -- Note that this is subject to change if `cborg` dependency changes. + -- Currently: cborg-0.2.10.0 + interpretReason :: String -> DeserialiseFailureReason + interpretReason = \case + -- Relevant Sources: + -- + -- + -- + "end of input" -> EndOfInput + -- Relevant Sources: + -- + "expected bytes" -> ExpectedBytes + msg -> OtherReason msg -{- | Similar to `CBOR.DeserialiseFailure`, with the difference that plain -string reason messages are turned into the datatype: `DeserialiseFailureReason`. --} +-- | Similar to `CBOR.DeserialiseFailure`, with the difference that plain +-- string reason messages are turned into the datatype: `DeserialiseFailureReason`. data DeserialiseFailureInfo = DeserialiseFailureInfo { dfOffset :: CBOR.ByteOffset , dfReason :: DeserialiseFailureReason diff --git a/plutus-core/plutus-core/src/Data/Aeson/Flatten.hs b/plutus-core/plutus-core/src/Data/Aeson/Flatten.hs index 4739d548633..ad253a0ec78 100644 --- a/plutus-core/plutus-core/src/Data/Aeson/Flatten.hs +++ b/plutus-core/plutus-core/src/Data/Aeson/Flatten.hs @@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} -module Data.Aeson.Flatten - ( flattenObject - , unflattenObject - , mergeObject - , mergeValue - , objToHm - , hmToObj - ) where + +module Data.Aeson.Flatten ( + flattenObject, + unflattenObject, + mergeObject, + mergeValue, + objToHm, + hmToObj, +) where import Data.Aeson #if MIN_VERSION_aeson(2,0,0) @@ -36,32 +37,32 @@ hmToObj = id -- The inverse of 'unflattenObject'. flattenObject :: Text.Text -> Object -> Object flattenObject sep o = hmToObj $ go Nothing (objToHm o) - where - go :: Maybe Text.Text -> HM.HashMap Text.Text Value -> HM.HashMap Text.Text Value - go mprefix = HM.foldMapWithKey $ \k v -> - let newName = case mprefix of - Just prefix -> prefix <> sep <> k - Nothing -> k - in case v of - Object o' -> go (Just newName) $ objToHm o' - leaf -> HM.singleton newName leaf + where + go :: Maybe Text.Text -> HM.HashMap Text.Text Value -> HM.HashMap Text.Text Value + go mprefix = HM.foldMapWithKey $ \k v -> + let newName = case mprefix of + Just prefix -> prefix <> sep <> k + Nothing -> k + in case v of + Object o' -> go (Just newName) $ objToHm o' + leaf -> HM.singleton newName leaf -- | Turn a "flat" object whose keys represent paths into an unflattened object. -- The keys in the result will be the resulting path, separated by `sep`. -- The inverse of 'flattenObject'. unflattenObject :: Text.Text -> Object -> Object unflattenObject sep o = - HM.foldlWithKey (\acc k v -> mergeObject acc (mkPathObject k v)) mempty (objToHm o) - where - mkPathObject :: Text.Text -> Value -> Object - mkPathObject k value = - let path = Text.splitOn sep k - in hmToObj $ go path value - where - go :: [Text.Text] -> Value -> HM.HashMap Text.Text Value - go [] _ = error "empty path" - go [n] v = HM.singleton n v - go (n:n':xs) v = HM.singleton n $ Object $ hmToObj $ go (n':xs) v + HM.foldlWithKey (\acc k v -> mergeObject acc (mkPathObject k v)) mempty (objToHm o) + where + mkPathObject :: Text.Text -> Value -> Object + mkPathObject k value = + let path = Text.splitOn sep k + in hmToObj $ go path value + where + go :: [Text.Text] -> Value -> HM.HashMap Text.Text Value + go [] _ = error "empty path" + go [n] v = HM.singleton n v + go (n : n' : xs) v = HM.singleton n $ Object $ hmToObj $ go (n' : xs) v -- | Merge two objects, merging the values where both sides have an entry for a key rather than -- taking the first. @@ -71,4 +72,4 @@ mergeObject o1 o2 = hmToObj $ HM.unionWith mergeValue (objToHm o1) (objToHm o2) -- | Merge two values, merging the objects using 'mergeObject'. Can't merge anything else. mergeValue :: Value -> Value -> Value mergeValue (Object o1) (Object o2) = Object $ mergeObject o1 o2 -mergeValue _ _ = error "can't merge" +mergeValue _ _ = error "can't merge" diff --git a/plutus-core/plutus-core/src/Data/Aeson/THReader.hs b/plutus-core/plutus-core/src/Data/Aeson/THReader.hs index aaf8cca3f8d..e2ae91f50bb 100644 --- a/plutus-core/plutus-core/src/Data/Aeson/THReader.hs +++ b/plutus-core/plutus-core/src/Data/Aeson/THReader.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module Data.Aeson.THReader where import Data.Aeson @@ -7,7 +8,7 @@ import TH.RelativePaths readJSONFromFile :: (FromJSON a, Lift a) => String -> Code Q a readJSONFromFile name = liftCode $ do - contents <- qReadFileLBS name - case eitherDecode contents of - Left err -> fail err - Right res -> examineCode [||res||] + contents <- qReadFileLBS name + case eitherDecode contents of + Left err -> fail err + Right res -> examineCode [||res||] diff --git a/plutus-core/plutus-core/src/Data/Either/Extras.hs b/plutus-core/plutus-core/src/Data/Either/Extras.hs index 1223715214b..a2839757d87 100644 --- a/plutus-core/plutus-core/src/Data/Either/Extras.hs +++ b/plutus-core/plutus-core/src/Data/Either/Extras.hs @@ -1,7 +1,7 @@ -module Data.Either.Extras - ( unsafeFromEither - , fromRightM - ) where +module Data.Either.Extras ( + unsafeFromEither, + fromRightM, +) where import Control.Exception diff --git a/plutus-core/plutus-core/src/Data/List/Extras.hs b/plutus-core/plutus-core/src/Data/List/Extras.hs index ca1d5f1cb44..acd2484d672 100644 --- a/plutus-core/plutus-core/src/Data/List/Extras.hs +++ b/plutus-core/plutus-core/src/Data/List/Extras.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} + module Data.List.Extras (wix) where import Control.Lens @@ -6,7 +7,8 @@ import Data.Word -- | A variant of 'ix' that takes a 'Word64' instead of an 'Int'. wix :: Word64 -> Traversal' [a] a -wix k f xs0 = go xs0 k where - go [] _ = pure [] - go (a:as) 0 = f a <&> (:as) - go (a:as) i = (a:) <$> (go as $! i - 1) +wix k f xs0 = go xs0 k + where + go [] _ = pure [] + go (a : as) 0 = f a <&> (: as) + go (a : as) i = (a :) <$> (go as $! i - 1) diff --git a/plutus-core/plutus-core/src/Data/Vector/Orphans.hs b/plutus-core/plutus-core/src/Data/Vector/Orphans.hs index c3ecd4743df..be95f1c8830 100644 --- a/plutus-core/plutus-core/src/Data/Vector/Orphans.hs +++ b/plutus-core/plutus-core/src/Data/Vector/Orphans.hs @@ -7,7 +7,7 @@ import Data.Vector.Strict qualified as Strict import PlutusCore.Flat (Flat (..)) import PlutusCore.Flat.Instances.Vector () -instance (Hashable a) => Hashable (Strict.Vector a) where +instance Hashable a => Hashable (Strict.Vector a) where hashWithSalt = Strict.foldl' hashWithSalt {- The `flat` library does not provide a `Flat` instance for @@ -18,7 +18,7 @@ encode vectors as lists. This incurs a slight size penalty (lists require one bit of overhead per entry whereas vectors can be encoded with an overhead of one byte per 255 elements), but this is offset by the decoding speedup. Encoding vectors as lists also simplifies maintenance and specification. -} -instance (Flat a) => Flat (Strict.Vector a) where +instance Flat a => Flat (Strict.Vector a) where size = size . Strict.toList encode = encode . Strict.toList decode = Strict.fromList <$> decode diff --git a/plutus-core/plutus-core/src/Data/Version/Extras.hs b/plutus-core/plutus-core/src/Data/Version/Extras.hs index 2f5f8bdd4ee..e71f1412698 100644 --- a/plutus-core/plutus-core/src/Data/Version/Extras.hs +++ b/plutus-core/plutus-core/src/Data/Version/Extras.hs @@ -1,16 +1,15 @@ {-# LANGUAGE CPP #-} -module Data.Version.Extras - ( gitAwareVersionInfo - ) where - +module Data.Version.Extras ( + gitAwareVersionInfo, +) where import Data.Version qualified as Data.Version - -gitAwareVersionInfo - :: Data.Version.Version -- ^ The version, usually coming from the Paths_ module - -> String +gitAwareVersionInfo :: + -- | The version, usually coming from the Paths_ module + Data.Version.Version -> + String gitAwareVersionInfo version = version' <> gitRev <> gitCommitDate where version' :: String diff --git a/plutus-core/plutus-core/src/PlutusCore.hs b/plutus-core/plutus-core/src/PlutusCore.hs index d6ada347064..26f68dc2ff1 100644 --- a/plutus-core/plutus-core/src/PlutusCore.hs +++ b/plutus-core/plutus-core/src/PlutusCore.hs @@ -1,128 +1,138 @@ -- Why is it needed here, but not in "Universe.Core"? {-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms #-} -module PlutusCore - ( - -- * Parser - parseProgram - , parseTerm - , parseType - , SourcePos - , SrcSpan (..) - , SrcSpans - -- * Builtins - , Some (..) - , SomeTypeIn (..) - , Kinded (..) - , ValueOf (..) - , someValueOf - , someValue - , someValueType - , Esc - , Contains (..) - , Closed (..) - , EverywhereAll - , knownUniOf - , GShow (..) - , show - , GEq (..) - , HasUniApply (..) - , checkStar - , withApplicable - , (:~:) (..) - , type (<:) - , HasTypeLevel - , HasTermLevel - , HasTypeAndTermLevel - , DefaultUni (..) - , pattern DefaultUniList - , pattern DefaultUniPair - , pattern DefaultUniArray - , DefaultFun (..) - -- * AST - , Term (..) - , termSubterms - , termSubtypes - , termMapNames - , programMapNames - , UniOf - , Type (..) - , typeSubtypes - , typeMapNames - , Kind (..) - , toPatFuncKind - , fromPatFuncKind - , argsFunKind - , ParserError (..) - , Version (..) - , Program (..) - , Name (..) - , TyName (..) - , Unique (..) - , UniqueMap (..) - , UniqueSet (..) - , Normalized (..) - , latestVersion - , termAnn - , typeAnn - , tyVarDeclAnn - , tyVarDeclName - , tyVarDeclKind - , varDeclAnn - , varDeclName - , varDeclType - , tyDeclAnn - , tyDeclType - , tyDeclKind - , progAnn - , progVer - , progTerm - , mapFun - -- * DeBruijn representation - , DeBruijn (..) - , TyDeBruijn (..) - , NamedDeBruijn (..) - , NamedTyDeBruijn (..) - , deBruijnTerm - , unDeBruijnTerm - -- * Processing - , HasUniques - , Rename (..) - -- * Type checking - , module TypeCheck - , normalizeTypesIn - , normalizeTypesInProgram - , TypeError - -- * Errors - , Error (..) - , NormCheckError (..) - , UniqueError (..) - , FreeVariableError (..) - -- * Quotation and term construction - , Quote - , runQuote - , QuoteT - , runQuoteT - , MonadQuote - , liftQuote - -- * Name generation - , freshUnique - , freshName - , freshTyName - -- * Evaluation - , EvaluationResult (..) - -- * Combining programs - , applyProgram - -- * Benchmarking - , termAstSize - , typeAstSize - , kindAstSize - , programAstSize - ) where +module PlutusCore ( + -- * Parser + parseProgram, + parseTerm, + parseType, + SourcePos, + SrcSpan (..), + SrcSpans, + -- * Builtins + Some (..), + SomeTypeIn (..), + Kinded (..), + ValueOf (..), + someValueOf, + someValue, + someValueType, + Esc, + Contains (..), + Closed (..), + EverywhereAll, + knownUniOf, + GShow (..), + show, + GEq (..), + HasUniApply (..), + checkStar, + withApplicable, + (:~:) (..), + type (<:), + HasTypeLevel, + HasTermLevel, + HasTypeAndTermLevel, + DefaultUni (..), + pattern DefaultUniList, + pattern DefaultUniPair, + pattern DefaultUniArray, + DefaultFun (..), + + -- * AST + Term (..), + termSubterms, + termSubtypes, + termMapNames, + programMapNames, + UniOf, + Type (..), + typeSubtypes, + typeMapNames, + Kind (..), + toPatFuncKind, + fromPatFuncKind, + argsFunKind, + ParserError (..), + Version (..), + Program (..), + Name (..), + TyName (..), + Unique (..), + UniqueMap (..), + UniqueSet (..), + Normalized (..), + latestVersion, + termAnn, + typeAnn, + tyVarDeclAnn, + tyVarDeclName, + tyVarDeclKind, + varDeclAnn, + varDeclName, + varDeclType, + tyDeclAnn, + tyDeclType, + tyDeclKind, + progAnn, + progVer, + progTerm, + mapFun, + + -- * DeBruijn representation + DeBruijn (..), + TyDeBruijn (..), + NamedDeBruijn (..), + NamedTyDeBruijn (..), + deBruijnTerm, + unDeBruijnTerm, + + -- * Processing + HasUniques, + Rename (..), + + -- * Type checking + module TypeCheck, + normalizeTypesIn, + normalizeTypesInProgram, + TypeError, + + -- * Errors + Error (..), + NormCheckError (..), + UniqueError (..), + FreeVariableError (..), + + -- * Quotation and term construction + Quote, + runQuote, + QuoteT, + runQuoteT, + MonadQuote, + liftQuote, + + -- * Name generation + freshUnique, + freshName, + freshTyName, + + -- * Evaluation + EvaluationResult (..), + + -- * Combining programs + applyProgram, + + -- * Benchmarking + termAstSize, + typeAstSize, + kindAstSize, + programAstSize, +) where import PlutusCore.Annotation +import PlutusCore.AstSize import PlutusCore.Builtin import PlutusCore.Core import PlutusCore.DeBruijn @@ -137,7 +147,6 @@ import PlutusCore.Normalize import PlutusCore.Parser import PlutusCore.Quote import PlutusCore.Rename -import PlutusCore.AstSize import PlutusCore.Subst import PlutusCore.TypeCheck as TypeCheck @@ -145,12 +154,13 @@ import Control.Monad.Except -- | Applies one program to another. Fails if the versions do not match -- and tries to merge annotations. -applyProgram - :: (MonadError ApplyProgramError m, Semigroup a) - => Program tyname name uni fun a - -> Program tyname name uni fun a - -> m (Program tyname name uni fun a) -applyProgram (Program a1 v1 t1) (Program a2 v2 t2) | v1 == v2 - = pure $ Program (a1 <> a2) v1 (Apply (termAnn t1 <> termAnn t2) t1 t2) +applyProgram :: + (MonadError ApplyProgramError m, Semigroup a) => + Program tyname name uni fun a -> + Program tyname name uni fun a -> + m (Program tyname name uni fun a) +applyProgram (Program a1 v1 t1) (Program a2 v2 t2) + | v1 == v2 = + pure $ Program (a1 <> a2) v1 (Apply (termAnn t1 <> termAnn t2) t1 t2) applyProgram (Program _a1 v1 _t1) (Program _a2 v2 _t2) = - throwError $ MkApplyProgramError v1 v2 + throwError $ MkApplyProgramError v1 v2 diff --git a/plutus-core/plutus-core/src/PlutusCore/Analysis/Definitions.hs b/plutus-core/plutus-core/src/PlutusCore/Analysis/Definitions.hs index dd3a4cd79f3..fc8763f61c5 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Analysis/Definitions.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Analysis/Definitions.hs @@ -1,23 +1,28 @@ {-# LANGUAGE LambdaCase #-} + -- | Definition analysis for Plutus Core. -module PlutusCore.Analysis.Definitions - ( UniqueInfos - , ScopeType(..) - , termDefs - , handleType - , runTermDefs - , addDef - , addUsage - ) where +module PlutusCore.Analysis.Definitions ( + UniqueInfos, + ScopeType (..), + termDefs, + handleType, + runTermDefs, + addDef, + addUsage, +) where import PlutusCore.Core.Plated (termSubtermsDeep, termSubtypesDeep) import PlutusCore.Core.Type (Term (LamAbs, TyAbs, Var), Type (TyForall, TyLam, TyVar)) import PlutusCore.Error (UniqueError (..)) -import PlutusCore.Name.Unique (HasUnique, TermUnique (TermUnique), TypeUnique (TypeUnique), - Unique (Unique), theUnique) +import PlutusCore.Name.Unique ( + HasUnique, + TermUnique (TermUnique), + TypeUnique (TypeUnique), + Unique (Unique), + theUnique, + ) import PlutusCore.Name.UniqueMap (UniqueMap, insertByNameIndex, lookupNameIndex) - import Control.Lens (forMOf_, (^.)) import Control.Monad (when) import Control.Monad.State (MonadState, execStateT, gets, modify) @@ -34,6 +39,7 @@ them all and allow the client to chose if they want to throw some of them. -- | Information about a unique, a pair of a definition if we have one and a set of uses. type UniqueInfo ann = (Maybe (ScopedLoc ann), Set.Set (ScopedLoc ann)) + type UniqueInfos ann = UniqueMap Unique (UniqueInfo ann) data ScopedLoc ann = ScopedLoc ScopeType ann deriving stock (Eq, Ord) @@ -42,145 +48,171 @@ data ScopedLoc ann = ScopedLoc ScopeType ann deriving stock (Eq, Ord) -- for variables or the type scope for variables. data ScopeType = TermScope | TypeScope deriving stock (Eq, Ord) -lookupDef - :: (Ord ann, - HasUnique name unique, - MonadState (UniqueInfos ann) m) - => name - -> m (UniqueInfo ann) +lookupDef :: + ( Ord ann + , HasUnique name unique + , MonadState (UniqueInfos ann) m + ) => + name -> + m (UniqueInfo ann) lookupDef n = do - previousDef <- gets $ lookupNameIndex n - case previousDef of - Just d -> pure d - Nothing -> do - let empty = (Nothing, mempty) - modify $ insertByNameIndex n empty - pure empty - -addDef - :: (Ord ann, - HasUnique n unique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => n -- ^ The variable - -> ann -- ^ The annotation of the variable - -> ScopeType -- ^ The scope type - -> m () + previousDef <- gets $ lookupNameIndex n + case previousDef of + Just d -> pure d + Nothing -> do + let empty = (Nothing, mempty) + modify $ insertByNameIndex n empty + pure empty + +addDef :: + ( Ord ann + , HasUnique n unique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + -- | The variable + n -> + -- | The annotation of the variable + ann -> + -- | The scope type + ScopeType -> + m () addDef n newDef tpe = do - let def = ScopedLoc tpe newDef + let def = ScopedLoc tpe newDef - d@(_, uses) <- lookupDef n - checkUndefined n def d - modify $ insertByNameIndex n (Just def, uses) + d@(_, uses) <- lookupDef n + checkUndefined n def d + modify $ insertByNameIndex n (Just def, uses) -- | Check that a variable is currently undefined. -checkUndefined - :: (HasUnique n u, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => n -- ^ The variable - -> ScopedLoc ann -- ^ The new definition - -> UniqueInfo ann -- ^ The existing info - -> m () +checkUndefined :: + ( HasUnique n u + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + -- | The variable + n -> + -- | The new definition + ScopedLoc ann -> + -- | The existing info + UniqueInfo ann -> + m () checkUndefined n (ScopedLoc _ newDef) info = case info of - (Just (ScopedLoc _ prevDef), _) -> tell [MultiplyDefined (n ^. theUnique) prevDef newDef] - _ -> pure () - -addUsage - :: (Ord ann, - HasUnique n unique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => n -- ^ The variable - -> ann -- ^ The annotation of the variable - -> ScopeType -- ^ The scope type - -> m () + (Just (ScopedLoc _ prevDef), _) -> tell [MultiplyDefined (n ^. theUnique) prevDef newDef] + _ -> pure () + +addUsage :: + ( Ord ann + , HasUnique n unique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + -- | The variable + n -> + -- | The annotation of the variable + ann -> + -- | The scope type + ScopeType -> + m () addUsage n newUse tpe = do - let use = ScopedLoc tpe newUse - - d@(def, uses) <- lookupDef n - checkCoherency n use d - checkDefined n use d - modify $ insertByNameIndex n (def, Set.insert use uses) - -checkDefined - :: (HasUnique n u, - MonadWriter [UniqueError ann] m) - => n -- ^ The variable - -> ScopedLoc ann -- ^ The new definition - -> UniqueInfo ann -- ^ The existing info - -> m () + let use = ScopedLoc tpe newUse + + d@(def, uses) <- lookupDef n + checkCoherency n use d + checkDefined n use d + modify $ insertByNameIndex n (def, Set.insert use uses) + +checkDefined :: + ( HasUnique n u + , MonadWriter [UniqueError ann] m + ) => + -- | The variable + n -> + -- | The new definition + ScopedLoc ann -> + -- | The existing info + UniqueInfo ann -> + m () checkDefined n (ScopedLoc _ loc) (def, _) = case def of - Nothing -> tell [FreeVariable (n ^. theUnique) loc] - Just _ -> pure () - -checkCoherency - :: (HasUnique n u, - MonadWriter [UniqueError ann] m) - => n -- ^ The variable - -> ScopedLoc ann -- ^ The new definition - -> UniqueInfo ann -- ^ The existing info - -> m () + Nothing -> tell [FreeVariable (n ^. theUnique) loc] + Just _ -> pure () + +checkCoherency :: + ( HasUnique n u + , MonadWriter [UniqueError ann] m + ) => + -- | The variable + n -> + -- | The new definition + ScopedLoc ann -> + -- | The existing info + UniqueInfo ann -> + m () checkCoherency n (ScopedLoc tpe loc) (def, uses) = do - for_ def checkLoc - for_ (Set.toList uses) checkLoc - - where - checkLoc (ScopedLoc tpe' loc') = when (tpe' /= tpe) $ - tell [IncoherentUsage (n ^. theUnique) loc' loc] + for_ def checkLoc + for_ (Set.toList uses) checkLoc + where + checkLoc (ScopedLoc tpe' loc') = + when (tpe' /= tpe) $ + tell [IncoherentUsage (n ^. theUnique) loc' loc] -- | Given a PLC term, add all of its term and type definitions and usages, including its subterms -- and subtypes, to a global map. -termDefs - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Term tyname name uni fun ann - -> m () +termDefs :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Term tyname name uni fun ann -> + m () termDefs tm = do - forMOf_ termSubtermsDeep tm handleTerm - forMOf_ termSubtypesDeep tm handleType - -handleTerm :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Term tyname name uni fun ann - -> m () + forMOf_ termSubtermsDeep tm handleTerm + forMOf_ termSubtypesDeep tm handleType + +handleTerm :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Term tyname name uni fun ann -> + m () handleTerm = \case - Var ann n -> - addUsage n ann TermScope - LamAbs ann n _ _ -> do - addDef n ann TermScope - TyAbs ann tn _ _ -> do - addDef tn ann TypeScope - _ -> pure () + Var ann n -> + addUsage n ann TermScope + LamAbs ann n _ _ -> do + addDef n ann TermScope + TyAbs ann tn _ _ -> do + addDef tn ann TypeScope + _ -> pure () -- | Given a type, add its type definition/usage, including its subtypes, to a global map. -handleType - :: (Ord ann, - HasUnique tyname TypeUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Type tyname uni ann - -> m () +handleType :: + ( Ord ann + , HasUnique tyname TypeUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Type tyname uni ann -> + m () handleType = \case - TyVar ann n -> - addUsage n ann TypeScope - TyForall ann tn _ _ -> - addDef tn ann TypeScope - TyLam ann tn _ _ -> - addDef tn ann TypeScope - _ -> pure () - -runTermDefs - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - Monad m) - => Term tyname name uni fun ann - -> m (UniqueInfos ann, [UniqueError ann]) + TyVar ann n -> + addUsage n ann TypeScope + TyForall ann tn _ _ -> + addDef tn ann TypeScope + TyLam ann tn _ _ -> + addDef tn ann TypeScope + _ -> pure () + +runTermDefs :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , Monad m + ) => + Term tyname name uni fun ann -> + m (UniqueInfos ann, [UniqueError ann]) runTermDefs = runWriterT . flip execStateT mempty . termDefs diff --git a/plutus-core/plutus-core/src/PlutusCore/Annotation.hs b/plutus-core/plutus-core/src/PlutusCore/Annotation.hs index 3c6d0b5d963..f8d74564a87 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Annotation.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Annotation.hs @@ -1,18 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TypeFamilies #-} - -module PlutusCore.Annotation - ( Ann (..) - , SrcSpan (..) - , SrcSpans (..) - , InlineHints (..) - , Inline (..) - , AnnInline (..) - , Megaparsec.SourcePos (..) - , Megaparsec.Pos - , addSrcSpan - , lineInSrcSpan - ) where +{-# LANGUAGE TypeFamilies #-} + +module PlutusCore.Annotation ( + Ann (..), + SrcSpan (..), + SrcSpans (..), + InlineHints (..), + Inline (..), + AnnInline (..), + Megaparsec.SourcePos (..), + Megaparsec.Pos, + addSrcSpan, + lineInSrcSpan, +) where import Control.DeepSeq import Data.Default.Class @@ -26,22 +26,22 @@ import PlutusCore.Flat (Flat (..)) import Prettyprinter import Text.Megaparsec.Pos as Megaparsec -newtype InlineHints name a = InlineHints { shouldInline :: a -> name -> Inline } +newtype InlineHints name a = InlineHints {shouldInline :: a -> name -> Inline} instance Show (InlineHints name a) where - show _ = "" + show _ = "" instance Default (InlineHints name a) where - def = InlineHints (\_ _ -> MayInline) + def = InlineHints (\_ _ -> MayInline) -- | An annotation type used during the compilation. data Ann = Ann - { annInline :: Inline - , annSrcSpans :: SrcSpans - , annIsAsDataMatcher :: Bool - } - deriving stock (Eq, Ord, Generic, Show) - deriving anyclass (Hashable) + { annInline :: Inline + , annSrcSpans :: SrcSpans + , annIsAsDataMatcher :: Bool + } + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (Hashable) instance Default Ann where def = @@ -52,24 +52,24 @@ instance Default Ann where } data Inline - = -- | When calling @PlutusIR.Compiler.Definitions.defineTerm@ to add a new term definition, - -- if we annotation the var on the LHS of the definition with `AlwaysInline`, the inliner will - -- always inline that var. - -- - -- This is currently used to ensure builtin functions such as @trace@ (when the @remove-trace@ - -- flag is on and @trace@ is rewritten to @const@) are inlined, because the inliner would - -- otherwise not inline them. To achieve that, we annotate the definition with `AlwaysInline` - -- when defining @trace@, i.e., @trace = \_ a -> a@. - AlwaysInline - | -- | Signaling to the compiler that a binding is safe to inline. This is useful for - -- annotating strict bindings that aren't obviously safe to inline. - SafeToInline - | MayInline - deriving stock (Eq, Ord, Generic, Show) - deriving anyclass (Hashable) + = -- | When calling @PlutusIR.Compiler.Definitions.defineTerm@ to add a new term definition, + -- if we annotation the var on the LHS of the definition with `AlwaysInline`, the inliner will + -- always inline that var. + -- + -- This is currently used to ensure builtin functions such as @trace@ (when the @remove-trace@ + -- flag is on and @trace@ is rewritten to @const@) are inlined, because the inliner would + -- otherwise not inline them. To achieve that, we annotate the definition with `AlwaysInline` + -- when defining @trace@, i.e., @trace = \_ a -> a@. + AlwaysInline + | -- | Signaling to the compiler that a binding is safe to inline. This is useful for + -- annotating strict bindings that aren't obviously safe to inline. + SafeToInline + | MayInline + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (Hashable) instance Pretty Ann where - pretty = viaShow + pretty = viaShow class AnnInline a where -- | An annotation instructing the inliner to always inline a binding. @@ -89,9 +89,9 @@ instance AnnInline () where annMayInline = () instance AnnInline Ann where - annAlwaysInline = def { annInline = AlwaysInline } - annSafeToInline = def { annInline = SafeToInline } - annMayInline = def { annInline = MayInline } + annAlwaysInline = def {annInline = AlwaysInline} + annSafeToInline = def {annInline = SafeToInline} + annMayInline = def {annInline = MayInline} -- | The span between two source locations. -- @@ -100,52 +100,52 @@ instance AnnInline Ann where -- -- The line and column numbers are 1-based, and the unit is Unicode code point (or `Char`). data SrcSpan = SrcSpan - { srcSpanFile :: FilePath - , srcSpanSLine :: Int - , 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, Hashable, NFData) + { srcSpanFile :: FilePath + , srcSpanSLine :: Int + , 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, Hashable, NFData) instance Show SrcSpan where - showsPrec _ s = - showString (srcSpanFile s) - . showChar ':' - . showsPrec 0 (srcSpanSLine s) - . showChar ':' - . showsPrec 0 (srcSpanSCol s) - . showChar '-' - . showsPrec 0 (srcSpanELine s) - . showChar ':' - . showsPrec 0 (if srcSpanECol s == 0 then 0 else srcSpanECol s - 1) + showsPrec _ s = + showString (srcSpanFile s) + . showChar ':' + . showsPrec 0 (srcSpanSLine s) + . showChar ':' + . showsPrec 0 (srcSpanSCol s) + . showChar '-' + . showsPrec 0 (srcSpanELine s) + . showChar ':' + . showsPrec 0 (if srcSpanECol s == 0 then 0 else srcSpanECol s - 1) instance Pretty SrcSpan where - pretty = viaShow + pretty = viaShow newtype SrcSpans = SrcSpans {unSrcSpans :: Set SrcSpan} - deriving newtype (Eq, Ord, Hashable, Semigroup, Monoid, MonoFoldable, NFData) - deriving stock (Generic) - deriving anyclass (Flat) + deriving newtype (Eq, Ord, Hashable, Semigroup, Monoid, MonoFoldable, NFData) + deriving stock (Generic) + deriving anyclass (Flat) type instance Element SrcSpans = SrcSpan instance Show SrcSpans where - showsPrec _ (SrcSpans xs) = - showString "{ " - . showString - ( case Set.toList xs of - [] -> "no-src-span" - ys -> List.intercalate ", " (show <$> ys) - ) - . showString " }" + showsPrec _ (SrcSpans xs) = + showString "{ " + . showString + ( case Set.toList xs of + [] -> "no-src-span" + ys -> List.intercalate ", " (show <$> ys) + ) + . showString " }" instance Pretty SrcSpans where - pretty = viaShow + pretty = viaShow -- | Add an extra SrcSpan to existing 'SrcSpans' of 'Ann' addSrcSpan :: SrcSpan -> Ann -> Ann @@ -154,5 +154,5 @@ addSrcSpan s (Ann i (SrcSpans ss) b) = Ann i (SrcSpans $ Set.insert s ss) b -- | Tells if a line (positive integer) falls inside a SrcSpan. lineInSrcSpan :: Pos -> SrcSpan -> Bool lineInSrcSpan pos spn = - let i = Megaparsec.unPos pos - in i >= srcSpanSLine spn && i <= srcSpanELine spn + let i = Megaparsec.unPos pos + in i >= srcSpanSLine spn && i <= srcSpanELine spn diff --git a/plutus-core/plutus-core/src/PlutusCore/Arity.hs b/plutus-core/plutus-core/src/PlutusCore/Arity.hs index 301249ab1c5..90768f6f9a1 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Arity.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Arity.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} + module PlutusCore.Arity where import Data.Proxy @@ -8,41 +9,41 @@ import PlutusCore.Builtin import Prettyprinter -- | Is the next argument a term or a type? -data Param = - TermParam | TypeParam - deriving stock (Show, Eq) +data Param + = TermParam + | TypeParam + deriving stock (Show, Eq) instance Pretty Param where pretty = viaShow -{-| -The (syntactic) arity of a term. That is, a record of the arguments that the -term expects before it may do some work. Since we have both type and lambda -abstractions, this is not a simple argument count, but rather a list of values -indicating whether the next argument should be a term or a type. - -Note that this is the syntactic arity, i.e. it just corresponds to the number of -syntactic lambda and type abstractions on the outside of the term. It is thus -an under-approximation of how many arguments the term may need. -e.g. consider the term @let id = \x -> x in id@: the variable @id@ has syntactic -arity @[]@, but does in fact need an argument before it does any work. --} +-- | +-- The (syntactic) arity of a term. That is, a record of the arguments that the +-- term expects before it may do some work. Since we have both type and lambda +-- abstractions, this is not a simple argument count, but rather a list of values +-- indicating whether the next argument should be a term or a type. +-- +-- Note that this is the syntactic arity, i.e. it just corresponds to the number of +-- syntactic lambda and type abstractions on the outside of the term. It is thus +-- an under-approximation of how many arguments the term may need. +-- e.g. consider the term @let id = \x -> x in id@: the variable @id@ has syntactic +-- arity @[]@, but does in fact need an argument before it does any work. type Arity = [Param] -- | Get the 'Arity' from a 'TypeScheme'. typeSchemeArity :: TypeScheme val args res -> Arity -typeSchemeArity TypeSchemeResult{} = [] +typeSchemeArity TypeSchemeResult {} = [] typeSchemeArity (TypeSchemeArrow sch) = TermParam : typeSchemeArity sch typeSchemeArity (TypeSchemeAll _ sch) = TypeParam : typeSchemeArity sch -- | Get the arity of a builtin function from the 'PLC.BuiltinSemanticsVariant'. -builtinArity - :: forall uni fun - . ToBuiltinMeaning uni fun - => Proxy uni - -> BuiltinSemanticsVariant fun - -> fun - -> Arity +builtinArity :: + forall uni fun. + ToBuiltinMeaning uni fun => + Proxy uni -> + BuiltinSemanticsVariant fun -> + fun -> + Arity builtinArity _ semvar fun = case toBuiltinMeaning @uni @fun @(Term TyName Name uni fun ()) semvar fun of BuiltinMeaning sch _ _ -> typeSchemeArity sch diff --git a/plutus-core/plutus-core/src/PlutusCore/AstSize.hs b/plutus-core/plutus-core/src/PlutusCore/AstSize.hs index bdb09c5a2a7..9142d6cc124 100644 --- a/plutus-core/plutus-core/src/PlutusCore/AstSize.hs +++ b/plutus-core/plutus-core/src/PlutusCore/AstSize.hs @@ -28,13 +28,12 @@ newtype AstSize = AstSize deriving anyclass (PrettyBy config) deriving (Semigroup, Monoid) via Sum Integer -{-| Count the number of AST nodes in a kind. - ->>> kindAstSize $ Type () -AstSize {unAstSize = 1} ->>> kindAstSize $ KindArrow () (KindArrow () (Type ()) (Type ())) (Type ()) -AstSize {unAstSize = 5} --} +-- | Count the number of AST nodes in a kind. +-- +-- >>> kindAstSize $ Type () +-- AstSize {unAstSize = 1} +-- >>> kindAstSize $ KindArrow () (KindArrow () (Type ()) (Type ())) (Type ()) +-- AstSize {unAstSize = 5} kindAstSize :: Kind a -> AstSize kindAstSize kind = fold @@ -80,5 +79,5 @@ programAstSize :: Program tyname name uni fun ann -> AstSize programAstSize (Program _ _ t) = termAstSize t -- | Compute the size of the serializabled form of a value. -serialisedAstSize :: (Flat a) => a -> Integer +serialisedAstSize :: Flat a => a -> Integer serialisedAstSize = fromIntegral . BS.length . flat diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise.hs index 047778e611f..d63197e7cc9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Bitwise.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise.hs @@ -1,7 +1,6 @@ -- editorconfig-checker-disable-file - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} -- | Implementations for CIP-121, CIP-122 and CIP-123. Grouped because they all operate on @@ -21,8 +20,8 @@ module PlutusCore.Bitwise ( countSetBits, findFirstSetBit, IntegerToByteStringError (..), - maximumOutputLength - ) where + maximumOutputLength, +) where import PlutusCore.Builtin (BuiltinResult, builtinResultFailure, emit) @@ -67,9 +66,10 @@ integerToByteString endiannessArg lengthArg input -- Check that the requested length does not exceed the limit. *NB*: if we remove the limit we'll -- still have to make sure that the length fits into an Int. | lengthArg > maximumOutputLength = do - emit . pack $ "integerToByteString: requested length is too long (maximum is " - ++ show maximumOutputLength - ++ " bytes)" + emit . pack $ + "integerToByteString: requested length is too long (maximum is " + ++ show maximumOutputLength + ++ " bytes)" emit $ "Length requested: " <> (pack . show $ lengthArg) builtinResultFailure -- If the requested length is zero (ie, an explicit output size is not @@ -77,44 +77,45 @@ integerToByteString endiannessArg lengthArg input -- limit. If the requested length is nonzero and less than the limit, -- integerToByteString checks that the input fits. | lengthArg == 0 -- integerLog2 n is one less than the number of significant bits in n - && fromIntegral (integerLog2 input) >= 8 * maximumOutputLength = - let bytesRequiredFor n = integerLog2 n `div` 8 + 1 - -- ^ This gives 1 instead of 0 for n=0, but we'll never get that. - in do - emit . pack $ "integerToByteString: input too long (maximum is 2^" - ++ show (8 * maximumOutputLength) - ++ "-1)" - emit $ "Length required: " <> (pack . show $ bytesRequiredFor input) - builtinResultFailure - | otherwise = let endianness = endiannessArgToByteOrder endiannessArg in - -- We use fromIntegral here, despite advice to the contrary in general when defining builtin - -- denotations. This is because, if we've made it this far, we know that overflow or truncation - -- are impossible: we've checked that whatever we got given fits inside a (non-negative) Int. - case unsafeIntegerToByteString endianness (fromIntegral lengthArg) input of - Left err -> case err of - NegativeInput -> do - emit "integerToByteString: cannot convert negative Integer" - -- This does work proportional to the size of input. However, we're in a failing case - -- anyway, and the user's paid for work proportional to this size in any case. - emit $ "Input: " <> (pack . show $ input) - builtinResultFailure - NotEnoughDigits -> do - emit "integerToByteString: cannot represent Integer in given number of bytes" - -- This does work proportional to the size of input. However, we're in a failing case - -- anyway, and the user's paid for work proportional to this size in any case. - emit $ "Input: " <> (pack . show $ input) - emit $ "Bytes requested: " <> (pack . show $ lengthArg) - builtinResultFailure - Right result -> pure result + && fromIntegral (integerLog2 input) >= 8 * maximumOutputLength = + let bytesRequiredFor n = integerLog2 n `div` 8 + 1 + in -- \^ This gives 1 instead of 0 for n=0, but we'll never get that. + do + emit . pack $ + "integerToByteString: input too long (maximum is 2^" + ++ show (8 * maximumOutputLength) + ++ "-1)" + emit $ "Length required: " <> (pack . show $ bytesRequiredFor input) + builtinResultFailure + | otherwise = + let endianness = endiannessArgToByteOrder endiannessArg + in -- We use fromIntegral here, despite advice to the contrary in general when defining builtin + -- denotations. This is because, if we've made it this far, we know that overflow or truncation + -- are impossible: we've checked that whatever we got given fits inside a (non-negative) Int. + case unsafeIntegerToByteString endianness (fromIntegral lengthArg) input of + Left err -> case err of + NegativeInput -> do + emit "integerToByteString: cannot convert negative Integer" + -- This does work proportional to the size of input. However, we're in a failing case + -- anyway, and the user's paid for work proportional to this size in any case. + emit $ "Input: " <> (pack . show $ input) + builtinResultFailure + NotEnoughDigits -> do + emit "integerToByteString: cannot represent Integer in given number of bytes" + -- This does work proportional to the size of input. However, we're in a failing case + -- anyway, and the user's paid for work proportional to this size in any case. + emit $ "Input: " <> (pack . show $ input) + emit $ "Bytes requested: " <> (pack . show $ lengthArg) + builtinResultFailure + Right result -> pure result -- | Conversion from 'Integer' to 'ByteString', as per -- [CIP-121](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0121). --- -- | Structured type to help indicate conversion errors. -data IntegerToByteStringError = - NegativeInput | - NotEnoughDigits +data IntegerToByteStringError + = NegativeInput + | NotEnoughDigits deriving stock (Eq, Show) endiannessArgToByteOrder :: Bool -> ByteOrder @@ -131,14 +132,14 @@ unsafeIntegerToByteString requestedByteOrder requestedLength input -- we can. See Note [Manual specialization] for details. | requestedLength == 0 = Right . Builder.builderBytes $ case requestedByteOrder of LittleEndian -> goLENoLimit mempty input - BigEndian -> goBENoLimit mempty input + BigEndian -> goBENoLimit mempty input | otherwise = do let result = case requestedByteOrder of - LittleEndian -> goLELimit mempty input - BigEndian -> goBELimit mempty input + LittleEndian -> goLELimit mempty input + BigEndian -> goBELimit mempty input case result of Nothing -> Left NotEnoughDigits - Just b -> Right . Builder.builderBytes $ b + Just b -> Right . Builder.builderBytes $ b where goLELimit :: Builder -> Integer -> Maybe Builder goLELimit acc remaining @@ -180,11 +181,12 @@ unsafeIntegerToByteString requestedByteOrder requestedLength input goLENoLimit :: Builder -> Integer -> Builder goLENoLimit acc remaining | remaining == 0 = acc - | otherwise = let newRemaining = remaining `unsafeShiftR` 64 - digitGroup :: Word64 = fromInteger remaining - in case newRemaining of - 0 -> finishLENoLimit acc digitGroup - _ -> goLENoLimit (acc <> Builder.storable digitGroup) newRemaining + | otherwise = + let newRemaining = remaining `unsafeShiftR` 64 + digitGroup :: Word64 = fromInteger remaining + in case newRemaining of + 0 -> finishLENoLimit acc digitGroup + _ -> goLENoLimit (acc <> Builder.storable digitGroup) newRemaining finishLENoLimit :: Builder -> Word64 -> Builder finishLENoLimit acc remaining | remaining == 0 = acc @@ -193,8 +195,9 @@ unsafeIntegerToByteString requestedByteOrder requestedLength input digit :: Word8 = fromIntegral remaining in finishLENoLimit (acc <> Builder.word8 digit) newRemaining padLE :: Builder -> Builder - padLE acc = let paddingLength = requestedLength - Builder.builderLength acc - in acc <> Builder.bytes (BS.replicate paddingLength 0x0) + padLE acc = + let paddingLength = requestedLength - Builder.builderLength acc + in acc <> Builder.bytes (BS.replicate paddingLength 0x0) -- We manually specialize the big-endian case: see Note [Manual specialization] for why. goBELimit :: Builder -> Integer -> Maybe Builder goBELimit acc remaining @@ -217,20 +220,23 @@ unsafeIntegerToByteString requestedByteOrder requestedLength input goBENoLimit :: Builder -> Integer -> Builder goBENoLimit acc remaining | remaining == 0 = acc - | otherwise = let newRemaining = remaining `unsafeShiftR` 64 - digitGroup = fromInteger remaining - in case newRemaining of - 0 -> finishBENoLimit acc digitGroup - _ -> goBENoLimit (Builder.word64BE digitGroup <> acc) newRemaining + | otherwise = + let newRemaining = remaining `unsafeShiftR` 64 + digitGroup = fromInteger remaining + in case newRemaining of + 0 -> finishBENoLimit acc digitGroup + _ -> goBENoLimit (Builder.word64BE digitGroup <> acc) newRemaining finishBENoLimit :: Builder -> Word64 -> Builder finishBENoLimit acc remaining | remaining == 0 = acc - | otherwise = let newRemaining = remaining `unsafeShiftR` 8 - digit = fromIntegral remaining - in finishBENoLimit (Builder.word8 digit <> acc) newRemaining + | otherwise = + let newRemaining = remaining `unsafeShiftR` 8 + digit = fromIntegral remaining + in finishBENoLimit (Builder.word8 digit <> acc) newRemaining padBE :: Builder -> Builder - padBE acc = let paddingLength = requestedLength - Builder.builderLength acc in - Builder.bytes (BS.replicate paddingLength 0x0) <> acc + padBE acc = + let paddingLength = requestedLength - Builder.builderLength acc + in Builder.bytes (BS.replicate paddingLength 0x0) <> acc -- | Conversion from 'ByteString' to 'Integer', as per -- [CIP-121](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0121). @@ -239,28 +245,28 @@ unsafeIntegerToByteString requestedByteOrder requestedLength input byteStringToInteger :: Bool -> ByteString -> Integer byteStringToInteger statedEndiannessArg input = - let endianness = endiannessArgToByteOrder statedEndiannessArg in - unsafeByteStringToInteger endianness input + let endianness = endiannessArgToByteOrder statedEndiannessArg + in unsafeByteStringToInteger endianness input -- For clarity, the stated endianness argument uses 'ByteOrder'. -- This function may not actually be unsafe, but it shouldn't be used outside this module. unsafeByteStringToInteger :: ByteOrder -> ByteString -> Integer - -- We use manual specialization to ensure as few branches in loop bodies as we can. See Note - -- [Manual specialization] for details. +-- We use manual specialization to ensure as few branches in loop bodies as we can. See Note +-- [Manual specialization] for details. unsafeByteStringToInteger statedByteOrder input = case statedByteOrder of - -- Since padding bytes in the most-significant-last representation go at - -- the end of the input, we can skip decoding them, as they won't affect - -- the result in any way. - LittleEndian -> case BS.findIndexEnd (/= 0x00) input of - -- If there are no nonzero bytes, it must be zero. - Nothing -> 0 - Just end -> goLE 0 end 0 - -- Since padding bytes in the most-significant-first representation go at - -- the beginning of the input, we can skip decoding them, as they won't - -- affect the result in any way. - BigEndian -> case BS.findIndex (/= 0x00) input of - Nothing -> 0 - Just end -> goBE 0 end 0 (BS.length input - 1) + -- Since padding bytes in the most-significant-last representation go at + -- the end of the input, we can skip decoding them, as they won't affect + -- the result in any way. + LittleEndian -> case BS.findIndexEnd (/= 0x00) input of + -- If there are no nonzero bytes, it must be zero. + Nothing -> 0 + Just end -> goLE 0 end 0 + -- Since padding bytes in the most-significant-first representation go at + -- the beginning of the input, we can skip decoding them, as they won't + -- affect the result in any way. + BigEndian -> case BS.findIndex (/= 0x00) input of + Nothing -> 0 + Just end -> goBE 0 end 0 (BS.length input - 1) where -- Like with toByteString, we use loop sectioning to decode eight digits at once. See Note [Loop -- sectioning] for why we do this. @@ -277,7 +283,7 @@ unsafeByteStringToInteger statedByteOrder input = case statedByteOrder of -- multiplication by 2^64*k, but significantly faster, as GHC doesn't optimize -- such multiplications into shifts for Integers. newAcc = acc + fromIntegral digitGroup `unsafeShiftL` shift - in goLE newAcc limit newIx + in goLE newAcc limit newIx | otherwise = finishLE acc limit ix finishLE :: Integer -> Int -> Int -> Integer finishLE acc limit ix @@ -289,7 +295,7 @@ unsafeByteStringToInteger statedByteOrder input = case statedByteOrder of -- Similarly to before, we use unsafeShiftL to move a single digit into the right -- position in the result. newAcc = acc + fromIntegral digit `unsafeShiftL` shift - in finishLE newAcc limit newIx + in finishLE newAcc limit newIx -- Technically, ByteString does not allow reading of anything bigger than a single byte. -- However, because ByteStrings are counted arrays, caching already brings in adjacent bytes, -- which makes fetching them quite cheap. Additionally, GHC appears to optimize this into a @@ -554,11 +560,11 @@ writeBits bs ixs bit = case unsafeDupablePerformIO . try $ go of -- exceptions], which covers why we did this. go :: IO ByteString go = BS.useAsCString bs $ \srcPtr -> - BSI.create len $ - \dstPtr -> - let go2 (i:is) = setOrClearAtIx dstPtr i *> go2 is - go2 _ = pure () - in do + BSI.create len $ + \dstPtr -> + let go2 (i : is) = setOrClearAtIx dstPtr i *> go2 is + go2 _ = pure () + in do copyBytes dstPtr (castPtr srcPtr) len go2 ixs len :: Int @@ -573,9 +579,10 @@ writeBits bs ixs bit = case unsafeDupablePerformIO . try $ go of let (bigIx, littleIx) = i `quotRem` 8 let flipIx = len - fromIntegral bigIx - 1 w8 :: Word8 <- peekByteOff ptr flipIx - let toWrite = if bit - then Bits.setBit w8 . fromIntegral $ littleIx - else Bits.clearBit w8 . fromIntegral $ littleIx + let toWrite = + if bit + then Bits.setBit w8 . fromIntegral $ littleIx + else Bits.clearBit w8 . fromIntegral $ littleIx pokeByteOff ptr flipIx toWrite {-# INLINEABLE setOrClearAtIx #-} {-# INLINEABLE writeBits #-} @@ -589,9 +596,10 @@ replicateByte len w8 emit "replicateByte: negative length requested" builtinResultFailure | len > maximumOutputLength = do - emit . pack $ "replicateByte: requested length is too long (maximum is " - ++ show maximumOutputLength - ++ " bytes)" + emit . pack $ + "replicateByte: requested length is too long (maximum is " + ++ show maximumOutputLength + ++ " bytes)" emit $ "Length requested: " <> (pack . show $ len) builtinResultFailure | otherwise = pure . BS.replicate (fromIntegral len) $ w8 @@ -606,14 +614,15 @@ shiftByteString :: ByteString -> Integer -> ByteString shiftByteString bs bitMove | BS.null bs = bs | bitMove == 0 = bs - | otherwise = let len = BS.length bs - bitLen = fromIntegral $ 8 * len - in if abs bitMove >= bitLen - then BS.replicate len 0x00 - -- fromIntegral is safe to use here, as the only way this - -- could overflow (or underflow) an Int is if we had a - -- ByteString onchain that was over 30 petabytes in size. - else unsafeShiftByteString bs (fromIntegral bitMove) + | otherwise = + let len = BS.length bs + bitLen = fromIntegral $ 8 * len + in if abs bitMove >= bitLen + then BS.replicate len 0x00 + -- fromIntegral is safe to use here, as the only way this + -- could overflow (or underflow) an Int is if we had a + -- ByteString onchain that was over 30 petabytes in size. + else unsafeShiftByteString bs (fromIntegral bitMove) -- | Wrapper for calling 'unsafeRotateByteString' safely. Specifically, we avoid various edge cases: -- @@ -627,15 +636,16 @@ shiftByteString bs bitMove rotateByteString :: ByteString -> Integer -> ByteString rotateByteString bs bitMove | BS.null bs = bs - | otherwise = let bitLen = fromIntegral $ 8 * BS.length bs - -- This is guaranteed non-negative - reducedBitMove = bitMove `mod` bitLen - in if reducedBitMove == 0 - then bs - -- fromIntegral is safe to use here since for a bytestring to have a - -- size that doesn't fit into an `Int` it would have to have a size - -- exceeding something like 37 petabytes. - else unsafeRotateByteString bs (fromIntegral reducedBitMove) + | otherwise = + let bitLen = fromIntegral $ 8 * BS.length bs + -- This is guaranteed non-negative + reducedBitMove = bitMove `mod` bitLen + in if reducedBitMove == 0 + then bs + -- fromIntegral is safe to use here since for a bytestring to have a + -- size that doesn't fit into an `Int` it would have to have a size + -- exceeding something like 37 petabytes. + else unsafeRotateByteString bs (fromIntegral reducedBitMove) {- Note [Shift and rotation implementation] @@ -667,9 +677,9 @@ we also observe that the 'large' shift moves around whole bytes, while also keeping consecutive bytes consecutive, assuming their bit indices remain in-bounds. This means that we can implement step 1 both simply and efficiently: -* For shifts, we perform a partial copy of all the bytes whose bits remain +\* For shifts, we perform a partial copy of all the bytes whose bits remain in-bounds, followed by clearing of whatever remains. -* For rotations, we perform two partial copies: first of all the bytes whose +\* For rotations, we perform two partial copies: first of all the bytes whose bits remain in-bounds, followed by whatever remains, at the 'opposite end'. These can make use of the bulk copying and clearing operations provided by the @@ -695,20 +705,20 @@ of 8, we can be _much_ faster, as Step 2 becomes unnecessary in that case. -- This may not actually be unsafe, but it shouldn't be used outside this module. unsafeShiftByteString :: ByteString -> Int -> ByteString unsafeShiftByteString bs bitMove = unsafeDupablePerformIO . BS.useAsCString bs $ \srcPtr -> - BSI.create len $ \dstPtr -> do - -- To simplify our calculations, we work only with absolute values, - -- letting different functions control for direction, instead of - -- trying to unify the scheme for both positive and negative shifts. - let magnitude = abs bitMove - -- Instead of worrying about partial clearing, we just zero the entire - -- block of memory, as the cost is essentially negligible and saves us - -- a bunch of offset arithmetic. - fillBytes dstPtr 0x00 len - unless (magnitude >= bitLen) $ do - let (bigShift, smallShift) = magnitude `quotRem` 8 - case signum bitMove of - (-1) -> negativeShift (castPtr srcPtr) dstPtr bigShift smallShift - _ -> positiveShift (castPtr srcPtr) dstPtr bigShift smallShift + BSI.create len $ \dstPtr -> do + -- To simplify our calculations, we work only with absolute values, + -- letting different functions control for direction, instead of + -- trying to unify the scheme for both positive and negative shifts. + let magnitude = abs bitMove + -- Instead of worrying about partial clearing, we just zero the entire + -- block of memory, as the cost is essentially negligible and saves us + -- a bunch of offset arithmetic. + fillBytes dstPtr 0x00 len + unless (magnitude >= bitLen) $ do + let (bigShift, smallShift) = magnitude `quotRem` 8 + case signum bitMove of + (-1) -> negativeShift (castPtr srcPtr) dstPtr bigShift smallShift + _ -> positiveShift (castPtr srcPtr) dstPtr bigShift smallShift where len :: Int !len = BS.length bs @@ -874,8 +884,8 @@ findFirstSetBit bs = unsafeDupablePerformIO . BS.useAsCString bs $ \srcPtr -> do -- maths required. goBig :: Ptr Word64 -> Int -> Int -> IO Int goBig !bigSrcPtr !acc !byteIx - -- We can do at least one large step. This works because we read - -- backwards, which means that `byteIx` is the _last_ position we read + -- We can do at least one large step. This works because we read + -- backwards, which means that `byteIx` is the _last_ position we read | byteIx >= 0 = do !(w64 :: Word64) <- peekByteOff bigSrcPtr byteIx -- In theory, we could use the same technique here as we do in @@ -891,18 +901,18 @@ findFirstSetBit bs = unsafeDupablePerformIO . BS.useAsCString bs $ \srcPtr -> do if w64 == 0x0 then goBig bigSrcPtr (acc + 64) (byteIx - 8) else goSmall (castPtr bigSrcPtr) acc (byteIx + 7) - -- We've 'walked off the end' and not found anything, so everything - -- must be zeroes + -- We've 'walked off the end' and not found anything, so everything + -- must be zeroes | byteIx <= (-8) = pure (-1) - -- We can end up here in one of two ways: - -- - -- 1. Our input `ByteString` is 7 bytes long or smaller; or - -- 2. We have done all the large steps we can, and have between 1 - -- and 7 bytes to go. - -- - -- In either case, we forward the accumulator (which will be 0 in - -- case 1) to small stepping. Combining these cases allows us to - -- avoid separate tests for these conditions. + -- We can end up here in one of two ways: + -- + -- 1. Our input `ByteString` is 7 bytes long or smaller; or + -- 2. We have done all the large steps we can, and have between 1 + -- and 7 bytes to go. + -- + -- In either case, we forward the accumulator (which will be 0 in + -- case 1) to small stepping. Combining these cases allows us to + -- avoid separate tests for these conditions. | otherwise = goSmall (castPtr bigSrcPtr) acc (8 + byteIx - 1) goSmall :: Ptr Word8 -> Int -> Int -> IO Int goSmall !smallSrcPtr !acc !byteIx @@ -1050,9 +1060,9 @@ bytes, the remaining 56 bits of the GPR holding that data are essentially 'wasted'. In the situation we have (namely, operating over arrays, whose data is adjacent in memory), we thus get two sources of inefficiency: -* Despite paying the cost for a memory transfer, we transfer only one-eighth +\* Despite paying the cost for a memory transfer, we transfer only one-eighth the data we could; and -* Despite transferring data from memory to registers, we utilize the register +\* Despite transferring data from memory to registers, we utilize the register at only one-eighth capacity. This essentially means we perform _eight times_ more rotations of the loop, diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin.hs index f95c0427f6d..4dfd2195264 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin.hs @@ -1,8 +1,7 @@ -- | Reexports from modules from the @Builtin@ folder. - -module PlutusCore.Builtin - ( module Export - ) where +module PlutusCore.Builtin ( + module Export, +) where import PlutusCore.Builtin.Case as Export import PlutusCore.Builtin.HasConstant as Export diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs index 99fc4fd9b12..176887069cb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} module PlutusCore.Builtin.Case where @@ -18,45 +18,49 @@ import Text.PrettyBy (display) import Universe class AnnotateCaseBuiltin uni where - -- | Given a tag for a built-in type and a list of branches, annotate each of the branches with - -- its expected argument types or fail if casing on values of the built-in type isn't supported. - -- Note: you don't need to include the resulting type of the whole case matching in the - -- returning list here. - annotateCaseBuiltin - :: UniOf term ~ uni - => Type TyName uni ann - -> [term] - -> Either Text [(term, [Type TyName uni ann])] + -- | Given a tag for a built-in type and a list of branches, annotate each of the branches with + -- its expected argument types or fail if casing on values of the built-in type isn't supported. + -- Note: you don't need to include the resulting type of the whole case matching in the + -- returning list here. + annotateCaseBuiltin :: + UniOf term ~ uni => + Type TyName uni ann -> + [term] -> + Either Text [(term, [Type TyName uni ann])] class CaseBuiltin uni where - -- | Given a constant with its type tag and a vector of branches, choose the appropriate branch - -- or fail if the constant doesn't correspond to any of the branches (or casing on constants of - -- this type isn't supported at all). - caseBuiltin - :: UniOf term ~ uni - => Some (ValueOf uni) - -> Vector term - -> Either Text (HeadSpine term (Some (ValueOf uni))) + -- | Given a constant with its type tag and a vector of branches, choose the appropriate branch + -- or fail if the constant doesn't correspond to any of the branches (or casing on constants of + -- this type isn't supported at all). + caseBuiltin :: + UniOf term ~ uni => + Some (ValueOf uni) -> + Vector term -> + Either Text (HeadSpine term (Some (ValueOf uni))) -- See Note [DO NOT newtype-wrap functions]. + -- | A @data@ version of 'CaseBuiltin'. we parameterize the evaluator by a 'CaserBuiltin' so that -- the caller can choose whether to use the 'caseBuiltin' method or the always failing caser (the -- latter is required for earlier protocol versions when we didn't support casing on builtins). data CaserBuiltin uni = CaserBuiltin - { unCaserBuiltin - :: !(forall term. UniOf term ~ uni => Some (ValueOf uni) -> Vector term -> Either Text (HeadSpine term (Some (ValueOf uni)))) - } + { unCaserBuiltin :: + !(forall term. UniOf term ~ uni => Some (ValueOf uni) -> Vector term -> Either Text (HeadSpine term (Some (ValueOf uni)))) + } instance NFData (CaserBuiltin uni) where - rnf = rwhnf + rnf = rwhnf -deriving via OnlyCheckWhnfNamed "PlutusCore.Builtin.Case.CaserBuiltin" (CaserBuiltin uni) - instance NoThunks (CaserBuiltin uni) +deriving via + OnlyCheckWhnfNamed "PlutusCore.Builtin.Case.CaserBuiltin" (CaserBuiltin uni) + instance + NoThunks (CaserBuiltin uni) instance CaseBuiltin uni => Default (CaserBuiltin uni) where - def = CaserBuiltin caseBuiltin + def = CaserBuiltin caseBuiltin unavailableCaserBuiltin :: Int -> CaserBuiltin uni unavailableCaserBuiltin ver = - CaserBuiltin $ \_ _ -> Left $ - "'case' on values of built-in types is not supported in protocol version " <> display ver + CaserBuiltin $ \_ _ -> + Left $ + "'case' on values of built-in types is not supported in protocol version " <> display ver diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Debug.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Debug.hs index 8b959de9ffd..fb74581fffe 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Debug.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Debug.hs @@ -1,16 +1,15 @@ +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-} -{-# LANGUAGE DataKinds #-} - -- | This module helps to visualize and debug the 'BuiltinMeaning' inference machinery from the -- @Elaborate@ and @Meaning@ modules. -module PlutusCore.Builtin.Debug - ( elaborateDebug - , makeBuiltinMeaningDebug +module PlutusCore.Builtin.Debug ( + elaborateDebug, + makeBuiltinMeaningDebug, -- Reexporting a bunch of stuff, so that debug output is not littered with module names. - , module Export - ) where + module Export, +) where import PlutusCore.Builtin.Elaborate as Export import PlutusCore.Builtin.Meaning as Export @@ -27,9 +26,10 @@ import PlutusCore.Name.Unique as Export -- elaborateDebug fst -- :: (TyVarRep ('TyNameRep "a" 0), TyVarRep ('TyNameRep "b" 1)) -- -> TyVarRep ('TyNameRep "a" 0) -elaborateDebug - :: forall a j. ElaborateFromTo DefaultUni 0 j (Term TyName Name DefaultUni DefaultFun ()) a - => a -> a +elaborateDebug :: + forall a j. + ElaborateFromTo DefaultUni 0 j (Term TyName Name DefaultUni DefaultFun ()) a => + a -> a elaborateDebug = id -- >>> :t makeBuiltinMeaningDebug $ \_ -> () @@ -107,7 +107,8 @@ elaborateDebug = id -- To fix this error apply type variables via explicit ‘TyAppRep’ -- • In the expression: -- makeBuiltinMeaningDebug (undefined :: Opaque val (f Bool) -> ()) -makeBuiltinMeaningDebug - :: forall a. MakeBuiltinMeaning a (Term TyName Name DefaultUni DefaultFun ()) - => a -> a +makeBuiltinMeaningDebug :: + forall a. + MakeBuiltinMeaning a (Term TyName Name DefaultUni DefaultFun ()) => + a -> a makeBuiltinMeaningDebug = id diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Elaborate.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Elaborate.hs index 9ab3ad40f8c..6b38ff3b1f7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Elaborate.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Elaborate.hs @@ -1,21 +1,20 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- editorconfig-checker-disable-file -- GHC doesn't like the definition of 'TrySpecializeAsVar'. {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Builtin.Elaborate - ( ElaborateFromTo - ) where +module PlutusCore.Builtin.Elaborate ( + ElaborateFromTo, +) where import PlutusCore.Builtin.KnownTypeAst import PlutusCore.Builtin.Polymorphism @@ -30,14 +29,16 @@ import GHC.TypeLits -- A heterogeneous version of @Type.Equality.(==)@. type (===) :: forall a b. a -> b -> Bool type family x === y where - x === x = 'True - x === y = 'False + x === x = 'True + x === y = 'False -- Explained in detail in https://github.com/effectfully-ou/sketches/tree/cbf3ee9d11e0e3d4fc397ce7bf419418224122e2/poly-type-of-saga/part1-try-unify + -- | Unify two values if possible, otherwise leave them alone. Useful for instantiating type -- variables. type TryUnify :: forall a b. Bool -> a -> b -> GHC.Constraint class same ~ (x === y) => TryUnify same x y + instance (x === y) ~ 'False => TryUnify 'False x y instance {-# INCOHERENT #-} (x ~~ y, same ~ 'True) => TryUnify same x y @@ -51,22 +52,22 @@ type x ~?~ y = TryUnify (x === y) x y -- | Get the element at an @i@th position in a list. type Lookup :: forall a. Nat -> [a] -> a type family Lookup n xs where - Lookup _ '[] = TypeError ('Text "Not enough elements") - Lookup 0 (x ': xs) = x - Lookup n (_ ': xs) = Lookup (n - 1) xs + Lookup _ '[] = TypeError ('Text "Not enough elements") + Lookup 0 (x ': xs) = x + Lookup n (_ ': xs) = Lookup (n - 1) xs -- | Get the name at the @i@th position in the list of default names. We could use @a_0@, @a_1@, -- @a_2@ etc instead, but @a@, @b@, @c@ etc are nicer. type GetName :: GHC.Type -> Nat -> Symbol type family GetName k i where - GetName GHC.Type i = Lookup i '["a", "b", "c", "d", "e", "i", "j", "k", "l"] - GetName _ i = Lookup i '["f", "g", "h", "m", "n"] -- For higher-kinded types. + GetName GHC.Type i = Lookup i '["a", "b", "c", "d", "e", "i", "j", "k", "l"] + GetName _ i = Lookup i '["f", "g", "h", "m", "n"] -- For higher-kinded types. -- | Apply the function stored in the provided 'Maybe' if there's one. type MaybeApply :: forall k. Maybe (k -> k) -> k -> k type family MaybeApply mayVal x where - MaybeApply 'Nothing a = a - MaybeApply ('Just f) a = f a + MaybeApply 'Nothing a = a + MaybeApply ('Just f) a = f a -- | Try to specialize @a@ as a type representing a PLC type variable. -- @i@ is a fresh id and @j@ is a final one (either @i + 1@ or @i@ depending on whether @@ -75,168 +76,187 @@ type family MaybeApply mayVal x where -- used). type TrySpecializeAsVar :: forall k. Nat -> Nat -> Maybe (k -> k) -> k -> GHC.Constraint class TrySpecializeAsVar i j mw a | i mw a -> j + instance - ( var ~ MaybeApply mw (TyVarRep @k ('TyNameRep (GetName k i) i)) - -- Try to unify @a@ with a freshly created @var@. - , a ~?~ var - -- If @a@ is equal to @var@ then unification was successful and we just used the fresh id and + ( var ~ MaybeApply mw (TyVarRep @k ('TyNameRep (GetName k i) i)) + , -- Try to unify @a@ with a freshly created @var@. + a ~?~ var + , -- If @a@ is equal to @var@ then unification was successful and we just used the fresh id and -- so we need to bump it up. Otherwise @var@ was discarded and so the fresh id is still fresh. -- Replacing @(===)@ with @(==)@ causes errors at use site, for whatever reason. - , j ~ If (a === var) (i + 1) i - ) => TrySpecializeAsVar i j mw (a :: k) + j ~ If (a === var) (i + 1) i + ) => + TrySpecializeAsVar i j mw (a :: k) type NoAppliedVarsHeader = - 'Text "A built-in function is not allowed to have applied type variables in its type" + 'Text "A built-in function is not allowed to have applied type variables in its type" -- See Note [Rep vs Type context]. + -- | Throw an error telling the user not to apply type variables to anything. type ThrowNoAppliedVars :: (GHC.Type -> GHC.Type) -> GHC.Constraint type family ThrowNoAppliedVars hole where - -- In the Rep context higher-kinded type variables are allowed, but need to be applied via - -- 'TyAppRep', hence the error message. - ThrowNoAppliedVars RepHole = TypeError - ( NoAppliedVarsHeader - ':$$: 'Text "To fix this error apply type variables via explicit ‘TyAppRep’" - ) - -- In the Type context no higher-kinded type variables are allowed. - ThrowNoAppliedVars TypeHole = TypeError - ( NoAppliedVarsHeader - ':$$: 'Text "To fix this error specialize all higher-kinded type variables" - ) - -- In case we add more contexts. - ThrowNoAppliedVars _ = TypeError - ( NoAppliedVarsHeader - ':$$: 'Text "Internal error: the context is not recognized. Please report" - ) + -- In the Rep context higher-kinded type variables are allowed, but need to be applied via + -- 'TyAppRep', hence the error message. + ThrowNoAppliedVars RepHole = + TypeError + ( NoAppliedVarsHeader + ':$$: 'Text "To fix this error apply type variables via explicit ‘TyAppRep’" + ) + -- In the Type context no higher-kinded type variables are allowed. + ThrowNoAppliedVars TypeHole = + TypeError + ( NoAppliedVarsHeader + ':$$: 'Text "To fix this error specialize all higher-kinded type variables" + ) + -- In case we add more contexts. + ThrowNoAppliedVars _ = + TypeError + ( NoAppliedVarsHeader + ':$$: 'Text "Internal error: the context is not recognized. Please report" + ) -- | Check that the higher-kinded type does not represent a PLC type variable and if it does. type CheckNotAppliedVar :: forall k. (GHC.Type -> GHC.Type) -> k -> GHC.Constraint type family CheckNotAppliedVar hole a where - CheckNotAppliedVar hole (TyVarRep _) = ThrowNoAppliedVars hole - CheckNotAppliedVar _ _ = () + CheckNotAppliedVar hole (TyVarRep _) = ThrowNoAppliedVars hole + CheckNotAppliedVar _ _ = () -- | Try to specialize the head of a (possibly nullary) type application to a type representing a -- PLC variable and throw if that succeeds or if it already was one. -type TrySpecializeHeadAsVar - :: forall a b. Nat -> Nat -> (GHC.Type -> GHC.Type) -> (a -> b) -> GHC.Constraint +type TrySpecializeHeadAsVar :: + forall a b. Nat -> Nat -> (GHC.Type -> GHC.Type) -> (a -> b) -> GHC.Constraint class TrySpecializeHeadAsVar i j hole f | i f -> j + -- | Recurse to reach the head. -instance {-# OVERLAPPABLE #-} - TrySpecializeHeadAsVar i j hole f => TrySpecializeHeadAsVar i j hole (f x) +instance {-# OVERLAPPABLE #-} TrySpecializeHeadAsVar i j hole f => TrySpecializeHeadAsVar i j hole (f x) + -- | Reached the head, it's a 'TyVarRep', throwing. Mostly to ensure that a 'TyVarRep' doesn't slip -- in via user input, but also out of pure paranoia (GHC seems to occasionally solve constraints -- for the same type multiple times by racing through different routes in the presence of -- @INCOHERENT@ pragmas, but this is not confirmed. It wouldn't be unreasonable, though). -instance {-# OVERLAPPING #-} - (ThrowNoAppliedVars hole, i ~ j) => TrySpecializeHeadAsVar i j hole (TyVarRep name) +instance {-# OVERLAPPING #-} (ThrowNoAppliedVars hole, i ~ j) => TrySpecializeHeadAsVar i j hole (TyVarRep name) + -- | Reached the head, try to specialize it as a variable and throw if that succeeds. -instance {-# INCOHERENT #-} - ( TrySpecializeAsVar i j 'Nothing f - , CheckNotAppliedVar hole f - ) => TrySpecializeHeadAsVar i j hole f - -{- | Try to specialize @a@ as a type representing a PLC type variable. -Same as 'TrySpecializeAsVar' (in particular, the parameters are the same), except this one also -checks if the given type is a type application, in which case it tries to specialize the head of the -application to a type representing a PLC type variable and throws if that succeeds. - -We need this because blindly specializing an @f A@ (where @f@ is a type variable and @A@ is an -arbitrary type) in the Type context would give us @Opaque val A@ (by @f ~ Opaque val@) instead of -@Opaque val (f' A)@, which would be very confusing to the user: the only reasonable way to elaborate -an application of a type variable in Haskell is to make an application of a type variable in PLC, -not to randomly drop the type variable. - -There's no way we could elaborate an applied type variable without surprising the user, because no -instantiation of @f@ could turn @f A@ into @Opaque val (f' A)@, hence we simply forbid applied type -variables and throw upon encountering one. It would be a pain to handle an iterated application of a -type representing a PLC type variable anyway. - -It's not possible to determine if @Opaque val A@ is a specialization of @f a@ or @a@ (for a type -variable @a@), hence we have to make this whole check during elaboration and not any later. - -Regardless of whether the given argument is a type application or not, it's attempted to be -specialized as a type representing a PLC type variable, because such a type is a type application -itself. Unifying an already known type variable with a fresh one is useful when the name part -of the former is unknown. --} -type TrySpecializeAsUnappliedVar - :: forall k. Nat -> Nat -> (GHC.Type -> GHC.Type) -> Maybe (k -> k) -> k -> GHC.Constraint +instance + {-# INCOHERENT #-} + ( TrySpecializeAsVar i j 'Nothing f + , CheckNotAppliedVar hole f + ) => + TrySpecializeHeadAsVar i j hole f + +-- | Try to specialize @a@ as a type representing a PLC type variable. +-- Same as 'TrySpecializeAsVar' (in particular, the parameters are the same), except this one also +-- checks if the given type is a type application, in which case it tries to specialize the head of the +-- application to a type representing a PLC type variable and throws if that succeeds. +-- +-- We need this because blindly specializing an @f A@ (where @f@ is a type variable and @A@ is an +-- arbitrary type) in the Type context would give us @Opaque val A@ (by @f ~ Opaque val@) instead of +-- @Opaque val (f' A)@, which would be very confusing to the user: the only reasonable way to elaborate +-- an application of a type variable in Haskell is to make an application of a type variable in PLC, +-- not to randomly drop the type variable. +-- +-- There's no way we could elaborate an applied type variable without surprising the user, because no +-- instantiation of @f@ could turn @f A@ into @Opaque val (f' A)@, hence we simply forbid applied type +-- variables and throw upon encountering one. It would be a pain to handle an iterated application of a +-- type representing a PLC type variable anyway. +-- +-- It's not possible to determine if @Opaque val A@ is a specialization of @f a@ or @a@ (for a type +-- variable @a@), hence we have to make this whole check during elaboration and not any later. +-- +-- Regardless of whether the given argument is a type application or not, it's attempted to be +-- specialized as a type representing a PLC type variable, because such a type is a type application +-- itself. Unifying an already known type variable with a fresh one is useful when the name part +-- of the former is unknown. +type TrySpecializeAsUnappliedVar :: + forall k. Nat -> Nat -> (GHC.Type -> GHC.Type) -> Maybe (k -> k) -> k -> GHC.Constraint class TrySpecializeAsUnappliedVar i j hole mw a | i mw a -> j + instance - ( TrySpecializeHeadAsVar i j hole f - , TrySpecializeAsVar j k mw (f x) - ) => TrySpecializeAsUnappliedVar i k hole mw (f x) + ( TrySpecializeHeadAsVar i j hole f + , TrySpecializeAsVar j k mw (f x) + ) => + TrySpecializeAsUnappliedVar i k hole mw (f x) instance {-# INCOHERENT #-} TrySpecializeAsVar i j mw a => TrySpecializeAsUnappliedVar i j hole mw a -- See Note [Rep vs Type context] + -- | First try to specialize the hole using 'TrySpecializeAsVar' and then recurse on the result of -- that using 'HandleHoles'. -- @i@ is a fresh id and @j@ is a final one as in 'TrySpecializeAsVar', but since 'HandleHole' can -- specialize multiple variables, @j@ can be equal to @i + n@ for any @n@ (including @0@). type HandleHole :: (GHC.Type -> GHC.Type) -> Nat -> Nat -> GHC.Type -> Hole -> GHC.Constraint class HandleHole uni i j val hole | uni i val hole -> j + -- In the Rep context @x@ is attempted to be specialized as a 'TyVarRep'. instance - ( TrySpecializeAsUnappliedVar i j RepHole 'Nothing x - , HandleHoles uni j k val RepHole x - ) => HandleHole uni i k val (RepHole x) + ( TrySpecializeAsUnappliedVar i j RepHole 'Nothing x + , HandleHoles uni j k val RepHole x + ) => + HandleHole uni i k val (RepHole x) + -- In the Type context @a@ is attempted to be specialized as a 'TyVarRep' wrapped in @Opaque val@. instance - ( TrySpecializeAsUnappliedVar i j TypeHole ('Just (Opaque val)) a - , HandleHoles uni j k val TypeHole a - ) => HandleHole uni i k val (TypeHole a) + ( TrySpecializeAsUnappliedVar i j TypeHole ('Just (Opaque val)) a + , HandleHoles uni j k val TypeHole a + ) => + HandleHole uni i k val (TypeHole a) -- | Call 'HandleHole' over each hole from the list, threading the state (the fresh unique) through -- the calls. type HandleHolesGo :: (GHC.Type -> GHC.Type) -> Nat -> Nat -> GHC.Type -> [Hole] -> GHC.Constraint class HandleHolesGo uni i j val holes | uni i val holes -> j + instance i ~ j => HandleHolesGo uni i j val '[] instance - ( HandleHole uni i j val hole - , HandleHolesGo uni j k val holes - ) => HandleHolesGo uni i k val (hole ': holes) + ( HandleHole uni i j val hole + , HandleHolesGo uni j k val holes + ) => + HandleHolesGo uni i k val (hole ': holes) -- | If the outermost constructor of the second argument is known and happens to be one of the -- constructors of the list data type, then the second argument is returned back. Otherwise the -- first one is returned, which is meant to be a custom type error. type ThrowOnStuckList :: forall a. [a] -> [a] -> [a] type family ThrowOnStuckList err xs where - ThrowOnStuckList _ '[] = '[] - ThrowOnStuckList _ (x ': xs) = x ': xs - ThrowOnStuckList err _ = err + ThrowOnStuckList _ '[] = '[] + ThrowOnStuckList _ (x ': xs) = x ': xs + ThrowOnStuckList err _ = err type UnknownTypeError :: forall a any. GHC.Type -> a -> any type family UnknownTypeError val x where - UnknownTypeError val x = TypeError - ( 'Text "No instance for ‘KnownTypeAst " - ':<>: 'ShowType (UniOf val) - ':<>: 'Text " (" - ':<>: 'ShowType x - ':<>: 'Text ")’" - ':$$: 'Text "Which means" - ':$$: 'Text " ‘" ':<>: 'ShowType x ':<>: 'Text "’" - ':$$: 'Text "is neither a built-in type, nor one of the control types." - ':$$: 'Text "If it can be represented in terms of one of the built-in types" - ':$$: 'Text " then go add the instance (you may need a few others too)" - ':$$: 'Text " alongside the instance for the built-in type." - ':$$: 'Text "Otherwise you may need to add a new built-in type" - ':$$: 'Text " (provided you're doing something that can be supported in principle)" - ) + UnknownTypeError val x = + TypeError + ( 'Text "No instance for ‘KnownTypeAst " + ':<>: 'ShowType (UniOf val) + ':<>: 'Text " (" + ':<>: 'ShowType x + ':<>: 'Text ")’" + ':$$: 'Text "Which means" + ':$$: 'Text " ‘" ':<>: 'ShowType x ':<>: 'Text "’" + ':$$: 'Text "is neither a built-in type, nor one of the control types." + ':$$: 'Text "If it can be represented in terms of one of the built-in types" + ':$$: 'Text " then go add the instance (you may need a few others too)" + ':$$: 'Text " alongside the instance for the built-in type." + ':$$: 'Text "Otherwise you may need to add a new built-in type" + ':$$: 'Text " (provided you're doing something that can be supported in principle)" + ) -- | Get the holes of @x@ and recurse into them. -type HandleHoles - :: forall a. (GHC.Type -> GHC.Type) -> Nat -> Nat -> GHC.Type -> (GHC.Type -> GHC.Type) -> a -> GHC.Constraint +type HandleHoles :: + forall a. (GHC.Type -> GHC.Type) -> Nat -> Nat -> GHC.Type -> (GHC.Type -> GHC.Type) -> a -> GHC.Constraint type HandleHoles uni i j val hole x = - -- Here we detect a stuck application of 'ToHoles' and throw 'UnknownTypeError' on it. - -- See https://blog.csongor.co.uk/report-stuck-families for a detailed description of how - -- detection of stuck type families works. - HandleHolesGo uni i j val (ThrowOnStuckList (UnknownTypeError val x) (ToHoles uni hole x)) + -- Here we detect a stuck application of 'ToHoles' and throw 'UnknownTypeError' on it. + -- See https://blog.csongor.co.uk/report-stuck-families for a detailed description of how + -- detection of stuck type families works. + HandleHolesGo uni i j val (ThrowOnStuckList (UnknownTypeError val x) (ToHoles uni hole x)) -- Check out the following for a detailed explanation of the idea (after learning about 'TryUnify'): -- https://github.com/effectfully-ou/sketches/tree/cbf3ee9d11e0e3d4fc397ce7bf419418224122e2/poly-type-of-saga/part2-enumerate-type-vars + -- | Specialize each Haskell type variable in @a@ as a type representing a PLC type variable. -- @i@ is a fresh id and @j@ is a final one as in 'TrySpecializeAsVar', but since 'HandleHole' can -- specialize multiple variables, @j@ can be equal to @i + n@ for any @n@ (including @0@). -type ElaborateFromTo - :: (GHC.Type -> GHC.Type) -> Nat -> Nat -> GHC.Type -> GHC.Type -> GHC.Constraint +type ElaborateFromTo :: + (GHC.Type -> GHC.Type) -> Nat -> Nat -> GHC.Type -> GHC.Type -> GHC.Constraint type ElaborateFromTo uni i j val a = HandleHole uni i j val (TypeHole a) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/HasConstant.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/HasConstant.hs index ad848cfbb46..63389547147 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/HasConstant.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/HasConstant.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module PlutusCore.Builtin.HasConstant - ( BuiltinError (..) - , notAConstant - , HasConstant (..) - , HasConstantIn - , fromValueOf - , fromValue - ) where +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module PlutusCore.Builtin.HasConstant ( + BuiltinError (..), + notAConstant, + HasConstant (..), + HasConstantIn, + fromValueOf, + fromValue, +) where import PlutusCore.Builtin.Result import PlutusCore.Core @@ -32,15 +32,17 @@ see Note [The CostingPart constraint in mkMachineParameters]. -- See Note [Existence of HasConstant]. -- We name it @term@ rather than @val@, because various @Term@ (UPLC/TPLC/PIR) data types have -- 'Constant'-like constructors too and we lift to / unlift from those in tests. + -- | Ensures that @term@ has a 'Constant'-like constructor to lift values to and unlift values from. class HasConstant term where - -- Switching from 'MonadError' to 'Either' here gave us a speedup of 2-4%. - -- | Unwrap from a 'Constant'-like constructor throwing an 'UnliftingError' if the provided - -- @term@ is not a wrapped Haskell value. - asConstant :: term -> Either BuiltinError (Some (ValueOf (UniOf term))) + -- Switching from 'MonadError' to 'Either' here gave us a speedup of 2-4%. + + -- | Unwrap from a 'Constant'-like constructor throwing an 'UnliftingError' if the provided + -- @term@ is not a wrapped Haskell value. + asConstant :: term -> Either BuiltinError (Some (ValueOf (UniOf term))) - -- | Wrap a Haskell value as a @term@. - fromConstant :: Some (ValueOf (UniOf term)) -> term + -- | Wrap a Haskell value as a @term@. + fromConstant :: Some (ValueOf (UniOf term)) -> term -- | Ensures that @term@ has a 'Constant'-like constructor to lift values to and unlift values from -- and connects @term@ and its @uni@. @@ -57,7 +59,7 @@ fromValue = fromValueOf knownUni {-# INLINE fromValue #-} instance HasConstant (Term TyName Name uni fun ()) where - asConstant (Constant _ val) = pure val - asConstant _ = throwError notAConstant + asConstant (Constant _ val) = pure val + asConstant _ = throwError notAConstant - fromConstant = Constant () + fromConstant = Constant () diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownKind.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownKind.hs index 1c49b758134..7de9cf9ccc4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownKind.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownKind.hs @@ -1,10 +1,10 @@ -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module PlutusCore.Builtin.KnownKind where @@ -21,37 +21,37 @@ infixr 5 `SingKindArrow` -- Indexing by a Haskell kind allows us to avoid an 'error' call in the 'ToKind' instance of -- 'DefaultUni' and not worry about proxies in the type of 'knownKind'. data SingKind k where - SingType :: SingKind GHC.Type - SingKindArrow :: SingKind k -> SingKind l -> SingKind (k -> l) + SingType :: SingKind GHC.Type + SingKindArrow :: SingKind k -> SingKind l -> SingKind (k -> l) -- | Feed the 'SingKind' version of the given 'Kind' to the given continuation. withSingKind :: Kind ann -> (forall k. SingKind k -> r) -> r withSingKind (Type _) k = k SingType withSingKind (KindArrow _ dom cod) k = - withSingKind dom $ \domS -> - withSingKind cod $ \codS -> - k $ SingKindArrow domS codS + withSingKind dom $ \domS -> + withSingKind cod $ \codS -> + k $ SingKindArrow domS codS -- | For reifying Haskell kinds representing Plutus kinds at the term level. class KnownKind k where - knownKind :: SingKind k + knownKind :: SingKind k -- | Plutus only supports lifted types, hence the equality constraint. instance rep ~ LiftedRep => KnownKind (TYPE rep) where - knownKind = SingType + knownKind = SingType instance (KnownKind dom, KnownKind cod) => KnownKind (dom -> cod) where - knownKind = SingKindArrow (knownKind @dom) (knownKind @cod) + knownKind = SingKindArrow (knownKind @dom) (knownKind @cod) -- | Satisfy the 'KnownKind' constraint of a continuation using the given 'SingKind'. bringKnownKind :: SingKind k -> (KnownKind k => r) -> r -bringKnownKind SingType r = r +bringKnownKind SingType r = r bringKnownKind (SingKindArrow dom cod) r = bringKnownKind dom $ bringKnownKind cod r withKnownKind :: Kind ann -> (forall k. KnownKind k => Proxy k -> r) -> r withKnownKind kind k = - withSingKind kind $ \(kindS :: SingKind kind) -> - bringKnownKind kindS $ k $ Proxy @kind + withSingKind kind $ \(kindS :: SingKind kind) -> + bringKnownKind kindS $ k $ Proxy @kind -- We need this for type checking Plutus, however we get Plutus types/terms/programs by either -- producing them directly or by parsing/decoding them and in both the cases we have access to the @@ -60,14 +60,15 @@ withKnownKind kind k = -- That might be less efficient and probably requires updating the Plutus Tx compiler, so we went -- with the simplest option for now and it's to have a class. Providing an instance per universe is -- no big deal. + -- | For computing the Plutus kind of a built-in type. See 'kindOfBuiltinType'. class ToKind (uni :: GHC.Type -> GHC.Type) where - -- | Reify the kind of a type from the universe at the term level. - toSingKind :: uni (Esc (a :: k)) -> SingKind k + -- | Reify the kind of a type from the universe at the term level. + toSingKind :: uni (Esc (a :: k)) -> SingKind k -- | Convert a reified Haskell kind to a Plutus kind. demoteKind :: SingKind k -> Kind () -demoteKind SingType = Type () +demoteKind SingType = Type () demoteKind (SingKindArrow dom cod) = KindArrow () (demoteKind dom) (demoteKind cod) -- | Compute the kind of a type from a universe. diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs index 0dbc43a4e2b..17e705786ec 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs @@ -1,41 +1,40 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE StrictData #-} - -module PlutusCore.Builtin.KnownType - ( BuiltinError - , GEqL (..) - , LoopBreaker (..) - , KnownBuiltinTypeIn - , KnownBuiltinType - , BuiltinResult (..) - , ReadKnownM - , Spine (..) - , HeadSpine (..) - , headSpine - , MonoHeadSpine - , MakeKnownIn (..) - , readKnownConstant - , MakeKnown - , ReadKnownIn (..) - , ReadKnown - , makeKnownOrFail - , readKnownSelf - ) where +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module PlutusCore.Builtin.KnownType ( + BuiltinError, + GEqL (..), + LoopBreaker (..), + KnownBuiltinTypeIn, + KnownBuiltinType, + BuiltinResult (..), + ReadKnownM, + Spine (..), + HeadSpine (..), + headSpine, + MonoHeadSpine, + MakeKnownIn (..), + readKnownConstant, + MakeKnown, + ReadKnownIn (..), + ReadKnown, + makeKnownOrFail, + readKnownSelf, +) where import PlutusPrelude @@ -77,7 +76,7 @@ import Universe -- was written. type GEqL :: (GHC.Type -> GHC.Type) -> GHC.Type -> GHC.Constraint class GEqL f a where - geqL :: f (Esc a) -> f (Esc b) -> EvaluationResult (a :~: b) + geqL :: f (Esc a) -> f (Esc b) -> EvaluationResult (a :~: b) -- | In @f = ... f ...@ where @f@ is a class method, how do you know if @f@ is going to be a -- recursive call or a type class method call? If both type check, then you don't really know how @@ -90,13 +89,13 @@ class GEqL f a where newtype LoopBreaker uni a = LoopBreaker (uni a) instance GEqL uni a => GEqL (LoopBreaker uni) a where - geqL = coerce $ geqL @uni - {-# INLINE geqL #-} + geqL = coerce $ geqL @uni + {-# INLINE geqL #-} -- | A constraint for \"@a@ is a 'ReadKnownIn' and 'MakeKnownIn' by means of being included -- in @uni@\". type KnownBuiltinTypeIn uni val a = - (HasConstantIn uni val, PrettyParens (SomeTypeIn uni), GEqL uni a, uni `HasTermLevel` a) + (HasConstantIn uni val, PrettyParens (SomeTypeIn uni), GEqL uni a, uni `HasTermLevel` a) -- | A constraint for \"@a@ is a 'ReadKnownIn' and 'MakeKnownIn' by means of being included -- in @UniOf term@\". @@ -282,17 +281,18 @@ Lifting is allowed to the following classes of types: one, and for another example define an instance for 'Void' in tests -} -typeMismatchError - :: PrettyParens (SomeTypeIn uni) - => uni (Esc a) - -> uni (Esc b) - -> UnliftingEvaluationError +typeMismatchError :: + PrettyParens (SomeTypeIn uni) => + uni (Esc a) -> + uni (Esc b) -> + UnliftingEvaluationError typeMismatchError uniExp uniAct = - MkUnliftingEvaluationError . StructuralError . fromString $ concat - [ "Type mismatch: " - , "expected: " ++ displayBy botRenderContext (SomeTypeIn uniExp) - , "; actual: " ++ displayBy botRenderContext (SomeTypeIn uniAct) - ] + MkUnliftingEvaluationError . StructuralError . fromString $ + concat + [ "Type mismatch: " + , "expected: " ++ displayBy botRenderContext (SomeTypeIn uniExp) + , "; actual: " ++ displayBy botRenderContext (SomeTypeIn uniAct) + ] -- See Note [INLINE and OPAQUE on error-related definitions]. {-# OPAQUE typeMismatchError #-} @@ -302,31 +302,34 @@ typeMismatchError uniExp uniAct = -- instances (and add new ones whenever we need them), wrap and unwrap all the time (including in -- user code), which can be non-trivial for such performance-sensitive code (see e.g. '(#.)' and -- 'coerceArg') and there is no abstraction barrier anyway. + -- | The monad that 'readKnown' runs in. type ReadKnownM = Either BuiltinError -- See Note [Unlifting a term as a value of a built-in type]. + -- | Convert a constant embedded into a PLC term to the corresponding Haskell value. readKnownConstant :: forall val a. KnownBuiltinType val a => val -> ReadKnownM a -- See Note [Performance of ReadKnownIn and MakeKnownIn instances] -readKnownConstant val = asConstant val >>= oneShot \case +readKnownConstant val = + asConstant val >>= oneShot \case Some (ValueOf uniAct x) -> do - let uniExp = knownUni @_ @(UniOf val) @a - -- 'geq' matches on its first argument first, so we make the type tag that will be known - -- statically (because this function will be inlined) go first in order for GHC to - -- optimize some of the matching away. - case uniExp `geqL` uniAct of - EvaluationSuccess Refl -> pure x - EvaluationFailure -> - throwError . BuiltinUnliftingEvaluationError $ typeMismatchError uniExp uniAct + let uniExp = knownUni @_ @(UniOf val) @a + -- 'geq' matches on its first argument first, so we make the type tag that will be known + -- statically (because this function will be inlined) go first in order for GHC to + -- optimize some of the matching away. + case uniExp `geqL` uniAct of + EvaluationSuccess Refl -> pure x + EvaluationFailure -> + throwError . BuiltinUnliftingEvaluationError $ typeMismatchError uniExp uniAct {-# INLINE readKnownConstant #-} -- | A non-empty spine. Isomorphic to 'NonEmpty', except is strict and is defined as a single -- recursive data type. data Spine a - = SpineLast a - | SpineCons a (Spine a) - deriving stock (Show, Eq, Foldable, Functor) + = SpineLast a + | SpineCons a (Spine a) + deriving stock (Show, Eq, Foldable, Functor) -- | The head-spine form of an iterated application. Provides O(1) access to the head of the -- application. @NonEmpty a ~ HeadSpine a a@, except is strict and the no-spine case is made a separate @@ -336,21 +339,21 @@ data Spine a -- -- Used in built-in functions returning function applications such as 'CaseList'. data HeadSpine a b - = HeadOnly a - | HeadSpine a (Spine b) - deriving stock (Show, Eq, Functor) + = HeadOnly a + | HeadSpine a (Spine b) + deriving stock (Show, Eq, Functor) -- | @HeadSpine@ but the type of head and spine is same type MonoHeadSpine a = HeadSpine a a instance Bifunctor HeadSpine where - bimap headF _ (HeadOnly a) = HeadOnly $ headF a + bimap headF _ (HeadOnly a) = HeadOnly $ headF a bimap headF spineF (HeadSpine a b) = HeadSpine (headF a) (spineF <$> b) -- | Construct @HeadSpine@ from head and list. headSpine :: a -> [b] -> HeadSpine a b headSpine h [] = HeadOnly h -headSpine h (x:xs) = +headSpine h (x : xs) = -- It's critical to use 'foldr' here, so that deforestation kicks in. -- See Note [Definition of foldl'] in "GHC.List" and related Notes around for an explanation -- of the trick. @@ -363,9 +366,12 @@ headSpine h (x:xs) = -- >>> pretty (SpineCons 'a' $ SpineLast 'b') -- [a, b] instance Pretty a => Pretty (Spine a) where pretty = pretty . map Identity . toList + instance PrettyBy config a => DefaultPrettyBy config (Spine a) -deriving via PrettyCommon (Spine a) - instance PrettyDefaultBy config (Spine a) => PrettyBy config (Spine a) +deriving via + PrettyCommon (Spine a) + instance + PrettyDefaultBy config (Spine a) => PrettyBy config (Spine a) -- | -- @@ -375,62 +381,65 @@ deriving via PrettyCommon (Spine a) -- >>> pretty (HeadSpine 'f' (SpineCons 'x' $ SpineLast 'y')) -- f `applyN` [x, y] instance (Pretty a, Pretty b) => Pretty (HeadSpine a b) where - pretty (HeadOnly x) = pretty x - pretty (HeadSpine f xs) = pretty f <+> "`applyN`" <+> pretty xs + pretty (HeadOnly x) = pretty x + pretty (HeadSpine f xs) = pretty f <+> "`applyN`" <+> pretty xs + instance (PrettyBy config a, PrettyBy config b) => DefaultPrettyBy config (HeadSpine a b) -deriving via PrettyCommon (HeadSpine a b) - instance PrettyDefaultBy config (HeadSpine a b) => PrettyBy config (HeadSpine a b) +deriving via + PrettyCommon (HeadSpine a b) + instance + PrettyDefaultBy config (HeadSpine a b) => PrettyBy config (HeadSpine a b) -- See Note [Performance of ReadKnownIn and MakeKnownIn instances]. class uni ~ UniOf val => MakeKnownIn uni val a where - -- | Convert a Haskell value to the corresponding PLC value. - -- The inverse of 'readKnown'. - makeKnown :: a -> BuiltinResult val - default makeKnown :: KnownBuiltinType val a => a -> BuiltinResult val - -- Everything on evaluation path has to be strict in production, so in theory we don't need to - -- force anything here. In practice however all kinds of weird things happen in tests and @val@ - -- can be non-strict enough to cause trouble here, so we're forcing the argument. Looking at the - -- generated Core, the forcing amounts to pulling a @case@ out of the 'fromConstant' call, - -- which doesn't affect the overall cost and benchmarking results suggest the same. - -- - -- Note that the value is only forced to WHNF, so care must be taken to ensure that every value - -- of a type from the universe gets forced to NF whenever it's forced to WHNF. - makeKnown x = pure . fromValue $! x - {-# INLINE makeKnown #-} + -- | Convert a Haskell value to the corresponding PLC value. + -- The inverse of 'readKnown'. + makeKnown :: a -> BuiltinResult val + default makeKnown :: KnownBuiltinType val a => a -> BuiltinResult val + -- Everything on evaluation path has to be strict in production, so in theory we don't need to + -- force anything here. In practice however all kinds of weird things happen in tests and @val@ + -- can be non-strict enough to cause trouble here, so we're forcing the argument. Looking at the + -- generated Core, the forcing amounts to pulling a @case@ out of the 'fromConstant' call, + -- which doesn't affect the overall cost and benchmarking results suggest the same. + -- + -- Note that the value is only forced to WHNF, so care must be taken to ensure that every value + -- of a type from the universe gets forced to NF whenever it's forced to WHNF. + makeKnown x = pure . fromValue $! x + {-# INLINE makeKnown #-} type MakeKnown val = MakeKnownIn (UniOf val) val -- See Note [Performance of ReadKnownIn and MakeKnownIn instances]. class uni ~ UniOf val => ReadKnownIn uni val a where - -- | Convert a PLC value to the corresponding Haskell value. - -- The inverse of 'makeKnown'. - readKnown :: val -> ReadKnownM a - default readKnown :: KnownBuiltinType val a => val -> ReadKnownM a - -- If 'inline' is not used, proper inlining does not happen for whatever reason. - readKnown = inline readKnownConstant - {-# INLINE readKnown #-} + -- | Convert a PLC value to the corresponding Haskell value. + -- The inverse of 'makeKnown'. + readKnown :: val -> ReadKnownM a + default readKnown :: KnownBuiltinType val a => val -> ReadKnownM a + -- If 'inline' is not used, proper inlining does not happen for whatever reason. + readKnown = inline readKnownConstant + {-# INLINE readKnown #-} type ReadKnown val = ReadKnownIn (UniOf val) val -- | Same as 'makeKnown', but allows for neither emitting nor storing the cause of a failure. makeKnownOrFail :: MakeKnownIn uni val a => a -> EvaluationResult val makeKnownOrFail x = case makeKnown x of - BuiltinSuccess val -> EvaluationSuccess val - BuiltinSuccessWithLogs _ val -> EvaluationSuccess val - BuiltinFailure _ _ -> EvaluationFailure + BuiltinSuccess val -> EvaluationSuccess val + BuiltinSuccessWithLogs _ val -> EvaluationSuccess val + BuiltinFailure _ _ -> EvaluationFailure {-# INLINE makeKnownOrFail #-} -- | Same as 'readKnown', but the cause of a potential failure is the provided term itself. -readKnownSelf - :: (ReadKnown val a, BuiltinErrorToEvaluationError structural operational) - => val -> Either (ErrorWithCause (EvaluationError structural operational) val) a +readKnownSelf :: + (ReadKnown val a, BuiltinErrorToEvaluationError structural operational) => + val -> Either (ErrorWithCause (EvaluationError structural operational) val) a readKnownSelf val = - fromRightM (flip throwErrorWithCause val . builtinErrorToEvaluationError) $ readKnown val + fromRightM (flip throwErrorWithCause val . builtinErrorToEvaluationError) $ readKnown val {-# INLINE readKnownSelf #-} instance MakeKnownIn uni val a => MakeKnownIn uni val (BuiltinResult a) where - makeKnown res = res >>= makeKnown - {-# INLINE makeKnown #-} + makeKnown res = res >>= makeKnown + {-# INLINE makeKnown #-} -- Catching 'EvaluationFailure' here would allow *not* to short-circuit when 'readKnown' fails -- to read a Haskell value of type @a@. Instead, in the denotation of the builtin function @@ -439,38 +448,44 @@ instance MakeKnownIn uni val a => MakeKnownIn uni val (BuiltinResult a) where -- I.e. it would essentially allow us to catch errors and handle them in a programmable way. -- We forbid this, because it complicates code and isn't supported by evaluation engines anyway. instance - ( TypeError ('Text "‘BuiltinResult’ cannot appear in the type of an argument") - , uni ~ UniOf val - ) => ReadKnownIn uni val (BuiltinResult a) where - readKnown _ = throwError underTypeError - {-# INLINE readKnown #-} + ( TypeError ('Text "‘BuiltinResult’ cannot appear in the type of an argument") + , uni ~ UniOf val + ) => + ReadKnownIn uni val (BuiltinResult a) + where + readKnown _ = throwError underTypeError + {-# INLINE readKnown #-} instance - ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘EvaluationResult’") - , uni ~ UniOf val - ) => MakeKnownIn uni val (EvaluationResult a) where - makeKnown _ = throwError underTypeError - {-# INLINE makeKnown #-} + ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘EvaluationResult’") + , uni ~ UniOf val + ) => + MakeKnownIn uni val (EvaluationResult a) + where + makeKnown _ = throwError underTypeError + {-# INLINE makeKnown #-} instance - ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘EvaluationResult’") - , uni ~ UniOf val - ) => ReadKnownIn uni val (EvaluationResult a) where - readKnown _ = throwError underTypeError - {-# INLINE readKnown #-} + ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘EvaluationResult’") + , uni ~ UniOf val + ) => + ReadKnownIn uni val (EvaluationResult a) + where + readKnown _ = throwError underTypeError + {-# INLINE readKnown #-} instance HasConstantIn uni val => MakeKnownIn uni val (SomeConstant uni rep) where - makeKnown = coerceArg $ pure . fromConstant - {-# INLINE makeKnown #-} + makeKnown = coerceArg $ pure . fromConstant + {-# INLINE makeKnown #-} instance HasConstantIn uni val => ReadKnownIn uni val (SomeConstant uni rep) where - readKnown = fmap SomeConstant #. asConstant - {-# INLINE readKnown #-} + readKnown = fmap SomeConstant #. asConstant + {-# INLINE readKnown #-} instance uni ~ UniOf val => MakeKnownIn uni val (Opaque val rep) where - makeKnown = coerceArg pure - {-# INLINE makeKnown #-} + makeKnown = coerceArg pure + {-# INLINE makeKnown #-} instance uni ~ UniOf val => ReadKnownIn uni val (Opaque val rep) where - readKnown = coerceArg pure - {-# INLINE readKnown #-} + readKnown = coerceArg pure + {-# INLINE readKnown #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownTypeAst.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownTypeAst.hs index 8a6ed461d46..f40334db9b7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownTypeAst.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownTypeAst.hs @@ -1,36 +1,36 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Builtin.KnownTypeAst - ( TyNameRep (..) - , TyVarRep - , TyAppRep - , TyForallRep - , Hole - , RepHole - , TypeHole - , RunHole - , HasTermLevel - , HasTypeLevel - , HasTypeAndTermLevel - , mkTyBuiltin - , KnownBuiltinTypeAst - , KnownTypeAst (..) - , toTypeAst - , Insert - , Delete - ) where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module PlutusCore.Builtin.KnownTypeAst ( + TyNameRep (..), + TyVarRep, + TyAppRep, + TyForallRep, + Hole, + RepHole, + TypeHole, + RunHole, + HasTermLevel, + HasTypeLevel, + HasTypeAndTermLevel, + mkTyBuiltin, + KnownBuiltinTypeAst, + KnownTypeAst (..), + toTypeAst, + Insert, + Delete, +) where import PlutusCore.Builtin.KnownKind import PlutusCore.Builtin.Polymorphism @@ -155,15 +155,18 @@ For the user defining a builtin this all is pretty much invisible. -} -- See Note [Rep vs Type context]. + -- | The kind of holes. data Hole -- See Note [Rep vs Type context]. + -- | A hole in the Rep context. type RepHole :: forall a hole. a -> hole data family RepHole x -- See Note [Rep vs Type context]. + -- | A hole in the Type context. type TypeHole :: forall hole. GHC.Type -> hole data family TypeHole a @@ -174,8 +177,8 @@ data family TypeHole a -- level and chokes upon encountering it. type RunHole :: (GHC.Type -> GHC.Type) -> a -> Hole type family RunHole hole where - RunHole RepHole = RepHole - RunHole TypeHole = TypeHole + RunHole RepHole = RepHole + RunHole TypeHole = TypeHole {- Note [Name generality of KnownTypeAst] The 'KnownTypeAst' class takes a @tyname@ argument. The reason for this is that we want to be able @@ -202,6 +205,7 @@ type HasTypeAndTermLevel uni x = (uni `HasTypeLevel` x, uni `HasTermLevel` x) -- See Note [Name generality of KnownTypeAst]. -- TODO: make it @forall {a}@ once we have that. -- (see https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0099-explicit-specificity.rst) + -- | Convert a Haskell representation of a possibly 0-ary application of a built-in type to -- arbitrary types implementing 'KnownTypeAst'. mkTyBuiltin :: forall a (x :: a) uni ann tyname. uni `HasTypeLevel` x => ann -> Type tyname uni ann @@ -212,6 +216,7 @@ type KnownBuiltinTypeAst :: forall a. GHC.Type -> (GHC.Type -> GHC.Type) -> a -> type KnownBuiltinTypeAst tyname uni x = AllBuiltinArgs uni (KnownTypeAst tyname uni) x -- See Note [Name generality of KnownTypeAst]. + -- | This class allows one to convert the type-level Haskell representation of a Plutus type into -- the corresponding Plutus type. Associated type families are needed to help elaboration. -- @@ -220,127 +225,147 @@ type KnownBuiltinTypeAst tyname uni x = AllBuiltinArgs uni (KnownTypeAst tyname -- class takes a @uni@ argument. Plus, elaboration is universe-specific too. type KnownTypeAst :: forall a. GHC.Type -> (GHC.Type -> GHC.Type) -> a -> GHC.Constraint class KnownTypeAst tyname uni x where - -- | Whether @x@ is a built-in type. - type IsBuiltin uni x :: Bool - type IsBuiltin uni x = IsBuiltin uni (ElaborateBuiltin uni x) - - -- | Return every part of the type that can be a to-be-instantiated type variable. - -- For example, in @Integer@ there's no such types and in @(a, b)@ it's the two arguments - -- (@a@ and @b@) and the same applies to @a -> b@ (to mention a type that is not built-in). - -- - -- Takes a @hole@ in the @GHC.Type -> GHC.Type@ form (a convention originally adopted in the - -- elaborator, perhaps not a very helpful one), which can be turned into an actual 'Hole' via - -- 'RunHole'. - type ToHoles uni (hole :: GHC.Type -> GHC.Type) x :: [Hole] - type ToHoles uni hole x = ToHoles uni hole (ElaborateBuiltin uni x) - - -- | Collect all unique variables (a variable consists of a textual name, a unique and a kind) - -- in an accumulator and return the accumulator once a leaf is reached. - type ToBinds uni (acc :: [GADT.Some TyNameRep]) x :: [GADT.Some TyNameRep] - type ToBinds uni acc x = ToBinds uni acc (ElaborateBuiltin uni x) - - -- Doesn't take a @proxy@, so that newtype- and via-deriving are available. - -- | The Plutus counterpart of the @x@ type. - typeAst :: Type tyname uni () - default typeAst :: KnownTypeAst tyname uni (ElaborateBuiltin uni x) => Type tyname uni () - typeAst = toTypeAst $ Proxy @(ElaborateBuiltin uni x) + -- | Whether @x@ is a built-in type. + type IsBuiltin uni x :: Bool + + type IsBuiltin uni x = IsBuiltin uni (ElaborateBuiltin uni x) + + -- | Return every part of the type that can be a to-be-instantiated type variable. + -- For example, in @Integer@ there's no such types and in @(a, b)@ it's the two arguments + -- (@a@ and @b@) and the same applies to @a -> b@ (to mention a type that is not built-in). + -- + -- Takes a @hole@ in the @GHC.Type -> GHC.Type@ form (a convention originally adopted in the + -- elaborator, perhaps not a very helpful one), which can be turned into an actual 'Hole' via + -- 'RunHole'. + type ToHoles uni (hole :: GHC.Type -> GHC.Type) x :: [Hole] + + type ToHoles uni hole x = ToHoles uni hole (ElaborateBuiltin uni x) + + -- | Collect all unique variables (a variable consists of a textual name, a unique and a kind) + -- in an accumulator and return the accumulator once a leaf is reached. + type ToBinds uni (acc :: [GADT.Some TyNameRep]) x :: [GADT.Some TyNameRep] + + type ToBinds uni acc x = ToBinds uni acc (ElaborateBuiltin uni x) + + -- Doesn't take a @proxy@, so that newtype- and via-deriving are available. + + -- | The Plutus counterpart of the @x@ type. + typeAst :: Type tyname uni () + default typeAst :: KnownTypeAst tyname uni (ElaborateBuiltin uni x) => Type tyname uni () + typeAst = toTypeAst $ Proxy @(ElaborateBuiltin uni x) instance KnownTypeAst tyname uni a => KnownTypeAst tyname uni (EvaluationResult a) where - type IsBuiltin _ (EvaluationResult a) = 'False - type ToHoles _ _ (EvaluationResult a) = '[TypeHole a] - type ToBinds uni acc (EvaluationResult a) = ToBinds uni acc a - typeAst = toTypeAst $ Proxy @a + type IsBuiltin _ (EvaluationResult a) = 'False + type ToHoles _ _ (EvaluationResult a) = '[TypeHole a] + type ToBinds uni acc (EvaluationResult a) = ToBinds uni acc a + typeAst = toTypeAst $ Proxy @a instance KnownTypeAst tyname uni a => KnownTypeAst tyname uni (BuiltinResult a) where - type IsBuiltin _ (BuiltinResult a) = 'False - type ToHoles _ _ (BuiltinResult a) = '[TypeHole a] - type ToBinds uni acc (BuiltinResult a) = ToBinds uni acc a - typeAst = toTypeAst $ Proxy @a + type IsBuiltin _ (BuiltinResult a) = 'False + type ToHoles _ _ (BuiltinResult a) = '[TypeHole a] + type ToBinds uni acc (BuiltinResult a) = ToBinds uni acc a + typeAst = toTypeAst $ Proxy @a instance KnownTypeAst tyname uni rep => KnownTypeAst tyname uni (SomeConstant uni rep) where - type IsBuiltin _ (SomeConstant uni rep) = 'False - type ToHoles _ _ (SomeConstant _ rep) = '[RepHole rep] - type ToBinds uni acc (SomeConstant _ rep) = ToBinds uni acc rep - typeAst = toTypeAst $ Proxy @rep + type IsBuiltin _ (SomeConstant uni rep) = 'False + type ToHoles _ _ (SomeConstant _ rep) = '[RepHole rep] + type ToBinds uni acc (SomeConstant _ rep) = ToBinds uni acc rep + typeAst = toTypeAst $ Proxy @rep instance KnownTypeAst tyname uni rep => KnownTypeAst tyname uni (Opaque val rep) where - type IsBuiltin _ (Opaque val rep) = 'False - type ToHoles _ _ (Opaque _ rep) = '[RepHole rep] - type ToBinds uni acc (Opaque _ rep) = ToBinds uni acc rep - typeAst = toTypeAst $ Proxy @rep + type IsBuiltin _ (Opaque val rep) = 'False + type ToHoles _ _ (Opaque _ rep) = '[RepHole rep] + type ToBinds uni acc (Opaque _ rep) = ToBinds uni acc rep + typeAst = toTypeAst $ Proxy @rep -- | Return the Plutus counterpart of the @x@ type. -toTypeAst - :: forall a tyname uni (x :: a) proxy. KnownTypeAst tyname uni x - => proxy x -> Type tyname uni () +toTypeAst :: + forall a tyname uni (x :: a) proxy. + KnownTypeAst tyname uni x => + proxy x -> Type tyname uni () toTypeAst _ = typeAst @_ @tyname @uni @x -toTyNameAst - :: forall text uniq. (KnownSymbol text, KnownNat uniq) - => Proxy ('TyNameRep text uniq) -> TyName +toTyNameAst :: + forall text uniq. + (KnownSymbol text, KnownNat uniq) => + Proxy ('TyNameRep text uniq) -> TyName toTyNameAst _ = - TyName $ Name - (Text.pack $ symbolVal @text Proxy) - (Unique . fromIntegral $ natVal @uniq Proxy) + TyName $ + Name + (Text.pack $ symbolVal @text Proxy) + (Unique . fromIntegral $ natVal @uniq Proxy) instance uni `Contains` f => KnownTypeAst tyname uni (BuiltinHead f) where - type IsBuiltin _ (BuiltinHead f) = 'True - type ToHoles _ _ (BuiltinHead f) = '[] - type ToBinds _ acc (BuiltinHead f) = acc - typeAst = TyBuiltin () $ someType @_ @f + type IsBuiltin _ (BuiltinHead f) = 'True + type ToHoles _ _ (BuiltinHead f) = '[] + type ToBinds _ acc (BuiltinHead f) = acc + typeAst = TyBuiltin () $ someType @_ @f instance KnownTypeAst tyname uni y => KnownTypeAst tyname uni (LastArg x y) where - type IsBuiltin uni (LastArg x y) = IsBuiltin uni y - type ToHoles _ hole (LastArg x y) = '[RunHole hole x, RunHole hole y] - type ToBinds uni acc (LastArg x y) = ToBinds uni (ToBinds uni acc x) y - typeAst = toTypeAst $ Proxy @y - -instance (KnownTypeAst tyname uni a, KnownTypeAst tyname uni b) => - KnownTypeAst tyname uni (a -> b) where - type IsBuiltin _ (a -> b) = 'False - type ToHoles _ hole (a -> b) = '[RunHole hole a, RunHole hole b] - type ToBinds uni acc (a -> b) = ToBinds uni (ToBinds uni acc a) b - typeAst = TyFun () (toTypeAst $ Proxy @a) (toTypeAst $ Proxy @b) - -instance (tyname ~ TyName, name ~ 'TyNameRep text uniq, KnownSymbol text, KnownNat uniq) => - KnownTypeAst tyname uni (TyVarRep name) where - type IsBuiltin _ (TyVarRep name) = 'False - type ToHoles _ _ (TyVarRep name) = '[] - type ToBinds _ acc (TyVarRep name) = Insert ('GADT.Some name) acc - typeAst = TyVar () . toTyNameAst $ Proxy @('TyNameRep text uniq) - -instance (KnownTypeAst tyname uni fun, KnownTypeAst tyname uni arg) => - KnownTypeAst tyname uni (TyAppRep fun arg) where - type IsBuiltin uni (TyAppRep fun arg) = IsBuiltin uni fun && IsBuiltin uni arg - type ToHoles _ _ (TyAppRep fun arg) = '[RepHole fun, RepHole arg] - type ToBinds uni acc (TyAppRep fun arg) = ToBinds uni (ToBinds uni acc fun) arg - typeAst = TyApp () (toTypeAst $ Proxy @fun) (toTypeAst $ Proxy @arg) + type IsBuiltin uni (LastArg x y) = IsBuiltin uni y + type ToHoles _ hole (LastArg x y) = '[RunHole hole x, RunHole hole y] + type ToBinds uni acc (LastArg x y) = ToBinds uni (ToBinds uni acc x) y + typeAst = toTypeAst $ Proxy @y + +instance + (KnownTypeAst tyname uni a, KnownTypeAst tyname uni b) => + KnownTypeAst tyname uni (a -> b) + where + type IsBuiltin _ (a -> b) = 'False + type ToHoles _ hole (a -> b) = '[RunHole hole a, RunHole hole b] + type ToBinds uni acc (a -> b) = ToBinds uni (ToBinds uni acc a) b + typeAst = TyFun () (toTypeAst $ Proxy @a) (toTypeAst $ Proxy @b) + +instance + (tyname ~ TyName, name ~ 'TyNameRep text uniq, KnownSymbol text, KnownNat uniq) => + KnownTypeAst tyname uni (TyVarRep name) + where + type IsBuiltin _ (TyVarRep name) = 'False + type ToHoles _ _ (TyVarRep name) = '[] + type ToBinds _ acc (TyVarRep name) = Insert ('GADT.Some name) acc + typeAst = TyVar () . toTyNameAst $ Proxy @('TyNameRep text uniq) + +instance + (KnownTypeAst tyname uni fun, KnownTypeAst tyname uni arg) => + KnownTypeAst tyname uni (TyAppRep fun arg) + where + type IsBuiltin uni (TyAppRep fun arg) = IsBuiltin uni fun && IsBuiltin uni arg + type ToHoles _ _ (TyAppRep fun arg) = '[RepHole fun, RepHole arg] + type ToBinds uni acc (TyAppRep fun arg) = ToBinds uni (ToBinds uni acc fun) arg + typeAst = TyApp () (toTypeAst $ Proxy @fun) (toTypeAst $ Proxy @arg) instance - ( tyname ~ TyName, name ~ 'TyNameRep @kind text uniq, KnownSymbol text, KnownNat uniq - , KnownKind kind, KnownTypeAst tyname uni a - ) => KnownTypeAst tyname uni (TyForallRep name a) where - type IsBuiltin _ (TyForallRep name a) = 'False - type ToHoles _ _ (TyForallRep name a) = '[RepHole a] - type ToBinds uni acc (TyForallRep name a) = Delete ('GADT.Some name) (ToBinds uni acc a) - typeAst = - TyForall () - (toTyNameAst $ Proxy @('TyNameRep text uniq)) - (demoteKind $ knownKind @kind) - (toTypeAst $ Proxy @a) + ( tyname ~ TyName + , name ~ 'TyNameRep @kind text uniq + , KnownSymbol text + , KnownNat uniq + , KnownKind kind + , KnownTypeAst tyname uni a + ) => + KnownTypeAst tyname uni (TyForallRep name a) + where + type IsBuiltin _ (TyForallRep name a) = 'False + type ToHoles _ _ (TyForallRep name a) = '[RepHole a] + type ToBinds uni acc (TyForallRep name a) = Delete ('GADT.Some name) (ToBinds uni acc a) + typeAst = + TyForall + () + (toTyNameAst $ Proxy @('TyNameRep text uniq)) + (demoteKind $ knownKind @kind) + (toTypeAst $ Proxy @a) -- Utils -- | Insert @x@ into @xs@ unless it's already there. type Insert :: forall a. a -> [a] -> [a] type family Insert x xs where - Insert x '[] = '[x] - Insert x (x : xs) = x ': xs - Insert x (y : xs) = y ': Insert x xs + Insert x '[] = '[x] + Insert x (x : xs) = x ': xs + Insert x (y : xs) = y ': Insert x xs -- | Delete the first @x@ from a list. Which is okay since we only ever put things in once. type Delete :: forall a. a -> [a] -> [a] type family Delete x xs where - Delete _ '[] = '[] - Delete x (x ': xs) = xs - Delete x (y ': xs) = y ': Delete x xs + Delete _ '[] = '[] + Delete x (x ': xs) = xs + Delete x (y ': xs) = y ': Delete x xs diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index 35e56b5e071..70bfd2752f7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -1,19 +1,18 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE StrictData #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusCore.Builtin.Meaning where @@ -45,8 +44,8 @@ import GHC.TypeLits -- FoldArgs [(), Bool] Integer :: * -- = () -> Bool -> Integer type family FoldArgs args res where - FoldArgs '[] res = res - FoldArgs (arg ': args) res = arg -> FoldArgs args res + FoldArgs '[] res = res + FoldArgs (arg ': args) res = arg -> FoldArgs args res -- | The meaning of a built-in function consists of its type represented as a 'TypeScheme', -- its Haskell denotation and its uninstantiated runtime denotation. @@ -60,57 +59,60 @@ type family FoldArgs args res where -- The denotation is lazy, so that we don't need to worry about a builtin being bottom -- (happens in tests). The production path is not affected by that, since only runtime denotations -- are used for evaluation. -data BuiltinMeaning val cost = - forall args res. BuiltinMeaning - (TypeScheme val args res) - ~(FoldArgs args res) - (cost -> BuiltinRuntime val) +data BuiltinMeaning val cost + = forall args res. BuiltinMeaning + (TypeScheme val args res) + ~(FoldArgs args res) + (cost -> BuiltinRuntime val) -- | Constraints available when defining a built-in function. type HasMeaningIn uni val = (Typeable val, ExMemoryUsage val, HasConstantIn uni val) -- | A type class for \"each function from a set of built-in functions has a 'BuiltinMeaning'\". class - ( Typeable uni - , Typeable fun - , Bounded fun - , Enum fun - , Ix fun - , Default (BuiltinSemanticsVariant fun) - ) => ToBuiltinMeaning uni fun where - -- | The @cost@ part of 'BuiltinMeaning'. - type CostingPart uni fun - - -- | See Note [Builtin semantics variants] - data BuiltinSemanticsVariant fun - - -- | Get the 'BuiltinMeaning' of a built-in function. - toBuiltinMeaning - :: HasMeaningIn uni val - => BuiltinSemanticsVariant fun - -> fun - -> BuiltinMeaning val (CostingPart uni fun) + ( Typeable uni + , Typeable fun + , Bounded fun + , Enum fun + , Ix fun + , Default (BuiltinSemanticsVariant fun) + ) => + ToBuiltinMeaning uni fun + where + -- | The @cost@ part of 'BuiltinMeaning'. + type CostingPart uni fun + + -- | See Note [Builtin semantics variants] + data BuiltinSemanticsVariant fun + + -- | Get the 'BuiltinMeaning' of a built-in function. + toBuiltinMeaning :: + HasMeaningIn uni val => + BuiltinSemanticsVariant fun -> + fun -> + BuiltinMeaning val (CostingPart uni fun) -- | Feed the 'TypeScheme' of the given built-in function to the continuation. -withTypeSchemeOfBuiltinFunction - :: forall val fun r. - (ToBuiltinMeaning (UniOf val) fun, ExMemoryUsage val, Typeable val, HasConstant val) - => BuiltinSemanticsVariant fun - -> fun - -> (forall args res. TypeScheme val args res -> r) - -> r +withTypeSchemeOfBuiltinFunction :: + forall val fun r. + (ToBuiltinMeaning (UniOf val) fun, ExMemoryUsage val, Typeable val, HasConstant val) => + BuiltinSemanticsVariant fun -> + fun -> + (forall args res. TypeScheme val args res -> r) -> + r withTypeSchemeOfBuiltinFunction semVar fun k = - case toBuiltinMeaning semVar fun of - BuiltinMeaning sch _ _ -> k sch + case toBuiltinMeaning semVar fun of + BuiltinMeaning sch _ _ -> k sch -- | Get the type of a built-in function. -typeOfBuiltinFunction - :: forall uni fun. ToBuiltinMeaning uni fun - => BuiltinSemanticsVariant fun - -> fun - -> Type TyName uni () +typeOfBuiltinFunction :: + forall uni fun. + ToBuiltinMeaning uni fun => + BuiltinSemanticsVariant fun -> + fun -> + Type TyName uni () typeOfBuiltinFunction semVar fun = - withTypeSchemeOfBuiltinFunction @(Term TyName Name uni fun ()) semVar fun typeSchemeToType + withTypeSchemeOfBuiltinFunction @(Term TyName Name uni fun ()) semVar fun typeSchemeToType {- Note [Builtin semantics variants] The purpose of the "builtin semantics variant" feature is to provide multiple, @@ -191,8 +193,8 @@ elaborated (i.e. monomorphic). -- | Chop a function type to get a list of its argument types. type GetArgs :: GHC.Type -> [GHC.Type] type family GetArgs a where - GetArgs (a -> b) = a ': GetArgs b - GetArgs _ = '[] + GetArgs (a -> b) = a ': GetArgs b + GetArgs _ = '[] {- Note [Merging the denotation and the costing function] The runtime denotation of a builtin computes both the builtin application and its cost @@ -225,39 +227,41 @@ into a single 'BuiltinRuntime'. -- to become a class anyway and we'd just replicate what we have here, except in a much more -- complicated way. class KnownMonotype val args res where - knownMonotype :: TypeScheme val args res + knownMonotype :: TypeScheme val args res - -- | Convert the denotation of a builtin to its runtime counterpart . - -- The argument is in 'ReadKnownM', because that's what deferred unlifting amounts to: - -- passing the action returning the builtin application around until full saturation, which is - -- when the action actually gets run. - toMonoF - :: ReadKnownM (FoldArgs args res, FoldArgs args ExBudgetStream) - -> BuiltinRuntime val + -- | Convert the denotation of a builtin to its runtime counterpart . + -- The argument is in 'ReadKnownM', because that's what deferred unlifting amounts to: + -- passing the action returning the builtin application around until full saturation, which is + -- when the action actually gets run. + toMonoF :: + ReadKnownM (FoldArgs args res, FoldArgs args ExBudgetStream) -> + BuiltinRuntime val -- | Once we've run out of term-level arguments, we return a -- 'TypeSchemeResult'/'RuntimeSchemeResult'. -instance (Typeable res, KnownTypeAst TyName (UniOf val) res, MakeKnown val res) => - KnownMonotype val '[] res where - knownMonotype = TypeSchemeResult - - toMonoF = - either - -- Unlifting has failed and we don't care about costing at this point, since we're about - -- to terminate evaluation anyway, hence we put 'mempty' as the cost of the operation. - -- - -- Note that putting the cost inside of 'BuiltinResult' is not an option, since forcing - -- the 'BuiltinResult' computation is exactly forcing the builtin application, which we - -- can't do before accounting for the cost of the application, i.e. the cost must be - -- outside of 'BuiltinResult'. - -- - -- We could introduce a level of indirection and say that a 'BuiltinCostedResult' is - -- either a budgeting failure or a budgeting success with a cost and a 'BuiltinResult' - -- computation inside, but that would slow things down a bit and the current strategy is - -- reasonable enough. - builtinRuntimeFailure - (\(x, cost) -> BuiltinCostedResult cost $ makeKnown x) - {-# INLINE toMonoF #-} +instance + (Typeable res, KnownTypeAst TyName (UniOf val) res, MakeKnown val res) => + KnownMonotype val '[] res + where + knownMonotype = TypeSchemeResult + + toMonoF = + either + -- Unlifting has failed and we don't care about costing at this point, since we're about + -- to terminate evaluation anyway, hence we put 'mempty' as the cost of the operation. + -- + -- Note that putting the cost inside of 'BuiltinResult' is not an option, since forcing + -- the 'BuiltinResult' computation is exactly forcing the builtin application, which we + -- can't do before accounting for the cost of the application, i.e. the cost must be + -- outside of 'BuiltinResult'. + -- + -- We could introduce a level of indirection and say that a 'BuiltinCostedResult' is + -- either a budgeting failure or a budgeting success with a cost and a 'BuiltinResult' + -- computation inside, but that would slow things down a bit and the current strategy is + -- reasonable enough. + builtinRuntimeFailure + (\(x, cost) -> BuiltinCostedResult cost $ makeKnown x) + {-# INLINE toMonoF #-} {- Note [One-shotting runtime denotations] In @KnownMonotype val (arg ': args) res@ we 'oneShot' the runtime denotations. Otherwise GHC creates @@ -286,95 +290,105 @@ evaluation anyway, hence we care much more about optimizing the happy path. -- | Every term-level argument becomes a 'TypeSchemeArrow'/'RuntimeSchemeArrow'. instance - ( Typeable arg, KnownTypeAst TyName (UniOf val) arg, MakeKnown val arg, ReadKnown val arg - , KnownMonotype val args res - ) => KnownMonotype val (arg ': args) res where - knownMonotype = TypeSchemeArrow knownMonotype - - -- See Note [One-shotting runtime denotations]. - -- Grow the builtin application within the received action and recurse on the result. - toMonoF getBoth = BuiltinExpectArgument . oneShot $ \arg -> - -- The lazy application of 'toMonoF' ensures that unlifting of the argument will happen - -- upon full saturation and not before that. This is known as "operationally deferred - -- unlifting" (as opposed to "operationally immediate unlifting") or "call-by-name - -- unlifting" (as opposed to "call-by-value unlifting"). We do it this way to guarantee that - -- the cost of unlifting will be accounted for before unlifting is performed. If we did - -- unlifting eagerly here, this would make the node do work that is not accounted for until - -- full saturation is reached, which may never happen if the partial application is thrown - -- away. - -- - -- The disadvantage of this approach is that @addInteger 42@ will always unlift @42@ upon - -- full saturation even if this partial application is saved to a variable. But the way - -- costing calibration benchmarks are set up, we always evaluate a single application, so - -- the cost of unlifting is included in the cost of the builtin regardless of whether - -- there's caching of unlifting or not. Hence the user pays for unlifting anyway and we can - -- prioritize safety over performance here. - -- - -- 'oneShot' ensures that GHC doesn't attempt to pull stuff out of the builtin - -- implementation to create thunks. This would give us a "call-by-need" behavior, which may - -- sound enticing as it would give us both caching and operationally deferred unlifting, but - -- this comes at a cost of creating unnecessary thunks in the most common case where there's - -- no benefit from having caching as the builtin application is going to be computed only - -- once. So we choose the "call-by-name" behavior and 'oneShot' is what enables that. - oneShot (toMonoF @val @args @res) $ do - (f, exF) <- getBoth - -- Force the argument that gets passed to the denotation. This seems to help performance - -- a bit (possibly due to its impact on strictness analysis), plus this way we ensure - -- that if computing the argument throws an exception (isn't supposed to happen), we'll - -- catch it in tests. - !x <- readKnown arg - -- See Note [Strict application in runtime denotations]. - let !exY = exF x - pure (f x, exY) - {-# INLINE toMonoF #-} + ( Typeable arg + , KnownTypeAst TyName (UniOf val) arg + , MakeKnown val arg + , ReadKnown val arg + , KnownMonotype val args res + ) => + KnownMonotype val (arg ': args) res + where + knownMonotype = TypeSchemeArrow knownMonotype + + -- See Note [One-shotting runtime denotations]. + -- Grow the builtin application within the received action and recurse on the result. + toMonoF getBoth = BuiltinExpectArgument . oneShot $ \arg -> + -- The lazy application of 'toMonoF' ensures that unlifting of the argument will happen + -- upon full saturation and not before that. This is known as "operationally deferred + -- unlifting" (as opposed to "operationally immediate unlifting") or "call-by-name + -- unlifting" (as opposed to "call-by-value unlifting"). We do it this way to guarantee that + -- the cost of unlifting will be accounted for before unlifting is performed. If we did + -- unlifting eagerly here, this would make the node do work that is not accounted for until + -- full saturation is reached, which may never happen if the partial application is thrown + -- away. + -- + -- The disadvantage of this approach is that @addInteger 42@ will always unlift @42@ upon + -- full saturation even if this partial application is saved to a variable. But the way + -- costing calibration benchmarks are set up, we always evaluate a single application, so + -- the cost of unlifting is included in the cost of the builtin regardless of whether + -- there's caching of unlifting or not. Hence the user pays for unlifting anyway and we can + -- prioritize safety over performance here. + -- + -- 'oneShot' ensures that GHC doesn't attempt to pull stuff out of the builtin + -- implementation to create thunks. This would give us a "call-by-need" behavior, which may + -- sound enticing as it would give us both caching and operationally deferred unlifting, but + -- this comes at a cost of creating unnecessary thunks in the most common case where there's + -- no benefit from having caching as the builtin application is going to be computed only + -- once. So we choose the "call-by-name" behavior and 'oneShot' is what enables that. + oneShot (toMonoF @val @args @res) $ do + (f, exF) <- getBoth + -- Force the argument that gets passed to the denotation. This seems to help performance + -- a bit (possibly due to its impact on strictness analysis), plus this way we ensure + -- that if computing the argument throws an exception (isn't supposed to happen), we'll + -- catch it in tests. + !x <- readKnown arg + -- See Note [Strict application in runtime denotations]. + let !exY = exF x + pure (f x, exY) + {-# INLINE toMonoF #-} -- | A class that allows us to derive a polytype for a builtin. class KnownMonotype val args res => KnownPolytype (binds :: [Some TyNameRep]) val args res where - knownPolytype :: TypeScheme val args res + knownPolytype :: TypeScheme val args res - -- | Convert the denotation of a builtin to its runtime counterpart. - -- The argument is in 'ReadKnownM', because that's what we need to do: - -- passing the action returning the builtin application around until full saturation, which is - -- when the action actually gets run. - toPolyF - :: ReadKnownM (FoldArgs args res, FoldArgs args ExBudgetStream) - -> BuiltinRuntime val + -- | Convert the denotation of a builtin to its runtime counterpart. + -- The argument is in 'ReadKnownM', because that's what we need to do: + -- passing the action returning the builtin application around until full saturation, which is + -- when the action actually gets run. + toPolyF :: + ReadKnownM (FoldArgs args res, FoldArgs args ExBudgetStream) -> + BuiltinRuntime val -- | Once we've run out of type-level arguments, we start handling term-level ones. instance KnownMonotype val args res => KnownPolytype '[] val args res where - knownPolytype = knownMonotype + knownPolytype = knownMonotype - toPolyF = toMonoF @val @args @res - {-# INLINE toPolyF #-} + toPolyF = toMonoF @val @args @res + {-# INLINE toPolyF #-} -- Here we unpack an existentially packed @kind@ and constrain it afterwards! -- So promoted existentials are true sigmas! If we were at the term level, we'd have to pack -- @kind@ along with the @KnownKind kind@ constraint, otherwise when we unpack the existential, -- all information is lost and we can't do anything with @kind@. + -- | Every type-level argument becomes a 'TypeSchemeAll'. -instance (KnownSymbol name, KnownNat uniq, KnownKind kind, KnownPolytype binds val args res) => - KnownPolytype ('Some ('TyNameRep @kind name uniq) ': binds) val args res where - knownPolytype = TypeSchemeAll @name @uniq @kind Proxy $ knownPolytype @binds +instance + (KnownSymbol name, KnownNat uniq, KnownKind kind, KnownPolytype binds val args res) => + KnownPolytype ('Some ('TyNameRep @kind name uniq) ': binds) val args res + where + knownPolytype = TypeSchemeAll @name @uniq @kind Proxy $ knownPolytype @binds - toPolyF = BuiltinExpectForce . toPolyF @binds @val @args @res - {-# INLINE toPolyF #-} + toPolyF = BuiltinExpectForce . toPolyF @binds @val @args @res + {-# INLINE toPolyF #-} -- | Ensure a built-in function is not nullary and throw a nice error otherwise. type ThrowOnBothEmpty :: [Some TyNameRep] -> [GHC.Type] -> Bool -> GHC.Type -> GHC.Constraint type family ThrowOnBothEmpty binds args isBuiltin a where - ThrowOnBothEmpty '[] '[] 'True a = - TypeError ( - 'Text "A built-in function must take at least one type or term argument" ':$$: - 'Text "‘" ':<>: 'ShowType a ':<>: 'Text "’ is a built-in type" ':<>: - 'Text " so you can embed any of its values as a constant" ':$$: - 'Text "If you still want a built-in function, add a dummy ‘()’ argument" - ) - ThrowOnBothEmpty '[] '[] 'False a = - TypeError ( - 'Text "A built-in function must take at least one type or term argument" ':$$: - 'Text "To fix this error add a dummy ‘()’ argument" - ) - ThrowOnBothEmpty _ _ _ _ = () + ThrowOnBothEmpty '[] '[] 'True a = + TypeError + ( 'Text "A built-in function must take at least one type or term argument" + ':$$: 'Text "‘" + ':<>: 'ShowType a + ':<>: 'Text "’ is a built-in type" + ':<>: 'Text " so you can embed any of its values as a constant" + ':$$: 'Text "If you still want a built-in function, add a dummy ‘()’ argument" + ) + ThrowOnBothEmpty '[] '[] 'False a = + TypeError + ( 'Text "A built-in function must take at least one type or term argument" + ':$$: 'Text "To fix this error add a dummy ‘()’ argument" + ) + ThrowOnBothEmpty _ _ _ _ = () -- | A function turned into a type class with exactly one fully general instance. -- We can't package up the constraints of 'makeBuiltinMeaning' (see the instance) into a type or @@ -386,34 +400,42 @@ type family ThrowOnBothEmpty binds args isBuiltin a where -- -- The @a@ type variable goes first, because @makeBuiltinMeaning \@A@ is a common pattern. class MakeBuiltinMeaning a val where - -- See Note [Automatic derivation of type schemes] - -- | Construct the meaning for a built-in function by automatically deriving its - -- 'TypeScheme', given - -- - -- 1. the denotation of the builtin - -- 2. an uninstantiated costing function - makeBuiltinMeaning - :: a - -> (cost -> FoldArgs (GetArgs a) ExBudgetStream) - -> BuiltinMeaning val cost + -- See Note [Automatic derivation of type schemes] + + -- | Construct the meaning for a built-in function by automatically deriving its + -- 'TypeScheme', given + -- + -- 1. the denotation of the builtin + -- 2. an uninstantiated costing function + makeBuiltinMeaning :: + a -> + (cost -> FoldArgs (GetArgs a) ExBudgetStream) -> + BuiltinMeaning val cost + instance - ( uni ~ UniOf val, binds ~ ToBinds uni '[] a, args ~ GetArgs a, a ~ FoldArgs args res - , ThrowOnBothEmpty binds args (IsBuiltin uni a) a - , ElaborateFromTo uni 0 j val a, KnownPolytype binds val args res - ) => MakeBuiltinMeaning a val where - makeBuiltinMeaning f toExF = - BuiltinMeaning (knownPolytype @binds @val @args @res) f $ \cost -> - -- In order to make the 'BuiltinRuntime' of a builtin cacheable we need to tell GHC to - -- create a thunk for it, which we achieve by applying 'lazy' to the 'BuiltinRuntime' - -- here. - -- - -- Those thunks however require a lot of care to be properly shared rather than - -- recreated every time a builtin application is evaluated, see 'toBuiltinsRuntime' for - -- how we sort it out. - lazy $ case toExF cost of - -- See Note [Optimizations of runCostingFun*] for why we use strict @case@. - !exF -> toPolyF @binds @val @args @res $ pure (f, exF) - {-# INLINE makeBuiltinMeaning #-} + ( uni ~ UniOf val + , binds ~ ToBinds uni '[] a + , args ~ GetArgs a + , a ~ FoldArgs args res + , ThrowOnBothEmpty binds args (IsBuiltin uni a) a + , ElaborateFromTo uni 0 j val a + , KnownPolytype binds val args res + ) => + MakeBuiltinMeaning a val + where + makeBuiltinMeaning f toExF = + BuiltinMeaning (knownPolytype @binds @val @args @res) f $ \cost -> + -- In order to make the 'BuiltinRuntime' of a builtin cacheable we need to tell GHC to + -- create a thunk for it, which we achieve by applying 'lazy' to the 'BuiltinRuntime' + -- here. + -- + -- Those thunks however require a lot of care to be properly shared rather than + -- recreated every time a builtin application is evaluated, see 'toBuiltinsRuntime' for + -- how we sort it out. + lazy $ case toExF cost of + -- See Note [Optimizations of runCostingFun*] for why we use strict @case@. + !exF -> toPolyF @binds @val @args @res $ pure (f, exF) + {-# INLINE makeBuiltinMeaning #-} -- | Convert a 'BuiltinMeaning' to a 'BuiltinRuntime' given a cost model. toBuiltinRuntime :: cost -> BuiltinMeaning val cost -> BuiltinRuntime val @@ -421,23 +443,24 @@ toBuiltinRuntime cost (BuiltinMeaning _ _ denot) = denot cost {-# INLINE toBuiltinRuntime #-} -- See Note [Inlining meanings of builtins]. + -- | Calculate runtime info for all built-in functions given meanings of builtins (as a constraint), -- the semantics variant of the set of builtins and a cost model. -toBuiltinsRuntime - :: (cost ~ CostingPart uni fun, ToBuiltinMeaning uni fun, HasMeaningIn uni val) - => BuiltinSemanticsVariant fun - -> cost - -> BuiltinsRuntime fun val +toBuiltinsRuntime :: + (cost ~ CostingPart uni fun, ToBuiltinMeaning uni fun, HasMeaningIn uni val) => + BuiltinSemanticsVariant fun -> + cost -> + BuiltinsRuntime fun val toBuiltinsRuntime semvar cost = - -- A call to 'lazy' is to make sure that the returned 'BuiltinsRuntime' is properly cached in a - -- 'let'-binding. This makes it easier for GHC to optimize the internals of builtins, because - -- without a 'let'-binding GHC would sometimes refuse to cooperate and push 'toBuiltinRuntime' - -- to the inside of the inlined 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's - -- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a lambda - -- binding the @cost@ variable, which makes the optimizations useless. - -- By using 'lazy' we tell GHC to create a separate thunk, which it can properly optimize, - -- because the other bazillion things don't get in the way. We used to use an explicit - -- 'let'-binding marked with @OPAQUE@, but that turned out to be unreliable, because GHC - -- feels free to turn it into a join point instead of a proper thunk. - lazy . BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar + -- A call to 'lazy' is to make sure that the returned 'BuiltinsRuntime' is properly cached in a + -- 'let'-binding. This makes it easier for GHC to optimize the internals of builtins, because + -- without a 'let'-binding GHC would sometimes refuse to cooperate and push 'toBuiltinRuntime' + -- to the inside of the inlined 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's + -- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a lambda + -- binding the @cost@ variable, which makes the optimizations useless. + -- By using 'lazy' we tell GHC to create a separate thunk, which it can properly optimize, + -- because the other bazillion things don't get in the way. We used to use an explicit + -- 'let'-binding marked with @OPAQUE@, but that turned out to be unreliable, because GHC + -- feels free to turn it into a join point instead of a proper thunk. + lazy . BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar {-# INLINE toBuiltinsRuntime #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs index 6a9db4568d9..d10b96d5a2a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs @@ -1,28 +1,28 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - -module PlutusCore.Builtin.Polymorphism - ( Opaque (..) - , SomeConstant (..) - , TyNameRep (..) - , TyVarRep - , TyAppRep - , TyForallRep - , BuiltinHead - , LastArg - , ElaborateBuiltin - , AllElaboratedArgs - , AllBuiltinArgs - ) where +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module PlutusCore.Builtin.Polymorphism ( + Opaque (..), + SomeConstant (..), + TyNameRep (..), + TyVarRep, + TyAppRep, + TyForallRep, + BuiltinHead, + LastArg, + ElaborateBuiltin, + AllElaboratedArgs, + AllBuiltinArgs, +) where import PlutusPrelude @@ -141,11 +141,14 @@ See Note [Elaboration of polymorphism] for how this machinery is used in practic -- See Note [Motivation for polymorphic built-in functions]. -- See Note [Implementation of polymorphic built-in functions]. + -- | The AST of a value with a Plutus type attached to it. The type is for the Plutus type checker -- to look at. 'Opaque' can appear in the type of the denotation of a builtin. newtype Opaque val (rep :: GHC.Type) = Opaque - { unOpaque :: val - } deriving newtype (HasConstant, ExMemoryUsage) + { unOpaque :: val + } + deriving newtype (HasConstant, ExMemoryUsage) + -- Try not to add instances for this data type, so that we can throw more 'NoConstraintsErrMsg' -- kind of type errors. @@ -157,20 +160,21 @@ type instance UniOf (Opaque val rep) = UniOf val -- The @rep@ parameter specifies how the type looks on the PLC side (i.e. just like with -- @Opaque val rep@). newtype SomeConstant uni (rep :: GHC.Type) = SomeConstant - { unSomeConstant :: Some (ValueOf uni) - } + { unSomeConstant :: Some (ValueOf uni) + } -deriving newtype instance (Everywhere uni ExMemoryUsage, Closed uni) - => ExMemoryUsage (SomeConstant uni rep) +deriving newtype instance + (Everywhere uni ExMemoryUsage, Closed uni) => + ExMemoryUsage (SomeConstant uni rep) type instance UniOf (SomeConstant uni rep) = uni instance HasConstant (SomeConstant uni rep) where - asConstant = coerceArg pure - {-# INLINE asConstant #-} + asConstant = coerceArg pure + {-# INLINE asConstant #-} - fromConstant = coerce - {-# INLINE fromConstant #-} + fromConstant = coerce + {-# INLINE fromConstant #-} -- | Representation of a type variable: its name and unique and an implicit kind. data TyNameRep (kind :: GHC.Type) = TyNameRep Symbol Nat @@ -218,75 +222,77 @@ type family ElaborateBuiltin uni x -- application of a built-in type. type AllElaboratedArgs :: forall a. (GHC.Type -> GHC.Constraint) -> a -> GHC.Constraint type family AllElaboratedArgs constr x where - AllElaboratedArgs constr (f `TyAppRep` x) = (constr x, AllElaboratedArgs constr f) - AllElaboratedArgs _ (BuiltinHead _) = () + AllElaboratedArgs constr (f `TyAppRep` x) = (constr x, AllElaboratedArgs constr f) + AllElaboratedArgs _ (BuiltinHead _) = () -- | Take a constraint and use it to constrain every argument of a possibly 0-ary application of a -- built-in type. -type AllBuiltinArgs - :: forall a. (GHC.Type -> GHC.Type) -> (GHC.Type -> GHC.Constraint) -> a -> GHC.Constraint -class AllElaboratedArgs constr (ElaborateBuiltin uni x) => AllBuiltinArgs uni constr x +type AllBuiltinArgs :: + forall a. (GHC.Type -> GHC.Type) -> (GHC.Type -> GHC.Constraint) -> a -> GHC.Constraint +class AllElaboratedArgs constr (ElaborateBuiltin uni x) => AllBuiltinArgs uni constr x + instance AllElaboratedArgs constr (ElaborateBuiltin uni x) => AllBuiltinArgs uni constr x -- Custom type errors to guide the programmer adding a new built-in function. -- We don't have @Unsatisfiable@ yet (https://github.com/ghc-proposals/ghc-proposals/pull/433). + -- | To be used when there's a 'TypeError' in the context. The condition is not checked as there's -- no way we could do that. underTypeError :: void underTypeError = error "Panic: a 'TypeError' was bypassed" type NoStandalonePolymorphicDataErrMsg = - 'Text "An unwrapped built-in type constructor can't be applied to a type variable" ':$$: - 'Text "Are you trying to define a polymorphic built-in function over a polymorphic type?" ':$$: - 'Text "In that case you need to wrap all polymorphic built-in types applied to type" ':$$: - 'Text " variables with either ‘SomeConstant’ or ‘Opaque’ depending on whether its the" ':$$: - 'Text " type of an argument or the type of the result, respectively" + 'Text "An unwrapped built-in type constructor can't be applied to a type variable" + ':$$: 'Text "Are you trying to define a polymorphic built-in function over a polymorphic type?" + ':$$: 'Text "In that case you need to wrap all polymorphic built-in types applied to type" + ':$$: 'Text " variables with either ‘SomeConstant’ or ‘Opaque’ depending on whether its the" + ':$$: 'Text " type of an argument or the type of the result, respectively" instance TypeError NoStandalonePolymorphicDataErrMsg => uni `Contains` TyVarRep where - knownUni = underTypeError + knownUni = underTypeError type NoConstraintsErrMsg = - 'Text "Built-in functions are not allowed to have constraints" ':$$: - 'Text "To fix this error instantiate all constrained type variables" + 'Text "Built-in functions are not allowed to have constraints" + ':$$: 'Text "To fix this error instantiate all constrained type variables" instance TypeError NoConstraintsErrMsg => Eq (Opaque val rep) where - (==) = underTypeError + (==) = underTypeError instance TypeError NoConstraintsErrMsg => Ord (Opaque val rep) where - compare = underTypeError + compare = underTypeError instance TypeError NoConstraintsErrMsg => Num (Opaque val rep) where - (+) = underTypeError - (*) = underTypeError - abs = underTypeError - signum = underTypeError - fromInteger = underTypeError - negate = underTypeError + (+) = underTypeError + (*) = underTypeError + abs = underTypeError + signum = underTypeError + fromInteger = underTypeError + negate = underTypeError instance TypeError NoConstraintsErrMsg => Enum (Opaque val rep) where - toEnum = underTypeError - fromEnum = underTypeError + toEnum = underTypeError + fromEnum = underTypeError instance TypeError NoConstraintsErrMsg => Real (Opaque val rep) where - toRational = underTypeError + toRational = underTypeError instance TypeError NoConstraintsErrMsg => Integral (Opaque val rep) where - quotRem = underTypeError - divMod = underTypeError - toInteger = underTypeError + quotRem = underTypeError + divMod = underTypeError + toInteger = underTypeError instance TypeError NoConstraintsErrMsg => Bounded (Opaque val rep) where - minBound = underTypeError - maxBound = underTypeError + minBound = underTypeError + maxBound = underTypeError instance TypeError NoConstraintsErrMsg => Ix (Opaque val rep) where - range = underTypeError - index = underTypeError - inRange = underTypeError + range = underTypeError + index = underTypeError + inRange = underTypeError instance TypeError NoConstraintsErrMsg => Semigroup (Opaque val rep) where - (<>) = underTypeError + (<>) = underTypeError instance TypeError NoConstraintsErrMsg => Monoid (Opaque val rep) where - mempty = underTypeError + mempty = underTypeError diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs index cd0e92d9027..9c0a8cbf198 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs @@ -1,27 +1,27 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StrictData #-} - -module PlutusCore.Builtin.Result - ( EvaluationError (..) - , UnliftingError (..) - , UnliftingEvaluationError (..) - , BuiltinError (..) - , BuiltinResult (..) - , notAConstant - , underTypeError - , operationalUnliftingError - , structuralUnliftingError - , emit - , withLogs - , throwing - , throwing_ - , builtinResultFailure - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} + +module PlutusCore.Builtin.Result ( + EvaluationError (..), + UnliftingError (..), + UnliftingEvaluationError (..), + BuiltinError (..), + BuiltinResult (..), + notAConstant, + underTypeError, + operationalUnliftingError, + structuralUnliftingError, + emit, + withLogs, + throwing, + throwing_, + builtinResultFailure, +) where import PlutusPrelude @@ -37,21 +37,23 @@ import Prettyprinter -- | The error message part of an 'UnliftingEvaluationError'. newtype UnliftingError = MkUnliftingError - { unUnliftingError :: Text - } deriving stock (Show, Eq) - deriving newtype (IsString, Semigroup, Monoid, NFData) + { unUnliftingError :: Text + } + deriving stock (Show, Eq) + deriving newtype (IsString, Semigroup, Monoid, NFData) -- | When unlifting of a PLC term into a Haskell value fails, this error is thrown. newtype UnliftingEvaluationError = MkUnliftingEvaluationError - { unUnliftingEvaluationError :: EvaluationError UnliftingError UnliftingError - } deriving stock (Show, Eq) - deriving newtype (NFData) + { unUnliftingEvaluationError :: EvaluationError UnliftingError UnliftingError + } + deriving stock (Show, Eq) + deriving newtype (NFData) -- | The type of errors that 'readKnown' and 'makeKnown' can return. data BuiltinError - = BuiltinUnliftingEvaluationError UnliftingEvaluationError - | BuiltinEvaluationFailure - deriving stock (Show, Eq) + = BuiltinUnliftingEvaluationError UnliftingEvaluationError + | BuiltinEvaluationFailure + deriving stock (Show, Eq) -- | The monad that 'makeKnown' runs in. -- Equivalent to @ExceptT BuiltinError (Writer (DList Text))@, except optimized in two ways: @@ -68,36 +70,38 @@ data BuiltinError -- logging, since there's no logging on the chain and builtins don't emit much anyway. Otherwise -- we'd have to use @text-builder@ or @text-builder-linear@ or something of this sort. data BuiltinResult a - = -- 'BuiltinSuccess' is the first constructor to make it a bit more likely for GHC to - -- branch-predict it (which is something that we want, because most builtins return this - -- constructor). It is however not guaranteed that GHC will predict it, because even though - -- it's likely going to be a recursive case (it certainly is in the CEK machine) and thus the - -- constructor has precedence over 'BuiltinFailure', it doesn't have precedence over - -- 'BuiltinSuccessWithLogs', since that case is equally likely to be recursive. - -- - -- Unfortunately, GHC doesn't offer any explicit control over branch-prediction (see this - -- ticket: https://gitlab.haskell.org/ghc/ghc/-/issues/849), so relying on hope is the best we - -- can do here. - BuiltinSuccess a - | BuiltinSuccessWithLogs (DList Text) a - | BuiltinFailure (DList Text) BuiltinError - deriving stock (Show, Foldable) + = -- 'BuiltinSuccess' is the first constructor to make it a bit more likely for GHC to + -- branch-predict it (which is something that we want, because most builtins return this + -- constructor). It is however not guaranteed that GHC will predict it, because even though + -- it's likely going to be a recursive case (it certainly is in the CEK machine) and thus the + -- constructor has precedence over 'BuiltinFailure', it doesn't have precedence over + -- 'BuiltinSuccessWithLogs', since that case is equally likely to be recursive. + -- + -- Unfortunately, GHC doesn't offer any explicit control over branch-prediction (see this + -- ticket: https://gitlab.haskell.org/ghc/ghc/-/issues/849), so relying on hope is the best we + -- can do here. + BuiltinSuccess a + | BuiltinSuccessWithLogs (DList Text) a + | BuiltinFailure (DList Text) BuiltinError + deriving stock (Show, Foldable) instance MonadFail BuiltinResult where - fail err = BuiltinFailure (pure $ Text.pack err) BuiltinEvaluationFailure - {-# INLINE fail #-} + fail err = BuiltinFailure (pure $ Text.pack err) BuiltinEvaluationFailure + {-# INLINE fail #-} instance Pretty UnliftingError where - pretty (MkUnliftingError err) = fold - [ "Could not unlift a value:", hardline - , pretty err - ] + pretty (MkUnliftingError err) = + fold + [ "Could not unlift a value:" + , hardline + , pretty err + ] deriving newtype instance Pretty UnliftingEvaluationError instance Pretty BuiltinError where - pretty (BuiltinUnliftingEvaluationError err) = "Builtin evaluation failure:" <+> pretty err - pretty BuiltinEvaluationFailure = "Builtin evaluation failure" + pretty (BuiltinUnliftingEvaluationError err) = "Builtin evaluation failure:" <+> pretty err + pretty BuiltinEvaluationFailure = "Builtin evaluation failure" {- Note [INLINE and OPAQUE on error-related definitions] We mark error-related definitions such as prisms like 'structuralUnliftingError' and regular @@ -115,6 +119,7 @@ variable). -} -- See Note [Ignoring context in OperationalError]. + -- | Construct a prism focusing on the @*EvaluationFailure@ part of @err@ by taking -- that @*EvaluationFailure@ and -- @@ -124,7 +129,6 @@ variable). -- -- This is useful for providing 'AsUnliftingError' instances for types such as 'CkUserError' and -- 'CekUserError'. - operationalUnliftingError :: Text -> BuiltinError operationalUnliftingError = BuiltinUnliftingEvaluationError . MkUnliftingEvaluationError . OperationalError . MkUnliftingError @@ -151,47 +155,47 @@ emit txt = BuiltinSuccessWithLogs (pure txt) () -- | Prepend logs to a 'BuiltinResult' computation. withLogs :: DList Text -> BuiltinResult a -> BuiltinResult a withLogs logs1 = \case - BuiltinSuccess x -> BuiltinSuccessWithLogs logs1 x - BuiltinSuccessWithLogs logs2 x -> BuiltinSuccessWithLogs (logs1 <> logs2) x - BuiltinFailure logs2 err -> BuiltinFailure (logs1 <> logs2) err + BuiltinSuccess x -> BuiltinSuccessWithLogs logs1 x + BuiltinSuccessWithLogs logs2 x -> BuiltinSuccessWithLogs (logs1 <> logs2) x + BuiltinFailure logs2 err -> BuiltinFailure (logs1 <> logs2) err {-# INLINE withLogs #-} instance Functor BuiltinResult where - fmap f (BuiltinSuccess x) = BuiltinSuccess (f x) - fmap f (BuiltinSuccessWithLogs logs x) = BuiltinSuccessWithLogs logs (f x) - fmap _ (BuiltinFailure logs err) = BuiltinFailure logs err - {-# INLINE fmap #-} + fmap f (BuiltinSuccess x) = BuiltinSuccess (f x) + fmap f (BuiltinSuccessWithLogs logs x) = BuiltinSuccessWithLogs logs (f x) + fmap _ (BuiltinFailure logs err) = BuiltinFailure logs err + {-# INLINE fmap #-} - -- Written out explicitly just in case. - x <$ BuiltinSuccess _ = BuiltinSuccess x - x <$ BuiltinSuccessWithLogs logs _ = BuiltinSuccessWithLogs logs x - _ <$ BuiltinFailure logs err = BuiltinFailure logs err - {-# INLINE (<$) #-} + -- Written out explicitly just in case. + x <$ BuiltinSuccess _ = BuiltinSuccess x + x <$ BuiltinSuccessWithLogs logs _ = BuiltinSuccessWithLogs logs x + _ <$ BuiltinFailure logs err = BuiltinFailure logs err + {-# INLINE (<$) #-} instance Applicative BuiltinResult where - pure = BuiltinSuccess - {-# INLINE pure #-} + pure = BuiltinSuccess + {-# INLINE pure #-} - BuiltinSuccess f <*> a = fmap f a - BuiltinSuccessWithLogs logs f <*> a = withLogs logs $ fmap f a - BuiltinFailure logs err <*> _ = BuiltinFailure logs err - {-# INLINE (<*>) #-} + BuiltinSuccess f <*> a = fmap f a + BuiltinSuccessWithLogs logs f <*> a = withLogs logs $ fmap f a + BuiltinFailure logs err <*> _ = BuiltinFailure logs err + {-# INLINE (<*>) #-} - -- Better than the default implementation, because the value in the 'BuiltinSuccess' case - -- doesn't need to be retained. - BuiltinSuccess _ *> b = b - BuiltinSuccessWithLogs logs _ *> b = withLogs logs b - BuiltinFailure logs err *> _ = BuiltinFailure logs err - {-# INLINE (*>) #-} + -- Better than the default implementation, because the value in the 'BuiltinSuccess' case + -- doesn't need to be retained. + BuiltinSuccess _ *> b = b + BuiltinSuccessWithLogs logs _ *> b = withLogs logs b + BuiltinFailure logs err *> _ = BuiltinFailure logs err + {-# INLINE (*>) #-} instance Monad BuiltinResult where - BuiltinSuccess x >>= f = f x - BuiltinSuccessWithLogs logs x >>= f = withLogs logs $ f x - BuiltinFailure logs err >>= _ = BuiltinFailure logs err - {-# INLINE (>>=) #-} + BuiltinSuccess x >>= f = f x + BuiltinSuccessWithLogs logs x >>= f = withLogs logs $ f x + BuiltinFailure logs err >>= _ = BuiltinFailure logs err + {-# INLINE (>>=) #-} - (>>) = (*>) - {-# INLINE (>>) #-} + (>>) = (*>) + {-# INLINE (>>) #-} -- | 'throwError' puts every operational unlifting error into the 'BuiltinFailure' logs. This is to -- compensate for the historical lack of error message content in operational errors (structural @@ -202,25 +206,28 @@ instance Monad BuiltinResult where -- the thrown unlifting error is an operational one, i.e. this is similar to what some builtins do -- manually (like when a crypto builtin fails and puts info about the failure into the logs). instance MonadError BuiltinError BuiltinResult where - throwError builtinErr = BuiltinFailure operationalLogs builtinErr where - operationalLogs = case builtinErr of - BuiltinUnliftingEvaluationError - (MkUnliftingEvaluationError - (OperationalError - (MkUnliftingError operationalErr))) -> pure operationalErr - _ -> mempty - {-# INLINE throwError #-} - - -- Throwing logs out is lame, but embedding them into the error would be weird, since that - -- would change the error. Not that any of that matters, we only implement this because it's a - -- method of 'MonadError' and we can't not implement it. - -- - -- We could make it @MonadError (DList Text, BuiltinError)@, but logs are arbitrary and are not - -- necessarily an inherent part of an error, so preserving them is as questionable as not doing - -- so. - BuiltinFailure _ err `catchError` f = f err - res `catchError` _ = res - {-# INLINE catchError #-} + throwError builtinErr = BuiltinFailure operationalLogs builtinErr + where + operationalLogs = case builtinErr of + BuiltinUnliftingEvaluationError + ( MkUnliftingEvaluationError + ( OperationalError + (MkUnliftingError operationalErr) + ) + ) -> pure operationalErr + _ -> mempty + {-# INLINE throwError #-} + + -- Throwing logs out is lame, but embedding them into the error would be weird, since that + -- would change the error. Not that any of that matters, we only implement this because it's a + -- method of 'MonadError' and we can't not implement it. + -- + -- We could make it @MonadError (DList Text, BuiltinError)@, but logs are arbitrary and are not + -- necessarily an inherent part of an error, so preserving them is as questionable as not doing + -- so. + BuiltinFailure _ err `catchError` f = f err + res `catchError` _ = res + {-# INLINE catchError #-} builtinResultFailure :: BuiltinResult a builtinResultFailure = BuiltinFailure mempty BuiltinEvaluationFailure diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/TestKnown.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/TestKnown.hs index 0c6642a05b7..7fd7faf1ee6 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/TestKnown.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/TestKnown.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -- | A module providing a tool for making sure that each type from a particular universe implements -- 'KnownTypeAst', 'ReadKnown' and 'MakeKnown'. Kept separate from the modules defining those -- classes in order not to introduce dependencies between them and because this extra safety is -- scary looking and it's best to keep it separate from what is necessary. -module PlutusCore.Builtin.TestKnown - ( TestTypesFromTheUniverseAreAllKnown - ) where +module PlutusCore.Builtin.TestKnown ( + TestTypesFromTheUniverseAreAllKnown, +) where import PlutusCore.Builtin.KnownType import PlutusCore.Builtin.KnownTypeAst @@ -21,29 +21,39 @@ import Universe -- | For providing a 'KnownTypeAst' instance for a built-in type it's enough for that type to -- satisfy 'KnownBuiltinTypeAst'. -class (forall tyname. KnownBuiltinTypeAst tyname uni a => KnownTypeAst tyname uni a) => - ImplementedKnownTypeAst uni a -instance (forall tyname. KnownBuiltinTypeAst tyname uni a => KnownTypeAst tyname uni a) => - ImplementedKnownTypeAst uni a +class + (forall tyname. KnownBuiltinTypeAst tyname uni a => KnownTypeAst tyname uni a) => + ImplementedKnownTypeAst uni a + +instance + (forall tyname. KnownBuiltinTypeAst tyname uni a => KnownTypeAst tyname uni a) => + ImplementedKnownTypeAst uni a -- | For providing a 'ReadKnownIn' instance for a built-in type it's enough for that type to -- satisfy 'KnownBuiltinTypeIn'. -class (forall val. KnownBuiltinTypeIn uni val a => ReadKnownIn uni val a) => - ImplementedReadKnownIn uni a -instance (forall val. KnownBuiltinTypeIn uni val a => ReadKnownIn uni val a) => - ImplementedReadKnownIn uni a +class + (forall val. KnownBuiltinTypeIn uni val a => ReadKnownIn uni val a) => + ImplementedReadKnownIn uni a + +instance + (forall val. KnownBuiltinTypeIn uni val a => ReadKnownIn uni val a) => + ImplementedReadKnownIn uni a -- | For providing a 'MakeKnownIn' instance for a built-in type it's enough for that type to -- satisfy 'KnownBuiltinTypeIn'. -class (forall val. KnownBuiltinTypeIn uni val a => MakeKnownIn uni val a) => - ImplementedMakeKnownIn uni a -instance (forall val. KnownBuiltinTypeIn uni val a => MakeKnownIn uni val a) => - ImplementedMakeKnownIn uni a +class + (forall val. KnownBuiltinTypeIn uni val a => MakeKnownIn uni val a) => + ImplementedMakeKnownIn uni a + +instance + (forall val. KnownBuiltinTypeIn uni val a => MakeKnownIn uni val a) => + ImplementedMakeKnownIn uni a -- | An instance of this class not having any constraints ensures that every type (according to -- 'Everywhere') from the universe has 'KnownTypeAst, 'ReadKnownIn' and 'MakeKnownIn' instances. class - ( uni `Everywhere` ImplementedKnownTypeAst uni - , uni `Everywhere` ImplementedReadKnownIn uni - , uni `Everywhere` ImplementedMakeKnownIn uni - ) => TestTypesFromTheUniverseAreAllKnown uni + ( uni `Everywhere` ImplementedKnownTypeAst uni + , uni `Everywhere` ImplementedReadKnownIn uni + , uni `Everywhere` ImplementedMakeKnownIn uni + ) => + TestTypesFromTheUniverseAreAllKnown uni diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/TypeScheme.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/TypeScheme.hs index dee1e4b7586..441962a1510 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/TypeScheme.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/TypeScheme.hs @@ -1,22 +1,20 @@ -- editorconfig-checker-disable-file +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | This module assigns types to built-ins. -- See the @plutus/plutus-core/docs/Constant application.md@ -- article for how this emerged. - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE StrictData #-} - -module PlutusCore.Builtin.TypeScheme - ( Typeable - , TypeScheme (..) - , argProxy - , typeSchemeToType - ) where +module PlutusCore.Builtin.TypeScheme ( + Typeable, + TypeScheme (..), + argProxy, + typeSchemeToType, +) where import PlutusCore.Builtin.KnownKind import PlutusCore.Builtin.KnownType @@ -54,51 +52,51 @@ on readability of the Core output. -- We have these 'Typeable' constraints here just for the generators tests. It's fine since -- 'TypeScheme' is not used for evaluation and so we can shove into 'TypeScheme' whatever we want. + -- | The type of type schemes of built-in functions. -- @args@ is a list of types of arguments, @res@ is the resulting type. -- E.g. @Text -> Bool -> Integer@ is encoded as @TypeScheme val [Text, Bool] Integer@. data TypeScheme val (args :: [GHC.Type]) res where - TypeSchemeResult - :: (Typeable res, KnownTypeAst TyName (UniOf val) res, MakeKnown val res) - => TypeScheme val '[] res - TypeSchemeArrow - :: (Typeable arg, KnownTypeAst TyName (UniOf val) arg, MakeKnown val arg, ReadKnown val arg) - => TypeScheme val args res -> TypeScheme val (arg ': args) res - TypeSchemeAll - :: (KnownSymbol text, KnownNat uniq, KnownKind kind) - => Proxy '(text, uniq, kind) - -> TypeScheme val args res - -> TypeScheme val args res + TypeSchemeResult :: + (Typeable res, KnownTypeAst TyName (UniOf val) res, MakeKnown val res) => + TypeScheme val '[] res + TypeSchemeArrow :: + (Typeable arg, KnownTypeAst TyName (UniOf val) arg, MakeKnown val arg, ReadKnown val arg) => + TypeScheme val args res -> TypeScheme val (arg ': args) res + TypeSchemeAll :: + (KnownSymbol text, KnownNat uniq, KnownKind kind) => + Proxy '(text, uniq, kind) -> + TypeScheme val args res -> + TypeScheme val args res argProxy :: TypeScheme val (arg ': args) res -> Proxy arg argProxy _ = Proxy -- | Convert a 'TypeScheme' to the corresponding 'Type'. typeSchemeToType :: TypeScheme val args res -> Type TyName (UniOf val) () -typeSchemeToType sch@TypeSchemeResult = toTypeAst sch +typeSchemeToType sch@TypeSchemeResult = toTypeAst sch typeSchemeToType sch@(TypeSchemeArrow schB) = - TyFun () (toTypeAst $ argProxy sch) $ typeSchemeToType schB + TyFun () (toTypeAst $ argProxy sch) $ typeSchemeToType schB typeSchemeToType (TypeSchemeAll (_ :: Proxy '(text, uniq, kind)) schB) = - let text = Text.pack $ symbolVal @text Proxy - uniq = fromIntegral $ natVal @uniq Proxy - a = TyName $ Name text $ Unique uniq - in TyForall () a (demoteKind $ knownKind @kind) $ typeSchemeToType schB + let text = Text.pack $ symbolVal @text Proxy + uniq = fromIntegral $ natVal @uniq Proxy + a = TyName $ Name text $ Unique uniq + in TyForall () a (demoteKind $ knownKind @kind) $ typeSchemeToType schB -- The precedence of @->@ is @-1@, which is why this number appears in the implementation of the -- instance. instance Show (TypeScheme val args res) where - showsPrec p sch@TypeSchemeResult = - showParen (p > 0) - $ showsPrec (-1) (typeRep sch) - showsPrec p sch@(TypeSchemeArrow schB) = - showParen (p > 0) - $ -- @0@ is to account for associativity, see https://stackoverflow.com/a/43639618 - showsPrec 0 (typeRep $ argProxy sch) - . showString " -> " - . showsPrec (-1) schB - showsPrec p (TypeSchemeAll (_ :: Proxy '(text, uniq, kind)) schB) = - showParen (p > 0) - $ showString "forall " - . showString (symbolVal @text Proxy) - . showString ". " - . showsPrec 0 schB + showsPrec p sch@TypeSchemeResult = + showParen (p > 0) $ + showsPrec (-1) (typeRep sch) + showsPrec p sch@(TypeSchemeArrow schB) = + showParen (p > 0) $ -- @0@ is to account for associativity, see https://stackoverflow.com/a/43639618 + showsPrec 0 (typeRep $ argProxy sch) + . showString " -> " + . showsPrec (-1) schB + showsPrec p (TypeSchemeAll (_ :: Proxy '(text, uniq, kind)) schB) = + showParen (p > 0) $ + showString "forall " + . showString (symbolVal @text Proxy) + . showString ". " + . showsPrec 0 schB diff --git a/plutus-core/plutus-core/src/PlutusCore/Check/Normal.hs b/plutus-core/plutus-core/src/PlutusCore/Check/Normal.hs index 1d52c7490ac..68536f0b6f9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Check/Normal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Check/Normal.hs @@ -1,15 +1,15 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} -- | This module makes sure types are normalized inside programs. -module PlutusCore.Check.Normal - ( checkProgram - , checkTerm - , isNormalType - , NormCheckError (..) - ) where +module PlutusCore.Check.Normal ( + checkProgram, + checkTerm, + isNormalType, + NormCheckError (..), +) where import PlutusPrelude @@ -21,58 +21,58 @@ import Control.Monad.Except import Universe.Core (HasUniApply (matchUniApply), SomeTypeIn (..)) -- | Ensure that all types in the 'Program' are normalized. -checkProgram - :: (HasUniApply uni, MonadError (NormCheckError tyname name uni fun ann) m) - => Program tyname name uni fun ann -> m () +checkProgram :: + (HasUniApply uni, MonadError (NormCheckError tyname name uni fun ann) m) => + Program tyname name uni fun ann -> m () checkProgram (Program _ _ t) = checkTerm t -- | Ensure that all types in the 'Term' are normalized. -checkTerm - :: (HasUniApply uni, MonadError (NormCheckError tyname name uni fun ann) m) - => Term tyname name uni fun ann -> m () +checkTerm :: + (HasUniApply uni, MonadError (NormCheckError tyname name uni fun ann) m) => + Term tyname name uni fun ann -> m () checkTerm p = liftEither $ check p -check - :: HasUniApply uni - => Term tyname name uni fun ann -> Either (NormCheckError tyname name uni fun ann) () -check (Error _ ty) = normalType ty -check (TyInst _ t ty) = check t >> normalType ty +check :: + HasUniApply uni => + Term tyname name uni fun ann -> Either (NormCheckError tyname name uni fun ann) () +check (Error _ ty) = normalType ty +check (TyInst _ t ty) = check t >> normalType ty check (IWrap _ pat arg term) = normalType pat >> normalType arg >> check term -check (Unwrap _ t) = check t -check (LamAbs _ _ ty t) = normalType ty >> check t -check (Apply _ t1 t2) = check t1 >> check t2 -check (TyAbs _ _ _ t) = check t -check (Constr _ ty _ es) = normalType ty >> traverse_ check es -check (Case _ ty arg cs) = normalType ty >> check arg >> traverse_ check cs -check Var{} = pure () -check Constant{} = pure () -check Builtin{} = pure () +check (Unwrap _ t) = check t +check (LamAbs _ _ ty t) = normalType ty >> check t +check (Apply _ t1 t2) = check t1 >> check t2 +check (TyAbs _ _ _ t) = check t +check (Constr _ ty _ es) = normalType ty >> traverse_ check es +check (Case _ ty arg cs) = normalType ty >> check arg >> traverse_ check cs +check Var {} = pure () +check Constant {} = pure () +check Builtin {} = pure () isNormalType :: HasUniApply uni => Type tyname uni ann -> Bool isNormalType = isRight . normalType -normalType - :: HasUniApply uni - => Type tyname uni ann -> Either (NormCheckError tyname name uni fun ann) () -normalType (TyFun _ i o) = normalType i >> normalType o +normalType :: + HasUniApply uni => + Type tyname uni ann -> Either (NormCheckError tyname name uni fun ann) () +normalType (TyFun _ i o) = normalType i >> normalType o normalType (TyForall _ _ _ ty) = normalType ty -normalType (TyIFix _ pat arg) = normalType pat >> normalType arg -normalType (TySOP _ tyls) = traverse_ (traverse_ normalType) tyls -normalType (TyLam _ _ _ ty) = normalType ty -normalType ty = neutralType ty +normalType (TyIFix _ pat arg) = normalType pat >> normalType arg +normalType (TySOP _ tyls) = traverse_ (traverse_ normalType) tyls +normalType (TyLam _ _ _ ty) = normalType ty +normalType ty = neutralType ty -neutralType - :: HasUniApply uni - => Type tyname uni ann -> Either (NormCheckError tyname name uni fun ann) () -neutralType TyVar{} = pure () +neutralType :: + HasUniApply uni => + Type tyname uni ann -> Either (NormCheckError tyname name uni fun ann) () +neutralType TyVar {} = pure () neutralType (TyBuiltin ann someUni) = neutralUni ann someUni -neutralType (TyApp _ ty1 ty2) = neutralType ty1 >> normalType ty2 -neutralType ty = Left (BadType (typeAnn ty) ty "neutral type") +neutralType (TyApp _ ty1 ty2) = neutralType ty1 >> normalType ty2 +neutralType ty = Left (BadType (typeAnn ty) ty "neutral type") -- See Note [Normalization of built-in types]. -neutralUni - :: HasUniApply uni - => ann -> SomeTypeIn uni -> Either (NormCheckError tyname name uni fun ann) () +neutralUni :: + HasUniApply uni => + ann -> SomeTypeIn uni -> Either (NormCheckError tyname name uni fun ann) () neutralUni ann (SomeTypeIn uni) = matchUniApply uni diff --git a/plutus-core/plutus-core/src/PlutusCore/Check/Scoping.hs b/plutus-core/plutus-core/src/PlutusCore/Check/Scoping.hs index 04f68ce620a..3ce768c014d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Check/Scoping.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Check/Scoping.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + -- TODO: add @NoFieldSelectors@ once we are past antiquity, so that 'ScopeError' doesn't generate -- partial field selectors. @@ -82,50 +83,54 @@ as importantly, what is not. -} data ScopedName - = TypeName TyName - | TermName Name - deriving stock (Show, Eq, Ord) + = TypeName TyName + | TermName Name + deriving stock (Show, Eq, Ord) isSameScope :: ScopedName -> ScopedName -> Bool -isSameScope TypeName{} TypeName{} = True -isSameScope TermName{} TermName{} = True -isSameScope TypeName{} TermName{} = False -isSameScope TermName{} TypeName{} = False +isSameScope TypeName {} TypeName {} = True +isSameScope TermName {} TermName {} = True +isSameScope TypeName {} TermName {} = False +isSameScope TermName {} TypeName {} = False -- | Staying names. data Stays - = StaysOutOfScopeVariable -- ^ An out-of-scope variable does not get renamed and hence stays. - | StaysFreeVariable -- ^ A free variable does not get renamed and hence stays. - deriving stock (Show, Eq) + = -- | An out-of-scope variable does not get renamed and hence stays. + StaysOutOfScopeVariable + | -- | A free variable does not get renamed and hence stays. + StaysFreeVariable + deriving stock (Show, Eq) -- | Changing names. data Disappears - = DisappearsBinding -- ^ A binding gets renamed and hence the name that it binds disappears. - | DisappearsVariable -- ^ A bound variable gets renamed and hence its name disappears. - deriving stock (Show, Eq) + = -- | A binding gets renamed and hence the name that it binds disappears. + DisappearsBinding + | -- | A bound variable gets renamed and hence its name disappears. + DisappearsVariable + deriving stock (Show, Eq) -- | A name either stays or disappears. data NameAction - = Stays Stays - | Disappears Disappears - deriving stock (Show, Eq) + = Stays Stays + | Disappears Disappears + deriving stock (Show, Eq) data NameAnn - = NameAction NameAction ScopedName - | NotAName - deriving stock (Show, Eq) + = NameAction NameAction ScopedName + | NotAName + deriving stock (Show, Eq) instance Pretty NameAnn where - pretty = viaShow + pretty = viaShow class ToScopedName name where - toScopedName :: name -> ScopedName + toScopedName :: name -> ScopedName instance ToScopedName TyName where - toScopedName = TypeName + toScopedName = TypeName instance ToScopedName Name where - toScopedName = TermName + toScopedName = TermName -- Naming: @introduce*@ for bindings and @register*@ for variables. @@ -146,14 +151,14 @@ registerFree :: ToScopedName name => name -> NameAnn registerFree = NameAction (Stays StaysFreeVariable) . toScopedName class Reference n t where - -- | Take a registering function, apply it to the provided name, create a type\/term variable - -- out of the resulting annotation and the original name and reference that variable in the - -- provided type\/term by prepending a constructor to it mentioning the variable. - referenceVia - :: (forall name. ToScopedName name => name -> NameAnn) - -> n - -> t NameAnn - -> t NameAnn + -- | Take a registering function, apply it to the provided name, create a type\/term variable + -- out of the resulting annotation and the original name and reference that variable in the + -- provided type\/term by prepending a constructor to it mentioning the variable. + referenceVia :: + (forall name. ToScopedName name => name -> NameAnn) -> + n -> + t NameAnn -> + t NameAnn -- | Reference the provided variable in the provided type\/term as an in-scope one. referenceBound :: Reference n t => n -> t NameAnn -> t NameAnn @@ -169,19 +174,19 @@ referenceOutOfScope = referenceVia registerOutOfScope -- | Each kind of old and new names. data ScopeEntry - = DisappearedBindings - | DisappearedVariables - | AppearedBindings - | AppearedVariables - | StayedOutOfScopeVariables - | StayedFreeVariables - deriving stock (Show, Eq, Ord) + = DisappearedBindings + | DisappearedVariables + | AppearedBindings + | AppearedVariables + | StayedOutOfScopeVariables + | StayedFreeVariables + deriving stock (Show, Eq, Ord) -- | A 'ScopeInfo' is a set of 'ScopedName's for each of the 'ScopeEntry'. -- If a 'ScopeEntry' is not present in the map, the corresponding set of 'ScopeName's is considered -- to be empty. newtype ScopeInfo = ScopeInfo (Map ScopeEntry (Set ScopedName)) - deriving stock (Show) + deriving stock (Show) -- Defining manually because of plan to move to @NoFieldSelectors@. unScopeInfo :: ScopeInfo -> Map ScopeEntry (Set ScopedName) @@ -195,32 +200,32 @@ emptyScopeInfo :: ScopeInfo emptyScopeInfo = ScopeInfo Map.empty -- | Check if a set is empty and report an error with the set embedded in it otherwise. -checkEmptyOn - :: (Set ScopedName -> Set ScopedName -> Set ScopedName) - -> (Set ScopedName -> Set ScopedName -> ScopeError) - -> Set ScopedName - -> Set ScopedName - -> Either ScopeError () +checkEmptyOn :: + (Set ScopedName -> Set ScopedName -> Set ScopedName) -> + (Set ScopedName -> Set ScopedName -> ScopeError) -> + Set ScopedName -> + Set ScopedName -> + Either ScopeError () checkEmptyOn f err s1 s2 = unless (Set.null $ f s1 s2) . Left $ err s1 s2 -- | Merge two 'ScopeInfo's checking that binders in them do not intersect along the way. mergeScopeInfo :: ScopeInfo -> ScopeInfo -> Either ScopeError ScopeInfo mergeScopeInfo si1 si2 = do - let disappearedBindings1 = to DisappearedBindings si1 - disappearedBindings2 = to DisappearedBindings si2 - appearedBindings1 = to AppearedBindings si1 - appearedBindings2 = to AppearedBindings si2 - checkEmptyOn - Set.intersection - DuplicateBindersInTheInput - disappearedBindings1 - disappearedBindings2 - checkEmptyOn - Set.intersection - DuplicateBindersInTheOutput - appearedBindings1 - appearedBindings2 - Right $ coerce (Map.unionWith Set.union) si1 si2 + let disappearedBindings1 = to DisappearedBindings si1 + disappearedBindings2 = to DisappearedBindings si2 + appearedBindings1 = to AppearedBindings si1 + appearedBindings2 = to AppearedBindings si2 + checkEmptyOn + Set.intersection + DuplicateBindersInTheInput + disappearedBindings1 + disappearedBindings2 + checkEmptyOn + Set.intersection + DuplicateBindersInTheOutput + appearedBindings1 + appearedBindings2 + Right $ coerce (Map.unionWith Set.union) si1 si2 -- We might want to use @Validation@ or something instead of 'Either'. -- @newtype@-ing it for the sake of providing very convenient 'Semigroup' and 'Monoid' instances. @@ -231,70 +236,68 @@ unScopeErrorOrInfo :: ScopeErrorOrInfo -> Either ScopeError ScopeInfo unScopeErrorOrInfo = coerce instance Semigroup ScopeErrorOrInfo where - ScopeErrorOrInfo errOrInfo1 <> ScopeErrorOrInfo errOrInfo2 = - ScopeErrorOrInfo . join $ mergeScopeInfo <$> errOrInfo1 <*> errOrInfo2 + ScopeErrorOrInfo errOrInfo1 <> ScopeErrorOrInfo errOrInfo2 = + ScopeErrorOrInfo . join $ mergeScopeInfo <$> errOrInfo1 <*> errOrInfo2 instance Monoid ScopeErrorOrInfo where - mempty = ScopeErrorOrInfo $ Right emptyScopeInfo + mempty = ScopeErrorOrInfo $ Right emptyScopeInfo -- | Whether it's OK if the pass removes bindings. A renamer isn't supposed to do that, but for -- example an inliner may do it, since it's basically the entire point of an inliner. data BindingRemoval - = BindingRemovalOk - | BindingRemovalNotOk - deriving stock (Show, Eq) + = BindingRemovalOk + | BindingRemovalNotOk + deriving stock (Show, Eq) -- ######################################################################## -- ## Main class for collecting scope information and relevant functions ## -- ######################################################################## class EstablishScoping t where - {-| Traverse a 't' freshening every name (both at the binding and the use sites) - and annotating the freshened names with either 'DisappearsBinding' or 'StaysFreeVariable' - depending on whether the name occurs at the binding or the use site. - - In addition to that every binder should be decorated with one out-of-scope variable (annotated - with 'StaysOutOfScopeVariable') and one in-scope one (annotated with 'DisappearsVariable'). - - Note that no original name occurring in 't' should survive this procedure (and hence we don't - care if any of the freshened names clashes with an original one as all original ones are - supposed to be gone). - - How to provide an implementation: - - 1. handle bindings with 'freshen*Name' + 'establishScopingBinder' (or similar) - 2. handle variables with 'freshen*Name' + 'registerFree' - 3. everything else is direct recursion + 'Applicative' stuff - -} - establishScoping :: t ann -> Quote (t NameAnn) + -- | Traverse a 't' freshening every name (both at the binding and the use sites) + -- and annotating the freshened names with either 'DisappearsBinding' or 'StaysFreeVariable' + -- depending on whether the name occurs at the binding or the use site. + -- + -- In addition to that every binder should be decorated with one out-of-scope variable (annotated + -- with 'StaysOutOfScopeVariable') and one in-scope one (annotated with 'DisappearsVariable'). + -- + -- Note that no original name occurring in 't' should survive this procedure (and hence we don't + -- care if any of the freshened names clashes with an original one as all original ones are + -- supposed to be gone). + -- + -- How to provide an implementation: + -- + -- 1. handle bindings with 'freshen*Name' + 'establishScopingBinder' (or similar) + -- 2. handle variables with 'freshen*Name' + 'registerFree' + -- 3. everything else is direct recursion + 'Applicative' stuff + establishScoping :: t ann -> Quote (t NameAnn) -- That will retraverse the same type multiple times. Should we have @referenceListVia@ as a -- primitive instead and derive 'referenceVia' in terms of it for better performance? -- Should we only pick an arbitrary sublist of the provided list instead of using the whole list -- for better performance? That requires enhancing 'Reference' with @Hedgehog.Gen@ or something. instance Reference n t => Reference [n] t where - referenceVia reg = flip . Prelude.foldr $ referenceVia reg + referenceVia reg = flip . Prelude.foldr $ referenceVia reg instance Reference n t => Reference (NonEmpty n) t where - referenceVia reg = referenceVia reg . NonEmpty.toList + referenceVia reg = referenceVia reg . NonEmpty.toList -- Given that it's straightforward to provide an implementation for the method, -- it would be nice to somehow do that generically by default. class CollectScopeInfo t where - {-| Collect scoping information after scoping was established and renaming was performed. - - How to provide an implementation: - - 1. handle names (both bindings and variables) with 'handleSname' - 2. everything else is direct recursion + 'Monoid' stuff - -} - collectScopeInfo :: t NameAnn -> ScopeErrorOrInfo + -- | Collect scoping information after scoping was established and renaming was performed. + -- + -- How to provide an implementation: + -- + -- 1. handle names (both bindings and variables) with 'handleSname' + -- 2. everything else is direct recursion + 'Monoid' stuff + collectScopeInfo :: t NameAnn -> ScopeErrorOrInfo instance EstablishScoping Proxy where - establishScoping _ = pure Proxy + establishScoping _ = pure Proxy instance CollectScopeInfo Proxy where - collectScopeInfo _ = mempty + collectScopeInfo _ = mempty -- See Note [Example of a scoping check]. type Scoping t = (EstablishScoping t, CollectScopeInfo t) @@ -303,19 +306,19 @@ type Scoping t = (EstablishScoping t, CollectScopeInfo t) -- (type\/term) and call 'establishScoping' on both the sort and its value and reassemble the -- original binder with the annotated sort and its value, but also decorate the reassembled binder -- with one out-of-scope variable and one in-scope one. -establishScopingBinder - :: (Reference name value, ToScopedName name, EstablishScoping sort, EstablishScoping value) - => (NameAnn -> name -> sort NameAnn -> value NameAnn -> value NameAnn) - -> name - -> sort ann - -> value ann - -> Quote (value NameAnn) +establishScopingBinder :: + (Reference name value, ToScopedName name, EstablishScoping sort, EstablishScoping value) => + (NameAnn -> name -> sort NameAnn -> value NameAnn -> value NameAnn) -> + name -> + sort ann -> + value ann -> + Quote (value NameAnn) establishScopingBinder binder name sort value = do - sortS <- establishScoping sort - referenceOutOfScope name . - binder (introduceBound name) name sortS . - referenceBound name <$> - establishScoping value + sortS <- establishScoping sort + referenceOutOfScope name + . binder (introduceBound name) name sortS + . referenceBound name + <$> establishScoping value -- ############################################# -- ## Checking coherence of scope information ## @@ -323,49 +326,49 @@ establishScopingBinder binder name sort value = do -- | Every kind of error thrown by the scope checking machinery at different stages. data ScopeError - = UnannotatedName !ScopedName - | NameChangedItsScope - { _oldName :: !ScopedName - , _newName :: !ScopedName - } - | NameUnexpectedlyDisappeared - { _oldName :: !ScopedName - , _newName :: !ScopedName - } - | NameUnexpectedlyStayed !ScopedName - | DuplicateBindersInTheInput - { _duplicateBindersLeft :: !(Set ScopedName) - , _duplicateBindersRight :: !(Set ScopedName) - } - | DuplicateBindersInTheOutput !(Set ScopedName) !(Set ScopedName) - | DisappearedBindingsDiscordWithBoundVariables - { _disappearedBindings :: !(Set ScopedName) - , _boundVariables :: !(Set ScopedName) - } - | DisappearedBindingsDiscordWithOutOfScopeVariables - { _disappearedBindings :: !(Set ScopedName) - , _outOfScopeVariables :: !(Set ScopedName) - } - | AppearedBindingsDiscordWithBoundVariables - { _appearedBindings :: !(Set ScopedName) - , _boundVariables :: !(Set ScopedName) - } - | DisappearedBindingsClashWithFreeVariables - { _disappearedBindings :: !(Set ScopedName) - , _freeVariables :: !(Set ScopedName) - } - | DisappearedBindingsClashWithAppearedBindings - { _disppearedBindings :: !(Set ScopedName) - , _appearedBindings :: !(Set ScopedName) - } - | AppearedBindingsClashWithFreeVariabes - { _appearedBindings :: !(Set ScopedName) - , _freeVariables :: !(Set ScopedName) - } - deriving stock (Show) + = UnannotatedName !ScopedName + | NameChangedItsScope + { _oldName :: !ScopedName + , _newName :: !ScopedName + } + | NameUnexpectedlyDisappeared + { _oldName :: !ScopedName + , _newName :: !ScopedName + } + | NameUnexpectedlyStayed !ScopedName + | DuplicateBindersInTheInput + { _duplicateBindersLeft :: !(Set ScopedName) + , _duplicateBindersRight :: !(Set ScopedName) + } + | DuplicateBindersInTheOutput !(Set ScopedName) !(Set ScopedName) + | DisappearedBindingsDiscordWithBoundVariables + { _disappearedBindings :: !(Set ScopedName) + , _boundVariables :: !(Set ScopedName) + } + | DisappearedBindingsDiscordWithOutOfScopeVariables + { _disappearedBindings :: !(Set ScopedName) + , _outOfScopeVariables :: !(Set ScopedName) + } + | AppearedBindingsDiscordWithBoundVariables + { _appearedBindings :: !(Set ScopedName) + , _boundVariables :: !(Set ScopedName) + } + | DisappearedBindingsClashWithFreeVariables + { _disappearedBindings :: !(Set ScopedName) + , _freeVariables :: !(Set ScopedName) + } + | DisappearedBindingsClashWithAppearedBindings + { _disppearedBindings :: !(Set ScopedName) + , _appearedBindings :: !(Set ScopedName) + } + | AppearedBindingsClashWithFreeVariabes + { _appearedBindings :: !(Set ScopedName) + , _freeVariables :: !(Set ScopedName) + } + deriving stock (Show) instance Pretty ScopeError where - pretty = viaShow + pretty = viaShow -- | Override the set at the provided 'ScopeEntry' to contain only the provided 'ScopedName'. overrideSname :: ScopeEntry -> ScopedName -> ScopeInfo -> ScopeInfo @@ -373,143 +376,152 @@ overrideSname key = coerce . Map.insert key . Set.singleton -- | Use a 'Stays' to handle an unchanged old name. applyStays :: Stays -> ScopedName -> ScopeInfo -applyStays stays sname = overrideSname key sname emptyScopeInfo where +applyStays stays sname = overrideSname key sname emptyScopeInfo + where key = case stays of - StaysOutOfScopeVariable -> StayedOutOfScopeVariables - StaysFreeVariable -> StayedFreeVariables + StaysOutOfScopeVariable -> StayedOutOfScopeVariables + StaysFreeVariable -> StayedFreeVariables -- | Use a 'Disappears' to handle differing old and new names. applyDisappears :: Disappears -> ScopedName -> ScopedName -> ScopeInfo applyDisappears disappears snameOld snameNew = - overrideSname keyNew snameNew $ overrideSname keyOld snameOld emptyScopeInfo where - (keyOld, keyNew) = case disappears of - DisappearsBinding -> (DisappearedBindings, AppearedBindings) - DisappearsVariable -> (DisappearedVariables, AppearedVariables) + overrideSname keyNew snameNew $ overrideSname keyOld snameOld emptyScopeInfo + where + (keyOld, keyNew) = case disappears of + DisappearsBinding -> (DisappearedBindings, AppearedBindings) + DisappearsVariable -> (DisappearedVariables, AppearedVariables) -- | Use a 'NameAction' to handle an old and a new name. -applyNameAction - :: NameAction -> ScopedName -> ScopedName -> Either ScopeError ScopeInfo +applyNameAction :: + NameAction -> ScopedName -> ScopedName -> Either ScopeError ScopeInfo applyNameAction (Stays stays) snameOld snameNew - | snameOld == snameNew = Right $ applyStays stays snameOld - | otherwise = Left $ NameUnexpectedlyDisappeared snameOld snameNew + | snameOld == snameNew = Right $ applyStays stays snameOld + | otherwise = Left $ NameUnexpectedlyDisappeared snameOld snameNew applyNameAction (Disappears disappears) snameOld snameNew - | snameOld == snameNew = Left $ NameUnexpectedlyStayed snameOld - | otherwise = Right $ applyDisappears disappears snameOld snameNew + | snameOld == snameNew = Left $ NameUnexpectedlyStayed snameOld + | otherwise = Right $ applyDisappears disappears snameOld snameNew -- | Use a 'NameAnn' to handle a new name. handleSname :: ToScopedName name => NameAnn -> name -> ScopeErrorOrInfo handleSname ann nameNew = ScopeErrorOrInfo $ do - let snameNew = toScopedName nameNew - case ann of - NotAName -> Left $ UnannotatedName snameNew - NameAction action snameOld -> - if snameOld `isSameScope` snameNew - then applyNameAction action snameOld snameNew - else Left $ NameChangedItsScope snameOld snameNew + let snameNew = toScopedName nameNew + case ann of + NotAName -> Left $ UnannotatedName snameNew + NameAction action snameOld -> + if snameOld `isSameScope` snameNew + then applyNameAction action snameOld snameNew + else Left $ NameChangedItsScope snameOld snameNew symmetricDifference :: Ord a => Set a -> Set a -> Set a symmetricDifference s t = (s `Set.union` t) `Set.difference` (s `Set.intersection` t) -{-| Check that each kind of 'Set' from 'ScopeInfo' relates to all other ones in a certain way. -We start with these three relations that are based on the assumption that for each binder we add -at least one out-of-scope variable and at least one in-scope one: - -1. disappeared bindings should be the same as stayed out of scope variables - (ensures that old bindings disappear via renaming and not via removal) -2. disappeared bindings should be the same as disappeared variables - (ensures that old names consistently disappear at the binding and use sites) -3. appeared bindings should be the same as appeared variables - (ensures that new names consistently appear at the binding and use sites) - -Once we've ensured all of that, we're left with only three sets and 3C2 equals 3, -so we only need to consider three more relations: - -1. disappeared bindings should not intersect with free variables - (an internal sanity check) -2. appeared bindings should not intersect with disappeared bindings -3. appeared bindings should not intersect with free variables - -The last two ensure that no new name has an old name's unique. --} +-- | Check that each kind of 'Set' from 'ScopeInfo' relates to all other ones in a certain way. +-- We start with these three relations that are based on the assumption that for each binder we add +-- at least one out-of-scope variable and at least one in-scope one: +-- +-- 1. disappeared bindings should be the same as stayed out of scope variables +-- (ensures that old bindings disappear via renaming and not via removal) +-- 2. disappeared bindings should be the same as disappeared variables +-- (ensures that old names consistently disappear at the binding and use sites) +-- 3. appeared bindings should be the same as appeared variables +-- (ensures that new names consistently appear at the binding and use sites) +-- +-- Once we've ensured all of that, we're left with only three sets and 3C2 equals 3, +-- so we only need to consider three more relations: +-- +-- 1. disappeared bindings should not intersect with free variables +-- (an internal sanity check) +-- 2. appeared bindings should not intersect with disappeared bindings +-- 3. appeared bindings should not intersect with free variables +-- +-- The last two ensure that no new name has an old name's unique. checkScopeInfo :: BindingRemoval -> ScopeInfo -> Either ScopeError () checkScopeInfo bindRem scopeInfo = do - let disappearedBindings = to DisappearedBindings scopeInfo - disappearedVariables = to DisappearedVariables scopeInfo - appearedBindings = to AppearedBindings scopeInfo - appearedVariables = to AppearedVariables scopeInfo - stayedOutOfScopeVariables = to StayedOutOfScopeVariables scopeInfo - stayedFreeVariables = to StayedFreeVariables scopeInfo - unless (bindRem == BindingRemovalOk) $ do - checkEmptyOn - symmetricDifference - DisappearedBindingsDiscordWithOutOfScopeVariables - disappearedBindings - stayedOutOfScopeVariables - checkEmptyOn - symmetricDifference - DisappearedBindingsDiscordWithBoundVariables - disappearedBindings - disappearedVariables - checkEmptyOn - symmetricDifference - AppearedBindingsDiscordWithBoundVariables - appearedBindings - appearedVariables + let disappearedBindings = to DisappearedBindings scopeInfo + disappearedVariables = to DisappearedVariables scopeInfo + appearedBindings = to AppearedBindings scopeInfo + appearedVariables = to AppearedVariables scopeInfo + stayedOutOfScopeVariables = to StayedOutOfScopeVariables scopeInfo + stayedFreeVariables = to StayedFreeVariables scopeInfo + unless (bindRem == BindingRemovalOk) $ do checkEmptyOn - Set.intersection - DisappearedBindingsClashWithFreeVariables - disappearedBindings - stayedFreeVariables - checkEmptyOn - Set.intersection - DisappearedBindingsClashWithAppearedBindings - appearedBindings - disappearedBindings - checkEmptyOn - Set.intersection - AppearedBindingsClashWithFreeVariabes - appearedBindings - stayedFreeVariables + symmetricDifference + DisappearedBindingsDiscordWithOutOfScopeVariables + disappearedBindings + stayedOutOfScopeVariables + checkEmptyOn + symmetricDifference + DisappearedBindingsDiscordWithBoundVariables + disappearedBindings + disappearedVariables + checkEmptyOn + symmetricDifference + AppearedBindingsDiscordWithBoundVariables + appearedBindings + appearedVariables + checkEmptyOn + Set.intersection + DisappearedBindingsClashWithFreeVariables + disappearedBindings + stayedFreeVariables + checkEmptyOn + Set.intersection + DisappearedBindingsClashWithAppearedBindings + appearedBindings + disappearedBindings + checkEmptyOn + Set.intersection + AppearedBindingsClashWithFreeVariabes + appearedBindings + stayedFreeVariables -- | The type of errors that the scope checking machinery returns. data ScopeCheckError t = ScopeCheckError - { _input :: !(t NameAnn) -- ^ What got fed to the scoping check pass before preparation. - , _prepared :: !(t NameAnn) -- ^ What got fed to the scoping check pass after preparation. - , _output :: !(t NameAnn) -- ^ What got out of it. - , _error :: !ScopeError -- ^ The error returned by the scoping check pass. - } + { _input :: !(t NameAnn) + -- ^ What got fed to the scoping check pass before preparation. + , _prepared :: !(t NameAnn) + -- ^ What got fed to the scoping check pass after preparation. + , _output :: !(t NameAnn) + -- ^ What got out of it. + , _error :: !ScopeError + -- ^ The error returned by the scoping check pass. + } deriving stock instance Show (t NameAnn) => Show (ScopeCheckError t) instance PrettyBy config (t NameAnn) => PrettyBy config (ScopeCheckError t) where - prettyBy config (ScopeCheckError input prepared output err) = vsep - [ pretty err - , "when checking that transformation of" <> hardline - , indent 2 $ prettyBy config input <> hardline - , "to" <> hardline - , indent 2 $ prettyBy config prepared <> hardline - , "to" <> hardline - , indent 2 $ prettyBy config output <> hardline - , "is correct" - ] + prettyBy config (ScopeCheckError input prepared output err) = + vsep + [ pretty err + , "when checking that transformation of" <> hardline + , indent 2 $ prettyBy config input <> hardline + , "to" <> hardline + , indent 2 $ prettyBy config prepared <> hardline + , "to" <> hardline + , indent 2 $ prettyBy config output <> hardline + , "is correct" + ] -- See Note [Example of a scoping check]. + -- | Check if a pass respects scoping. -- -- Returns the thing that the scoping tests run on, the result of the pass and the scope checking -- outcome, respectively. -checkRespectsScoping - :: Scoping t - => BindingRemoval - -> (t NameAnn -> t NameAnn) -- ^ For preparation before running the scoping tests. - -- Commonly, either @runQuote . rename@ or @id@. - -> (t NameAnn -> t NameAnn) -- ^ The runner of the pass. - -> t ann - -> Either (ScopeCheckError t) () +checkRespectsScoping :: + Scoping t => + BindingRemoval -> + -- | For preparation before running the scoping tests. + -- Commonly, either @runQuote . rename@ or @id@. + (t NameAnn -> t NameAnn) -> + -- | The runner of the pass. + (t NameAnn -> t NameAnn) -> + t ann -> + Either (ScopeCheckError t) () checkRespectsScoping bindRem prep run thing = - first (ScopeCheckError input prepared output) $ - unScopeErrorOrInfo (collectScopeInfo output) >>= checkScopeInfo bindRem + first (ScopeCheckError input prepared output) $ + unScopeErrorOrInfo (collectScopeInfo output) >>= checkScopeInfo bindRem where - input = runQuote $ establishScoping thing + input = runQuote $ establishScoping thing prepared = prep input - output = run prepared + output = run prepared diff --git a/plutus-core/plutus-core/src/PlutusCore/Check/Uniques.hs b/plutus-core/plutus-core/src/PlutusCore/Check/Uniques.hs index ede4d77517a..7470d70254a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Check/Uniques.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Check/Uniques.hs @@ -1,8 +1,8 @@ -module PlutusCore.Check.Uniques - ( checkProgram - , checkTerm - , UniqueError (..) - ) where +module PlutusCore.Check.Uniques ( + checkProgram, + checkTerm, + UniqueError (..), +) where import PlutusCore.Analysis.Definitions import PlutusCore.Core @@ -14,24 +14,26 @@ import Control.Monad.Except (MonadError, throwError) import Data.Foldable -checkProgram - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadError (UniqueError ann) m) - => (UniqueError ann -> Bool) - -> Program tyname name uni fun ann - -> m () +checkProgram :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadError (UniqueError ann) m + ) => + (UniqueError ann -> Bool) -> + Program tyname name uni fun ann -> + m () checkProgram p (Program _ _ t) = checkTerm p t -checkTerm - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadError (UniqueError ann) m) - => (UniqueError ann -> Bool) - -> Term tyname name uni fun ann - -> m () +checkTerm :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadError (UniqueError ann) m + ) => + (UniqueError ann -> Bool) -> + Term tyname name uni fun ann -> + m () checkTerm p t = do - (_, errs) <- runTermDefs t - for_ errs $ \e -> when (p e) $ throwError e + (_, errs) <- runTermDefs t + for_ errs $ \e -> when (p e) $ throwError e diff --git a/plutus-core/plutus-core/src/PlutusCore/Check/Value.hs b/plutus-core/plutus-core/src/PlutusCore/Check/Value.hs index 90c7dca946a..eb923fe1d1d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Check/Value.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Check/Value.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.Check.Value - ( isTermValue - ) where + +module PlutusCore.Check.Value ( + isTermValue, +) where import PlutusCore.Core import PlutusCore.Error @@ -13,7 +14,7 @@ isTermValue = isRight . termValue termValue :: Term tyname name uni fun ann -> Either (NormCheckError tyname name uni fun ann) () termValue (IWrap _ _ _ term) = termValue term -termValue LamAbs {} = pure () -termValue TyAbs {} = pure () -termValue Constant {} = pure () -termValue t = Left $ BadTerm (termAnn t) t "term value" +termValue LamAbs {} = pure () +termValue TyAbs {} = pure () +termValue Constant {} = pure () +termValue t = Left $ BadTerm (termAnn t) t "term value" diff --git a/plutus-core/plutus-core/src/PlutusCore/Compiler.hs b/plutus-core/plutus-core/src/PlutusCore/Compiler.hs index 2fe5907b52a..472ac3f4bc0 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Compiler.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Compiler.hs @@ -1,9 +1,9 @@ -module PlutusCore.Compiler - ( module Opts - , compileTerm - , compileProgram - , compileProgramWithTrace - ) where +module PlutusCore.Compiler ( + module Opts, + compileTerm, + compileProgram, + compileProgramWithTrace, +) where import PlutusCore.Compiler.Erase import PlutusCore.Compiler.Opts as Opts @@ -18,12 +18,12 @@ import Control.Lens (view) import Control.Monad.Reader (MonadReader) -- | Compile a PLC term to UPLC, and optimize it. -compileTerm - :: (Compiling m uni fun name a +compileTerm :: + ( Compiling m uni fun name a , MonadReader (CompilationOpts name fun a) m - ) - => Term tyname name uni fun a - -> m (UPLC.Term name uni fun a) + ) => + Term tyname name uni fun a -> + m (UPLC.Term name uni fun a) compileTerm t = do simplOpts <- view coSimplifyOpts builtinSemanticsVariant <- view coBuiltinSemanticsVariant @@ -32,22 +32,22 @@ compileTerm t = do UPLC.simplifyTerm simplOpts builtinSemanticsVariant renamed -- | Compile a PLC program to UPLC, and optimize it. -compileProgram - :: (Compiling m uni fun name a +compileProgram :: + ( Compiling m uni fun name a , MonadReader (CompilationOpts name fun a) m - ) - => Program tyname name uni fun a - -> m (UPLC.Program name uni fun a) + ) => + Program tyname name uni fun a -> + m (UPLC.Program name uni fun a) compileProgram (Program a v t) = UPLC.Program a v <$> compileTerm t -- | Compile a PLC program to UPLC, and optimize it. This includes -- the compilation trace in the result. -compileProgramWithTrace - :: (Compiling m uni fun name a +compileProgramWithTrace :: + ( Compiling m uni fun name a , MonadReader (CompilationOpts name fun a) m - ) - => Program tyname name uni fun a - -> m (UPLC.Program name uni fun a, UPLC.SimplifierTrace name uni fun a) + ) => + Program tyname name uni fun a -> + m (UPLC.Program name uni fun a, UPLC.SimplifierTrace name uni fun a) compileProgramWithTrace (Program a v t) = do simplOpts <- view coSimplifyOpts builtinSemanticsVariant <- view coBuiltinSemanticsVariant diff --git a/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs b/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs index 6dd766d58f8..1c6dd24c1a7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs @@ -5,29 +5,30 @@ import PlutusCore.Core import PlutusCore.Name.Unique import UntypedPlutusCore.Core qualified as UPLC -{-| Erase a Typed Plutus Core term to its untyped counterpart. - -Restricted to Plc terms with `Name`s, because erasing a (Named-)Debruijn term will -mess up its debruijn indexing and thus break scope-checking. --- FIXME: Lift this restriction of `eraseTerm` for (Named-)DeBruijn terms. --} -eraseTerm :: HasUnique name TermUnique - => Term tyname name uni fun ann - -> UPLC.Term name uni fun ann -eraseTerm (Var ann name) = UPLC.Var ann name -eraseTerm (TyAbs ann _ _ body) = UPLC.Delay ann (eraseTerm body) +-- | Erase a Typed Plutus Core term to its untyped counterpart. +-- +-- Restricted to Plc terms with `Name`s, because erasing a (Named-)Debruijn term will +-- mess up its debruijn indexing and thus break scope-checking. +-- -- FIXME: Lift this restriction of `eraseTerm` for (Named-)DeBruijn terms. +eraseTerm :: + HasUnique name TermUnique => + Term tyname name uni fun ann -> + UPLC.Term name uni fun ann +eraseTerm (Var ann name) = UPLC.Var ann name +eraseTerm (TyAbs ann _ _ body) = UPLC.Delay ann (eraseTerm body) eraseTerm (LamAbs ann name _ body) = UPLC.LamAbs ann name (eraseTerm body) -eraseTerm (Apply ann fun arg) = UPLC.Apply ann (eraseTerm fun) (eraseTerm arg) -eraseTerm (Constant ann con) = UPLC.Constant ann con -eraseTerm (Builtin ann bn) = UPLC.Builtin ann bn -eraseTerm (TyInst ann term _) = UPLC.Force ann (eraseTerm term) -eraseTerm (Unwrap _ term) = eraseTerm term -eraseTerm (IWrap _ _ _ term) = eraseTerm term -eraseTerm (Error ann _) = UPLC.Error ann -eraseTerm (Constr ann _ i args) = UPLC.Constr ann i (fmap eraseTerm args) -eraseTerm (Case ann _ arg cs) = UPLC.Case ann (eraseTerm arg) (fromList $ fmap eraseTerm cs) +eraseTerm (Apply ann fun arg) = UPLC.Apply ann (eraseTerm fun) (eraseTerm arg) +eraseTerm (Constant ann con) = UPLC.Constant ann con +eraseTerm (Builtin ann bn) = UPLC.Builtin ann bn +eraseTerm (TyInst ann term _) = UPLC.Force ann (eraseTerm term) +eraseTerm (Unwrap _ term) = eraseTerm term +eraseTerm (IWrap _ _ _ term) = eraseTerm term +eraseTerm (Error ann _) = UPLC.Error ann +eraseTerm (Constr ann _ i args) = UPLC.Constr ann i (fmap eraseTerm args) +eraseTerm (Case ann _ arg cs) = UPLC.Case ann (eraseTerm arg) (fromList $ fmap eraseTerm cs) -eraseProgram :: HasUnique name TermUnique - => Program tyname name uni fun ann - -> UPLC.Program name uni fun ann +eraseProgram :: + HasUnique name TermUnique => + Program tyname name uni fun ann -> + UPLC.Program name uni fun ann eraseProgram (Program a v t) = UPLC.Program a v $ eraseTerm t diff --git a/plutus-core/plutus-core/src/PlutusCore/Compiler/Opts.hs b/plutus-core/plutus-core/src/PlutusCore/Compiler/Opts.hs index ea08279ff83..3e1e1580277 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Compiler/Opts.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Compiler/Opts.hs @@ -1,11 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} -module PlutusCore.Compiler.Opts - ( CompilationOpts (..) - , coSimplifyOpts - , coBuiltinSemanticsVariant - , defaultCompilationOpts - ) where +module PlutusCore.Compiler.Opts ( + CompilationOpts (..), + coSimplifyOpts, + coBuiltinSemanticsVariant, + defaultCompilationOpts, +) where import Control.Lens (makeLenses) import Data.Default.Class (Default (def)) @@ -13,13 +13,13 @@ import PlutusCore.Builtin.Meaning (BuiltinSemanticsVariant) import UntypedPlutusCore.Simplify.Opts (SimplifyOpts, defaultSimplifyOpts) data CompilationOpts name fun a = CompilationOpts - { _coSimplifyOpts :: SimplifyOpts name a + { _coSimplifyOpts :: SimplifyOpts name a , _coBuiltinSemanticsVariant :: BuiltinSemanticsVariant fun } $(makeLenses ''CompilationOpts) -defaultCompilationOpts :: (Default (BuiltinSemanticsVariant fun)) => CompilationOpts name fun a +defaultCompilationOpts :: Default (BuiltinSemanticsVariant fun) => CompilationOpts name fun a defaultCompilationOpts = CompilationOpts { _coSimplifyOpts = defaultSimplifyOpts diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Eq.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Eq.hs index 7a8f77c5ef2..edf359a0a65 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Eq.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Eq.hs @@ -1,15 +1,13 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- editorconfig-checker-disable-file --- | 'Eq' instances for core data types. - {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - +-- | 'Eq' instances for core data types. module PlutusCore.Core.Instance.Eq () where import PlutusPrelude @@ -23,12 +21,18 @@ import PlutusCore.Rename.Monad import Universe instance (GEq uni, Eq ann) => Eq (Type TyName uni ann) where - ty1 == ty2 = runEqRename @TypeRenaming $ eqTypeM ty1 ty2 + ty1 == ty2 = runEqRename @TypeRenaming $ eqTypeM ty1 ty2 instance - ( GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann - ) => Eq (Term TyName Name uni fun ann) where - term1 == term2 = runEqRename $ eqTermM term1 term2 + ( GEq uni + , Closed uni + , uni `Everywhere` Eq + , Eq fun + , Eq ann + ) => + Eq (Term TyName Name uni fun ann) + where + term1 == term2 = runEqRename $ eqTermM term1 term2 -- Simple Structural Equality of a `Term NamedDeBruijn`. This implies three things: -- b) We do not do equality "modulo starting index". E.g. `LamAbs 0 (Var 0) /= LamAbs 1 (Var 1)`. @@ -36,24 +40,30 @@ instance -- Note that we ignore the name part in case of the nameddebruijn -- If a user wants to ignore annotations he must prior do `void <$> term`, to throw away any annotations. deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => - Eq (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => + Eq (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => - Eq (Term TyDeBruijn DeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => + Eq (Term TyDeBruijn DeBruijn uni fun ann) deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq ann) => - Eq (Type NamedTyDeBruijn uni ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq ann) => + Eq (Type NamedTyDeBruijn uni ann) deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq ann) => - Eq (Type TyDeBruijn uni ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq ann) => + Eq (Type TyDeBruijn uni ann) -deriving stock instance (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann, - Eq (Term tyname name uni fun ann) - ) => Eq (Program tyname name uni fun ann) +deriving stock instance + ( GEq uni + , Closed uni + , uni `Everywhere` Eq + , Eq fun + , Eq ann + , Eq (Term tyname name uni fun ann) + ) => + Eq (Program tyname name uni fun ann) type EqRenameOf ren a = HasUniques a => a -> a -> EqRename ren @@ -81,117 +91,119 @@ arguments gets extended with additional constructors. -- See Note [Scope tracking] -- See Note [Side tracking] -- See Note [No catch-all]. + -- | Check equality of two 'Type's. eqTypeM :: (HasRenaming ren TypeUnique, GEq uni, Eq ann) => EqRenameOf ren (Type tyname uni ann) eqTypeM (TyVar ann1 name1) (TyVar ann2 name2) = do - eqM ann1 ann2 - eqNameM name1 name2 + eqM ann1 ann2 + eqNameM name1 name2 eqTypeM (TyLam ann1 name1 kind1 ty1) (TyLam ann2 name2 kind2 ty2) = do - eqM ann1 ann2 - eqM kind1 kind2 - withTwinBindings name1 name2 $ eqTypeM ty1 ty2 + eqM ann1 ann2 + eqM kind1 kind2 + withTwinBindings name1 name2 $ eqTypeM ty1 ty2 eqTypeM (TyForall ann1 name1 kind1 ty1) (TyForall ann2 name2 kind2 ty2) = do - eqM ann1 ann2 - eqM kind1 kind2 - withTwinBindings name1 name2 $ eqTypeM ty1 ty2 + eqM ann1 ann2 + eqM kind1 kind2 + withTwinBindings name1 name2 $ eqTypeM ty1 ty2 eqTypeM (TyIFix ann1 pat1 arg1) (TyIFix ann2 pat2 arg2) = do - eqM ann1 ann2 - eqTypeM pat1 pat2 - eqTypeM arg1 arg2 + eqM ann1 ann2 + eqTypeM pat1 pat2 + eqTypeM arg1 arg2 eqTypeM (TyApp ann1 fun1 arg1) (TyApp ann2 fun2 arg2) = do - eqM ann1 ann2 - eqTypeM fun1 fun2 - eqTypeM arg1 arg2 + eqM ann1 ann2 + eqTypeM fun1 fun2 + eqTypeM arg1 arg2 eqTypeM (TyFun ann1 dom1 cod1) (TyFun ann2 dom2 cod2) = do - eqM ann1 ann2 - eqTypeM dom1 dom2 - eqTypeM cod1 cod2 + eqM ann1 ann2 + eqTypeM dom1 dom2 + eqTypeM cod1 cod2 eqTypeM (TyBuiltin ann1 someUni1) (TyBuiltin ann2 someUni2) = do - eqM ann1 ann2 - eqM someUni1 someUni2 + eqM ann1 ann2 + eqM someUni1 someUni2 eqTypeM (TySOP ann1 tyls1) (TySOP ann2 tyls2) = do - eqM ann1 ann2 - case zipExact tyls1 tyls2 of - Just ps -> for_ ps $ \(ptys1, ptys2) -> case zipExact ptys1 ptys2 of - Just tys -> for_ tys $ \(ty1, ty2) -> eqTypeM ty1 ty2 - Nothing -> empty - Nothing -> empty -eqTypeM TyVar{} _ = empty -eqTypeM TyLam{} _ = empty -eqTypeM TyForall{} _ = empty -eqTypeM TyIFix{} _ = empty -eqTypeM TyApp{} _ = empty -eqTypeM TyFun{} _ = empty -eqTypeM TyBuiltin{} _ = empty -eqTypeM TySOP{} _ = empty + eqM ann1 ann2 + case zipExact tyls1 tyls2 of + Just ps -> for_ ps $ \(ptys1, ptys2) -> case zipExact ptys1 ptys2 of + Just tys -> for_ tys $ \(ty1, ty2) -> eqTypeM ty1 ty2 + Nothing -> empty + Nothing -> empty +eqTypeM TyVar {} _ = empty +eqTypeM TyLam {} _ = empty +eqTypeM TyForall {} _ = empty +eqTypeM TyIFix {} _ = empty +eqTypeM TyApp {} _ = empty +eqTypeM TyFun {} _ = empty +eqTypeM TyBuiltin {} _ = empty +eqTypeM TySOP {} _ = empty -- See Note [Modulo alpha]. -- See Note [Scope tracking] -- See Note [Side tracking] -- See Note [No catch-all]. + -- | Check equality of two 'Term's. -eqTermM - :: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) - => EqRenameOf ScopedRenaming (Term tyname name uni fun ann) +eqTermM :: + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => + EqRenameOf ScopedRenaming (Term tyname name uni fun ann) eqTermM (LamAbs ann1 name1 ty1 body1) (LamAbs ann2 name2 ty2 body2) = do - eqM ann1 ann2 - eqTypeM ty1 ty2 - withTwinBindings name1 name2 $ eqTermM body1 body2 + eqM ann1 ann2 + eqTypeM ty1 ty2 + withTwinBindings name1 name2 $ eqTermM body1 body2 eqTermM (TyAbs ann1 name1 kind1 body1) (TyAbs ann2 name2 kind2 body2) = do - eqM ann1 ann2 - eqM kind1 kind2 - withTwinBindings name1 name2 $ eqTermM body1 body2 + eqM ann1 ann2 + eqM kind1 kind2 + withTwinBindings name1 name2 $ eqTermM body1 body2 eqTermM (IWrap ann1 pat1 arg1 term1) (IWrap ann2 pat2 arg2 term2) = do - eqM ann1 ann2 - eqTypeM pat1 pat2 - eqTypeM arg1 arg2 - eqTermM term1 term2 + eqM ann1 ann2 + eqTypeM pat1 pat2 + eqTypeM arg1 arg2 + eqTermM term1 term2 eqTermM (Apply ann1 fun1 arg1) (Apply ann2 fun2 arg2) = do - eqM ann1 ann2 - eqTermM fun1 fun2 - eqTermM arg1 arg2 + eqM ann1 ann2 + eqTermM fun1 fun2 + eqTermM arg1 arg2 eqTermM (Unwrap ann1 term1) (Unwrap ann2 term2) = do - eqM ann1 ann2 - eqTermM term1 term2 + eqM ann1 ann2 + eqTermM term1 term2 eqTermM (Error ann1 ty1) (Error ann2 ty2) = do - eqM ann1 ann2 - eqTypeM ty1 ty2 + eqM ann1 ann2 + eqTypeM ty1 ty2 eqTermM (TyInst ann1 term1 ty1) (TyInst ann2 term2 ty2) = do - eqM ann1 ann2 - eqTermM term1 term2 - eqTypeM ty1 ty2 + eqM ann1 ann2 + eqTermM term1 term2 + eqTypeM ty1 ty2 eqTermM (Var ann1 name1) (Var ann2 name2) = do - eqM ann1 ann2 - eqNameM name1 name2 + eqM ann1 ann2 + eqNameM name1 name2 eqTermM (Constant ann1 con1) (Constant ann2 con2) = do - eqM ann1 ann2 - eqM con1 con2 + eqM ann1 ann2 + eqM con1 con2 eqTermM (Builtin ann1 bi1) (Builtin ann2 bi2) = do - eqM ann1 ann2 - eqM bi1 bi2 + eqM ann1 ann2 + eqM bi1 bi2 eqTermM (Constr ann1 ty1 i1 args1) (Constr ann2 ty2 i2 args2) = do - eqM ann1 ann2 - eqTypeM ty1 ty2 - eqM i1 i2 - case zipExact args1 args2 of - Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 - Nothing -> empty + eqM ann1 ann2 + eqTypeM ty1 ty2 + eqM i1 i2 + case zipExact args1 args2 of + Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 + Nothing -> empty eqTermM (Case ann1 ty1 a1 cs1) (Case ann2 ty2 a2 cs2) = do - eqM ann1 ann2 - eqTypeM ty1 ty2 - eqTermM a1 a2 - case zipExact cs1 cs2 of - Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 - Nothing -> empty -eqTermM LamAbs{} _ = empty -eqTermM TyAbs{} _ = empty -eqTermM IWrap{} _ = empty -eqTermM Apply{} _ = empty -eqTermM Unwrap{} _ = empty -eqTermM Error{} _ = empty -eqTermM TyInst{} _ = empty -eqTermM Var{} _ = empty -eqTermM Constant{} _ = empty -eqTermM Builtin{} _ = empty -eqTermM Constr{} _ = empty -eqTermM Case{} _ = empty + eqM ann1 ann2 + eqTypeM ty1 ty2 + eqTermM a1 a2 + case zipExact cs1 cs2 of + Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 + Nothing -> empty +eqTermM LamAbs {} _ = empty +eqTermM TyAbs {} _ = empty +eqTermM IWrap {} _ = empty +eqTermM Apply {} _ = empty +eqTermM Unwrap {} _ = empty +eqTermM Error {} _ = empty +eqTermM TyInst {} _ = empty +eqTermM Var {} _ = empty +eqTermM Constant {} _ = empty +eqTermM Builtin {} _ = empty +eqTermM Constr {} _ = empty +eqTermM Case {} _ = empty diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Classic.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Classic.hs index 5daad075b2e..282aa4a5f4a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Classic.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Classic.hs @@ -1,15 +1,13 @@ --- | A "classic" (i.e. as seen in the specification) way to pretty-print PLC entities. - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | A "classic" (i.e. as seen in the specification) way to pretty-print PLC entities. module PlutusCore.Core.Instance.Pretty.Classic () where import PlutusPrelude @@ -23,86 +21,174 @@ import Prettyprinter.Custom import Universe instance Pretty ann => PrettyBy (PrettyConfigClassic configName) (Kind ann) where - prettyBy config = \case - Type ann -> - parens (sep (consAnnIf config ann - ["type"])) - KindArrow ann k k' -> - sexp "fun" (consAnnIf config ann - [prettyBy config k, prettyBy config k']) - -instance (PrettyClassicBy configName tyname, PrettyParens (SomeTypeIn uni), Pretty ann) => - PrettyBy (PrettyConfigClassic configName) (Type tyname uni ann) where - prettyBy config = \case - TyApp ann t t' -> - brackets' (sep (consAnnIf config ann - [prettyBy config t, prettyBy config t'])) - TyVar ann n -> - sep (consAnnIf config ann - [prettyBy config n]) - TyFun ann t t' -> - sexp "fun" (consAnnIf config ann - [prettyBy config t, prettyBy config t']) - TyIFix ann pat arg -> - sexp "ifix" (consAnnIf config ann - [prettyBy config pat, prettyBy config arg]) - TyForall ann n k t -> - sexp "all" (consAnnIf config ann - [prettyBy config n, prettyBy config k, prettyBy config t]) - TyBuiltin ann someUni -> - sexp "con" (consAnnIf config ann [prettyBy juxtRenderContext someUni]) - TyLam ann n k t -> - sexp "lam" (consAnnIf config ann - [prettyBy config n, prettyBy config k, prettyBy config t]) - TySOP ann tyls -> - sexp "sop" (consAnnIf config ann (fmap prettyTyl tyls)) - where - prettyTyl tyl = brackets (sep (fmap (prettyBy config) tyl)) + prettyBy config = \case + Type ann -> + parens + ( sep + ( consAnnIf + config + ann + ["type"] + ) + ) + KindArrow ann k k' -> + sexp + "fun" + ( consAnnIf + config + ann + [prettyBy config k, prettyBy config k'] + ) instance - ( PrettyClassicBy configName tyname - , PrettyClassicBy configName name - , PrettyUni uni - , Pretty fun - , Pretty ann - ) => PrettyBy (PrettyConfigClassic configName) (Term tyname name uni fun ann) where - prettyBy config = \case - Var ann n -> - sep (consAnnIf config ann [prettyBy config n]) - TyAbs ann tn k t -> - sexp "abs" (consAnnIf config ann - [prettyBy config tn, prettyBy config k, prettyBy config t]) - LamAbs ann n ty t -> - sexp "lam" (consAnnIf config ann - [prettyBy config n, prettyBy config ty, prettyBy config t]) - Apply ann t1 t2 -> - brackets' (sep (consAnnIf config ann - [prettyBy config t1, prettyBy config t2])) - Constant ann c -> - sexp "con" (consAnnIf config ann [prettyTypeOf c, pretty c]) - Builtin ann bi -> - sexp "builtin" (consAnnIf config ann [pretty bi]) - TyInst ann t ty -> - braces' (sep (consAnnIf config ann - [prettyBy config t, prettyBy config ty])) - Error ann ty -> - sexp "error" (consAnnIf config ann [prettyBy config ty]) - IWrap ann ty1 ty2 t -> - sexp "iwrap" (consAnnIf config ann - [prettyBy config ty1, prettyBy config ty2, prettyBy config t]) - Unwrap ann t -> - sexp "unwrap" (consAnnIf config ann [prettyBy config t]) - Constr ann ty i es -> - sexp "constr" (consAnnIf config ann ([prettyBy config ty, pretty i ] - ++ (fmap (prettyBy config) es))) - Case ann ty arg cs -> - sexp "case" (consAnnIf config ann ([prettyBy config ty, prettyBy config arg] - ++ (fmap (prettyBy config) cs))) + (PrettyClassicBy configName tyname, PrettyParens (SomeTypeIn uni), Pretty ann) => + PrettyBy (PrettyConfigClassic configName) (Type tyname uni ann) + where + prettyBy config = \case + TyApp ann t t' -> + brackets' + ( sep + ( consAnnIf + config + ann + [prettyBy config t, prettyBy config t'] + ) + ) + TyVar ann n -> + sep + ( consAnnIf + config + ann + [prettyBy config n] + ) + TyFun ann t t' -> + sexp + "fun" + ( consAnnIf + config + ann + [prettyBy config t, prettyBy config t'] + ) + TyIFix ann pat arg -> + sexp + "ifix" + ( consAnnIf + config + ann + [prettyBy config pat, prettyBy config arg] + ) + TyForall ann n k t -> + sexp + "all" + ( consAnnIf + config + ann + [prettyBy config n, prettyBy config k, prettyBy config t] + ) + TyBuiltin ann someUni -> + sexp "con" (consAnnIf config ann [prettyBy juxtRenderContext someUni]) + TyLam ann n k t -> + sexp + "lam" + ( consAnnIf + config + ann + [prettyBy config n, prettyBy config k, prettyBy config t] + ) + TySOP ann tyls -> + sexp "sop" (consAnnIf config ann (fmap prettyTyl tyls)) where - prettyTypeOf :: Some (ValueOf uni) -> Doc dann - prettyTypeOf (Some (ValueOf uni _ )) = prettyBy juxtRenderContext $ SomeTypeIn uni + prettyTyl tyl = brackets (sep (fmap (prettyBy config) tyl)) -instance (PrettyClassicBy configName (Term tyname name uni fun ann), Pretty ann) => - PrettyBy (PrettyConfigClassic configName) (Program tyname name uni fun ann) where - prettyBy config (Program ann version term) = - sexp "program" (consAnnIf config ann [pretty version, prettyBy config term]) +instance + ( PrettyClassicBy configName tyname + , PrettyClassicBy configName name + , PrettyUni uni + , Pretty fun + , Pretty ann + ) => + PrettyBy (PrettyConfigClassic configName) (Term tyname name uni fun ann) + where + prettyBy config = \case + Var ann n -> + sep (consAnnIf config ann [prettyBy config n]) + TyAbs ann tn k t -> + sexp + "abs" + ( consAnnIf + config + ann + [prettyBy config tn, prettyBy config k, prettyBy config t] + ) + LamAbs ann n ty t -> + sexp + "lam" + ( consAnnIf + config + ann + [prettyBy config n, prettyBy config ty, prettyBy config t] + ) + Apply ann t1 t2 -> + brackets' + ( sep + ( consAnnIf + config + ann + [prettyBy config t1, prettyBy config t2] + ) + ) + Constant ann c -> + sexp "con" (consAnnIf config ann [prettyTypeOf c, pretty c]) + Builtin ann bi -> + sexp "builtin" (consAnnIf config ann [pretty bi]) + TyInst ann t ty -> + braces' + ( sep + ( consAnnIf + config + ann + [prettyBy config t, prettyBy config ty] + ) + ) + Error ann ty -> + sexp "error" (consAnnIf config ann [prettyBy config ty]) + IWrap ann ty1 ty2 t -> + sexp + "iwrap" + ( consAnnIf + config + ann + [prettyBy config ty1, prettyBy config ty2, prettyBy config t] + ) + Unwrap ann t -> + sexp "unwrap" (consAnnIf config ann [prettyBy config t]) + Constr ann ty i es -> + sexp + "constr" + ( consAnnIf + config + ann + ( [prettyBy config ty, pretty i] + ++ (fmap (prettyBy config) es) + ) + ) + Case ann ty arg cs -> + sexp + "case" + ( consAnnIf + config + ann + ( [prettyBy config ty, prettyBy config arg] + ++ (fmap (prettyBy config) cs) + ) + ) + where + prettyTypeOf :: Some (ValueOf uni) -> Doc dann + prettyTypeOf (Some (ValueOf uni _)) = prettyBy juxtRenderContext $ SomeTypeIn uni + +instance + (PrettyClassicBy configName (Term tyname name uni fun ann), Pretty ann) => + PrettyBy (PrettyConfigClassic configName) (Program tyname name uni fun ann) + where + prettyBy config (Program ann version term) = + sexp "program" (consAnnIf config ann [pretty version, prettyBy config term]) diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs index cdbb574f1f4..86d8132b465 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs @@ -1,12 +1,10 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | While the flexible pretty-printing infrastructure is useful when you want it, -- it's helpful to have an implementation of the default Pretty typeclass that -- does the default thing. - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - module PlutusCore.Core.Instance.Pretty.Default () where import PlutusPrelude @@ -20,32 +18,38 @@ import PlutusCore.Pretty.PrettyConst import Universe instance Pretty TyName where - pretty = prettyClassic + pretty = prettyClassic instance Pretty Name where - pretty = prettyClassic + pretty = prettyClassic instance Pretty ann => Pretty (Kind ann) where - pretty = prettyClassic + pretty = prettyClassic -instance (PrettyClassic tyname, PrettyParens (SomeTypeIn uni), Pretty ann) => - Pretty (Type tyname uni ann) where - pretty = prettyClassic +instance + (PrettyClassic tyname, PrettyParens (SomeTypeIn uni), Pretty ann) => + Pretty (Type tyname uni ann) + where + pretty = prettyClassic instance - ( PrettyClassic tyname - , PrettyClassic name - , PrettyUni uni - , Pretty fun - , Pretty ann - ) => Pretty (Term tyname name uni fun ann) where - pretty = prettyClassic + ( PrettyClassic tyname + , PrettyClassic name + , PrettyUni uni + , Pretty fun + , Pretty ann + ) => + Pretty (Term tyname name uni fun ann) + where + pretty = prettyClassic instance - ( PrettyClassic tyname - , PrettyClassic name - , PrettyUni uni - , Pretty fun - , Pretty ann - ) => Pretty (Program tyname name uni fun ann) where - pretty = prettyClassic + ( PrettyClassic tyname + , PrettyClassic name + , PrettyUni uni + , Pretty fun + , Pretty ann + ) => + Pretty (Program tyname name uni fun ann) + where + pretty = prettyClassic diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Plc.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Plc.hs index 5d64317a98d..a5a146e55a5 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Plc.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Plc.hs @@ -1,8 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusCore.Core.Instance.Pretty.Plc () where @@ -13,15 +12,23 @@ import PlutusCore.Core.Instance.Pretty.Readable () import PlutusCore.Core.Type import PlutusCore.Pretty.Plc -deriving via PrettyAny (Kind ann) - instance DefaultPrettyPlcStrategy (Kind ann) => - PrettyBy PrettyConfigPlc (Kind ann) -deriving via PrettyAny (Type tyname uni ann) - instance DefaultPrettyPlcStrategy (Type tyname uni ann) => - PrettyBy PrettyConfigPlc (Type tyname uni ann) -deriving via PrettyAny (Term tyname name uni fun ann) - instance DefaultPrettyPlcStrategy (Term tyname name uni fun ann) => - PrettyBy PrettyConfigPlc (Term tyname name uni fun ann) -deriving via PrettyAny (Program tyname name uni fun ann) - instance DefaultPrettyPlcStrategy (Program tyname name uni fun ann) => - PrettyBy PrettyConfigPlc (Program tyname name uni fun ann) +deriving via + PrettyAny (Kind ann) + instance + DefaultPrettyPlcStrategy (Kind ann) => + PrettyBy PrettyConfigPlc (Kind ann) +deriving via + PrettyAny (Type tyname uni ann) + instance + DefaultPrettyPlcStrategy (Type tyname uni ann) => + PrettyBy PrettyConfigPlc (Type tyname uni ann) +deriving via + PrettyAny (Term tyname name uni fun ann) + instance + DefaultPrettyPlcStrategy (Term tyname name uni fun ann) => + PrettyBy PrettyConfigPlc (Term tyname name uni fun ann) +deriving via + PrettyAny (Program tyname name uni fun ann) + instance + DefaultPrettyPlcStrategy (Program tyname name uni fun ann) => + PrettyBy PrettyConfigPlc (Program tyname name uni fun ann) diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Readable.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Readable.hs index 6e68256f9b0..f3d882e4123 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Readable.hs @@ -1,13 +1,11 @@ --- | A "readable" Agda-like way to pretty-print PLC entities. - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | A "readable" Agda-like way to pretty-print PLC entities. module PlutusCore.Core.Instance.Pretty.Readable () where import PlutusPrelude @@ -22,143 +20,161 @@ import Universe -- | Split an iterated 'KindArrow' (if any) into the list of argument types and the resulting type. viewKindArrow :: Kind ann -> Maybe ([Kind ann], Kind ann) -viewKindArrow kind0@KindArrow{} = Just $ go kind0 where +viewKindArrow kind0@KindArrow {} = Just $ go kind0 + where go (KindArrow _ dom cod) = first (dom :) $ go cod - go kind = ([], kind) + go kind = ([], kind) viewKindArrow _ = Nothing -- | Split an iterated 'TyFun' (if any) into the list of argument types and the resulting type. viewTyFun :: Type tyname uni ann -> Maybe ([Type tyname uni ann], Type tyname uni ann) -viewTyFun ty0@TyFun{} = Just $ go ty0 where +viewTyFun ty0@TyFun {} = Just $ go ty0 + where go (TyFun _ dom cod) = first (dom :) $ go cod - go ty = ([], ty) + go ty = ([], ty) viewTyFun _ = Nothing -- | Split an iterated 'TyForall' (if any) into a list of variables that it binds and its body. viewTyForall :: Type tyname uni ann -> Maybe ([TyVarDecl tyname ann], Type tyname uni ann) -viewTyForall ty0@TyForall{} = Just $ go ty0 where +viewTyForall ty0@TyForall {} = Just $ go ty0 + where go (TyForall ann name kind body) = first (TyVarDecl ann name kind :) $ go body - go ty = ([], ty) + go ty = ([], ty) viewTyForall _ = Nothing -- | Split an iterated 'TyLam' (if any) into a list of variables that it binds and its body. viewTyLam :: Type tyname uni ann -> Maybe ([TyVarDecl tyname ann], Type tyname uni ann) -viewTyLam ty0@TyLam{} = Just $ go ty0 where +viewTyLam ty0@TyLam {} = Just $ go ty0 + where go (TyLam ann name kind body) = first (TyVarDecl ann name kind :) $ go body - go ty = ([], ty) + go ty = ([], ty) viewTyLam _ = Nothing -- | Split an iterated 'LamAbs' (if any) into a list of variables that it binds and its body. -viewLamAbs - :: Term tyname name uni fun ann - -> Maybe ([VarDecl tyname name uni ann], Term tyname name uni fun ann) -viewLamAbs term0@LamAbs{} = Just $ go term0 where +viewLamAbs :: + Term tyname name uni fun ann -> + Maybe ([VarDecl tyname name uni ann], Term tyname name uni fun ann) +viewLamAbs term0@LamAbs {} = Just $ go term0 + where go (LamAbs ann name ty body) = first (VarDecl ann name ty :) $ go body - go term = ([], term) + go term = ([], term) viewLamAbs _ = Nothing -- | Split an iterated 'TyAbs' (if any) into a list of variables that it binds and its body. -viewTyAbs - :: Term tyname name uni fun ann -> Maybe ([TyVarDecl tyname ann], Term tyname name uni fun ann) -viewTyAbs term0@TyAbs{} = Just $ go term0 where +viewTyAbs :: + Term tyname name uni fun ann -> Maybe ([TyVarDecl tyname ann], Term tyname name uni fun ann) +viewTyAbs term0@TyAbs {} = Just $ go term0 + where go (TyAbs ann name kind body) = first (TyVarDecl ann name kind :) $ go body - go term = ([], term) + go term = ([], term) viewTyAbs _ = Nothing -- | Split an iterated 'TyApp' (if any) into the head of the application and the spine. -viewTyApp - :: Type tyname uni ann -> Maybe (Type tyname uni ann, [Type tyname uni ann]) -viewTyApp ty0 = go ty0 [] where +viewTyApp :: + Type tyname uni ann -> Maybe (Type tyname uni ann, [Type tyname uni ann]) +viewTyApp ty0 = go ty0 [] + where go (TyApp _ fun arg) args = go fun $ arg : args - go _ [] = Nothing - go fun args = Just (fun, args) + go _ [] = Nothing + go fun args = Just (fun, args) -- | Split an iterated 'Apply'/'TyInst' (if any) into the head of the application and the spine. -viewApp - :: Term tyname name uni fun ann - -> Maybe - ( Term tyname name uni fun ann - , [Either (Type tyname uni ann) (Term tyname name uni fun ann)] - ) -viewApp term0 = go term0 [] where +viewApp :: + Term tyname name uni fun ann -> + Maybe + ( Term tyname name uni fun ann + , [Either (Type tyname uni ann) (Term tyname name uni fun ann)] + ) +viewApp term0 = go term0 [] + where go (Apply _ fun argTerm) args = go fun $ Right argTerm : args - go (TyInst _ fun argTy) args = go fun $ Left argTy : args - go _ [] = Nothing - go fun args = Just (fun, args) + go (TyInst _ fun argTy) args = go fun $ Left argTy : args + go _ [] = Nothing + go fun args = Just (fun, args) -instance PrettyReadableBy configName tyname => - PrettyBy (PrettyConfigReadable configName) (TyVarDecl tyname ann) where +instance + PrettyReadableBy configName tyname => + PrettyBy (PrettyConfigReadable configName) (TyVarDecl tyname ann) + where prettyBy = inContextM $ \case - TyVarDecl _ x k -> do - showKinds <- view $ prettyConfig . pcrShowKinds - withPrettyAt ToTheRight botFixity $ \prettyBot -> do - case showKinds of - ShowKindsYes -> encloseM binderFixity $ (prettyBot x <+> "::") prettyBot k - ShowKindsNonType -> case k of - Type{} -> pure $ prettyBot x - _ -> encloseM binderFixity $ (prettyBot x <+> "::") prettyBot k - ShowKindsNo -> pure $ prettyBot x + TyVarDecl _ x k -> do + showKinds <- view $ prettyConfig . pcrShowKinds + withPrettyAt ToTheRight botFixity $ \prettyBot -> do + case showKinds of + ShowKindsYes -> encloseM binderFixity $ (prettyBot x <+> "::") prettyBot k + ShowKindsNonType -> case k of + Type {} -> pure $ prettyBot x + _ -> encloseM binderFixity $ (prettyBot x <+> "::") prettyBot k + ShowKindsNo -> pure $ prettyBot x instance - ( PrettyReadableBy configName tyname - , PrettyReadableBy configName name - , PrettyUni uni - ) => PrettyBy (PrettyConfigReadable configName) (VarDecl tyname name uni ann) where + ( PrettyReadableBy configName tyname + , PrettyReadableBy configName name + , PrettyUni uni + ) => + PrettyBy (PrettyConfigReadable configName) (VarDecl tyname name uni ann) + where prettyBy = inContextM $ \case - VarDecl _ x t -> do - withPrettyAt ToTheRight botFixity $ \prettyBot -> do - encloseM binderFixity $ (prettyBot x <+> ":") prettyBot t + VarDecl _ x t -> do + withPrettyAt ToTheRight botFixity $ \prettyBot -> do + encloseM binderFixity $ (prettyBot x <+> ":") prettyBot t instance PrettyBy (PrettyConfigReadable configName) (Kind a) where - prettyBy = inContextM $ \case - (viewKindArrow -> Just (args, res)) -> iterArrowPrettyM args res - KindArrow {} -> error "Panic: 'KindArrow' is not covered by 'viewKindArrow'" - Type{} -> "*" - -instance (PrettyReadableBy configName tyname, PrettyParens (SomeTypeIn uni)) => - PrettyBy (PrettyConfigReadable configName) (Type tyname uni a) where - prettyBy = inContextM $ \case - (viewTyApp -> Just (fun, args)) -> iterAppPrettyM fun args - TyApp {} -> error "Panic: 'TyApp' is not covered by 'viewTyApp'" - TyVar _ name -> prettyM name - (viewTyFun -> Just (args, res)) -> iterArrowPrettyM args res - TyFun {} -> error "Panic: 'TyFun' is not covered by 'viewTyFun'" - TyIFix _ pat arg -> iterAppDocM $ \_ prettyArg -> "ifix" :| map prettyArg [pat, arg] - (viewTyForall -> Just (args, body)) -> iterTyForallPrettyM args body - TyForall {} -> error "Panic: 'TyForall' is not covered by 'viewTyForall'" - TyBuiltin _ someUni -> lmap _pcrRenderContext $ prettyM someUni - (viewTyLam -> Just (args, body)) -> iterLamAbsPrettyM args body - TyLam {} -> error "Panic: 'TyLam' is not covered by 'viewTyLam'" - TySOP _ tls -> iterAppDocM $ \_ prettyArg -> "sop" :| fmap prettyArg tls + prettyBy = inContextM $ \case + (viewKindArrow -> Just (args, res)) -> iterArrowPrettyM args res + KindArrow {} -> error "Panic: 'KindArrow' is not covered by 'viewKindArrow'" + Type {} -> "*" + +instance + (PrettyReadableBy configName tyname, PrettyParens (SomeTypeIn uni)) => + PrettyBy (PrettyConfigReadable configName) (Type tyname uni a) + where + prettyBy = inContextM $ \case + (viewTyApp -> Just (fun, args)) -> iterAppPrettyM fun args + TyApp {} -> error "Panic: 'TyApp' is not covered by 'viewTyApp'" + TyVar _ name -> prettyM name + (viewTyFun -> Just (args, res)) -> iterArrowPrettyM args res + TyFun {} -> error "Panic: 'TyFun' is not covered by 'viewTyFun'" + TyIFix _ pat arg -> iterAppDocM $ \_ prettyArg -> "ifix" :| map prettyArg [pat, arg] + (viewTyForall -> Just (args, body)) -> iterTyForallPrettyM args body + TyForall {} -> error "Panic: 'TyForall' is not covered by 'viewTyForall'" + TyBuiltin _ someUni -> lmap _pcrRenderContext $ prettyM someUni + (viewTyLam -> Just (args, body)) -> iterLamAbsPrettyM args body + TyLam {} -> error "Panic: 'TyLam' is not covered by 'viewTyLam'" + TySOP _ tls -> iterAppDocM $ \_ prettyArg -> "sop" :| fmap prettyArg tls + +instance + ( PrettyReadableBy configName tyname + , PrettyReadableBy configName name + , PrettyUni uni + , Pretty fun + ) => + PrettyBy (PrettyConfigReadable configName) (Term tyname name uni fun a) + where + prettyBy = inContextM $ \case + Constant _ con -> lmap (ConstConfig . _pcrRenderContext) $ prettyM con + Builtin _ bi -> unitDocM $ pretty bi + (viewApp -> Just (fun, args)) -> iterInterAppPrettyM fun args + Apply {} -> error "Panic: 'Apply' is not covered by 'viewApp'" + TyInst {} -> error "Panic: 'TyInst' is not covered by 'viewApp'" + Var _ name -> prettyM name + (viewTyAbs -> Just (args, body)) -> iterTyAbsPrettyM args body + TyAbs {} -> error "Panic: 'TyAbs' is not covered by 'viewTyAbs'" + (viewLamAbs -> Just (args, body)) -> iterLamAbsPrettyM args body + LamAbs {} -> error "Panic: 'LamAbs' is not covered by 'viewLamAbs'" + Unwrap _ term -> iterAppDocM $ \_ prettyArg -> "unwrap" :| [prettyArg term] + IWrap _ pat arg term -> + iterAppDocM $ \_ prettyArg -> + "iwrap" :| [prettyArg pat, prettyArg arg, prettyArg term] + Error _ ty -> iterAppDocM $ \_ prettyArg -> "error" :| [prettyArg $ inBraces ty] + Constr _ ty i es -> + iterAppDocM $ \_ prettyArg -> "constr" :| [prettyArg ty, prettyArg i, prettyArg es] + Case _ ty arg cs -> + iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg ty, prettyArg arg, prettyArg cs] instance - ( PrettyReadableBy configName tyname - , PrettyReadableBy configName name - , PrettyUni uni - , Pretty fun - ) => PrettyBy (PrettyConfigReadable configName) (Term tyname name uni fun a) where - prettyBy = inContextM $ \case - Constant _ con -> lmap (ConstConfig . _pcrRenderContext) $ prettyM con - Builtin _ bi -> unitDocM $ pretty bi - (viewApp -> Just (fun, args)) -> iterInterAppPrettyM fun args - Apply {} -> error "Panic: 'Apply' is not covered by 'viewApp'" - TyInst {} -> error "Panic: 'TyInst' is not covered by 'viewApp'" - Var _ name -> prettyM name - (viewTyAbs -> Just (args, body)) -> iterTyAbsPrettyM args body - TyAbs {} -> error "Panic: 'TyAbs' is not covered by 'viewTyAbs'" - (viewLamAbs -> Just (args, body)) -> iterLamAbsPrettyM args body - LamAbs {} -> error "Panic: 'LamAbs' is not covered by 'viewLamAbs'" - Unwrap _ term -> iterAppDocM $ \_ prettyArg -> "unwrap" :| [prettyArg term] - IWrap _ pat arg term -> - iterAppDocM $ \_ prettyArg -> - "iwrap" :| [prettyArg pat, prettyArg arg, prettyArg term] - Error _ ty -> iterAppDocM $ \_ prettyArg -> "error" :| [prettyArg $ inBraces ty] - Constr _ ty i es -> - iterAppDocM $ \_ prettyArg -> "constr" :| [prettyArg ty, prettyArg i, prettyArg es] - Case _ ty arg cs -> - iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg ty, prettyArg arg, prettyArg cs] - -instance PrettyReadableBy configName (Term tyname name uni fun a) => - PrettyBy (PrettyConfigReadable configName) (Program tyname name uni fun a) where - prettyBy = inContextM $ \(Program _ version term) -> - iterAppDocM $ \_ prettyArg -> "program" :| [pretty version, prettyArg term] + PrettyReadableBy configName (Term tyname name uni fun a) => + PrettyBy (PrettyConfigReadable configName) (Program tyname name uni fun a) + where + prettyBy = inContextM $ \(Program _ version term) -> + iterAppDocM $ \_ prettyArg -> "program" :| [pretty version, prettyArg term] diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Scoping.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Scoping.hs index 44c98e76bf6..e84d7ffb3db 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Scoping.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Scoping.hs @@ -1,8 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusCore.Core.Instance.Scoping () where @@ -17,115 +16,116 @@ import PlutusCore.Quote -- Just to be consistent. instance tyname ~ TyName => Reference TyName (Type tyname uni) where - referenceVia reg tyname ty = TyApp NotAName ty $ TyVar (reg tyname) tyname + referenceVia reg tyname ty = TyApp NotAName ty $ TyVar (reg tyname) tyname instance tyname ~ TyName => Reference TyName (Term tyname name uni fun) where - referenceVia reg tyname term = TyInst NotAName term $ TyVar (reg tyname) tyname + referenceVia reg tyname term = TyInst NotAName term $ TyVar (reg tyname) tyname instance name ~ Name => Reference Name (Term tyname name uni fun) where - referenceVia reg name term = Apply NotAName term $ Var (reg name) name + referenceVia reg name term = Apply NotAName term $ Var (reg name) name -- Kinds have no names, hence the simple instance. instance EstablishScoping Kind where - establishScoping kind = pure $ NotAName <$ kind + establishScoping kind = pure $ NotAName <$ kind -- Kinds have no names, hence the simple instance. instance CollectScopeInfo Kind where - collectScopeInfo _ = mempty + collectScopeInfo _ = mempty instance tyname ~ TyName => EstablishScoping (Type tyname uni) where - establishScoping (TyLam _ nameDup kind ty) = do - name <- freshenTyName nameDup - establishScopingBinder TyLam name kind ty - establishScoping (TyForall _ nameDup kind ty) = do - name <- freshenTyName nameDup - establishScopingBinder TyForall name kind ty - establishScoping (TyIFix _ pat arg) = - TyIFix NotAName <$> establishScoping pat <*> establishScoping arg - establishScoping (TyApp _ fun arg) = - TyApp NotAName <$> establishScoping fun <*> establishScoping arg - establishScoping (TyFun _ dom cod) = - TyFun NotAName <$> establishScoping dom <*> establishScoping cod - establishScoping (TyVar _ nameDup) = do - name <- freshenTyName nameDup - pure $ TyVar (registerFree name) name - establishScoping (TyBuiltin _ someUni) = pure $ TyBuiltin NotAName someUni - establishScoping (TySOP _ tyls) = - TySOP NotAName <$> (traverse . traverse) establishScoping tyls + establishScoping (TyLam _ nameDup kind ty) = do + name <- freshenTyName nameDup + establishScopingBinder TyLam name kind ty + establishScoping (TyForall _ nameDup kind ty) = do + name <- freshenTyName nameDup + establishScopingBinder TyForall name kind ty + establishScoping (TyIFix _ pat arg) = + TyIFix NotAName <$> establishScoping pat <*> establishScoping arg + establishScoping (TyApp _ fun arg) = + TyApp NotAName <$> establishScoping fun <*> establishScoping arg + establishScoping (TyFun _ dom cod) = + TyFun NotAName <$> establishScoping dom <*> establishScoping cod + establishScoping (TyVar _ nameDup) = do + name <- freshenTyName nameDup + pure $ TyVar (registerFree name) name + establishScoping (TyBuiltin _ someUni) = pure $ TyBuiltin NotAName someUni + establishScoping (TySOP _ tyls) = + TySOP NotAName <$> (traverse . traverse) establishScoping tyls firstBound :: Term tyname name uni fun ann -> [name] firstBound (Apply _ (LamAbs _ name _ body) _) = name : firstBound body -firstBound _ = [] +firstBound _ = [] instance (tyname ~ TyName, name ~ Name) => EstablishScoping (Term tyname name uni fun) where - establishScoping (LamAbs _ nameDup ty body) = do - name <- freshenName nameDup - establishScopingBinder LamAbs name ty body - establishScoping (TyAbs _ nameDup kind body) = do - name <- freshenTyName nameDup - establishScopingBinder TyAbs name kind body - establishScoping (IWrap _ pat arg term) = - IWrap NotAName <$> establishScoping pat <*> establishScoping arg <*> establishScoping term - establishScoping (Apply _ fun arg) = - Apply NotAName <$> establishScoping fun <*> establishScoping arg - establishScoping (Unwrap _ term) = Unwrap NotAName <$> establishScoping term - establishScoping (Error _ ty) = Error NotAName <$> establishScoping ty - establishScoping (TyInst _ term ty) = - TyInst NotAName <$> establishScoping term <*> establishScoping ty - establishScoping (Var _ nameDup) = do - name <- freshenName nameDup - pure $ Var (registerFree name) name - establishScoping (Constant _ con) = pure $ Constant NotAName con - establishScoping (Builtin _ bi) = pure $ Builtin NotAName bi - establishScoping (Constr _ ty i es) = - Constr NotAName <$> establishScoping ty <*> pure i <*> traverse establishScoping es - establishScoping (Case _ ty a es) = do - esScoped <- traverse establishScoping es - let esScopedPoked = addTheRest $ map (\e -> (e, firstBound e)) esScoped - branchBounds = map (snd . fst) esScopedPoked - referenceInBranch ((branch, _), others) = referenceOutOfScope (map snd others) branch - tyScoped <- establishScoping ty - aScoped <- establishScoping a - -- For each of the branches reference (as out-of-scope) the variables bound in that branch - -- in all the other ones, as well as outside of the whole case-expression. This is to check - -- that none of the transformations leak variables outside of the branch they're bound in. - pure . referenceOutOfScope branchBounds $ - Case NotAName tyScoped aScoped $ map referenceInBranch esScopedPoked + establishScoping (LamAbs _ nameDup ty body) = do + name <- freshenName nameDup + establishScopingBinder LamAbs name ty body + establishScoping (TyAbs _ nameDup kind body) = do + name <- freshenTyName nameDup + establishScopingBinder TyAbs name kind body + establishScoping (IWrap _ pat arg term) = + IWrap NotAName <$> establishScoping pat <*> establishScoping arg <*> establishScoping term + establishScoping (Apply _ fun arg) = + Apply NotAName <$> establishScoping fun <*> establishScoping arg + establishScoping (Unwrap _ term) = Unwrap NotAName <$> establishScoping term + establishScoping (Error _ ty) = Error NotAName <$> establishScoping ty + establishScoping (TyInst _ term ty) = + TyInst NotAName <$> establishScoping term <*> establishScoping ty + establishScoping (Var _ nameDup) = do + name <- freshenName nameDup + pure $ Var (registerFree name) name + establishScoping (Constant _ con) = pure $ Constant NotAName con + establishScoping (Builtin _ bi) = pure $ Builtin NotAName bi + establishScoping (Constr _ ty i es) = + Constr NotAName <$> establishScoping ty <*> pure i <*> traverse establishScoping es + establishScoping (Case _ ty a es) = do + esScoped <- traverse establishScoping es + let esScopedPoked = addTheRest $ map (\e -> (e, firstBound e)) esScoped + branchBounds = map (snd . fst) esScopedPoked + referenceInBranch ((branch, _), others) = referenceOutOfScope (map snd others) branch + tyScoped <- establishScoping ty + aScoped <- establishScoping a + -- For each of the branches reference (as out-of-scope) the variables bound in that branch + -- in all the other ones, as well as outside of the whole case-expression. This is to check + -- that none of the transformations leak variables outside of the branch they're bound in. + pure . referenceOutOfScope branchBounds $ + Case NotAName tyScoped aScoped $ + map referenceInBranch esScopedPoked instance (tyname ~ TyName, name ~ Name) => EstablishScoping (Program tyname name uni fun) where - establishScoping (Program _ ver term) = - Program NotAName ver <$> establishScoping term + establishScoping (Program _ ver term) = + Program NotAName ver <$> establishScoping term instance tyname ~ TyName => CollectScopeInfo (Type tyname uni) where - collectScopeInfo (TyLam ann name kind ty) = - handleSname ann name <> collectScopeInfo kind <> collectScopeInfo ty - collectScopeInfo (TyForall ann name kind ty) = - handleSname ann name <> collectScopeInfo kind <> collectScopeInfo ty - collectScopeInfo (TyIFix _ pat arg) = collectScopeInfo pat <> collectScopeInfo arg - collectScopeInfo (TyApp _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg - collectScopeInfo (TyFun _ dom cod) = collectScopeInfo dom <> collectScopeInfo cod - collectScopeInfo (TyVar ann name) = handleSname ann name - collectScopeInfo (TyBuiltin _ _) = mempty - collectScopeInfo (TySOP _ tyls) = (foldMap . foldMap) collectScopeInfo tyls + collectScopeInfo (TyLam ann name kind ty) = + handleSname ann name <> collectScopeInfo kind <> collectScopeInfo ty + collectScopeInfo (TyForall ann name kind ty) = + handleSname ann name <> collectScopeInfo kind <> collectScopeInfo ty + collectScopeInfo (TyIFix _ pat arg) = collectScopeInfo pat <> collectScopeInfo arg + collectScopeInfo (TyApp _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg + collectScopeInfo (TyFun _ dom cod) = collectScopeInfo dom <> collectScopeInfo cod + collectScopeInfo (TyVar ann name) = handleSname ann name + collectScopeInfo (TyBuiltin _ _) = mempty + collectScopeInfo (TySOP _ tyls) = (foldMap . foldMap) collectScopeInfo tyls instance (tyname ~ TyName, name ~ Name) => CollectScopeInfo (Term tyname name uni fun) where - collectScopeInfo (LamAbs ann name ty body) = - handleSname ann name <> collectScopeInfo ty <> collectScopeInfo body - collectScopeInfo (TyAbs ann name kind body) = - handleSname ann name <> collectScopeInfo kind <> collectScopeInfo body - collectScopeInfo (IWrap _ pat arg term) = - collectScopeInfo pat <> collectScopeInfo arg <> collectScopeInfo term - collectScopeInfo (Apply _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg - collectScopeInfo (Unwrap _ term) = collectScopeInfo term - collectScopeInfo (Error _ ty) = collectScopeInfo ty - collectScopeInfo (TyInst _ term ty) = collectScopeInfo term <> collectScopeInfo ty - collectScopeInfo (Var ann name) = handleSname ann name - collectScopeInfo (Constant _ _) = mempty - collectScopeInfo (Builtin _ _) = mempty - collectScopeInfo (Constr _ ty _ es) = - collectScopeInfo ty <> foldMap collectScopeInfo es - collectScopeInfo (Case _ ty arg cs) = - collectScopeInfo ty <> collectScopeInfo arg <> foldMap collectScopeInfo cs + collectScopeInfo (LamAbs ann name ty body) = + handleSname ann name <> collectScopeInfo ty <> collectScopeInfo body + collectScopeInfo (TyAbs ann name kind body) = + handleSname ann name <> collectScopeInfo kind <> collectScopeInfo body + collectScopeInfo (IWrap _ pat arg term) = + collectScopeInfo pat <> collectScopeInfo arg <> collectScopeInfo term + collectScopeInfo (Apply _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg + collectScopeInfo (Unwrap _ term) = collectScopeInfo term + collectScopeInfo (Error _ ty) = collectScopeInfo ty + collectScopeInfo (TyInst _ term ty) = collectScopeInfo term <> collectScopeInfo ty + collectScopeInfo (Var ann name) = handleSname ann name + collectScopeInfo (Constant _ _) = mempty + collectScopeInfo (Builtin _ _) = mempty + collectScopeInfo (Constr _ ty _ es) = + collectScopeInfo ty <> foldMap collectScopeInfo es + collectScopeInfo (Case _ ty arg cs) = + collectScopeInfo ty <> collectScopeInfo arg <> foldMap collectScopeInfo cs instance (tyname ~ TyName, name ~ Name) => CollectScopeInfo (Program tyname name uni fun) where - collectScopeInfo (Program _ _ term) = collectScopeInfo term + collectScopeInfo (Program _ _ term) = collectScopeInfo term diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Plated.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Plated.hs index d6f7ac7d7c9..8e418152ec1 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Plated.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Plated.hs @@ -1,31 +1,31 @@ -- editorconfig-checker-disable-file {-# LANGUAGE RankNTypes #-} -module PlutusCore.Core.Plated - ( kindSubkinds - , kindSubkindsDeep - , tyVarDeclSubkinds - , typeTyBinds - , typeTyVars - , typeUniques - , typeSubkinds - , typeSubtypes - , typeSubtypesDeep - , varDeclSubtypes - , termConstants - , termTyBinds - , termBinds - , termVars - , termUniques - , termSubkinds - , termSubtypes - , termSubtermsDeep - , termSubtypesDeep - , termConstantsDeep - , termSubterms - , typeUniquesDeep - , termUniquesDeep - ) where +module PlutusCore.Core.Plated ( + kindSubkinds, + kindSubkindsDeep, + tyVarDeclSubkinds, + typeTyBinds, + typeTyVars, + typeUniques, + typeSubkinds, + typeSubtypes, + typeSubtypesDeep, + varDeclSubtypes, + termConstants, + termTyBinds, + termBinds, + termVars, + termUniques, + termSubkinds, + termSubtypes, + termSubtermsDeep, + termSubtypesDeep, + termConstantsDeep, + termSubterms, + typeUniquesDeep, + termUniquesDeep, +) where import PlutusPrelude ((<^>)) @@ -37,8 +37,8 @@ import Universe kindSubkinds :: Traversal' (Kind ann) (Kind ann) kindSubkinds f kind0 = case kind0 of - KindArrow ann dom cod -> KindArrow ann <$> f dom <*> f cod - Type{} -> pure kind0 + KindArrow ann dom cod -> KindArrow ann <$> f dom <*> f cod + Type {} -> pure kind0 kindSubkindsDeep :: Fold (Kind ann) (Kind ann) kindSubkindsDeep = cosmosOf kindSubkinds @@ -51,63 +51,63 @@ tyVarDeclSubkinds f (TyVarDecl a ty k) = TyVarDecl a ty <$> f k -- | Get all the direct child 'tyname a's of the given 'Type' from binders. typeTyBinds :: Traversal' (Type tyname uni ann) tyname typeTyBinds f ty0 = case ty0 of - TyForall ann tn k ty -> f tn <&> \tn' -> TyForall ann tn' k ty - TyLam ann tn k ty -> f tn <&> \tn' -> TyLam ann tn' k ty - TyApp{} -> pure ty0 - TyIFix{} -> pure ty0 - TyFun{} -> pure ty0 - TyBuiltin{} -> pure ty0 - TyVar{} -> pure ty0 - TySOP{} -> pure ty0 + TyForall ann tn k ty -> f tn <&> \tn' -> TyForall ann tn' k ty + TyLam ann tn k ty -> f tn <&> \tn' -> TyLam ann tn' k ty + TyApp {} -> pure ty0 + TyIFix {} -> pure ty0 + TyFun {} -> pure ty0 + TyBuiltin {} -> pure ty0 + TyVar {} -> pure ty0 + TySOP {} -> pure ty0 -- | Get all the direct child 'tyname a's of the given 'Type' from 'TyVar's. typeTyVars :: Traversal' (Type tyname uni ann) tyname typeTyVars f ty0 = case ty0 of - TyVar ann n -> TyVar ann <$> f n - TyForall{} -> pure ty0 - TyLam{} -> pure ty0 - TyApp{} -> pure ty0 - TyIFix{} -> pure ty0 - TyFun{} -> pure ty0 - TyBuiltin{} -> pure ty0 - TySOP{} -> pure ty0 + TyVar ann n -> TyVar ann <$> f n + TyForall {} -> pure ty0 + TyLam {} -> pure ty0 + TyApp {} -> pure ty0 + TyIFix {} -> pure ty0 + TyFun {} -> pure ty0 + TyBuiltin {} -> pure ty0 + TySOP {} -> pure ty0 -- | Get all the direct child 'Unique's of the given 'Type' from binders 'TyVar's. typeUniques :: HasUniques (Type tyname uni ann) => Traversal' (Type tyname uni ann) Unique typeUniques f ty0 = case ty0 of - TyForall ann tn k ty -> theUnique f tn <&> \tn' -> TyForall ann tn' k ty - TyLam ann tn k ty -> theUnique f tn <&> \tn' -> TyLam ann tn' k ty - TyVar ann n -> theUnique f n <&> TyVar ann - TyApp{} -> pure ty0 - TyIFix{} -> pure ty0 - TyFun{} -> pure ty0 - TyBuiltin{} -> pure ty0 - TySOP{} -> pure ty0 + TyForall ann tn k ty -> theUnique f tn <&> \tn' -> TyForall ann tn' k ty + TyLam ann tn k ty -> theUnique f tn <&> \tn' -> TyLam ann tn' k ty + TyVar ann n -> theUnique f n <&> TyVar ann + TyApp {} -> pure ty0 + TyIFix {} -> pure ty0 + TyFun {} -> pure ty0 + TyBuiltin {} -> pure ty0 + TySOP {} -> pure ty0 -- | Get all the direct child 'Kind's of the given 'Type'. typeSubkinds :: Traversal' (Type tyname uni ann) (Kind ann) typeSubkinds f ty0 = case ty0 of - TyForall ann tn k ty -> f k <&> \k' -> TyForall ann tn k' ty - TyLam ann tn k ty -> f k <&> \k' -> TyLam ann tn k' ty - TyApp{} -> pure ty0 - TyIFix{} -> pure ty0 - TyFun{} -> pure ty0 - TyBuiltin{} -> pure ty0 - TyVar{} -> pure ty0 - TySOP{} -> pure ty0 + TyForall ann tn k ty -> f k <&> \k' -> TyForall ann tn k' ty + TyLam ann tn k ty -> f k <&> \k' -> TyLam ann tn k' ty + TyApp {} -> pure ty0 + TyIFix {} -> pure ty0 + TyFun {} -> pure ty0 + TyBuiltin {} -> pure ty0 + TyVar {} -> pure ty0 + TySOP {} -> pure ty0 {-# INLINE typeSubkinds #-} -- | Get all the direct child 'Type's of the given 'Type'. typeSubtypes :: Traversal' (Type tyname uni ann) (Type tyname uni ann) typeSubtypes f ty0 = case ty0 of - TyFun ann ty1 ty2 -> TyFun ann <$> f ty1 <*> f ty2 - TyIFix ann pat arg -> TyIFix ann <$> f pat <*> f arg - TyForall ann tn k ty -> TyForall ann tn k <$> f ty - TyLam ann tn k ty -> TyLam ann tn k <$> f ty - TyApp ann ty1 ty2 -> TyApp ann <$> f ty1 <*> f ty2 - TySOP ann tyls -> TySOP ann <$> (traverse . traverse) f tyls - TyBuiltin{} -> pure ty0 - TyVar{} -> pure ty0 + TyFun ann ty1 ty2 -> TyFun ann <$> f ty1 <*> f ty2 + TyIFix ann pat arg -> TyIFix ann <$> f pat <*> f arg + TyForall ann tn k ty -> TyForall ann tn k <$> f ty + TyLam ann tn k ty -> TyLam ann tn k <$> f ty + TyApp ann ty1 ty2 -> TyApp ann <$> f ty1 <*> f ty2 + TySOP ann tyls -> TySOP ann <$> (traverse . traverse) f tyls + TyBuiltin {} -> pure ty0 + TyVar {} -> pure ty0 {-# INLINE typeSubtypes #-} -- | Get all the transitive child 'Type's of the given 'Type'. @@ -122,115 +122,115 @@ varDeclSubtypes f (VarDecl a n ty) = VarDecl a n <$> f ty -- | Get all the direct constants of the given 'Term' from 'Constant's. termConstants :: Traversal' (Term tyname name uni fun ann) (Some (ValueOf uni)) termConstants f term0 = case term0 of - Constant ann val -> Constant ann <$> f val - Var{} -> pure term0 - TyAbs{} -> pure term0 - LamAbs{} -> pure term0 - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + Constant ann val -> Constant ann <$> f val + Var {} -> pure term0 + TyAbs {} -> pure term0 + LamAbs {} -> pure term0 + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 -- | Get all the direct child 'tyname a's of the given 'Term' from 'TyAbs'es. termTyBinds :: Traversal' (Term tyname name uni fun ann) tyname termTyBinds f term0 = case term0 of - TyAbs ann tn k t -> f tn <&> \tn' -> TyAbs ann tn' k t - Var{} -> pure term0 - LamAbs{} -> pure term0 - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + TyAbs ann tn k t -> f tn <&> \tn' -> TyAbs ann tn' k t + Var {} -> pure term0 + LamAbs {} -> pure term0 + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 -- | Get all the direct child 'name a's of the given 'Term' from 'LamAbs'es. termBinds :: Traversal' (Term tyname name uni fun ann) name termBinds f term0 = case term0 of - LamAbs ann n ty t -> f n <&> \n' -> LamAbs ann n' ty t - Var{} -> pure term0 - TyAbs{} -> pure term0 - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + LamAbs ann n ty t -> f n <&> \n' -> LamAbs ann n' ty t + Var {} -> pure term0 + TyAbs {} -> pure term0 + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 -- | Get all the direct child 'name a's of the given 'Term' from 'Var's. termVars :: Traversal' (Term tyname name uni fun ann) name termVars f term0 = case term0 of - Var ann n -> Var ann <$> f n - TyAbs{} -> pure term0 - LamAbs{} -> pure term0 - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + Var ann n -> Var ann <$> f n + TyAbs {} -> pure term0 + LamAbs {} -> pure term0 + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 -- | Get all the direct child 'Unique's of the given 'Term' (including the type-level ones). termUniques :: HasUniques (Term tyname name uni fun ann) => Traversal' (Term tyname name uni fun ann) Unique termUniques f term0 = case term0 of - TyAbs ann tn k t -> theUnique f tn <&> \tn' -> TyAbs ann tn' k t - LamAbs ann n ty t -> theUnique f n <&> \n' -> LamAbs ann n' ty t - Var ann n -> theUnique f n <&> Var ann - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + TyAbs ann tn k t -> theUnique f tn <&> \tn' -> TyAbs ann tn' k t + LamAbs ann n ty t -> theUnique f n <&> \n' -> LamAbs ann n' ty t + Var ann n -> theUnique f n <&> Var ann + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 -- | Get all the direct child 'Kind's of the given 'Term'. termSubkinds :: Traversal' (Term tyname name uni fun ann) (Kind ann) termSubkinds f term0 = case term0 of - TyAbs ann n k t -> f k <&> \k' -> TyAbs ann n k' t - LamAbs{} -> pure term0 - Var{} -> pure term0 - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + TyAbs ann n k t -> f k <&> \k' -> TyAbs ann n k' t + LamAbs {} -> pure term0 + Var {} -> pure term0 + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 {-# INLINE termSubkinds #-} -- | Get all the direct child 'Type's of the given 'Term'. termSubtypes :: Traversal' (Term tyname name uni fun ann) (Type tyname uni ann) termSubtypes f term0 = case term0 of - LamAbs ann n ty t -> LamAbs ann n <$> f ty <*> pure t - TyInst ann t ty -> TyInst ann t <$> f ty - IWrap ann ty1 ty2 t -> IWrap ann <$> f ty1 <*> f ty2 <*> pure t - Error ann ty -> Error ann <$> f ty - Constr ann ty i es -> Constr ann <$> f ty <*> pure i <*> pure es - Case ann ty arg cs -> Case ann <$> f ty <*> pure arg <*> pure cs - TyAbs{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Var{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 + LamAbs ann n ty t -> LamAbs ann n <$> f ty <*> pure t + TyInst ann t ty -> TyInst ann t <$> f ty + IWrap ann ty1 ty2 t -> IWrap ann <$> f ty1 <*> f ty2 <*> pure t + Error ann ty -> Error ann <$> f ty + Constr ann ty i es -> Constr ann <$> f ty <*> pure i <*> pure es + Case ann ty arg cs -> Case ann <$> f ty <*> pure arg <*> pure cs + TyAbs {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Var {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 {-# INLINE termSubtypes #-} -- | Get all the transitive child 'Constant's of the given 'Term'. @@ -244,18 +244,18 @@ termSubtypesDeep = termSubtermsDeep . termSubtypes . typeSubtypesDeep -- | Get all the direct child 'Term's of the given 'Term'. termSubterms :: Traversal' (Term tyname name uni fun ann) (Term tyname name uni fun ann) termSubterms f term0 = case term0 of - LamAbs ann n ty t -> LamAbs ann n ty <$> f t - TyInst ann t ty -> TyInst ann <$> f t <*> pure ty - IWrap ann ty1 ty2 t -> IWrap ann ty1 ty2 <$> f t - TyAbs ann n k t -> TyAbs ann n k <$> f t - Apply ann t1 t2 -> Apply ann <$> f t1 <*> f t2 - Unwrap ann t -> Unwrap ann <$> f t - Constr ann ty i es -> Constr ann ty i <$> traverse f es - Case ann ty arg cs -> Case ann ty <$> f arg <*> traverse f cs - Error{} -> pure term0 - Var{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 + LamAbs ann n ty t -> LamAbs ann n ty <$> f t + TyInst ann t ty -> TyInst ann <$> f t <*> pure ty + IWrap ann ty1 ty2 t -> IWrap ann ty1 ty2 <$> f t + TyAbs ann n k t -> TyAbs ann n k <$> f t + Apply ann t1 t2 -> Apply ann <$> f t1 <*> f t2 + Unwrap ann t -> Unwrap ann <$> f t + Constr ann ty i es -> Constr ann ty i <$> traverse f es + Case ann ty arg cs -> Case ann ty <$> f arg <*> traverse f cs + Error {} -> pure term0 + Var {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 {-# INLINE termSubterms #-} -- | Get all the transitive child 'Term's of the given 'Term'. diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Type.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Type.hs index 861a2858655..1a428b79e64 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Type.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Type.hs @@ -1,59 +1,60 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- We rely on things from this module being lazy (e.g. the PIR generators rely on types being lazy), -- so don't use @StrictData@ in this module. -module PlutusCore.Core.Type - ( Kind (..) - , toPatFuncKind - , fromPatFuncKind - , argsFunKind - , Type (..) - , splitFunTyParts - , funTyArgs - , funTyResultType - , Term (..) - , Program (..) - , HasTermLevel - , UniOf - , Normalized (..) - , TyVarDecl (..) - , VarDecl (..) - , TyDecl (..) - , tyDeclVar - , HasUniques - , Binder (..) - , module Export - -- * Helper functions - , termAnn - , typeAnn - , mapFun - , tyVarDeclAnn - , tyVarDeclName - , tyVarDeclKind - , varDeclAnn - , varDeclName - , varDeclType - , tyDeclAnn - , tyDeclType - , tyDeclKind - , progAnn - , progVer - , progTerm - ) +module PlutusCore.Core.Type ( + Kind (..), + toPatFuncKind, + fromPatFuncKind, + argsFunKind, + Type (..), + splitFunTyParts, + funTyArgs, + funTyResultType, + Term (..), + Program (..), + HasTermLevel, + UniOf, + Normalized (..), + TyVarDecl (..), + VarDecl (..), + TyDecl (..), + tyDeclVar, + HasUniques, + Binder (..), + module Export, + + -- * Helper functions + termAnn, + typeAnn, + mapFun, + tyVarDeclAnn, + tyVarDeclName, + tyVarDeclKind, + varDeclAnn, + varDeclName, + varDeclType, + tyDeclAnn, + tyDeclType, + tyDeclKind, + progAnn, + progVer, + progTerm, +) where import PlutusPrelude @@ -72,10 +73,10 @@ import Language.Haskell.TH.Lift import Universe data Kind ann - = Type ann - | KindArrow ann (Kind ann) (Kind ann) - deriving stock (Eq, Show, Functor, Generic, Lift) - deriving anyclass (NFData, Hashable) + = Type ann + | KindArrow ann (Kind ann) (Kind ann) + deriving stock (Eq, Show, Functor, Generic, Lift) + deriving anyclass (NFData, Hashable) -- | The kind of a pattern functor (the first 'Type' argument of 'TyIFix') at a given kind (of the -- second 'Type' argument of 'TyIFix'): @@ -86,90 +87,113 @@ toPatFuncKind k = KindArrow () (KindArrow () k (Type ())) (KindArrow () k (Type fromPatFuncKind :: Kind () -> Maybe (Kind ()) fromPatFuncKind (KindArrow () (KindArrow () k1 (Type ())) (KindArrow () k2 (Type ()))) - | k1 == k2 = Just k1 + | k1 == k2 = Just k1 fromPatFuncKind _ = Nothing -- | Extract all @a_i@ from @a_0 -> a_1 -> ... -> r@. argsFunKind :: Kind ann -> [Kind ann] -argsFunKind Type{} = [] +argsFunKind Type {} = [] argsFunKind (KindArrow _ k l) = k : argsFunKind l -- | A 'Type' assigned to expressions. type Type :: GHC.Type -> (GHC.Type -> GHC.Type) -> GHC.Type -> GHC.Type data Type tyname uni ann - = TyVar ann tyname -- ^ Type variable - | TyFun ann (Type tyname uni ann) (Type tyname uni ann) -- ^ Function type - | TyIFix ann (Type tyname uni ann) (Type tyname uni ann) - -- ^ Fix-point type, for constructing self-recursive types - | TyForall ann tyname (Kind ann) (Type tyname uni ann) -- ^ Polymorphic type - | TyBuiltin ann (SomeTypeIn uni) -- ^ Builtin type - | TyLam ann tyname (Kind ann) (Type tyname uni ann) -- ^ Type lambda - | TyApp ann (Type tyname uni ann) (Type tyname uni ann) -- ^ Type application - | TySOP ann [[Type tyname uni ann]] -- ^ Sum-of-products type - deriving stock (Show, Functor, Generic) - deriving anyclass (NFData) + = -- | Type variable + TyVar ann tyname + | -- | Function type + TyFun ann (Type tyname uni ann) (Type tyname uni ann) + | -- | Fix-point type, for constructing self-recursive types + TyIFix ann (Type tyname uni ann) (Type tyname uni ann) + | -- | Polymorphic type + TyForall ann tyname (Kind ann) (Type tyname uni ann) + | -- | Builtin type + TyBuiltin ann (SomeTypeIn uni) + | -- | Type lambda + TyLam ann tyname (Kind ann) (Type tyname uni ann) + | -- | Type application + TyApp ann (Type tyname uni ann) (Type tyname uni ann) + | -- | Sum-of-products type + TySOP ann [[Type tyname uni ann]] + deriving stock (Show, Functor, Generic) + deriving anyclass (NFData) -- | Get recursively all the domains and codomains of a type. -- @splitFunTyParts (A->B->C) = [A, B, C]@ -- @splitFunTyParts (X) = [X]@ splitFunTyParts :: Type tyname uni a -> NE.NonEmpty (Type tyname uni a) splitFunTyParts = \case - TyFun _ t1 t2 -> t1 NE.<| splitFunTyParts t2 - t -> pure t + TyFun _ t1 t2 -> t1 NE.<| splitFunTyParts t2 + t -> pure t -- | Get the argument types of a function type. -- @funTyArgs (A->B->C) = [A, B]@ -funTyArgs :: Type tyname uni a -> [Type tyname uni a] +funTyArgs :: Type tyname uni a -> [Type tyname uni a] funTyArgs = NE.init . splitFunTyParts -- | Get the result type of a function. -- If not a function, then is the same as `id` -- @funResultType (A->B->C) = C@ -- @funResultType (X) = X@ -funTyResultType :: Type tyname uni a -> Type tyname uni a +funTyResultType :: Type tyname uni a -> Type tyname uni a funTyResultType = NE.last . splitFunTyParts data Term tyname name uni fun ann - = Var ann name -- ^ a named variable - | LamAbs ann name (Type tyname uni ann) (Term tyname name uni fun ann) -- ^ lambda abstraction - | Apply ann (Term tyname name uni fun ann) (Term tyname name uni fun ann) -- ^ application - | TyAbs ann tyname (Kind ann) (Term tyname name uni fun ann) -- ^ type abstraction - | TyInst ann (Term tyname name uni fun ann) (Type tyname uni ann) -- ^ instantiation - | IWrap ann (Type tyname uni ann) (Type tyname uni ann) (Term tyname name uni fun ann) -- ^ wrapping - | Unwrap ann (Term tyname name uni fun ann) -- ^ unwrapping + = -- | a named variable + Var ann name + | -- | lambda abstraction + LamAbs ann name (Type tyname uni ann) (Term tyname name uni fun ann) + | -- | application + Apply ann (Term tyname name uni fun ann) (Term tyname name uni fun ann) + | -- | type abstraction + TyAbs ann tyname (Kind ann) (Term tyname name uni fun ann) + | -- | instantiation + TyInst ann (Term tyname name uni fun ann) (Type tyname uni ann) + | -- | wrapping + IWrap ann (Type tyname uni ann) (Type tyname uni ann) (Term tyname name uni fun ann) + | -- | unwrapping -- See Note [Constr tag type] - | Constr ann (Type tyname uni ann) Word64 [Term tyname name uni fun ann] -- ^ constructor - | Case ann (Type tyname uni ann) (Term tyname name uni fun ann) [Term tyname name uni fun ann] -- ^ case - | Constant ann (Some (ValueOf uni)) -- ^ constants - | Builtin ann fun -- ^ builtin functions - | Error ann (Type tyname uni ann) -- ^ fail with error - deriving stock (Functor, Generic) - -deriving stock instance (Show tyname, Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Term tyname name uni fun ann) - -deriving anyclass instance (NFData tyname, NFData name, NFData fun, NFData ann, Everywhere uni NFData, Closed uni) - => NFData (Term tyname name uni fun ann) + Unwrap ann (Term tyname name uni fun ann) + | -- | constructor + Constr ann (Type tyname uni ann) Word64 [Term tyname name uni fun ann] + | -- | case + Case ann (Type tyname uni ann) (Term tyname name uni fun ann) [Term tyname name uni fun ann] + | -- | constants + Constant ann (Some (ValueOf uni)) + | -- | builtin functions + Builtin ann fun + | -- | fail with error + Error ann (Type tyname uni ann) + deriving stock (Functor, Generic) + +deriving stock instance + (Show tyname, Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (Term tyname name uni fun ann) + +deriving anyclass instance + (NFData tyname, NFData name, NFData fun, NFData ann, Everywhere uni NFData, Closed uni) => + NFData (Term tyname name uni fun ann) -- See Note [ExMemoryUsage instances for non-constants]. instance ExMemoryUsage (Term tyname name uni fun ann) where - memoryUsage = error "Internal error: 'memoryUsage' for Core 'Term' is not supposed to be forced" + memoryUsage = error "Internal error: 'memoryUsage' for Core 'Term' is not supposed to be forced" -- | A 'Program' is simply a 'Term' coupled with a 'Version' of the core language. data Program tyname name uni fun ann = Program - { _progAnn :: ann - , _progVer :: Version - , _progTerm :: Term tyname name uni fun ann - } - deriving stock (Functor, Generic) + { _progAnn :: ann + , _progVer :: Version + , _progTerm :: Term tyname name uni fun ann + } + deriving stock (Functor, Generic) makeLenses ''Program -deriving stock instance (Show tyname, Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Program tyname name uni fun ann) +deriving stock instance + (Show tyname, Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (Program tyname name uni fun ann) -deriving anyclass instance (NFData tyname, NFData name, Everywhere uni NFData, NFData fun, NFData ann, Closed uni) - => NFData (Program tyname name uni fun ann) +deriving anyclass instance + (NFData tyname, NFData name, Everywhere uni NFData, NFData fun, NFData ann, Closed uni) => + NFData (Program tyname name uni fun ann) -- | Specifies that the given type is a built-in one and its values can be embedded into a 'Term'. type HasTermLevel :: forall a. (GHC.Type -> GHC.Type) -> a -> GHC.Constraint @@ -182,102 +206,113 @@ type instance UniOf (Term tyname name uni fun ann) = uni -- | A "type variable declaration", i.e. a name and a kind for a type variable. data TyVarDecl tyname ann = TyVarDecl - { _tyVarDeclAnn :: ann - , _tyVarDeclName :: tyname - , _tyVarDeclKind :: Kind ann - } deriving stock (Functor, Show, Generic) + { _tyVarDeclAnn :: ann + , _tyVarDeclName :: tyname + , _tyVarDeclKind :: Kind ann + } + deriving stock (Functor, Show, Generic) + makeLenses ''TyVarDecl -- | A "variable declaration", i.e. a name and a type for a variable. data VarDecl tyname name uni ann = VarDecl - { _varDeclAnn :: ann - , _varDeclName :: name - , _varDeclType :: Type tyname uni ann - } deriving stock (Functor, Show, Generic) + { _varDeclAnn :: ann + , _varDeclName :: name + , _varDeclType :: Type tyname uni ann + } + deriving stock (Functor, Show, Generic) + makeLenses ''VarDecl -- | A "type declaration", i.e. a kind for a type. data TyDecl tyname uni ann = TyDecl - { _tyDeclAnn :: ann - , _tyDeclType :: Type tyname uni ann - , _tyDeclKind :: Kind ann - } deriving stock (Functor, Show, Generic) + { _tyDeclAnn :: ann + , _tyDeclType :: Type tyname uni ann + , _tyDeclKind :: Kind ann + } + deriving stock (Functor, Show, Generic) + makeLenses ''TyDecl tyDeclVar :: TyVarDecl tyname ann -> TyDecl tyname uni ann tyDeclVar (TyVarDecl ann name kind) = TyDecl ann (TyVar ann name) kind instance HasUnique tyname TypeUnique => HasUnique (TyVarDecl tyname ann) TypeUnique where - unique f (TyVarDecl ann tyname kind) = - unique f tyname <&> \tyname' -> TyVarDecl ann tyname' kind + unique f (TyVarDecl ann tyname kind) = + unique f tyname <&> \tyname' -> TyVarDecl ann tyname' kind instance HasUnique name TermUnique => HasUnique (VarDecl tyname name uni ann) TermUnique where - unique f (VarDecl ann name ty) = - unique f name <&> \name' -> VarDecl ann name' ty + unique f (VarDecl ann name ty) = + unique f name <&> \name' -> VarDecl ann name' ty newtype Normalized a = Normalized - { unNormalized :: a - } deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic) - deriving newtype (NFData, Pretty, PrettyBy config) - deriving Applicative via Identity + { unNormalized :: a + } + deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic) + deriving newtype (NFData, Pretty, PrettyBy config) + deriving (Applicative) via Identity -- | All kinds of uniques an entity contains. type family HasUniques a :: GHC.Constraint + type instance HasUniques (Kind ann) = () type instance HasUniques (Type tyname uni ann) = HasUnique tyname TypeUnique -type instance HasUniques (Term tyname name uni fun ann) = +type instance + HasUniques (Term tyname name uni fun ann) = (HasUnique tyname TypeUnique, HasUnique name TermUnique) -type instance HasUniques (Program tyname name uni fun ann) = +type instance + HasUniques (Program tyname name uni fun ann) = HasUniques (Term tyname name uni fun ann) typeAnn :: Type tyname uni ann -> ann -typeAnn (TyVar ann _ ) = ann -typeAnn (TyFun ann _ _ ) = ann -typeAnn (TyIFix ann _ _ ) = ann +typeAnn (TyVar ann _) = ann +typeAnn (TyFun ann _ _) = ann +typeAnn (TyIFix ann _ _) = ann typeAnn (TyForall ann _ _ _) = ann -typeAnn (TyBuiltin ann _ ) = ann -typeAnn (TyLam ann _ _ _ ) = ann -typeAnn (TyApp ann _ _ ) = ann -typeAnn (TySOP ann _ ) = ann +typeAnn (TyBuiltin ann _) = ann +typeAnn (TyLam ann _ _ _) = ann +typeAnn (TyApp ann _ _) = ann +typeAnn (TySOP ann _) = ann termAnn :: Term tyname name uni fun ann -> ann -termAnn (Var ann _ ) = ann -termAnn (TyAbs ann _ _ _ ) = ann -termAnn (Apply ann _ _ ) = ann -termAnn (Constant ann _ ) = ann -termAnn (Builtin ann _ ) = ann -termAnn (TyInst ann _ _ ) = ann -termAnn (Unwrap ann _ ) = ann -termAnn (IWrap ann _ _ _ ) = ann -termAnn (Error ann _ ) = ann +termAnn (Var ann _) = ann +termAnn (TyAbs ann _ _ _) = ann +termAnn (Apply ann _ _) = ann +termAnn (Constant ann _) = ann +termAnn (Builtin ann _) = ann +termAnn (TyInst ann _ _) = ann +termAnn (Unwrap ann _) = ann +termAnn (IWrap ann _ _ _) = ann +termAnn (Error ann _) = ann termAnn (LamAbs ann _ _ _) = ann termAnn (Constr ann _ _ _) = ann -termAnn (Case ann _ _ _ ) = ann +termAnn (Case ann _ _ _) = ann -- | Map a function over the set of built-in functions. mapFun :: (fun -> fun') -> Term tyname name uni fun ann -> Term tyname name uni fun' ann -mapFun f = go where - go (LamAbs ann name ty body) = LamAbs ann name ty (go body) +mapFun f = go + where + go (LamAbs ann name ty body) = LamAbs ann name ty (go body) go (TyAbs ann name kind body) = TyAbs ann name kind (go body) - go (IWrap ann pat arg term) = IWrap ann pat arg (go term) - go (Apply ann fun arg) = Apply ann (go fun) (go arg) - go (Unwrap ann term) = Unwrap ann (go term) - go (Error ann ty) = Error ann ty - go (TyInst ann term ty) = TyInst ann (go term) ty - go (Var ann name) = Var ann name - go (Constant ann con) = Constant ann con - go (Builtin ann fun) = Builtin ann (f fun) - go (Constr ann ty i args) = Constr ann ty i (map go args) - go (Case ann ty arg cs) = Case ann ty (go arg) (map go cs) + go (IWrap ann pat arg term) = IWrap ann pat arg (go term) + go (Apply ann fun arg) = Apply ann (go fun) (go arg) + go (Unwrap ann term) = Unwrap ann (go term) + go (Error ann ty) = Error ann ty + go (TyInst ann term ty) = TyInst ann (go term) ty + go (Var ann name) = Var ann name + go (Constant ann con) = Constant ann con + go (Builtin ann fun) = Builtin ann (f fun) + go (Constr ann ty i args) = Constr ann ty i (map go args) + go (Case ann ty arg cs) = Case ann ty (go arg) (map go cs) -- | This is a wrapper to mark the place where the binder is introduced (i.e. LamAbs/TyAbs) -- and not where it is actually used (TyVar/Var..). -- This marking allows us to skip the (de)serialization of binders at LamAbs/TyAbs positions -- iff 'name' is DeBruijn-encoded (level or index). See for example the instance of 'UntypedPlutusCore.Core.Instance.Flat' -newtype Binder name = Binder { unBinder :: name } - deriving stock (Eq, Show) - -- using this generates faster code, see discussion at - deriving Functor via Identity +newtype Binder name = Binder {unBinder :: name} + deriving stock (Eq, Show) + -- using this generates faster code, see discussion at + deriving (Functor) via Identity {- Note [Constr tag type] Constructor tags are not dynamically created, they can only come from the program itself. diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Error.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Error.hs index d8b388244c5..35eb1d9a326 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Error.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Error.hs @@ -1,6 +1,6 @@ module PlutusCore.Crypto.BLS12_381.Error where -data BLS12_381_Error = - HashToCurveDstTooBig -- DSTs can be at most 255 bytes long. - deriving stock Show +data BLS12_381_Error + = HashToCurveDstTooBig -- DSTs can be at most 255 bytes long. + deriving stock (Show) diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs index 0557fc93ef6..11913d65d2e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs @@ -1,23 +1,23 @@ -- editorconfig-checker-disable {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module PlutusCore.Crypto.BLS12_381.G1 - ( Element (..) - , add - , neg - , scalarMul - , hashToGroup - , compress - , uncompress - , offchain_zero - , compressed_zero - , compressed_generator - , memSizeBytes - , compressedSizeBytes - , multiScalarMul - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusCore.Crypto.BLS12_381.G1 ( + Element (..), + add, + neg, + scalarMul, + hashToGroup, + compress, + uncompress, + offchain_zero, + compressed_zero, + compressed_generator, + memSizeBytes, + compressedSizeBytes, + multiScalarMul, +) where import Cardano.Crypto.EllipticCurve.BLS12_381 qualified as BlstBindings import Cardano.Crypto.EllipticCurve.BLS12_381.Internal qualified as BlstBindings.Internal @@ -50,29 +50,32 @@ functions at the appropriate phantom types. See also Note [Wrapping the BLS12-381 types in PlutusTx]. -} -newtype Element = Element { unElement :: BlstBindings.Point1 } - deriving newtype (Eq) +newtype Element = Element {unElement :: BlstBindings.Point1} + deriving newtype (Eq) instance Show Element where - show = byteStringAsHex . compress + show = byteStringAsHex . compress instance Pretty Element where - pretty = pretty . show + pretty = pretty . show instance PrettyBy ConstConfig Element -{- | We don't support direct flat encoding of G2 elements because of the expense - of on-chain uncompression. Users should convert between G2 elements and - bytestrings using `compress` and `uncompress`: the bytestrings can be - flat-encoded in the usual way. -} + +-- | We don't support direct flat encoding of G2 elements because of the expense +-- of on-chain uncompression. Users should convert between G2 elements and +-- bytestrings using `compress` and `uncompress`: the bytestrings can be +-- flat-encoded in the usual way. instance Flat Element where - -- This might happen on the chain, so `fail` rather than `error`. - decode = fail "Flat decoding is not supported for objects of type bls12_381_G1_element: use bls12_381_G1_uncompress on a bytestring instead." - -- This will be a Haskell runtime error, but encoding doesn't happen on chain, - -- so it's not too bad. - encode = error "Flat encoding is not supported for objects of type bls12_381_G1_element: use bls12_381_G1_compress to obtain a bytestring instead." - size _ = id + -- This might happen on the chain, so `fail` rather than `error`. + decode = fail "Flat decoding is not supported for objects of type bls12_381_G1_element: use bls12_381_G1_uncompress on a bytestring instead." + + -- This will be a Haskell runtime error, but encoding doesn't happen on chain, + -- so it's not too bad. + encode = error "Flat encoding is not supported for objects of type bls12_381_G1_element: use bls12_381_G1_compress to obtain a bytestring instead." + size _ = id + instance NFData Element where - rnf (Element x) = rwhnf x -- Just to be on the safe side. + rnf (Element x) = rwhnf x -- Just to be on the safe side. instance Hashable Element where - hashWithSalt salt = hashWithSalt salt . compress + hashWithSalt salt = hashWithSalt salt . compress -- | Add two G1 group elements add :: Element -> Element -> Element @@ -91,26 +94,24 @@ scalarMul :: Integer -> Element -> Element scalarMul = coerce $ flip (BlstBindings.blsMult @BlstBindings.Curve1) {-# INLINE scalarMul #-} -{- | Compress a G1 element to a bytestring. This serialises a curve point to its - x coordinate only. The compressed bytestring is 48 bytes long, with three - spare bits used to convey extra information about the point, including - determining which of two possible y coordinates the point has and whether the - point is the point at infinity. See - https://github.com/supranational/blst#serialization-format --} +-- | Compress a G1 element to a bytestring. This serialises a curve point to its +-- x coordinate only. The compressed bytestring is 48 bytes long, with three +-- spare bits used to convey extra information about the point, including +-- determining which of two possible y coordinates the point has and whether the +-- point is the point at infinity. See +-- https://github.com/supranational/blst#serialization-format compress :: Element -> ByteString compress = coerce (BlstBindings.blsCompress @BlstBindings.Curve1) {-# INLINE compress #-} -{- | Uncompress a bytestring to get a G1 point. This will fail if any of the - following are true. - * The bytestring is not exactly 48 bytes long. - * The most significant three bits are used incorrectly. - * The bytestring encodes a field element which is not the - x coordinate of a point on the E1 curve. - * The bytestring does represent a point on the E1 curve, but the - point is not in the G1 subgroup. --} +-- | Uncompress a bytestring to get a G1 point. This will fail if any of the +-- following are true. +-- * The bytestring is not exactly 48 bytes long. +-- * The most significant three bits are used incorrectly. +-- * The bytestring encodes a field element which is not the +-- x coordinate of a point on the E1 curve. +-- * The bytestring does represent a point on the E1 curve, but the +-- point is not in the G1 subgroup. uncompress :: ByteString -> Either BlstBindings.BLSTError Element uncompress = coerce (BlstBindings.blsUncompress @BlstBindings.Curve1) {-# INLINE uncompress #-} @@ -142,7 +143,7 @@ uncompress = coerce (BlstBindings.blsUncompress @BlstBindings.Curve1) -- them to a get point in G1. hashToGroup :: ByteString -> ByteString -> Either BLS12_381_Error Element hashToGroup msg dst = - if Data.ByteString.length dst > 255 + if Data.ByteString.length dst > 255 then Left HashToCurveDstTooBig else Right . Element $ BlstBindings.blsHash @BlstBindings.Curve1 msg (Just dst) Nothing @@ -155,7 +156,7 @@ offchain_zero = coerce (BlstBindings.Internal.blsZero @BlstBindings.Curve1) -- convenience in PlutusTx and is not exported as a builtin. compressed_zero :: ByteString compressed_zero = compress $ coerce (BlstBindings.Internal.blsZero @BlstBindings.Curve1) -{-# INLINABLE compressed_zero #-} +{-# INLINEABLE compressed_zero #-} -- | The standard generator of G1 compressed into a bytestring. This is -- provided for convenience in PlutusTx and is not exported as a builtin. diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs index b474ead61a4..67d5ce787ba 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs @@ -1,23 +1,23 @@ -- editorconfig-checker-disable {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module PlutusCore.Crypto.BLS12_381.G2 - ( Element (..) - , add - , neg - , scalarMul - , hashToGroup - , compress - , uncompress - , offchain_zero - , compressed_zero - , compressed_generator - , memSizeBytes - , compressedSizeBytes - , multiScalarMul - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusCore.Crypto.BLS12_381.G2 ( + Element (..), + add, + neg, + scalarMul, + hashToGroup, + compress, + uncompress, + offchain_zero, + compressed_zero, + compressed_generator, + memSizeBytes, + compressedSizeBytes, + multiScalarMul, +) where import Cardano.Crypto.EllipticCurve.BLS12_381 qualified as BlstBindings import Cardano.Crypto.EllipticCurve.BLS12_381.Internal qualified as BlstBindings.Internal @@ -35,30 +35,34 @@ import Data.Proxy (Proxy (..)) import PlutusCore.Flat import Prettyprinter -{- | See Note [Wrapping the BLS12-381 types in Plutus Core]. -} -newtype Element = Element { unElement :: BlstBindings.Point2 } - deriving newtype (Eq) +-- | See Note [Wrapping the BLS12-381 types in Plutus Core]. +newtype Element = Element {unElement :: BlstBindings.Point2} + deriving newtype (Eq) + instance Show Element where - show = byteStringAsHex . compress + show = byteStringAsHex . compress instance Pretty Element where - pretty = pretty . show + pretty = pretty . show instance PrettyBy ConstConfig Element -{- | We don't support direct flat encoding of G1 elements because of the expense - of on-chain uncompression. Users should convert between G1 elements and - bytestrings using `compress` and `uncompress`: the bytestrings can be - flat-encoded in the usual way. -} + +-- | We don't support direct flat encoding of G1 elements because of the expense +-- of on-chain uncompression. Users should convert between G1 elements and +-- bytestrings using `compress` and `uncompress`: the bytestrings can be +-- flat-encoded in the usual way. instance Flat Element where - -- This might happen on the chain, so `fail` rather than `error`. - decode = fail "Flat decoding is not supported for objects of type bls12_381_G2_element: use bls12_381_G2_uncompress on a bytestring instead." - -- This will be a Haskell runtime error, but encoding doesn't happen on chain, - -- so it's not too bad. - encode = error "Flat encoding is not supported for objects of type bls12_381_G2_element: use bls12_381_G2_compress to obtain a bytestring instead." - size _ = id + -- This might happen on the chain, so `fail` rather than `error`. + decode = fail "Flat decoding is not supported for objects of type bls12_381_G2_element: use bls12_381_G2_uncompress on a bytestring instead." + + -- This will be a Haskell runtime error, but encoding doesn't happen on chain, + -- so it's not too bad. + encode = error "Flat encoding is not supported for objects of type bls12_381_G2_element: use bls12_381_G2_compress to obtain a bytestring instead." + size _ = id + instance NFData Element where - rnf (Element x) = rwhnf x -- Just to be on the safe side. + rnf (Element x) = rwhnf x -- Just to be on the safe side. instance Hashable Element where - hashWithSalt salt = hashWithSalt salt . compress + hashWithSalt salt = hashWithSalt salt . compress -- | Add two G2 group elements add :: Element -> Element -> Element @@ -74,24 +78,22 @@ scalarMul :: Integer -> Element -> Element -- Other way round from library funct scalarMul = coerce $ flip (BlstBindings.blsMult @BlstBindings.Curve2) {-# INLINE scalarMul #-} -{- | Compress a G2 element to a bytestring. This serialises a curve point to its x - coordinate only, using an extra bit to determine which of two possible y - coordinates the point has. The compressed bytestring is 96 bytes long. See - https://github.com/supranational/blst#serialization-format --} +-- | Compress a G2 element to a bytestring. This serialises a curve point to its x +-- coordinate only, using an extra bit to determine which of two possible y +-- coordinates the point has. The compressed bytestring is 96 bytes long. See +-- https://github.com/supranational/blst#serialization-format compress :: Element -> ByteString compress = coerce (BlstBindings.blsCompress @BlstBindings.Curve2) {-# INLINE compress #-} -{- | Uncompress a bytestring to get a G2 point. This will fail if any of the - following are true: - * The bytestring is not exactly 96 bytes long - * The most significant three bits are used incorrectly - * The bytestring encodes a field element which is not the - x coordinate of a point on the E2 curve - * The bytestring does represent a point on the E2 curve, but the - point is not in the G2 subgroup --} +-- | Uncompress a bytestring to get a G2 point. This will fail if any of the +-- following are true: +-- * The bytestring is not exactly 96 bytes long +-- * The most significant three bits are used incorrectly +-- * The bytestring encodes a field element which is not the +-- x coordinate of a point on the E2 curve +-- * The bytestring does represent a point on the E2 curve, but the +-- point is not in the G2 subgroup uncompress :: ByteString -> Either BlstBindings.BLSTError Element uncompress = coerce (BlstBindings.blsUncompress @BlstBindings.Curve2) {-# INLINE uncompress #-} @@ -100,7 +102,7 @@ uncompress = coerce (BlstBindings.blsUncompress @BlstBindings.Curve2) -- get point in G2. See Note [Hashing and Domain Separation Tags]. hashToGroup :: ByteString -> ByteString -> Either BLS12_381_Error Element hashToGroup msg dst = - if Data.ByteString.length dst > 255 + if Data.ByteString.length dst > 255 then Left HashToCurveDstTooBig else Right . Element $ BlstBindings.blsHash @BlstBindings.Curve2 msg (Just dst) Nothing diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs index a1aad0a524a..1f23ec7854f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -module PlutusCore.Crypto.BLS12_381.Pairing - ( - MlResult (..), - millerLoop, - mulMlResult, - finalVerify, - mlResultMemSizeBytes, - identityMlResult - ) where +{-# LANGUAGE TypeApplications #-} + +module PlutusCore.Crypto.BLS12_381.Pairing ( + MlResult (..), + millerLoop, + mulMlResult, + finalVerify, + mlResultMemSizeBytes, + identityMlResult, +) where import Cardano.Crypto.EllipticCurve.BLS12_381 qualified as BlstBindings import Cardano.Crypto.EllipticCurve.BLS12_381.Internal qualified as BlstBindings.Internal @@ -25,33 +25,36 @@ import Data.Hashable import PlutusCore.Flat import Prettyprinter -{- | This type represents the result of computing a pairing using the Miller - loop. Values of this type are ephemeral, only created during script - execution. We do not provide any means of serialising, deserialising, - printing, or parsing MlResult values. -} -newtype MlResult = MlResult { unMlResult :: BlstBindings.PT } - deriving newtype (Eq) +-- | This type represents the result of computing a pairing using the Miller +-- loop. Values of this type are ephemeral, only created during script +-- execution. We do not provide any means of serialising, deserialising, +-- printing, or parsing MlResult values. +newtype MlResult = MlResult {unMlResult :: BlstBindings.PT} + deriving newtype (Eq) + instance Show MlResult where - show _ = "" + show _ = "" instance Pretty MlResult where - pretty = pretty . show + pretty = pretty . show instance PrettyBy ConstConfig MlResult where - prettyBy _ = pretty + prettyBy _ = pretty + -- We need a Flat instance to get everything to build properly; however we'll -- never want MlResult values in serialised scripts, so the decoding and -- encoding functions just raise errors. instance Flat MlResult where - -- This might happen on the chain, so `fail` rather than `error`. - decode = fail "Flat decoding is not supported for objects of type bls12_381_mlresult" - -- This will be a Haskell runtime error, but encoding doesn't happen on chain, - -- so it's not too bad. - encode = error "Flat encoding is not supported for objects of type bls12_381_mlresult" - size _ = id + -- This might happen on the chain, so `fail` rather than `error`. + decode = fail "Flat decoding is not supported for objects of type bls12_381_mlresult" + + -- This will be a Haskell runtime error, but encoding doesn't happen on chain, + -- so it's not too bad. + encode = error "Flat encoding is not supported for objects of type bls12_381_mlresult" + size _ = id instance NFData MlResult where - rnf _ = () + rnf _ = () instance Hashable MlResult where - hashWithSalt salt _MlResult = salt + hashWithSalt salt _MlResult = salt millerLoop :: G1.Element -> G2.Element -> MlResult millerLoop = coerce BlstBindings.millerLoop @@ -62,7 +65,6 @@ mulMlResult = coerce BlstBindings.ptMult finalVerify :: MlResult -> MlResult -> Bool finalVerify = coerce BlstBindings.ptFinalVerify - -- Not exposed as builtins -- | Memory usage of an MlResult point (576 bytes) diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/Ed25519.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/Ed25519.hs index f5684d6b97b..f0c07861bb2 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/Ed25519.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/Ed25519.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module PlutusCore.Crypto.Ed25519 (verifyEd25519Signature) where @@ -16,21 +16,24 @@ import Data.Text (Text) -- This will fail if the key or the signature are not of the expected length. -- This version uses the cardano-crypto-class implementation of the verification -- function (using libsodium). -verifyEd25519Signature - :: BS.ByteString -- ^ Public Key (32 bytes) - -> BS.ByteString -- ^ Message (arbitrary length) - -> BS.ByteString -- ^ Signature (64 bytes) - -> BuiltinResult Bool +verifyEd25519Signature :: + -- | Public Key (32 bytes) + BS.ByteString -> + -- | Message (arbitrary length) + BS.ByteString -> + -- | Signature (64 bytes) + BS.ByteString -> + BuiltinResult Bool verifyEd25519Signature pk msg sig = case DSIGN.rawDeserialiseVerKeyDSIGN @Ed25519DSIGN pk of Nothing -> failWithMessage loc "Invalid verification key." Just pk' -> case DSIGN.rawDeserialiseSigDSIGN @Ed25519DSIGN sig of Nothing -> failWithMessage loc "Invalid signature." Just sig' -> - pure $ - case DSIGN.verifyDSIGN () pk' msg sig' of - Left _ -> False - Right () -> True + pure $ + case DSIGN.verifyDSIGN () pk' msg sig' of + Left _ -> False + Right () -> True where loc :: Text loc = "Ed25519 signature verification" diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/ExpMod.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/ExpMod.hs index f1367474a49..0852349f10e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/ExpMod.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/ExpMod.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedSums #-} -module PlutusCore.Crypto.ExpMod - ( expMod - ) where + +module PlutusCore.Crypto.ExpMod ( + expMod, +) where import PlutusCore.Builtin @@ -15,17 +16,18 @@ import GHC.Num.Integer expMod :: Integer -> Integer -> Natural -> BuiltinResult Natural expMod b e m | m <= 0 = fail "expMod: invalid modulus" - -- ^ We can't have m<0 when m is a Natural, but we may as well be paranoid. + -- \^ We can't have m<0 when m is a Natural, but we may as well be paranoid. | m == 1 = pure 0 - -- ^ Just in case: GHC.Num.Integer.integerRecip# gets this wrong. Note that 0 + -- \^ Just in case: GHC.Num.Integer.integerRecip# gets this wrong. Note that 0 -- is invertible modulo 1, with inverse 0. | b == 0 && e < 0 = failNonInvertible 0 m - -- ^ integerPowMod# incorrectly returns 0 in this case. + -- \^ integerPowMod# incorrectly returns 0 in this case. | otherwise = case integerPowMod# b e m of - (# n | #) -> pure n + (# n | #) -> pure n (# | () #) -> failNonInvertible b m - where failNonInvertible :: Integer -> Natural -> BuiltinResult Natural - failNonInvertible b1 m1 = - fail ("expMod: " ++ (show b1) ++ " is not invertible modulo " ++ (show m1)) + where + failNonInvertible :: Integer -> Natural -> BuiltinResult Natural + failNonInvertible b1 m1 = + fail ("expMod: " ++ (show b1) ++ " is not invertible modulo " ++ (show m1)) {-# INLINE expMod #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/Hash.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/Hash.hs index 9d311f60e58..32d38c5d109 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/Hash.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/Hash.hs @@ -1,13 +1,14 @@ --- | Hash functions for lazy [[Data.ByteString.ByteString]]s {-# LANGUAGE TypeApplications #-} -module PlutusCore.Crypto.Hash - ( sha2_256 - , sha3_256 - , blake2b_224 - , blake2b_256 - , keccak_256 - , ripemd_160 - ) where + +-- | Hash functions for lazy [[Data.ByteString.ByteString]]s +module PlutusCore.Crypto.Hash ( + sha2_256, + sha3_256, + blake2b_224, + blake2b_256, + keccak_256, + ripemd_160, +) where import Cardano.Crypto.Hash.Blake2b import Cardano.Crypto.Hash.Class diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/Secp256k1.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/Secp256k1.hs index 1a73ec5af5c..2ab0e7f2947 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/Secp256k1.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/Secp256k1.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module PlutusCore.Crypto.Secp256k1 ( - verifyEcdsaSecp256k1Signature, - verifySchnorrSecp256k1Signature - ) where + verifyEcdsaSecp256k1Signature, + verifySchnorrSecp256k1Signature, +) where import PlutusCore.Builtin.Result import PlutusCore.Crypto.Utils @@ -37,11 +37,14 @@ import Data.Text (Text) -- said sender. Failure to do so can be -- [dangerous](https://bitcoin.stackexchange.com/a/81116/35586). Other than -- length, we make no requirements of what hash gets used. -verifyEcdsaSecp256k1Signature - :: BS.ByteString -- ^ Public key (33 bytes) - -> BS.ByteString -- ^ Message hash (32 bytes) - -> BS.ByteString -- ^ Signature (64 bytes) - -> BuiltinResult Bool +verifyEcdsaSecp256k1Signature :: + -- | Public key (33 bytes) + BS.ByteString -> + -- | Message hash (32 bytes) + BS.ByteString -> + -- | Signature (64 bytes) + BS.ByteString -> + BuiltinResult Bool verifyEcdsaSecp256k1Signature pk msg sig = case DSIGN.rawDeserialiseVerKeyDSIGN @EcdsaSecp256k1DSIGN pk of Nothing -> failWithMessage loc "Invalid verification key." @@ -50,7 +53,7 @@ verifyEcdsaSecp256k1Signature pk msg sig = Just sig' -> case toMessageHash msg of Nothing -> failWithMessage loc "Invalid message hash." Just msg' -> pure $ case DSIGN.verifyDSIGN () pk' msg' sig' of - Left _ -> False + Left _ -> False Right () -> True where loc :: Text @@ -73,20 +76,22 @@ verifyEcdsaSecp256k1Signature pk msg sig = -- = See also -- -- * [BIP-340](https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki) -verifySchnorrSecp256k1Signature - :: BS.ByteString -- ^ Public key (32 bytes) - -> BS.ByteString -- ^ Message (arbitrary length) - -> BS.ByteString -- ^ Signature (64 bytes) - -> BuiltinResult Bool +verifySchnorrSecp256k1Signature :: + -- | Public key (32 bytes) + BS.ByteString -> + -- | Message (arbitrary length) + BS.ByteString -> + -- | Signature (64 bytes) + BS.ByteString -> + BuiltinResult Bool verifySchnorrSecp256k1Signature pk msg sig = case DSIGN.rawDeserialiseVerKeyDSIGN @SchnorrSecp256k1DSIGN pk of Nothing -> failWithMessage loc "Invalid verification key." Just pk' -> case DSIGN.rawDeserialiseSigDSIGN @SchnorrSecp256k1DSIGN sig of Nothing -> failWithMessage loc "Invalid signature." Just sig' -> pure $ case DSIGN.verifyDSIGN () pk' msg sig' of - Left _ -> False + Left _ -> False Right () -> True where loc :: Text loc = "Schnorr SECP256k1 signature verification" - diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs index 47e20611978..d9c576945db 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} module PlutusCore.Crypto.Utils (failWithMessage, byteStringAsHex) where @@ -16,4 +16,4 @@ failWithMessage location reason = do builtinResultFailure byteStringAsHex :: ByteString -> String -byteStringAsHex bs = "0x" ++ (Prelude.concat $ foldr' (\w s -> (printf "%02x" w):s) [] bs) +byteStringAsHex bs = "0x" ++ (Prelude.concat $ foldr' (\w s -> (printf "%02x" w) : s) [] bs) diff --git a/plutus-core/plutus-core/src/PlutusCore/Data.hs b/plutus-core/plutus-core/src/PlutusCore/Data.hs index f0bcf128239..807eff5312d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Data.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Data.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module PlutusCore.Data (Data (..)) where @@ -27,36 +27,37 @@ import Data.Text.Encoding qualified as Text import Data.Word (Word64, Word8) import GHC.Generics import NoThunks.Class -import Prelude import Prettyprinter +import Prelude -- Attempting to make this strict made code slower by 2%, -- see https://github.com/IntersectMBO/plutus/pull/4622 + -- | A generic "data" type. -- -- The main constructor 'Constr' represents a datatype value in sum-of-products -- form: @Constr i args@ represents a use of the @i@th constructor along with its arguments. -- -- The other constructors are various primitives. -data Data = - Constr Integer [Data] - | Map [(Data, Data)] - | List [Data] - | I Integer - | B BS.ByteString - deriving stock (Show, Read, Eq, Ord, Generic, Data.Data.Data) - deriving anyclass (Hashable, NFData, NoThunks) +data Data + = Constr Integer [Data] + | Map [(Data, Data)] + | List [Data] + | I Integer + | B BS.ByteString + deriving stock (Show, Read, Eq, Ord, Generic, Data.Data.Data) + deriving anyclass (Hashable, NFData, NoThunks) instance Pretty Data where - pretty = \case - Constr _ ds -> angles (sep (punctuate comma (fmap pretty ds))) - Map entries -> - braces (sep (punctuate comma (fmap (\(k, v) -> pretty k <> ":" <+> pretty v) entries))) - List ds -> brackets (sep (punctuate comma (fmap pretty ds))) - I i -> pretty i - B b -> - -- Base64 encode the ByteString since it may contain arbitrary bytes - pretty (Text.decodeLatin1 (Base64.encode b)) + pretty = \case + Constr _ ds -> angles (sep (punctuate comma (fmap pretty ds))) + Map entries -> + braces (sep (punctuate comma (fmap (\(k, v) -> pretty k <> ":" <+> pretty v) entries))) + List ds -> brackets (sep (punctuate comma (fmap pretty ds))) + I i -> pretty i + B b -> + -- Base64 encode the ByteString since it may contain arbitrary bytes + pretty (Text.decodeLatin1 (Base64.encode b)) {- Note [Encoding via Term] We want to write a custom encoder/decoder for Data (i.e. not use the Generic version), but actually @@ -65,9 +66,9 @@ more structured representation, which is a lot easier. -} instance Serialise Data where - -- See Note [Encoding via Term] - encode = encodeData - decode = decodeData + -- See Note [Encoding via Term] + encode = encodeData + decode = decodeData {- Note [CBOR alternative tags] We've proposed to add additional tags to the CBOR standard to cover (essentially) sum types. @@ -144,47 +145,51 @@ Again, we need to write some manual encoders/decoders. -- | Turn Data into a CBOR Term. encodeData :: Data -> Encoding encodeData = \case - -- See Note [CBOR alternative tags] - Constr i ds | 0 <= i && i < 7 -> CBOR.encodeTag (fromIntegral (121 + i)) <> encode ds - Constr i ds | 7 <= i && i < 128 -> CBOR.encodeTag (fromIntegral (1280 + (i - 7))) <> encode ds - Constr i ds | otherwise -> + -- See Note [CBOR alternative tags] + Constr i ds | 0 <= i && i < 7 -> CBOR.encodeTag (fromIntegral (121 + i)) <> encode ds + Constr i ds | 7 <= i && i < 128 -> CBOR.encodeTag (fromIntegral (1280 + (i - 7))) <> encode ds + Constr i ds + | otherwise -> let tagEncoding = if fromIntegral (minBound @Word64) <= i && i <= fromIntegral (maxBound @Word64) - then CBOR.encodeWord64 (fromIntegral i) - -- This is a "correct"-ish encoding of the tag, but it will *not* deserialise, since - -- we insist on a 'Word64' when we deserialise. - -- So this is really a "soft" failure, without using 'error' or something. - else CBOR.encodeInteger i - in CBOR.encodeTag 102 <> CBOR.encodeListLen 2 <> tagEncoding <> encode ds - Map es -> - CBOR.encodeMapLen (fromIntegral $ length es) <> - mconcat [ encode t <> encode t' | (t, t') <-es ] - List ds -> encode ds - I i -> encodeInteger i - B b -> encodeBs b + then CBOR.encodeWord64 (fromIntegral i) + -- This is a "correct"-ish encoding of the tag, but it will *not* deserialise, since + -- we insist on a 'Word64' when we deserialise. + -- So this is really a "soft" failure, without using 'error' or something. + else CBOR.encodeInteger i + in CBOR.encodeTag 102 <> CBOR.encodeListLen 2 <> tagEncoding <> encode ds + Map es -> + CBOR.encodeMapLen (fromIntegral $ length es) + <> mconcat [encode t <> encode t' | (t, t') <- es] + List ds -> encode ds + I i -> encodeInteger i + B b -> encodeBs b -- Logic for choosing encoding borrowed from Codec.CBOR.Write + -- | Given an integer, create a 'CBOR.Term' that encodes it, following our size restrictions. encodeInteger :: Integer -> Encoding -- If it fits in a Word64, then it's less than 64 bytes for sure, and we can just send it off -- as a normal integer for cborg to deal with -encodeInteger i | i >= 0 , i <= fromIntegral (maxBound :: Word64) = CBOR.encodeInteger i - | i < 0 , i >= -1 - fromIntegral (maxBound :: Word64) = CBOR.encodeInteger i +encodeInteger i + | i >= 0, i <= fromIntegral (maxBound :: Word64) = CBOR.encodeInteger i + | i < 0, i >= -1 - fromIntegral (maxBound :: Word64) = CBOR.encodeInteger i -- Otherwise, it would be encoded as a bignum anyway, so we manually do the bignum -- encoding with a bytestring inside, and since we use bsToTerm, that bytestring will -- get chunked up if it's too big. -- See Note [Evading the 64-byte limit] encodeInteger i | i >= 0 = CBOR.encodeTag 2 <> encodeBs (integerToBytes i) -encodeInteger i | otherwise = CBOR.encodeTag 3 <> encodeBs (integerToBytes (-1 -i)) +encodeInteger i | otherwise = CBOR.encodeTag 3 <> encodeBs (integerToBytes (-1 - i)) -- Taken exactly from Codec.CBOR.Write integerToBytes :: Integer -> BS.ByteString integerToBytes n0 - | n0 == 0 = BS.pack [0] + | n0 == 0 = BS.pack [0] | otherwise = BS.pack (reverse (go n0)) where - go n | n == 0 = [] - | otherwise = narrow n : go (n `shiftR` 8) + go n + | n == 0 = [] + | otherwise = narrow n : go (n `shiftR` 8) narrow :: Integer -> Word8 narrow = fromIntegral @@ -199,9 +204,10 @@ encodeBs b = CBOR.encodeBytesIndef <> foldMap encode (to64ByteChunks b) <> CBOR. -- | Turns a 'BS.ByteString' into a list of <=64 byte chunks. to64ByteChunks :: BS.ByteString -> [BS.ByteString] -to64ByteChunks b | BS.length b > 64 = - let (chunk, rest) = BS.splitAt 64 b - in chunk:to64ByteChunks rest +to64ByteChunks b + | BS.length b > 64 = + let (chunk, rest) = BS.splitAt 64 b + in chunk : to64ByteChunks rest to64ByteChunks b = [b] {- Note [Definite and indefinite forms of CBOR] @@ -214,45 +220,42 @@ the indefinite kinds, but see Note [Evading the 64-byte limit] for some cases wh -- | Turn a CBOR Term into Data if possible. decodeData :: Decoder s Data -decodeData = CBOR.peekTokenType >>= \case - -- These integers are at most 64 *bits*, so certainly less than 64 *bytes* - CBOR.TypeUInt -> I <$> CBOR.decodeInteger - CBOR.TypeUInt64 -> I <$> CBOR.decodeInteger - CBOR.TypeNInt -> I <$> CBOR.decodeInteger - CBOR.TypeNInt64 -> I <$> CBOR.decodeInteger - -- See Note [The 64-byte limit] - CBOR.TypeInteger -> I <$> decodeBoundedBigInteger - - -- See Note [The 64-byte limit] - CBOR.TypeBytes -> B <$> decodeBoundedBytes - CBOR.TypeBytesIndef -> B . BSL.toStrict <$> decodeBoundedBytesIndef - - CBOR.TypeListLen -> decodeList - CBOR.TypeListLen64 -> decodeList - CBOR.TypeListLenIndef -> decodeList - - CBOR.TypeMapLen -> decodeMap - CBOR.TypeMapLen64 -> decodeMap - CBOR.TypeMapLenIndef -> decodeMap - - CBOR.TypeTag -> decodeConstr - CBOR.TypeTag64 -> decodeConstr - - t -> fail ("Unrecognized value of type " ++ show t) +decodeData = + CBOR.peekTokenType >>= \case + -- These integers are at most 64 *bits*, so certainly less than 64 *bytes* + CBOR.TypeUInt -> I <$> CBOR.decodeInteger + CBOR.TypeUInt64 -> I <$> CBOR.decodeInteger + CBOR.TypeNInt -> I <$> CBOR.decodeInteger + CBOR.TypeNInt64 -> I <$> CBOR.decodeInteger + -- See Note [The 64-byte limit] + CBOR.TypeInteger -> I <$> decodeBoundedBigInteger + -- See Note [The 64-byte limit] + CBOR.TypeBytes -> B <$> decodeBoundedBytes + CBOR.TypeBytesIndef -> B . BSL.toStrict <$> decodeBoundedBytesIndef + CBOR.TypeListLen -> decodeList + CBOR.TypeListLen64 -> decodeList + CBOR.TypeListLenIndef -> decodeList + CBOR.TypeMapLen -> decodeMap + CBOR.TypeMapLen64 -> decodeMap + CBOR.TypeMapLenIndef -> decodeMap + CBOR.TypeTag -> decodeConstr + CBOR.TypeTag64 -> decodeConstr + t -> fail ("Unrecognized value of type " ++ show t) decodeBoundedBigInteger :: Decoder s Integer decodeBoundedBigInteger = do - tag <- CBOR.decodeTag - -- Bignums contain a bytestring as the payload - bs <- CBOR.peekTokenType >>= \case - CBOR.TypeBytes -> decodeBoundedBytes - CBOR.TypeBytesIndef -> BSL.toStrict <$> decodeBoundedBytesIndef - t -> fail ("Bignum must contain a byte string, got: " ++ show t) - -- Depending on the tag, the bytestring is either a positive or negative integer - case tag of - 2 -> pure $ CBOR.uintegerFromBytes bs - 3 -> pure $ CBOR.nintegerFromBytes bs - t -> fail ("Bignum tag must be one of 2 or 3, got: " ++ show t) + tag <- CBOR.decodeTag + -- Bignums contain a bytestring as the payload + bs <- + CBOR.peekTokenType >>= \case + CBOR.TypeBytes -> decodeBoundedBytes + CBOR.TypeBytesIndef -> BSL.toStrict <$> decodeBoundedBytesIndef + t -> fail ("Bignum must contain a byte string, got: " ++ show t) + -- Depending on the tag, the bytestring is either a positive or negative integer + case tag of + 2 -> pure $ CBOR.uintegerFromBytes bs + 3 -> pure $ CBOR.nintegerFromBytes bs + t -> fail ("Bignum tag must be one of 2 or 3, got: " ++ show t) -- Adapted from Codec.CBOR.Read decodeBoundedBytesIndef :: Decoder s BSL.ByteString @@ -261,13 +264,15 @@ decodeBoundedBytesIndef = CBOR.decodeBytesIndef >> decodeBoundedBytesIndefLen [] -- Adapted from Codec.CBOR.Read, to call the size-checking bytestring decoder decodeBoundedBytesIndefLen :: [BS.ByteString] -> Decoder s BSL.ByteString decodeBoundedBytesIndefLen acc = do - stop <- CBOR.decodeBreakOr - if stop then return $! BSL.fromChunks (reverse acc) - else do !bs <- decodeBoundedBytes - decodeBoundedBytesIndefLen (bs : acc) + stop <- CBOR.decodeBreakOr + if stop + then return $! BSL.fromChunks (reverse acc) + else do + !bs <- decodeBoundedBytes + decodeBoundedBytesIndefLen (bs : acc) decodeBoundedBytes :: Decoder s BS.ByteString -decodeBoundedBytes = do +decodeBoundedBytes = do b <- CBOR.decodeBytes -- See Note [The 64-byte limit] unless (BS.length b <= 64) $ fail "ByteString exceeds 64 bytes" @@ -277,34 +282,39 @@ decodeList :: Decoder s Data decodeList = List <$> decodeListOf decodeData decodeListOf :: Decoder s x -> Decoder s [x] -decodeListOf decoder = CBOR.decodeListLenOrIndef >>= \case - Nothing -> decodeSequenceLenIndef (flip (:)) [] reverse decoder - Just n -> decodeSequenceLenN (flip (:)) [] reverse n decoder +decodeListOf decoder = + CBOR.decodeListLenOrIndef >>= \case + Nothing -> decodeSequenceLenIndef (flip (:)) [] reverse decoder + Just n -> decodeSequenceLenN (flip (:)) [] reverse n decoder decodeMap :: Decoder s Data -decodeMap = CBOR.decodeMapLenOrIndef >>= \case - Nothing -> Map <$> decodeSequenceLenIndef (flip (:)) [] reverse decodePair - Just n -> Map <$> decodeSequenceLenN (flip (:)) [] reverse n decodePair +decodeMap = + CBOR.decodeMapLenOrIndef >>= \case + Nothing -> Map <$> decodeSequenceLenIndef (flip (:)) [] reverse decodePair + Just n -> Map <$> decodeSequenceLenN (flip (:)) [] reverse n decodePair where - decodePair = (,) <$> decodeData <*> decodeData + decodePair = (,) <$> decodeData <*> decodeData -- See Note [CBOR alternative tags] for the encoding scheme. decodeConstr :: Decoder s Data -decodeConstr = CBOR.decodeTag64 >>= \case - 102 -> decodeConstrExtended - t | 121 <= t && t < 128 -> - Constr (fromIntegral t - 121) <$> decodeListOf decodeData - t | 1280 <= t && t < 1401 -> - Constr ((fromIntegral t - 1280) + 7) <$> decodeListOf decodeData - t -> fail ("Unrecognized tag " ++ show t) +decodeConstr = + CBOR.decodeTag64 >>= \case + 102 -> decodeConstrExtended + t + | 121 <= t && t < 128 -> + Constr (fromIntegral t - 121) <$> decodeListOf decodeData + t + | 1280 <= t && t < 1401 -> + Constr ((fromIntegral t - 1280) + 7) <$> decodeListOf decodeData + t -> fail ("Unrecognized tag " ++ show t) where - decodeConstrExtended = do - len <- CBOR.decodeListLenOrIndef - i <- CBOR.decodeWord64 - args <- decodeListOf decodeData - case len of - Nothing -> do - done <- CBOR.decodeBreakOr - unless done $ fail "Expected exactly two elements" - Just n -> unless (n == 2) $ fail "Expected exactly two elements" - pure $ Constr (fromIntegral i) args + decodeConstrExtended = do + len <- CBOR.decodeListLenOrIndef + i <- CBOR.decodeWord64 + args <- decodeListOf decodeData + case len of + Nothing -> do + done <- CBOR.decodeBreakOr + unless done $ fail "Expected exactly two elements" + Just n -> unless (n == 2) $ fail "Expected exactly two elements" + pure $ Constr (fromIntegral i) args diff --git a/plutus-core/plutus-core/src/PlutusCore/DataFilePaths.hs b/plutus-core/plutus-core/src/PlutusCore/DataFilePaths.hs index ea1a8ddceaa..7e93b6087fb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/DataFilePaths.hs +++ b/plutus-core/plutus-core/src/PlutusCore/DataFilePaths.hs @@ -1,6 +1,5 @@ -- | Various file paths used in plutus-core, currently all to do with the cost -- model. - module PlutusCore.DataFilePaths where @@ -41,4 +40,3 @@ rModelFile = costModelDataDir "models" <.> "R" -- needed for cost-model-test. benchingResultsFile :: FilePath benchingResultsFile = costModelDataDir "benching-conway" <.> "csv" - diff --git a/plutus-core/plutus-core/src/PlutusCore/DeBruijn.hs b/plutus-core/plutus-core/src/PlutusCore/DeBruijn.hs index 0ca5927d3a7..961f3bd677a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/DeBruijn.hs +++ b/plutus-core/plutus-core/src/PlutusCore/DeBruijn.hs @@ -1,40 +1,41 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | Support for using de Bruijn indices for term and type names. -module PlutusCore.DeBruijn - ( Index (..) - , Level (..) - , LevelInfo (..) - , HasIndex (..) - , DeBruijn (..) - , NamedDeBruijn (..) - -- we follow the same approach as Renamed, expose the constructor from Internal module, - -- but hide it in this parent module. - , FakeNamedDeBruijn (unFakeNamedDeBruijn) - , TyDeBruijn (..) - , NamedTyDeBruijn (..) - , FreeVariableError (..) - , unNameDeBruijn - , unNameTyDeBruijn - , fakeNameDeBruijn - , fakeTyNameDeBruijn - , deBruijnTy - , deBruijnTerm - , unDeBruijnTy - , unDeBruijnTerm - -- * unsafe api, use with care - , deBruijnTyWith - , deBruijnTermWith - , unDeBruijnTyWith - , unDeBruijnTermWith - , freeIndexAsConsistentLevel - , deBruijnInitIndex - , fromFake - , toFake - ) where +module PlutusCore.DeBruijn ( + Index (..), + Level (..), + LevelInfo (..), + HasIndex (..), + DeBruijn (..), + NamedDeBruijn (..), + -- we follow the same approach as Renamed, expose the constructor from Internal module, + -- but hide it in this parent module. + FakeNamedDeBruijn (unFakeNamedDeBruijn), + TyDeBruijn (..), + NamedTyDeBruijn (..), + FreeVariableError (..), + unNameDeBruijn, + unNameTyDeBruijn, + fakeNameDeBruijn, + fakeTyNameDeBruijn, + deBruijnTy, + deBruijnTerm, + unDeBruijnTy, + unDeBruijnTerm, + + -- * unsafe api, use with care + deBruijnTyWith, + deBruijnTermWith, + unDeBruijnTyWith, + unDeBruijnTermWith, + freeIndexAsConsistentLevel, + deBruijnInitIndex, + fromFake, + toFake, +) where import PlutusCore.DeBruijn.Internal @@ -55,61 +56,61 @@ a fixed debruijn index '0' at their introduction. -} -- | Takes a "handler" function to execute when encountering free variables. -unDeBruijnTyWith - :: MonadQuote m - => (Index -> ReaderT LevelInfo m Unique) - -> Type NamedTyDeBruijn uni ann - -> m (Type TyName uni ann) +unDeBruijnTyWith :: + MonadQuote m => + (Index -> ReaderT LevelInfo m Unique) -> + Type NamedTyDeBruijn uni ann -> + m (Type TyName uni ann) unDeBruijnTyWith = (runDeBruijnT .) . unDeBruijnTyWithM -- | Takes a "handler" function to execute when encountering free variables. -unDeBruijnTermWith - :: MonadQuote m - => (Index -> ReaderT LevelInfo m Unique) - -> Term NamedTyDeBruijn NamedDeBruijn uni fun ann - -> m (Term TyName Name uni fun ann) +unDeBruijnTermWith :: + MonadQuote m => + (Index -> ReaderT LevelInfo m Unique) -> + Term NamedTyDeBruijn NamedDeBruijn uni fun ann -> + m (Term TyName Name uni fun ann) unDeBruijnTermWith = (runDeBruijnT .) . unDeBruijnTermWithM -- | Convert a 'Type' with 'NamedTyDeBruijn's into a 'Type' with 'TyName's. -- Will throw an error if a free variable is encountered. -unDeBruijnTy - :: (MonadQuote m, MonadError FreeVariableError m) - => Type NamedTyDeBruijn uni ann -> m (Type TyName uni ann) +unDeBruijnTy :: + (MonadQuote m, MonadError FreeVariableError m) => + Type NamedTyDeBruijn uni ann -> m (Type TyName uni ann) unDeBruijnTy = unDeBruijnTyWith freeIndexThrow -- | Convert a 'Term' with 'NamedTyDeBruijn's and 'NamedDeBruijn's into a 'Term' with 'TyName's and -- 'Name's. Will throw an error if a free variable is encountered. -unDeBruijnTerm - :: (MonadQuote m, MonadError FreeVariableError m) - => Term NamedTyDeBruijn NamedDeBruijn uni fun ann -> m (Term TyName Name uni fun ann) +unDeBruijnTerm :: + (MonadQuote m, MonadError FreeVariableError m) => + Term NamedTyDeBruijn NamedDeBruijn uni fun ann -> m (Term TyName Name uni fun ann) unDeBruijnTerm = unDeBruijnTermWith freeIndexThrow -- | Convert a 'Type' with 'TyName's into a 'Type' with 'NamedTyDeBruijn's. -- Will throw an error if a free variable is encountered. -deBruijnTy - :: (MonadError FreeVariableError m) - => Type TyName uni ann -> m (Type NamedTyDeBruijn uni ann) +deBruijnTy :: + MonadError FreeVariableError m => + Type TyName uni ann -> m (Type NamedTyDeBruijn uni ann) deBruijnTy = deBruijnTyWith freeUniqueThrow -- | Convert a 'Term' with 'TyName's and 'Name's into a 'Term' with 'NamedTyDeBruijn's and -- 'NamedDeBruijn's. Will throw an error if a free variable is encountered. -deBruijnTerm - :: (MonadError FreeVariableError m) - => Term TyName Name uni fun ann -> m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) +deBruijnTerm :: + MonadError FreeVariableError m => + Term TyName Name uni fun ann -> m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) deBruijnTerm = deBruijnTermWith freeUniqueThrow -deBruijnTermWith - :: Monad m - => (Unique -> ReaderT LevelInfo m Index) - -> Term TyName Name uni fun ann - -> m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) +deBruijnTermWith :: + Monad m => + (Unique -> ReaderT LevelInfo m Index) -> + Term TyName Name uni fun ann -> + m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) deBruijnTermWith = (runDeBruijnT .) . deBruijnTermWithM -deBruijnTyWith - :: Monad m - => (Unique -> ReaderT LevelInfo m Index) - -> Type TyName uni ann - -> m (Type NamedTyDeBruijn uni ann) +deBruijnTyWith :: + Monad m => + (Unique -> ReaderT LevelInfo m Index) -> + Type TyName uni ann -> + m (Type NamedTyDeBruijn uni ann) deBruijnTyWith = (runDeBruijnT .) . deBruijnTyWithM {- Note [De Bruijn conversion and recursion schemes] @@ -118,37 +119,39 @@ we are not only altering the recursive type, but also the name type parameters. These are normally constant in a catamorphic application. -} -deBruijnTyWithM - :: forall m uni ann. MonadReader LevelInfo m - => (Unique -> m Index) - -> Type TyName uni ann - -> m (Type NamedTyDeBruijn uni ann) +deBruijnTyWithM :: + forall m uni ann. + MonadReader LevelInfo m => + (Unique -> m Index) -> + Type TyName uni ann -> + m (Type NamedTyDeBruijn uni ann) deBruijnTyWithM h = go where go :: Type TyName uni ann -> m (Type NamedTyDeBruijn uni ann) go = \case - -- variable case - TyVar ann n -> TyVar ann <$> tyNameToDeBruijn h n - -- binder cases - TyForall ann tn k ty -> declareUnique tn $ do - tn' <- tyNameToDeBruijn h tn - withScope $ TyForall ann tn' k <$> go ty - TyLam ann tn k ty -> declareUnique tn $ do - tn' <- tyNameToDeBruijn h tn - withScope $ TyLam ann tn' k <$> go ty - -- boring recursive cases - TyFun ann i o -> TyFun ann <$> go i <*> go o - TyApp ann fun arg -> TyApp ann <$> go fun <*> go arg - TyIFix ann pat arg -> TyIFix ann <$> go pat <*> go arg - TySOP ann tyls -> TySOP ann <$> (traverse . traverse) go tyls - -- boring non-recursive cases - TyBuiltin ann someUni -> pure $ TyBuiltin ann someUni - -deBruijnTermWithM - :: forall m uni fun ann. (MonadReader LevelInfo m) - => (Unique -> m Index) - -> Term TyName Name uni fun ann - -> m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) + -- variable case + TyVar ann n -> TyVar ann <$> tyNameToDeBruijn h n + -- binder cases + TyForall ann tn k ty -> declareUnique tn $ do + tn' <- tyNameToDeBruijn h tn + withScope $ TyForall ann tn' k <$> go ty + TyLam ann tn k ty -> declareUnique tn $ do + tn' <- tyNameToDeBruijn h tn + withScope $ TyLam ann tn' k <$> go ty + -- boring recursive cases + TyFun ann i o -> TyFun ann <$> go i <*> go o + TyApp ann fun arg -> TyApp ann <$> go fun <*> go arg + TyIFix ann pat arg -> TyIFix ann <$> go pat <*> go arg + TySOP ann tyls -> TySOP ann <$> (traverse . traverse) go tyls + -- boring non-recursive cases + TyBuiltin ann someUni -> pure $ TyBuiltin ann someUni + +deBruijnTermWithM :: + forall m uni fun ann. + MonadReader LevelInfo m => + (Unique -> m Index) -> + Term TyName Name uni fun ann -> + m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) deBruijnTermWithM h = go where goT :: Type TyName uni ann -> m (Type NamedTyDeBruijn uni ann) @@ -156,33 +159,34 @@ deBruijnTermWithM h = go go :: Term TyName Name uni fun ann -> m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann) go = \case - -- variable case - Var ann n -> Var ann <$> nameToDeBruijn h n - -- binder cases - TyAbs ann tn k t -> declareUnique tn $ do - tn' <- tyNameToDeBruijn h tn - withScope $ TyAbs ann tn' k <$> go t - LamAbs ann n ty t -> declareUnique n $ do - n' <- nameToDeBruijn h n - withScope $ LamAbs ann n' <$> goT ty <*> go t - -- boring recursive cases - Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 - TyInst ann t ty -> TyInst ann <$> go t <*> goT ty - Unwrap ann t -> Unwrap ann <$> go t - IWrap ann pat arg t -> IWrap ann <$> goT pat <*> goT arg <*> go t - Error ann ty -> Error ann <$> goT ty - Constr ann ty i es -> Constr ann <$> goT ty <*> pure i <*> traverse go es - Case ann ty arg cs -> Case ann <$> goT ty <*> go arg <*> traverse go cs - -- boring non-recursive cases - Constant ann con -> pure $ Constant ann con - Builtin ann bn -> pure $ Builtin ann bn + -- variable case + Var ann n -> Var ann <$> nameToDeBruijn h n + -- binder cases + TyAbs ann tn k t -> declareUnique tn $ do + tn' <- tyNameToDeBruijn h tn + withScope $ TyAbs ann tn' k <$> go t + LamAbs ann n ty t -> declareUnique n $ do + n' <- nameToDeBruijn h n + withScope $ LamAbs ann n' <$> goT ty <*> go t + -- boring recursive cases + Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 + TyInst ann t ty -> TyInst ann <$> go t <*> goT ty + Unwrap ann t -> Unwrap ann <$> go t + IWrap ann pat arg t -> IWrap ann <$> goT pat <*> goT arg <*> go t + Error ann ty -> Error ann <$> goT ty + Constr ann ty i es -> Constr ann <$> goT ty <*> pure i <*> traverse go es + Case ann ty arg cs -> Case ann <$> goT ty <*> go arg <*> traverse go cs + -- boring non-recursive cases + Constant ann con -> pure $ Constant ann con + Builtin ann bn -> pure $ Builtin ann bn -- | Takes a "handler" function to execute when encountering free variables. -unDeBruijnTyWithM - :: forall m uni ann. (MonadReader LevelInfo m, MonadQuote m) - => (Index -> m Unique) - -> Type NamedTyDeBruijn uni ann - -> m (Type TyName uni ann) +unDeBruijnTyWithM :: + forall m uni ann. + (MonadReader LevelInfo m, MonadQuote m) => + (Index -> m Unique) -> + Type NamedTyDeBruijn uni ann -> + m (Type TyName uni ann) unDeBruijnTyWithM h = go where go :: Type NamedTyDeBruijn uni ann -> m (Type TyName uni ann) @@ -191,15 +195,15 @@ unDeBruijnTyWithM h = go TyVar ann n -> TyVar ann <$> deBruijnToTyName h n -- binder cases TyForall ann tn k ty -> - -- See Note [DeBruijn indices of Binders] - declareBinder $ do - tn' <- deBruijnToTyName h $ set index deBruijnInitIndex tn - withScope $ TyForall ann tn' k <$> go ty + -- See Note [DeBruijn indices of Binders] + declareBinder $ do + tn' <- deBruijnToTyName h $ set index deBruijnInitIndex tn + withScope $ TyForall ann tn' k <$> go ty TyLam ann tn k ty -> - -- See Note [DeBruijn indices of Binders] - declareBinder $ do - tn' <- deBruijnToTyName h $ set index deBruijnInitIndex tn - withScope $ TyLam ann tn' k <$> go ty + -- See Note [DeBruijn indices of Binders] + declareBinder $ do + tn' <- deBruijnToTyName h $ set index deBruijnInitIndex tn + withScope $ TyLam ann tn' k <$> go ty -- boring recursive cases TyFun ann i o -> TyFun ann <$> go i <*> go o TyApp ann fun arg -> TyApp ann <$> go fun <*> go arg @@ -209,11 +213,12 @@ unDeBruijnTyWithM h = go TyBuiltin ann someUni -> pure $ TyBuiltin ann someUni -- | Takes a "handler" function to execute when encountering free variables. -unDeBruijnTermWithM - :: forall m uni fun ann. (MonadReader LevelInfo m, MonadQuote m) - => (Index -> m Unique) - -> Term NamedTyDeBruijn NamedDeBruijn uni fun ann - -> m (Term TyName Name uni fun ann) +unDeBruijnTermWithM :: + forall m uni fun ann. + (MonadReader LevelInfo m, MonadQuote m) => + (Index -> m Unique) -> + Term NamedTyDeBruijn NamedDeBruijn uni fun ann -> + m (Term TyName Name uni fun ann) unDeBruijnTermWithM h = go where goT :: Type NamedTyDeBruijn uni ann -> m (Type TyName uni ann) @@ -221,27 +226,27 @@ unDeBruijnTermWithM h = go go :: Term NamedTyDeBruijn NamedDeBruijn uni fun ann -> m (Term TyName Name uni fun ann) go = \case - -- variable case - Var ann n -> Var ann <$> deBruijnToName h n - -- binder cases - TyAbs ann tn k t -> - -- See Note [DeBruijn indices of Binders] - declareBinder $ do - tn' <- deBruijnToTyName h $ set index deBruijnInitIndex tn - withScope $ TyAbs ann tn' k <$> go t - LamAbs ann n ty t -> - -- See Note [DeBruijn indices of Binders] - declareBinder $ do - n' <- deBruijnToName h $ set index deBruijnInitIndex n - withScope $ LamAbs ann n' <$> goT ty <*> go t - -- boring recursive cases - Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 - TyInst ann t ty -> TyInst ann <$> go t <*> goT ty - Unwrap ann t -> Unwrap ann <$> go t - IWrap ann pat arg t -> IWrap ann <$> goT pat <*> goT arg <*> go t - Error ann ty -> Error ann <$> goT ty - Constr ann ty i es -> Constr ann <$> goT ty <*> pure i <*> traverse go es - Case ann ty arg cs -> Case ann <$> goT ty <*> go arg <*> traverse go cs - -- boring non-recursive cases - Constant ann con -> pure $ Constant ann con - Builtin ann bn -> pure $ Builtin ann bn + -- variable case + Var ann n -> Var ann <$> deBruijnToName h n + -- binder cases + TyAbs ann tn k t -> + -- See Note [DeBruijn indices of Binders] + declareBinder $ do + tn' <- deBruijnToTyName h $ set index deBruijnInitIndex tn + withScope $ TyAbs ann tn' k <$> go t + LamAbs ann n ty t -> + -- See Note [DeBruijn indices of Binders] + declareBinder $ do + n' <- deBruijnToName h $ set index deBruijnInitIndex n + withScope $ LamAbs ann n' <$> goT ty <*> go t + -- boring recursive cases + Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 + TyInst ann t ty -> TyInst ann <$> go t <*> goT ty + Unwrap ann t -> Unwrap ann <$> go t + IWrap ann pat arg t -> IWrap ann <$> goT pat <*> goT arg <*> go t + Error ann ty -> Error ann <$> goT ty + Constr ann ty i es -> Constr ann <$> goT ty <*> pure i <*> traverse go es + Case ann ty arg cs -> Case ann <$> goT ty <*> go arg <*> traverse go cs + -- boring non-recursive cases + Constant ann con -> pure $ Constant ann con + Builtin ann bn -> pure $ Builtin ann bn diff --git a/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs index b9200ce9fe9..9f79a9f0fcb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs @@ -1,48 +1,48 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- This fires on GHC-9.2.4 for some reason, not entirely sure -- what's going on {-# OPTIONS_GHC -Wno-identities #-} -- | Support for using de Bruijn indices for term and type names. -module PlutusCore.DeBruijn.Internal - ( Index (..) - , HasIndex (..) - , DeBruijn (..) - , NamedDeBruijn (..) +module PlutusCore.DeBruijn.Internal ( + Index (..), + HasIndex (..), + DeBruijn (..), + NamedDeBruijn (..), -- we follow the same approach as Renamed: expose the constructor from Internal module, -- but hide it in the parent module. - , FakeNamedDeBruijn (..) - , TyDeBruijn (..) - , NamedTyDeBruijn (..) - , FreeVariableError (..) - , Level (..) - , LevelInfo (..) - , declareUnique - , declareBinder - , withScope - , getIndex - , getUnique - , unNameDeBruijn - , unNameTyDeBruijn - , fakeNameDeBruijn - , fakeTyNameDeBruijn - , nameToDeBruijn - , tyNameToDeBruijn - , deBruijnToName - , deBruijnToTyName - , freeIndexThrow - , freeIndexAsConsistentLevel - , freeUniqueThrow - , runDeBruijnT - , deBruijnInitIndex - , toFake - , fromFake - ) where + FakeNamedDeBruijn (..), + TyDeBruijn (..), + NamedTyDeBruijn (..), + FreeVariableError (..), + Level (..), + LevelInfo (..), + declareUnique, + declareBinder, + withScope, + getIndex, + getUnique, + unNameDeBruijn, + unNameTyDeBruijn, + fakeNameDeBruijn, + fakeTyNameDeBruijn, + nameToDeBruijn, + tyNameToDeBruijn, + deBruijnToName, + deBruijnToTyName, + freeIndexThrow, + freeIndexAsConsistentLevel, + freeUniqueThrow, + runDeBruijnT, + deBruijnInitIndex, + toFake, + fromFake, +) where import PlutusCore.Name.Unique import PlutusCore.Pretty @@ -93,13 +93,12 @@ the optimized `Flat DeBruijn` instance. This is ok, because `FND<->D` are isomorphic. -} -{- | A relative index used for de Bruijn identifiers. - -FIXME: downside of using newtype+Num instead of type-synonym is that `-Woverflowed-literals` -does not work, e.g.: `DeBruijn (-1)` has no warning. To trigger the warning you have to bypass -the Num and write `DeBruijn (Index -1)`. This can be revisited when we implement PLT-1053. -Tracked by: https://github.com/IntersectMBO/plutus-private/issues/1552 --} +-- | A relative index used for de Bruijn identifiers. +-- +-- FIXME: downside of using newtype+Num instead of type-synonym is that `-Woverflowed-literals` +-- does not work, e.g.: `DeBruijn (-1)` has no warning. To trigger the warning you have to bypass +-- the Num and write `DeBruijn (Index -1)`. This can be revisited when we implement PLT-1053. +-- Tracked by: https://github.com/IntersectMBO/plutus-private/issues/1552 newtype Index = Index Word64 deriving stock (Generic) deriving newtype (Show, Num, Enum, Real, Integral, Eq, Ord, Hashable, Pretty, NFData, Read) @@ -115,13 +114,12 @@ data NamedDeBruijn = NamedDeBruijn {ndbnString :: !T.Text, ndbnIndex :: !Index} deriving stock (Show, Generic, Read) deriving anyclass (Hashable, NFData) -{- | A wrapper around `NamedDeBruijn` that *must* hold the invariant of name=`fakeName`. - -We do not export the `FakeNamedDeBruijn` constructor: the projection `FND->ND` is safe -but injection `ND->FND` is unsafe, thus they are not isomorphic. - -See Note [Why newtype FakeNamedDeBruijn] --} +-- | A wrapper around `NamedDeBruijn` that *must* hold the invariant of name=`fakeName`. +-- +-- We do not export the `FakeNamedDeBruijn` constructor: the projection `FND->ND` is safe +-- but injection `ND->FND` is unsafe, thus they are not isomorphic. +-- +-- See Note [Why newtype FakeNamedDeBruijn] newtype FakeNamedDeBruijn = FakeNamedDeBruijn {unFakeNamedDeBruijn :: NamedDeBruijn} deriving newtype (Show, Eq, Hashable, NFData, PrettyBy config) @@ -161,14 +159,14 @@ newtype TyDeBruijn = TyDeBruijn DeBruijn instance Wrapped TyDeBruijn -instance (HasPrettyConfigName config) => PrettyBy config NamedDeBruijn where +instance HasPrettyConfigName config => PrettyBy config NamedDeBruijn where prettyBy config (NamedDeBruijn txt (Index ix)) | showsUnique = pretty $ toPrintedName txt <> "!" <> render (pretty ix) | otherwise = pretty $ toPrintedName txt where PrettyConfigName showsUnique = toPrettyConfigName config -instance (HasPrettyConfigName config) => PrettyBy config DeBruijn where +instance HasPrettyConfigName config => PrettyBy config DeBruijn where prettyBy config (DeBruijn (Index ix)) | showsUnique = "!" <> pretty ix | otherwise = "" @@ -182,13 +180,13 @@ instance HasIndex NamedDeBruijn where index = lens g s where g = ndbnIndex - s n i = n{ndbnIndex = i} + s n i = n {ndbnIndex = i} instance HasIndex DeBruijn where index = lens g s where g = dbnIndex - s n i = n{dbnIndex = i} + s n i = n {dbnIndex = i} instance HasIndex NamedTyDeBruijn where index = _Wrapped' . index @@ -221,11 +219,10 @@ We use a newtype to keep these separate, since getting it wrong will lead to ann -- | An absolute level in the program. newtype Level = Level Integer deriving newtype (Eq, Ord, Num, Real, Enum, Integral) -{- | During visiting the AST we hold a reader "state" of current level and a current -scoping (levelMapping). -Invariant-A: the current level is positive and greater than all levels in the levelMapping. -Invariant-B: only positive levels are stored in the levelMapping. --} +-- | During visiting the AST we hold a reader "state" of current level and a current +-- scoping (levelMapping). +-- Invariant-A: the current level is positive and greater than all levels in the levelMapping. +-- Invariant-B: only positive levels are stored in the levelMapping. data LevelInfo = LevelInfo { currentLevel :: Level , levelMapping :: BM.Bimap Unique Level @@ -236,25 +233,22 @@ declareUnique :: (MonadReader LevelInfo m, HasUnique name unique) => name -> m a declareUnique n = local $ \(LevelInfo current ls) -> LevelInfo current $ BM.insert (n ^. theUnique) current ls -{- | Declares a new binder by assigning a fresh unique to the *current level*. -Maintains invariant-B of 'LevelInfo' (that only positive levels are stored), -since current level is always positive (invariant-A). -See Note [DeBruijn indices of Binders] --} +-- | Declares a new binder by assigning a fresh unique to the *current level*. +-- Maintains invariant-B of 'LevelInfo' (that only positive levels are stored), +-- since current level is always positive (invariant-A). +-- See Note [DeBruijn indices of Binders] declareBinder :: (MonadReader LevelInfo m, MonadQuote m) => m a -> m a declareBinder act = do newU <- freshUnique local (\(LevelInfo current ls) -> LevelInfo current $ BM.insert newU current ls) act -{- | Enter a scope, incrementing the current 'Level' by one -Maintains invariant-A (that the current level is positive). --} -withScope :: (MonadReader LevelInfo m) => m a -> m a +-- | Enter a scope, incrementing the current 'Level' by one +-- Maintains invariant-A (that the current level is positive). +withScope :: MonadReader LevelInfo m => m a -> m a withScope = local $ \(LevelInfo current ls) -> LevelInfo (current + 1) ls -{- | We cannot do a correct translation to or from de Bruijn indices if the program is -not well-scoped. So we throw an error in such a case. --} +-- | We cannot do a correct translation to or from de Bruijn indices if the program is +-- not well-scoped. So we throw an error in such a case. data FreeVariableError = FreeUnique !Unique | FreeIndex !Index @@ -263,20 +257,19 @@ data FreeVariableError instance Pretty FreeVariableError where pretty (FreeUnique u) = "Free unique:" <+> pretty u - pretty (FreeIndex i) = "Free index:" <+> pretty i + pretty (FreeIndex i) = "Free index:" <+> pretty i makeClassyPrisms ''FreeVariableError -{- | Get the 'Index' corresponding to a given 'Unique'. -Uses supplied handler for free names (uniques). --} -getIndex :: (MonadReader LevelInfo m) => Unique -> (Unique -> m Index) -> m Index +-- | Get the 'Index' corresponding to a given 'Unique'. +-- Uses supplied handler for free names (uniques). +getIndex :: MonadReader LevelInfo m => Unique -> (Unique -> m Index) -> m Index getIndex u h = do LevelInfo current ls <- ask case BM.lookup u ls of Just foundlvl -> pure $ levelToIx current foundlvl -- This call should return an index greater than the current level, -- otherwise it will map unbound variables to bound variables. - Nothing -> h u + Nothing -> h u where -- Compute the relative 'Index' of a absolute 'Level' relative to the current 'Level'. levelToIx :: Level -> Level -> Index @@ -286,10 +279,9 @@ getIndex u h = do -- its conversion to Natural will not lead to arithmetic underflow. fromIntegral $ current - foundLvl -{- | Get the 'Unique' corresponding to a given 'Index'. -Uses supplied handler for free debruijn indices. --} -getUnique :: (MonadReader LevelInfo m) => Index -> (Index -> m Unique) -> m Unique +-- | Get the 'Unique' corresponding to a given 'Index'. +-- Uses supplied handler for free debruijn indices. +getUnique :: MonadReader LevelInfo m => Index -> (Index -> m Unique) -> m Unique getUnique ix h = do LevelInfo current ls <- ask case BM.lookupR (ixToLevel current ix) ls of @@ -302,12 +294,12 @@ getUnique ix h = do -- (absolute) level. h ix -unNameDeBruijn - :: NamedDeBruijn -> DeBruijn +unNameDeBruijn :: + NamedDeBruijn -> DeBruijn unNameDeBruijn (NamedDeBruijn _ ix) = DeBruijn ix -unNameTyDeBruijn - :: NamedTyDeBruijn -> TyDeBruijn +unNameTyDeBruijn :: + NamedTyDeBruijn -> TyDeBruijn unNameTyDeBruijn (NamedTyDeBruijn db) = TyDeBruijn $ unNameDeBruijn db fakeNameDeBruijn :: DeBruijn -> NamedDeBruijn @@ -316,52 +308,51 @@ fakeNameDeBruijn = coerce . toFake fakeTyNameDeBruijn :: TyDeBruijn -> NamedTyDeBruijn fakeTyNameDeBruijn (TyDeBruijn n) = NamedTyDeBruijn $ fakeNameDeBruijn n -nameToDeBruijn - :: (MonadReader LevelInfo m) - => (Unique -> m Index) - -> Name - -> m NamedDeBruijn +nameToDeBruijn :: + MonadReader LevelInfo m => + (Unique -> m Index) -> + Name -> + m NamedDeBruijn nameToDeBruijn h (Name str u) = NamedDeBruijn str <$> getIndex u h -tyNameToDeBruijn - :: (MonadReader LevelInfo m) - => (Unique -> m Index) - -> TyName - -> m NamedTyDeBruijn +tyNameToDeBruijn :: + MonadReader LevelInfo m => + (Unique -> m Index) -> + TyName -> + m NamedTyDeBruijn tyNameToDeBruijn h (TyName n) = NamedTyDeBruijn <$> nameToDeBruijn h n -deBruijnToName - :: (MonadReader LevelInfo m) - => (Index -> m Unique) - -> NamedDeBruijn - -> m Name +deBruijnToName :: + MonadReader LevelInfo m => + (Index -> m Unique) -> + NamedDeBruijn -> + m Name deBruijnToName h (NamedDeBruijn str ix) = Name str <$> getUnique ix h -deBruijnToTyName - :: (MonadReader LevelInfo m) - => (Index -> m Unique) - -> NamedTyDeBruijn - -> m TyName +deBruijnToTyName :: + MonadReader LevelInfo m => + (Index -> m Unique) -> + NamedTyDeBruijn -> + m TyName deBruijnToTyName h (NamedTyDeBruijn n) = TyName <$> deBruijnToName h n -- | The default handler of throwing an error upon encountering a free name (unique). -freeUniqueThrow :: (MonadError FreeVariableError m) => Unique -> m Index +freeUniqueThrow :: MonadError FreeVariableError m => Unique -> m Index freeUniqueThrow = throwError . FreeUnique -- | The default handler of throwing an error upon encountering a free debruijn index. -freeIndexThrow :: (MonadError FreeVariableError m) => Index -> m Unique +freeIndexThrow :: MonadError FreeVariableError m => Index -> m Unique freeIndexThrow = throwError . FreeIndex -{- | A different implementation of a handler, where "free" debruijn indices do not throw an error -but are instead gracefully converted to fresh uniques. -These generated uniques remain free; i.e. if the original term was open, it will remain open -after applying this handler. -These generated free uniques are consistent across the open term (by using a state cache). --} -freeIndexAsConsistentLevel - :: (MonadReader LevelInfo m, MonadState (M.Map Level Unique) m, MonadQuote m) - => Index - -> m Unique +-- | A different implementation of a handler, where "free" debruijn indices do not throw an error +-- but are instead gracefully converted to fresh uniques. +-- These generated uniques remain free; i.e. if the original term was open, it will remain open +-- after applying this handler. +-- These generated free uniques are consistent across the open term (by using a state cache). +freeIndexAsConsistentLevel :: + (MonadReader LevelInfo m, MonadState (M.Map Level Unique) m, MonadQuote m) => + Index -> + m Unique freeIndexAsConsistentLevel ix = do cache <- get LevelInfo current _ <- ask diff --git a/plutus-core/plutus-core/src/PlutusCore/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Default.hs index 6bcc4d4110e..890ba29493b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default.hs @@ -1,6 +1,6 @@ -module PlutusCore.Default - ( module Export - ) where +module PlutusCore.Default ( + module Export, +) where import PlutusCore.Default.Builtins as Export import PlutusCore.Default.Universe as Export diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 04165c16ef4..b7c4f0edd6e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1,18 +1,18 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusCore.Default.Builtins where @@ -23,9 +23,13 @@ import PlutusCore.Data (Data (..)) import PlutusCore.Default.Universe import PlutusCore.Evaluation.Machine.BuiltinCostModel import PlutusCore.Evaluation.Machine.ExBudgetStream (ExBudgetStream) -import PlutusCore.Evaluation.Machine.ExMemoryUsage (ExMemoryUsage, IntegerCostedLiterally (..), - NumBytesCostedAsNumWords (..), memoryUsage, - singletonRose) +import PlutusCore.Evaluation.Machine.ExMemoryUsage ( + ExMemoryUsage, + IntegerCostedLiterally (..), + NumBytesCostedAsNumWords (..), + memoryUsage, + singletonRose, + ) import PlutusCore.Pretty (PrettyConfigPlc) import PlutusCore.Value (Value) import PlutusCore.Value qualified as Value @@ -60,145 +64,146 @@ import PlutusCore.Flat.Encoder as Flat (Encoding, NumBits, eBits) import Prettyprinter (viaShow) -- TODO: should we have the commonest built-in functions at the front to have more compact encoding? + -- | Default built-in functions. -- -- When updating these, make sure to add them to the protocol version listing! -- See Note [New builtins/language versions and protocol versions] data DefaultFun - -- Integers - = AddInteger - | SubtractInteger - | MultiplyInteger - | DivideInteger - | QuotientInteger - | RemainderInteger - | ModInteger - | EqualsInteger - | LessThanInteger - | LessThanEqualsInteger - -- Bytestrings - | AppendByteString - | ConsByteString - | SliceByteString - | LengthOfByteString - | IndexByteString - | EqualsByteString - | LessThanByteString - | LessThanEqualsByteString - -- Cryptography and hashes - | Sha2_256 - | Sha3_256 - | Blake2b_256 - | VerifyEd25519Signature -- formerly verifySignature - | VerifyEcdsaSecp256k1Signature - | VerifySchnorrSecp256k1Signature - -- Strings - | AppendString - | EqualsString - | EncodeUtf8 - | DecodeUtf8 - -- Bool - | IfThenElse - -- Unit - | ChooseUnit - -- Tracing - | Trace - -- Pairs - | FstPair - | SndPair - -- Lists - | ChooseList - | MkCons - | HeadList - | TailList - | NullList - -- Data + = -- Integers + AddInteger + | SubtractInteger + | MultiplyInteger + | DivideInteger + | QuotientInteger + | RemainderInteger + | ModInteger + | EqualsInteger + | LessThanInteger + | LessThanEqualsInteger + | -- Bytestrings + AppendByteString + | ConsByteString + | SliceByteString + | LengthOfByteString + | IndexByteString + | EqualsByteString + | LessThanByteString + | LessThanEqualsByteString + | -- Cryptography and hashes + Sha2_256 + | Sha3_256 + | Blake2b_256 + | VerifyEd25519Signature -- formerly verifySignature + | VerifyEcdsaSecp256k1Signature + | VerifySchnorrSecp256k1Signature + | -- Strings + AppendString + | EqualsString + | EncodeUtf8 + | DecodeUtf8 + | -- Bool + IfThenElse + | -- Unit + ChooseUnit + | -- Tracing + Trace + | -- Pairs + FstPair + | SndPair + | -- Lists + ChooseList + | MkCons + | HeadList + | TailList + | NullList + | -- Data -- See Note [Legacy pattern matching on built-in types]. -- It is convenient to have a "choosing" function for a data type that has more than two -- constructors to get pattern matching over it and we may end up having multiple such data -- types, hence we include the name of the data type as a suffix. - | ChooseData - | ConstrData - | MapData - | ListData - | IData - | BData - | UnConstrData - | UnMapData - | UnListData - | UnIData - | UnBData - | EqualsData - | SerialiseData - -- Misc monomorphized constructors. + ChooseData + | ConstrData + | MapData + | ListData + | IData + | BData + | UnConstrData + | UnMapData + | UnListData + | UnIData + | UnBData + | EqualsData + | SerialiseData + | -- Misc monomorphized constructors. -- We could simply replace those with constants, but we use built-in functions for consistency -- with monomorphic built-in types. Polymorphic built-in constructors are generally problematic, -- See Note [Representable built-in functions over polymorphic built-in types]. - | MkPairData - | MkNilData - | MkNilPairData - -- BLS12_381 operations + MkPairData + | MkNilData + | MkNilPairData + | -- BLS12_381 operations -- G1 - | Bls12_381_G1_add - | Bls12_381_G1_neg - | Bls12_381_G1_scalarMul - | Bls12_381_G1_equal - | Bls12_381_G1_hashToGroup - | Bls12_381_G1_compress - | Bls12_381_G1_uncompress - -- G2 - | Bls12_381_G2_add - | Bls12_381_G2_neg - | Bls12_381_G2_scalarMul - | Bls12_381_G2_equal - | Bls12_381_G2_hashToGroup - | Bls12_381_G2_compress - | Bls12_381_G2_uncompress - -- Pairing - | Bls12_381_millerLoop - | Bls12_381_mulMlResult - | Bls12_381_finalVerify - -- Keccak_256, Blake2b_224 - | Keccak_256 - | Blake2b_224 - -- Conversions - | IntegerToByteString - | ByteStringToInteger - -- Logical - | AndByteString - | OrByteString - | XorByteString - | ComplementByteString - | ReadBit - | WriteBits - | ReplicateByte - -- Bitwise - | ShiftByteString - | RotateByteString - | CountSetBits - | FindFirstSetBit - -- Ripemd_160 - | Ripemd_160 - -- Batch 6 - | ExpModInteger - | DropList - -- Arrays - | LengthOfArray - | ListToArray - | IndexArray - -- BLS12_381 multi scalar multiplication - | Bls12_381_G1_multiScalarMul - | Bls12_381_G2_multiScalarMul - -- Values - | InsertCoin - | LookupCoin - | UnionValue - | ValueContains - | ValueData - | UnValueData - | ScaleValue - deriving stock (Show, Eq, Ord, Enum, Bounded, Generic, Ix) - deriving anyclass (NFData, Hashable, PrettyBy PrettyConfigPlc) + Bls12_381_G1_add + | Bls12_381_G1_neg + | Bls12_381_G1_scalarMul + | Bls12_381_G1_equal + | Bls12_381_G1_hashToGroup + | Bls12_381_G1_compress + | Bls12_381_G1_uncompress + | -- G2 + Bls12_381_G2_add + | Bls12_381_G2_neg + | Bls12_381_G2_scalarMul + | Bls12_381_G2_equal + | Bls12_381_G2_hashToGroup + | Bls12_381_G2_compress + | Bls12_381_G2_uncompress + | -- Pairing + Bls12_381_millerLoop + | Bls12_381_mulMlResult + | Bls12_381_finalVerify + | -- Keccak_256, Blake2b_224 + Keccak_256 + | Blake2b_224 + | -- Conversions + IntegerToByteString + | ByteStringToInteger + | -- Logical + AndByteString + | OrByteString + | XorByteString + | ComplementByteString + | ReadBit + | WriteBits + | ReplicateByte + | -- Bitwise + ShiftByteString + | RotateByteString + | CountSetBits + | FindFirstSetBit + | -- Ripemd_160 + Ripemd_160 + | -- Batch 6 + ExpModInteger + | DropList + | -- Arrays + LengthOfArray + | ListToArray + | IndexArray + | -- BLS12_381 multi scalar multiplication + Bls12_381_G1_multiScalarMul + | Bls12_381_G2_multiScalarMul + | -- Values + InsertCoin + | LookupCoin + | UnionValue + | ValueContains + | ValueData + | UnValueData + | ScaleValue + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic, Ix) + deriving anyclass (NFData, Hashable, PrettyBy PrettyConfigPlc) {- Note [Textual representation of names of built-in functions]. The plc parser parses builtin names by looking at an enumeration of all of the built-in @@ -207,17 +212,17 @@ data DefaultFun the built-in functions are obtained by applying the function below to the constructor names above. -} instance Pretty DefaultFun where - pretty fun = pretty $ lowerInitialChar $ show fun + pretty fun = pretty $ lowerInitialChar $ show fun instance ExMemoryUsage DefaultFun where - memoryUsage _ = singletonRose 1 - {-# INLINE memoryUsage #-} + memoryUsage _ = singletonRose 1 + {-# INLINE memoryUsage #-} -- | Turn a function into another function that 'fail's when its second argument is @0@ or calls the -- original function otherwise and wraps the result in 'pure'. Useful for correctly handling `div`, -- `mod`, etc. -nonZeroSecondArg - :: (Integer -> Integer -> Integer) -> Integer -> Integer -> BuiltinResult Integer +nonZeroSecondArg :: + (Integer -> Integer -> Integer) -> Integer -> Integer -> BuiltinResult Integer -- If we match against @IS 0#@ instead of @0@, GHC will generate tidier Core for some reason. It -- probably doesn't really matter performance-wise, but would be easier to read. We don't do it out -- of paranoia and because it requires importing the 'IS' constructor, which is in different @@ -231,9 +236,9 @@ nonZeroSecondArg -- The bang is to communicate to GHC that the function is strict in both the arguments just in case -- it'd want to allocate a thunk for the first argument otherwise. nonZeroSecondArg _ !_ 0 = - -- See Note [Structural vs operational errors within builtins]. - fail "Cannot divide by zero" -nonZeroSecondArg f x y = pure $ f x y + -- See Note [Structural vs operational errors within builtins]. + fail "Cannot divide by zero" +nonZeroSecondArg f x y = pure $ f x y {-# INLINE nonZeroSecondArg #-} -- | Turn a function returning 'Either' into another function that 'fail's in the 'Left' case and @@ -1045,1092 +1050,994 @@ functions. -} instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where - type CostingPart uni DefaultFun = BuiltinCostModel - - {- | Allow different variants of builtins with different implementations, and - possibly different semantics. Note that DefaultFunSemanticsVariantA, - DefaultFunSemanticsVariantB etc. do not correspond directly to PlutusV1, - PlutusV2 etc. in plutus-ledger-api: see Note [Builtin semantics variants]. -} - data BuiltinSemanticsVariant DefaultFun - = DefaultFunSemanticsVariantA - | DefaultFunSemanticsVariantB - | DefaultFunSemanticsVariantC - deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) - deriving anyclass (NFData, NoThunks) - - -- Integers - toBuiltinMeaning - :: forall val. HasMeaningIn uni val - => BuiltinSemanticsVariant DefaultFun - -> DefaultFun - -> BuiltinMeaning val BuiltinCostModel - - toBuiltinMeaning _semvar AddInteger = - let addIntegerDenotation :: Integer -> Integer -> Integer - addIntegerDenotation = (+) - {-# INLINE addIntegerDenotation #-} - in makeBuiltinMeaning - addIntegerDenotation - (runCostingFunTwoArguments . paramAddInteger) - - toBuiltinMeaning _semvar SubtractInteger = - let subtractIntegerDenotation :: Integer -> Integer -> Integer - subtractIntegerDenotation = (-) - {-# INLINE subtractIntegerDenotation #-} - in makeBuiltinMeaning - subtractIntegerDenotation - (runCostingFunTwoArguments . paramSubtractInteger) - - toBuiltinMeaning _semvar MultiplyInteger = - let multiplyIntegerDenotation :: Integer -> Integer -> Integer - multiplyIntegerDenotation = (*) - {-# INLINE multiplyIntegerDenotation #-} - in makeBuiltinMeaning - multiplyIntegerDenotation - (runCostingFunTwoArguments . paramMultiplyInteger) - - toBuiltinMeaning _semvar DivideInteger = - let divideIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer - divideIntegerDenotation = nonZeroSecondArg div - {-# INLINE divideIntegerDenotation #-} - in makeBuiltinMeaning - divideIntegerDenotation - (runCostingFunTwoArguments . paramDivideInteger) - - toBuiltinMeaning _semvar QuotientInteger = - let quotientIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer - quotientIntegerDenotation = nonZeroSecondArg quot - {-# INLINE quotientIntegerDenotation #-} - in makeBuiltinMeaning - quotientIntegerDenotation - (runCostingFunTwoArguments . paramQuotientInteger) - - toBuiltinMeaning _semvar RemainderInteger = - let remainderIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer - remainderIntegerDenotation = nonZeroSecondArg rem - {-# INLINE remainderIntegerDenotation #-} - in makeBuiltinMeaning - remainderIntegerDenotation - (runCostingFunTwoArguments . paramRemainderInteger) - - toBuiltinMeaning _semvar ModInteger = - let modIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer - modIntegerDenotation = nonZeroSecondArg mod - {-# INLINE modIntegerDenotation #-} - in makeBuiltinMeaning - modIntegerDenotation - (runCostingFunTwoArguments . paramModInteger) - - toBuiltinMeaning _semvar EqualsInteger = - let equalsIntegerDenotation :: Integer -> Integer -> Bool - equalsIntegerDenotation = (==) - {-# INLINE equalsIntegerDenotation #-} - in makeBuiltinMeaning - equalsIntegerDenotation - (runCostingFunTwoArguments . paramEqualsInteger) - - toBuiltinMeaning _semvar LessThanInteger = - let lessThanIntegerDenotation :: Integer -> Integer -> Bool - lessThanIntegerDenotation = (<) - {-# INLINE lessThanIntegerDenotation #-} - in makeBuiltinMeaning - lessThanIntegerDenotation - (runCostingFunTwoArguments . paramLessThanInteger) - - toBuiltinMeaning _semvar LessThanEqualsInteger = - let lessThanEqualsIntegerDenotation :: Integer -> Integer -> Bool - lessThanEqualsIntegerDenotation = (<=) - {-# INLINE lessThanEqualsIntegerDenotation #-} - in makeBuiltinMeaning - lessThanEqualsIntegerDenotation - (runCostingFunTwoArguments . paramLessThanEqualsInteger) - - -- Bytestrings - toBuiltinMeaning _semvar AppendByteString = - let appendByteStringDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString - appendByteStringDenotation = BS.append - {-# INLINE appendByteStringDenotation #-} - in makeBuiltinMeaning - appendByteStringDenotation - (runCostingFunTwoArguments . paramAppendByteString) - - -- See Note [Builtin semantics variants] - toBuiltinMeaning semvar ConsByteString = - -- The costing function is the same for all variants of this builtin, - -- but since the denotation of the builtin accepts constants of - -- different types ('Integer' vs 'Word8'), the costing function needs to - -- by polymorphic over the type of constant. - let costingFun - :: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream - costingFun = runCostingFunTwoArguments . paramConsByteString - {-# INLINE costingFun #-} - consByteStringMeaning_V1 = - let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString - consByteStringDenotation n = BS.cons (fromIntegral n) - -- Earlier instructions say never to use `fromIntegral` in the definition of a - -- builtin; however in this case it reduces its argument modulo 256 to get a - -- `Word8`, which is exactly what we want. - {-# INLINE consByteStringDenotation #-} - in makeBuiltinMeaning - consByteStringDenotation - costingFun - -- For builtin semantics variants larger than 'DefaultFunSemanticsVariantA', the first - -- input must be in range @[0..255]@. - consByteStringMeaning_V2 = - let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString - consByteStringDenotation = BS.cons - {-# INLINE consByteStringDenotation #-} - in makeBuiltinMeaning - consByteStringDenotation - costingFun - in case semvar of - DefaultFunSemanticsVariantA -> consByteStringMeaning_V1 - DefaultFunSemanticsVariantB -> consByteStringMeaning_V1 - DefaultFunSemanticsVariantC -> consByteStringMeaning_V2 - - toBuiltinMeaning _semvar SliceByteString = - let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString - sliceByteStringDenotation start n xs = BS.take n (BS.drop start xs) - {-# INLINE sliceByteStringDenotation #-} - in makeBuiltinMeaning - sliceByteStringDenotation - (runCostingFunThreeArguments . paramSliceByteString) - - toBuiltinMeaning _semvar LengthOfByteString = - let lengthOfByteStringDenotation :: BS.ByteString -> Int - lengthOfByteStringDenotation = BS.length - {-# INLINE lengthOfByteStringDenotation #-} - in makeBuiltinMeaning - lengthOfByteStringDenotation - (runCostingFunOneArgument . paramLengthOfByteString) - - toBuiltinMeaning _semvar IndexByteString = - let indexByteStringDenotation :: BS.ByteString -> Int -> BuiltinResult Word8 - indexByteStringDenotation xs n = do - unless (n >= 0 && n < BS.length xs) $ - -- See Note [Structural vs operational errors within builtins]. - -- The arguments are going to be printed in the "cause" part of the error - -- message, so we don't need to repeat them here. - fail "Index out of bounds" - pure $ BS.index xs n - {-# INLINE indexByteStringDenotation #-} - in makeBuiltinMeaning - indexByteStringDenotation - (runCostingFunTwoArguments . paramIndexByteString) - - toBuiltinMeaning _semvar EqualsByteString = - let equalsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool - equalsByteStringDenotation = (==) - {-# INLINE equalsByteStringDenotation #-} - in makeBuiltinMeaning - equalsByteStringDenotation - (runCostingFunTwoArguments . paramEqualsByteString) - - toBuiltinMeaning _semvar LessThanByteString = - let lessThanByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool - lessThanByteStringDenotation = (<) - {-# INLINE lessThanByteStringDenotation #-} - in makeBuiltinMeaning - lessThanByteStringDenotation - (runCostingFunTwoArguments . paramLessThanByteString) - - toBuiltinMeaning _semvar LessThanEqualsByteString = - let lessThanEqualsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool - lessThanEqualsByteStringDenotation = (<=) - {-# INLINE lessThanEqualsByteStringDenotation #-} - in makeBuiltinMeaning - lessThanEqualsByteStringDenotation - (runCostingFunTwoArguments . paramLessThanEqualsByteString) - - -- Cryptography and hashes - toBuiltinMeaning _semvar Sha2_256 = - let sha2_256Denotation :: BS.ByteString -> BS.ByteString - sha2_256Denotation = Hash.sha2_256 - {-# INLINE sha2_256Denotation #-} - in makeBuiltinMeaning - sha2_256Denotation - (runCostingFunOneArgument . paramSha2_256) - - toBuiltinMeaning _semvar Sha3_256 = - let sha3_256Denotation :: BS.ByteString -> BS.ByteString - sha3_256Denotation = Hash.sha3_256 - {-# INLINE sha3_256Denotation #-} - in makeBuiltinMeaning - sha3_256Denotation - (runCostingFunOneArgument . paramSha3_256) - - toBuiltinMeaning _semvar Blake2b_256 = - let blake2b_256Denotation :: BS.ByteString -> BS.ByteString - blake2b_256Denotation = Hash.blake2b_256 - {-# INLINE blake2b_256Denotation #-} - in makeBuiltinMeaning - blake2b_256Denotation - (runCostingFunOneArgument . paramBlake2b_256) - - toBuiltinMeaning _semvar VerifyEd25519Signature = - let verifyEd25519SignatureDenotation - :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool - verifyEd25519SignatureDenotation = verifyEd25519Signature - {-# INLINE verifyEd25519SignatureDenotation #-} - in makeBuiltinMeaning - verifyEd25519SignatureDenotation - -- Benchmarks indicate that the two variants have very similar - -- execution times, so it's safe to use the same costing function for - -- both. - (runCostingFunThreeArguments . paramVerifyEd25519Signature) - - {- Note [ECDSA secp256k1 signature verification]. An ECDSA signature - consists of a pair of values (r,s), and for each value of r there are in - fact two valid values of s, one effectively the negative of the other. - The Bitcoin implementation that underlies `verifyEcdsaSecp256k1Signature` - expects that the lower of the two possible values of the s component of - the signature is used, returning `false` immediately if that's not the - case. It appears that this restriction is peculiar to Bitcoin, and ECDSA - schemes in general don't require it. Thus this function may be more - restrictive than expected. See - - https://github.com/bitcoin/bips/blob/master/bip-0146.mediawiki#LOW_S - - and the implementation of secp256k1_ecdsa_verify in - - https://github.com/bitcoin-core/secp256k1. - -} - toBuiltinMeaning _semvar VerifyEcdsaSecp256k1Signature = - let verifyEcdsaSecp256k1SignatureDenotation - :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool - verifyEcdsaSecp256k1SignatureDenotation = verifyEcdsaSecp256k1Signature - {-# INLINE verifyEcdsaSecp256k1SignatureDenotation #-} - in makeBuiltinMeaning - verifyEcdsaSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature) - - toBuiltinMeaning _semvar VerifySchnorrSecp256k1Signature = - let verifySchnorrSecp256k1SignatureDenotation - :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool - verifySchnorrSecp256k1SignatureDenotation = verifySchnorrSecp256k1Signature - {-# INLINE verifySchnorrSecp256k1SignatureDenotation #-} - in makeBuiltinMeaning - verifySchnorrSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature) - - -- Strings - toBuiltinMeaning _semvar AppendString = - let appendStringDenotation :: Text -> Text -> Text - appendStringDenotation = (<>) - {-# INLINE appendStringDenotation #-} - in makeBuiltinMeaning - appendStringDenotation - (runCostingFunTwoArguments . paramAppendString) - - toBuiltinMeaning _semvar EqualsString = - let equalsStringDenotation :: Text -> Text -> Bool - equalsStringDenotation = (==) - {-# INLINE equalsStringDenotation #-} - in makeBuiltinMeaning - equalsStringDenotation - (runCostingFunTwoArguments . paramEqualsString) - - toBuiltinMeaning _semvar EncodeUtf8 = - let encodeUtf8Denotation :: Text -> BS.ByteString - encodeUtf8Denotation = encodeUtf8 - {-# INLINE encodeUtf8Denotation #-} - in makeBuiltinMeaning - encodeUtf8Denotation - (runCostingFunOneArgument . paramEncodeUtf8) - - toBuiltinMeaning _semvar DecodeUtf8 = - let decodeUtf8Denotation :: BS.ByteString -> BuiltinResult Text - decodeUtf8Denotation = eitherToBuiltinResult . decodeUtf8' - {-# INLINE decodeUtf8Denotation #-} - in makeBuiltinMeaning - decodeUtf8Denotation - (runCostingFunOneArgument . paramDecodeUtf8) - - -- Bool - toBuiltinMeaning _semvar IfThenElse = - let ifThenElseDenotation :: Bool -> a -> a -> a - ifThenElseDenotation b x y = if b then x else y - {-# INLINE ifThenElseDenotation #-} - in makeBuiltinMeaning - ifThenElseDenotation - (runCostingFunThreeArguments . paramIfThenElse) - - -- Unit - toBuiltinMeaning _semvar ChooseUnit = - let chooseUnitDenotation :: () -> a -> a - chooseUnitDenotation () x = x - {-# INLINE chooseUnitDenotation #-} - in makeBuiltinMeaning - chooseUnitDenotation - (runCostingFunTwoArguments . paramChooseUnit) - - -- Tracing - toBuiltinMeaning _semvar Trace = - let traceDenotation :: Text -> a -> BuiltinResult a - traceDenotation text a = a <$ emit text - {-# INLINE traceDenotation #-} - in makeBuiltinMeaning - traceDenotation - (runCostingFunTwoArguments . paramTrace) - - -- Pairs - toBuiltinMeaning _semvar FstPair = - let fstPairDenotation :: SomeConstant uni (a, b) -> BuiltinResult (Opaque val a) - fstPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = - case uniPairAB of - DefaultUniPair uniA _ -> pure . fromValueOf uniA $ fst xy - _ -> - -- See Note [Structural vs operational errors within builtins]. - throwError $ structuralUnliftingError "Expected a pair but got something else" - {-# INLINE fstPairDenotation #-} - in makeBuiltinMeaning - fstPairDenotation - (runCostingFunOneArgument . paramFstPair) - - toBuiltinMeaning _semvar SndPair = - let sndPairDenotation :: SomeConstant uni (a, b) -> BuiltinResult (Opaque val b) - sndPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = - case uniPairAB of - DefaultUniPair _ uniB -> pure . fromValueOf uniB $ snd xy - _ -> - -- See Note [Structural vs operational errors within builtins]. - throwError $ structuralUnliftingError "Expected a pair but got something else" - {-# INLINE sndPairDenotation #-} - in makeBuiltinMeaning - sndPairDenotation - (runCostingFunOneArgument . paramSndPair) - - -- Lists - toBuiltinMeaning _semvar ChooseList = - let chooseListDenotation :: SomeConstant uni [a] -> b -> b -> BuiltinResult b - chooseListDenotation (SomeConstant (Some (ValueOf uniListA xs))) a b = - case uniListA of - DefaultUniList _ -> pure $ case xs of - [] -> a - _ : _ -> b - _ -> - -- See Note [Structural vs operational errors within builtins]. - throwError $ structuralUnliftingError "Expected a list but got something else" - {-# INLINE chooseListDenotation #-} - in makeBuiltinMeaning - chooseListDenotation - (runCostingFunThreeArguments . paramChooseList) - - toBuiltinMeaning _semvar MkCons = - let mkConsDenotation - :: SomeConstant uni a -> SomeConstant uni [a] -> BuiltinResult (Opaque val [a]) - mkConsDenotation - (SomeConstant (Some (ValueOf uniA x))) - (SomeConstant (Some (ValueOf uniListA xs))) = - -- See Note [Structural vs operational errors within builtins]. - case uniListA of - DefaultUniList uniA' -> case uniA `geq` uniA' of - Just Refl -> pure . fromValueOf uniListA $ x : xs - Nothing -> throwError $ structuralUnliftingError - "The type of the value does not match the type of elements in the list" - _ -> throwError $ structuralUnliftingError "Expected a list but got something else" - {-# INLINE mkConsDenotation #-} - in makeBuiltinMeaning - mkConsDenotation - (runCostingFunTwoArguments . paramMkCons) - - toBuiltinMeaning _semvar HeadList = - let headListDenotation :: SomeConstant uni [a] -> BuiltinResult (Opaque val a) - headListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = - case uniListA of - DefaultUniList uniA -> case xs of - [] -> fail "Expected a non-empty list but got an empty one" - x : _ -> pure $ fromValueOf uniA x - _ -> throwError $ structuralUnliftingError "Expected a list but got something else" - {-# INLINE headListDenotation #-} - in makeBuiltinMeaning - headListDenotation - (runCostingFunOneArgument . paramHeadList) - - toBuiltinMeaning _semvar TailList = - let tailListDenotation :: SomeConstant uni [a] -> BuiltinResult (Opaque val [a]) - tailListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = - case uniListA of - DefaultUniList _argUni -> - case xs of - [] -> fail "Expected a non-empty list but got an empty one" - _ : xs' -> pure $ fromValueOf uniListA xs' - _ -> throwError $ structuralUnliftingError "Expected a list but got something else" - {-# INLINE tailListDenotation #-} - in makeBuiltinMeaning - tailListDenotation - (runCostingFunOneArgument . paramTailList) - - toBuiltinMeaning _semvar NullList = - let nullListDenotation :: SomeConstant uni [a] -> BuiltinResult Bool - nullListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = - case uniListA of - DefaultUniList _uniA -> pure $ null xs - _ -> throwError $ structuralUnliftingError "Expected a list but got something else" - {-# INLINE nullListDenotation #-} - in makeBuiltinMeaning - nullListDenotation - (runCostingFunOneArgument . paramNullList) - - -- Data - toBuiltinMeaning _semvar ChooseData = - let chooseDataDenotation :: Data -> a -> a -> a -> a -> a -> a - chooseDataDenotation d xConstr xMap xList xI xB = - case d of - Constr {} -> xConstr - Map {} -> xMap - List {} -> xList - I {} -> xI - B {} -> xB - {-# INLINE chooseDataDenotation #-} - in makeBuiltinMeaning - chooseDataDenotation - (runCostingFunSixArguments . paramChooseData) - - toBuiltinMeaning _semvar ConstrData = - let constrDataDenotation :: Integer -> [Data] -> Data - constrDataDenotation = Constr - {-# INLINE constrDataDenotation #-} - in makeBuiltinMeaning - constrDataDenotation - (runCostingFunTwoArguments . paramConstrData) - - toBuiltinMeaning _semvar MapData = - let mapDataDenotation :: [(Data, Data)] -> Data - mapDataDenotation = Map - {-# INLINE mapDataDenotation #-} - in makeBuiltinMeaning - mapDataDenotation - (runCostingFunOneArgument . paramMapData) - - toBuiltinMeaning _semvar ListData = - let listDataDenotation :: [Data] -> Data - listDataDenotation = List - {-# INLINE listDataDenotation #-} - in makeBuiltinMeaning - listDataDenotation - (runCostingFunOneArgument . paramListData) - - toBuiltinMeaning _semvar IData = - let iDataDenotation :: Integer -> Data - iDataDenotation = I - {-# INLINE iDataDenotation #-} - in makeBuiltinMeaning - iDataDenotation - (runCostingFunOneArgument . paramIData) - - toBuiltinMeaning _semvar BData = - let bDataDenotation :: BS.ByteString -> Data - bDataDenotation = B - {-# INLINE bDataDenotation #-} - in makeBuiltinMeaning - bDataDenotation - (runCostingFunOneArgument . paramBData) - - toBuiltinMeaning _semvar UnConstrData = - let unConstrDataDenotation :: Data -> BuiltinResult (Integer, [Data]) - unConstrDataDenotation = \case - Constr i ds -> pure (i, ds) - _ -> - -- See Note [Structural vs operational errors within builtins]. - fail "Expected the Constr constructor but got a different one" - {-# INLINE unConstrDataDenotation #-} - in makeBuiltinMeaning - unConstrDataDenotation - (runCostingFunOneArgument . paramUnConstrData) - - toBuiltinMeaning _semvar UnMapData = - let unMapDataDenotation :: Data -> BuiltinResult [(Data, Data)] - unMapDataDenotation = \case - Map es -> pure es - _ -> - -- See Note [Structural vs operational errors within builtins]. - fail "Expected the Map constructor but got a different one" - {-# INLINE unMapDataDenotation #-} - in makeBuiltinMeaning - unMapDataDenotation - (runCostingFunOneArgument . paramUnMapData) - - toBuiltinMeaning _semvar UnListData = - let unListDataDenotation :: Data -> BuiltinResult [Data] - unListDataDenotation = \case - List ds -> pure ds - _ -> - -- See Note [Structural vs operational errors within builtins]. - fail "Expected the List constructor but got a different one" - {-# INLINE unListDataDenotation #-} - in makeBuiltinMeaning - unListDataDenotation - (runCostingFunOneArgument . paramUnListData) - - toBuiltinMeaning _semvar UnIData = - let unIDataDenotation :: Data -> BuiltinResult Integer - unIDataDenotation = \case - I i -> pure i - _ -> - -- See Note [Structural vs operational errors within builtins]. - fail "Expected the I constructor but got a different one" - {-# INLINE unIDataDenotation #-} - in makeBuiltinMeaning - unIDataDenotation - (runCostingFunOneArgument . paramUnIData) - - toBuiltinMeaning _semvar UnBData = - let unBDataDenotation :: Data -> BuiltinResult BS.ByteString - unBDataDenotation = \case - B b -> pure b - _ -> - -- See Note [Structural vs operational errors within builtins]. - fail "Expected the B constructor but got a different one" - {-# INLINE unBDataDenotation #-} - in makeBuiltinMeaning - unBDataDenotation - (runCostingFunOneArgument . paramUnBData) - - toBuiltinMeaning _semvar EqualsData = - let equalsDataDenotation :: Data -> Data -> Bool - equalsDataDenotation = (==) - {-# INLINE equalsDataDenotation #-} - in makeBuiltinMeaning - equalsDataDenotation - (runCostingFunTwoArguments . paramEqualsData) - - toBuiltinMeaning _semvar SerialiseData = - let serialiseDataDenotation :: Data -> BS.ByteString - serialiseDataDenotation = BSL.toStrict . serialise - {-# INLINE serialiseDataDenotation #-} - in makeBuiltinMeaning - serialiseDataDenotation - (runCostingFunOneArgument . paramSerialiseData) - - -- Misc constructors - toBuiltinMeaning _semvar MkPairData = - let mkPairDataDenotation :: Data -> Data -> (Data, Data) - mkPairDataDenotation = (,) - {-# INLINE mkPairDataDenotation #-} - in makeBuiltinMeaning - mkPairDataDenotation - (runCostingFunTwoArguments . paramMkPairData) - - toBuiltinMeaning _semvar MkNilData = - -- Nullary built-in functions don't work, so we need a unit argument. - -- We don't really need this built-in function, see Note [Constants vs built-in functions], - -- but we keep it around for historical reasons and convenience. - let mkNilDataDenotation :: () -> [Data] - mkNilDataDenotation () = [] - {-# INLINE mkNilDataDenotation #-} - in makeBuiltinMeaning - mkNilDataDenotation - (runCostingFunOneArgument . paramMkNilData) - - toBuiltinMeaning _semvar MkNilPairData = - -- Nullary built-in functions don't work, so we need a unit argument. - -- We don't really need this built-in function, see Note [Constants vs built-in functions], - -- but we keep it around for historical reasons and convenience. - let mkNilPairDataDenotation :: () -> [(Data, Data)] - mkNilPairDataDenotation () = [] - {-# INLINE mkNilPairDataDenotation #-} - in makeBuiltinMeaning - mkNilPairDataDenotation - (runCostingFunOneArgument . paramMkNilPairData) - - -- BLS12_381.G1 - toBuiltinMeaning _semvar Bls12_381_G1_add = - let bls12_381_G1_addDenotation - :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> BLS12_381.G1.Element - bls12_381_G1_addDenotation = BLS12_381.G1.add - {-# INLINE bls12_381_G1_addDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_add) - - toBuiltinMeaning _semvar Bls12_381_G1_neg = - let bls12_381_G1_negDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element - bls12_381_G1_negDenotation = BLS12_381.G1.neg - {-# INLINE bls12_381_G1_negDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_negDenotation - (runCostingFunOneArgument . paramBls12_381_G1_neg) - - toBuiltinMeaning _semvar Bls12_381_G1_scalarMul = - let bls12_381_G1_scalarMulDenotation - :: Integer -> BLS12_381.G1.Element -> BLS12_381.G1.Element - bls12_381_G1_scalarMulDenotation = BLS12_381.G1.scalarMul - {-# INLINE bls12_381_G1_scalarMulDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul) - - toBuiltinMeaning _semvar Bls12_381_G1_compress = - let bls12_381_G1_compressDenotation :: BLS12_381.G1.Element -> BS.ByteString - bls12_381_G1_compressDenotation = BLS12_381.G1.compress - {-# INLINE bls12_381_G1_compressDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_compress) - - toBuiltinMeaning _semvar Bls12_381_G1_uncompress = - let bls12_381_G1_uncompressDenotation - :: BS.ByteString -> BuiltinResult BLS12_381.G1.Element - bls12_381_G1_uncompressDenotation = eitherToBuiltinResult . BLS12_381.G1.uncompress - {-# INLINE bls12_381_G1_uncompressDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_uncompress) - - toBuiltinMeaning _semvar Bls12_381_G1_hashToGroup = - let bls12_381_G1_hashToGroupDenotation - :: BS.ByteString -> BS.ByteString -> BuiltinResult BLS12_381.G1.Element - bls12_381_G1_hashToGroupDenotation = eitherToBuiltinResult .* BLS12_381.G1.hashToGroup - {-# INLINE bls12_381_G1_hashToGroupDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup) - - toBuiltinMeaning _semvar Bls12_381_G1_equal = - let bls12_381_G1_equalDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> Bool - bls12_381_G1_equalDenotation = (==) - {-# INLINE bls12_381_G1_equalDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_equal) - - -- BLS12_381.G2 - toBuiltinMeaning _semvar Bls12_381_G2_add = - let bls12_381_G2_addDenotation - :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> BLS12_381.G2.Element - bls12_381_G2_addDenotation = BLS12_381.G2.add - {-# INLINE bls12_381_G2_addDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_add) - - toBuiltinMeaning _semvar Bls12_381_G2_neg = - let bls12_381_G2_negDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element - bls12_381_G2_negDenotation = BLS12_381.G2.neg - {-# INLINE bls12_381_G2_negDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_negDenotation - (runCostingFunOneArgument . paramBls12_381_G2_neg) - - toBuiltinMeaning _semvar Bls12_381_G2_scalarMul = - let bls12_381_G2_scalarMulDenotation - :: Integer -> BLS12_381.G2.Element -> BLS12_381.G2.Element - bls12_381_G2_scalarMulDenotation = BLS12_381.G2.scalarMul - {-# INLINE bls12_381_G2_scalarMulDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul) - - toBuiltinMeaning _semvar Bls12_381_G2_compress = - let bls12_381_G2_compressDenotation :: BLS12_381.G2.Element -> BS.ByteString - bls12_381_G2_compressDenotation = BLS12_381.G2.compress - {-# INLINE bls12_381_G2_compressDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_compress) - - toBuiltinMeaning _semvar Bls12_381_G2_uncompress = - let bls12_381_G2_uncompressDenotation - :: BS.ByteString -> BuiltinResult BLS12_381.G2.Element - bls12_381_G2_uncompressDenotation = eitherToBuiltinResult . BLS12_381.G2.uncompress - {-# INLINE bls12_381_G2_uncompressDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_uncompress) - - toBuiltinMeaning _semvar Bls12_381_G2_hashToGroup = - let bls12_381_G2_hashToGroupDenotation - :: BS.ByteString -> BS.ByteString -> BuiltinResult BLS12_381.G2.Element - bls12_381_G2_hashToGroupDenotation = eitherToBuiltinResult .* BLS12_381.G2.hashToGroup - {-# INLINE bls12_381_G2_hashToGroupDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup) - - toBuiltinMeaning _semvar Bls12_381_G2_equal = - let bls12_381_G2_equalDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> Bool - bls12_381_G2_equalDenotation = (==) - {-# INLINE bls12_381_G2_equalDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_equal) - - -- BLS12_381.Pairing - toBuiltinMeaning _semvar Bls12_381_millerLoop = - let bls12_381_millerLoopDenotation - :: BLS12_381.G1.Element -> BLS12_381.G2.Element -> BLS12_381.Pairing.MlResult - bls12_381_millerLoopDenotation = BLS12_381.Pairing.millerLoop - {-# INLINE bls12_381_millerLoopDenotation #-} - in makeBuiltinMeaning - bls12_381_millerLoopDenotation - (runCostingFunTwoArguments . paramBls12_381_millerLoop) - - toBuiltinMeaning _semvar Bls12_381_mulMlResult = - let bls12_381_mulMlResultDenotation - :: BLS12_381.Pairing.MlResult - -> BLS12_381.Pairing.MlResult - -> BLS12_381.Pairing.MlResult - bls12_381_mulMlResultDenotation = BLS12_381.Pairing.mulMlResult - {-# INLINE bls12_381_mulMlResultDenotation #-} - in makeBuiltinMeaning - bls12_381_mulMlResultDenotation - (runCostingFunTwoArguments . paramBls12_381_mulMlResult) - - toBuiltinMeaning _semvar Bls12_381_finalVerify = - let bls12_381_finalVerifyDenotation - :: BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult -> Bool - bls12_381_finalVerifyDenotation = BLS12_381.Pairing.finalVerify - {-# INLINE bls12_381_finalVerifyDenotation #-} - in makeBuiltinMeaning - bls12_381_finalVerifyDenotation - (runCostingFunTwoArguments . paramBls12_381_finalVerify) - - toBuiltinMeaning _semvar Keccak_256 = - let keccak_256Denotation :: BS.ByteString -> BS.ByteString - keccak_256Denotation = Hash.keccak_256 - {-# INLINE keccak_256Denotation #-} - in makeBuiltinMeaning - keccak_256Denotation - (runCostingFunOneArgument . paramKeccak_256) - - toBuiltinMeaning _semvar Blake2b_224 = - let blake2b_224Denotation :: BS.ByteString -> BS.ByteString - blake2b_224Denotation = Hash.blake2b_224 - {-# INLINE blake2b_224Denotation #-} - in makeBuiltinMeaning - blake2b_224Denotation - (runCostingFunOneArgument . paramBlake2b_224) - - - -- Extra bytestring operations - - -- Conversions - {- See Note [Input length limitation for IntegerToByteString] -} - toBuiltinMeaning _semvar IntegerToByteString = - let integerToByteStringDenotation :: Bool -> NumBytesCostedAsNumWords -> Integer -> BuiltinResult BS.ByteString - {- The second argument is wrapped in a NumBytesCostedAsNumWords to allow us to - interpret it as a size during costing. -} - integerToByteStringDenotation b (NumBytesCostedAsNumWords w) = Bitwise.integerToByteString b w - {-# INLINE integerToByteStringDenotation #-} - in makeBuiltinMeaning - integerToByteStringDenotation - (runCostingFunThreeArguments . paramIntegerToByteString) - - toBuiltinMeaning _semvar ByteStringToInteger = - let byteStringToIntegerDenotation :: Bool -> BS.ByteString -> Integer - byteStringToIntegerDenotation = Bitwise.byteStringToInteger - {-# INLINE byteStringToIntegerDenotation #-} - in makeBuiltinMeaning - byteStringToIntegerDenotation - (runCostingFunTwoArguments . paramByteStringToInteger) - - -- Logical - toBuiltinMeaning _semvar AndByteString = - let andByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - andByteStringDenotation = Bitwise.andByteString - {-# INLINE andByteStringDenotation #-} - in makeBuiltinMeaning - andByteStringDenotation - (runCostingFunThreeArguments . paramAndByteString) - - toBuiltinMeaning _semvar OrByteString = - let orByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - orByteStringDenotation = Bitwise.orByteString - {-# INLINE orByteStringDenotation #-} - in makeBuiltinMeaning - orByteStringDenotation - (runCostingFunThreeArguments . paramOrByteString) - - toBuiltinMeaning _semvar XorByteString = - let xorByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - xorByteStringDenotation = Bitwise.xorByteString - {-# INLINE xorByteStringDenotation #-} - in makeBuiltinMeaning - xorByteStringDenotation - (runCostingFunThreeArguments . paramXorByteString) - - toBuiltinMeaning _semvar ComplementByteString = - let complementByteStringDenotation :: BS.ByteString -> BS.ByteString - complementByteStringDenotation = Bitwise.complementByteString - {-# INLINE complementByteStringDenotation #-} - in makeBuiltinMeaning - complementByteStringDenotation - (runCostingFunOneArgument . paramComplementByteString) - - -- Bitwise operations - - toBuiltinMeaning _semvar ReadBit = - let readBitDenotation :: BS.ByteString -> Int -> BuiltinResult Bool - readBitDenotation = Bitwise.readBit - {-# INLINE readBitDenotation #-} - in makeBuiltinMeaning - readBitDenotation - (runCostingFunTwoArguments . paramReadBit) - - toBuiltinMeaning _semvar WriteBits = - let writeBitsDenotation - :: BS.ByteString - -> [Integer] - -> Bool - -> BuiltinResult BS.ByteString - writeBitsDenotation s ixs = Bitwise.writeBits s ixs - {-# INLINE writeBitsDenotation #-} - in makeBuiltinMeaning - writeBitsDenotation - (runCostingFunThreeArguments . paramWriteBits) - - toBuiltinMeaning _semvar ReplicateByte = - let replicateByteDenotation :: NumBytesCostedAsNumWords -> Word8 -> BuiltinResult BS.ByteString - replicateByteDenotation (NumBytesCostedAsNumWords n) = Bitwise.replicateByte n - {-# INLINE replicateByteDenotation #-} - in makeBuiltinMeaning - replicateByteDenotation - (runCostingFunTwoArguments . paramReplicateByte) - - toBuiltinMeaning _semvar ShiftByteString = - let shiftByteStringDenotation :: BS.ByteString -> IntegerCostedLiterally -> BS.ByteString - shiftByteStringDenotation s (IntegerCostedLiterally n) = Bitwise.shiftByteString s n - {-# INLINE shiftByteStringDenotation #-} - in makeBuiltinMeaning - shiftByteStringDenotation - (runCostingFunTwoArguments . paramShiftByteString) - - toBuiltinMeaning _semvar RotateByteString = - let rotateByteStringDenotation :: BS.ByteString -> IntegerCostedLiterally -> BS.ByteString - rotateByteStringDenotation s (IntegerCostedLiterally n) = Bitwise.rotateByteString s n - {-# INLINE rotateByteStringDenotation #-} - in makeBuiltinMeaning - rotateByteStringDenotation - (runCostingFunTwoArguments . paramRotateByteString) - - toBuiltinMeaning _semvar CountSetBits = - let countSetBitsDenotation :: BS.ByteString -> Int - countSetBitsDenotation = Bitwise.countSetBits - {-# INLINE countSetBitsDenotation #-} - in makeBuiltinMeaning - countSetBitsDenotation - (runCostingFunOneArgument . paramCountSetBits) - - toBuiltinMeaning _semvar FindFirstSetBit = - let findFirstSetBitDenotation :: BS.ByteString -> Int - findFirstSetBitDenotation = Bitwise.findFirstSetBit - {-# INLINE findFirstSetBitDenotation #-} - in makeBuiltinMeaning - findFirstSetBitDenotation - (runCostingFunOneArgument . paramFindFirstSetBit) - - toBuiltinMeaning _semvar Ripemd_160 = - let ripemd_160Denotation :: BS.ByteString -> BS.ByteString - ripemd_160Denotation = Hash.ripemd_160 - {-# INLINE ripemd_160Denotation #-} - in makeBuiltinMeaning - ripemd_160Denotation - (runCostingFunOneArgument . paramRipemd_160) - - -- Batch 6 - - toBuiltinMeaning _semvar ExpModInteger = - let expModIntegerDenotation - :: Integer - -> Integer - -> Integer - -> BuiltinResult Natural - expModIntegerDenotation a b m = - if m < 0 - then fail "expModInteger: negative modulus" - else ExpMod.expMod a b (naturalFromInteger m) - {-# INLINE expModIntegerDenotation #-} - in makeBuiltinMeaning - expModIntegerDenotation - (runCostingFunThreeArguments . paramExpModInteger) - - toBuiltinMeaning _semvar DropList = - let dropListDenotation - :: IntegerCostedLiterally -> SomeConstant uni [a] -> BuiltinResult (Opaque val [a]) - dropListDenotation i (SomeConstant (Some (ValueOf uniListA xs))) = do - -- See Note [Operational vs structural errors within builtins]. - case uniListA of - DefaultUniList _ -> - -- The fastest way of dropping elements from a list is by operating on - -- an unboxed int (i.e. an 'Int#'). We could implement that manually, but - -- 'drop' in @Prelude@ already does that under the hood, so we just need to - -- convert the given 'Integer' to an 'Int' and call 'drop' over that. - fromValueOf uniListA <$> case unIntegerCostedLiterally i of - IS i# -> pure $ drop (I# i#) xs - IN _ -> pure xs - -- If the given 'Integer' is higher than @maxBound :: Int@, then we - -- call 'drop' over the latter instead to get the same performance as in - -- the previous case. This will produce a different result when the - -- list is longer than @maxBound :: Int@, but in practice not only is - -- the budget going to get exhausted long before a @maxBound@ number of - -- elements is skipped, it's not even feasible to skip so many elements - -- for 'Int64' (and we enforce @Int = Int64@ in the @Universe@ module) - -- as that'll take ~3000 years assuming it takes a second to skip - -- @10^8@ elements. - -- - -- We could "optimistically" return '[]' directly without doing any - -- skipping at all, but then we'd be occasionally returning the wrong - -- answer immediately rather than in 3000 years and that doesn't sound - -- like a good idea. Particularly given that costing for this builtin is - -- oblivious to such implementation details anyway, so we wouldn't even - -- be able to capitalize on the fast and loose approach. - -- - -- Instead of using 'drop' we could've made it something like - -- @foldl' const []@, which would be a tad faster while taking even more - -- than 3000 years to return the wrong result, but with the current - -- approach the wrong result is an error, while with the foldl-based one - -- it'd be an actual incorrect value. Plus, it's best not to rely on - -- GHC not optimizing such an expression away to just '[]' (it really - -- shouldn't, but not taking chances with GHC is the best approach). And - -- again, we wouldn't be able to capitalize on such a speedup anyway. - IP _ -> case drop maxBound xs of - [] -> pure [] - _ -> - throwError $ structuralUnliftingError - "Panic: unreachable clause executed" - _ -> throwError $ structuralUnliftingError "Expected a list but got something else" - {-# INLINE dropListDenotation #-} - in makeBuiltinMeaning - dropListDenotation - (runCostingFunTwoArguments . paramDropList) - - toBuiltinMeaning _semvar LengthOfArray = - let lengthOfArrayDenotation :: SomeConstant uni (Vector a) -> BuiltinResult Int - lengthOfArrayDenotation (SomeConstant (Some (ValueOf uni vec))) = - case uni of - DefaultUniArray _uniA -> pure $ Vector.length vec - _ -> throwError $ structuralUnliftingError "Expected an array but got something else" - {-# INLINE lengthOfArrayDenotation #-} - in makeBuiltinMeaning lengthOfArrayDenotation (runCostingFunOneArgument . paramLengthOfArray) - - toBuiltinMeaning _semvar ListToArray = - let listToArrayDenotation :: SomeConstant uni [a] -> BuiltinResult (Opaque val (Vector a)) - listToArrayDenotation (SomeConstant (Some (ValueOf uniListA xs))) = + type CostingPart uni DefaultFun = BuiltinCostModel + + -- \| Allow different variants of builtins with different implementations, and + -- possibly different semantics. Note that DefaultFunSemanticsVariantA, + -- DefaultFunSemanticsVariantB etc. do not correspond directly to PlutusV1, + -- PlutusV2 etc. in plutus-ledger-api: see Note [Builtin semantics variants]. + data BuiltinSemanticsVariant DefaultFun + = DefaultFunSemanticsVariantA + | DefaultFunSemanticsVariantB + | DefaultFunSemanticsVariantC + deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) + deriving anyclass (NFData, NoThunks) + + -- Integers + toBuiltinMeaning :: + forall val. + HasMeaningIn uni val => + BuiltinSemanticsVariant DefaultFun -> + DefaultFun -> + BuiltinMeaning val BuiltinCostModel + toBuiltinMeaning _semvar AddInteger = + let addIntegerDenotation :: Integer -> Integer -> Integer + addIntegerDenotation = (+) + {-# INLINE addIntegerDenotation #-} + in makeBuiltinMeaning + addIntegerDenotation + (runCostingFunTwoArguments . paramAddInteger) + toBuiltinMeaning _semvar SubtractInteger = + let subtractIntegerDenotation :: Integer -> Integer -> Integer + subtractIntegerDenotation = (-) + {-# INLINE subtractIntegerDenotation #-} + in makeBuiltinMeaning + subtractIntegerDenotation + (runCostingFunTwoArguments . paramSubtractInteger) + toBuiltinMeaning _semvar MultiplyInteger = + let multiplyIntegerDenotation :: Integer -> Integer -> Integer + multiplyIntegerDenotation = (*) + {-# INLINE multiplyIntegerDenotation #-} + in makeBuiltinMeaning + multiplyIntegerDenotation + (runCostingFunTwoArguments . paramMultiplyInteger) + toBuiltinMeaning _semvar DivideInteger = + let divideIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer + divideIntegerDenotation = nonZeroSecondArg div + {-# INLINE divideIntegerDenotation #-} + in makeBuiltinMeaning + divideIntegerDenotation + (runCostingFunTwoArguments . paramDivideInteger) + toBuiltinMeaning _semvar QuotientInteger = + let quotientIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer + quotientIntegerDenotation = nonZeroSecondArg quot + {-# INLINE quotientIntegerDenotation #-} + in makeBuiltinMeaning + quotientIntegerDenotation + (runCostingFunTwoArguments . paramQuotientInteger) + toBuiltinMeaning _semvar RemainderInteger = + let remainderIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer + remainderIntegerDenotation = nonZeroSecondArg rem + {-# INLINE remainderIntegerDenotation #-} + in makeBuiltinMeaning + remainderIntegerDenotation + (runCostingFunTwoArguments . paramRemainderInteger) + toBuiltinMeaning _semvar ModInteger = + let modIntegerDenotation :: Integer -> Integer -> BuiltinResult Integer + modIntegerDenotation = nonZeroSecondArg mod + {-# INLINE modIntegerDenotation #-} + in makeBuiltinMeaning + modIntegerDenotation + (runCostingFunTwoArguments . paramModInteger) + toBuiltinMeaning _semvar EqualsInteger = + let equalsIntegerDenotation :: Integer -> Integer -> Bool + equalsIntegerDenotation = (==) + {-# INLINE equalsIntegerDenotation #-} + in makeBuiltinMeaning + equalsIntegerDenotation + (runCostingFunTwoArguments . paramEqualsInteger) + toBuiltinMeaning _semvar LessThanInteger = + let lessThanIntegerDenotation :: Integer -> Integer -> Bool + lessThanIntegerDenotation = (<) + {-# INLINE lessThanIntegerDenotation #-} + in makeBuiltinMeaning + lessThanIntegerDenotation + (runCostingFunTwoArguments . paramLessThanInteger) + toBuiltinMeaning _semvar LessThanEqualsInteger = + let lessThanEqualsIntegerDenotation :: Integer -> Integer -> Bool + lessThanEqualsIntegerDenotation = (<=) + {-# INLINE lessThanEqualsIntegerDenotation #-} + in makeBuiltinMeaning + lessThanEqualsIntegerDenotation + (runCostingFunTwoArguments . paramLessThanEqualsInteger) + -- Bytestrings + toBuiltinMeaning _semvar AppendByteString = + let appendByteStringDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString + appendByteStringDenotation = BS.append + {-# INLINE appendByteStringDenotation #-} + in makeBuiltinMeaning + appendByteStringDenotation + (runCostingFunTwoArguments . paramAppendByteString) + -- See Note [Builtin semantics variants] + toBuiltinMeaning semvar ConsByteString = + -- The costing function is the same for all variants of this builtin, + -- but since the denotation of the builtin accepts constants of + -- different types ('Integer' vs 'Word8'), the costing function needs to + -- by polymorphic over the type of constant. + let costingFun :: + ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream + costingFun = runCostingFunTwoArguments . paramConsByteString + {-# INLINE costingFun #-} + consByteStringMeaning_V1 = + let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString + consByteStringDenotation n = BS.cons (fromIntegral n) + -- Earlier instructions say never to use `fromIntegral` in the definition of a + -- builtin; however in this case it reduces its argument modulo 256 to get a + -- `Word8`, which is exactly what we want. + {-# INLINE consByteStringDenotation #-} + in makeBuiltinMeaning + consByteStringDenotation + costingFun + -- For builtin semantics variants larger than 'DefaultFunSemanticsVariantA', the first + -- input must be in range @[0..255]@. + consByteStringMeaning_V2 = + let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString + consByteStringDenotation = BS.cons + {-# INLINE consByteStringDenotation #-} + in makeBuiltinMeaning + consByteStringDenotation + costingFun + in case semvar of + DefaultFunSemanticsVariantA -> consByteStringMeaning_V1 + DefaultFunSemanticsVariantB -> consByteStringMeaning_V1 + DefaultFunSemanticsVariantC -> consByteStringMeaning_V2 + toBuiltinMeaning _semvar SliceByteString = + let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString + sliceByteStringDenotation start n xs = BS.take n (BS.drop start xs) + {-# INLINE sliceByteStringDenotation #-} + in makeBuiltinMeaning + sliceByteStringDenotation + (runCostingFunThreeArguments . paramSliceByteString) + toBuiltinMeaning _semvar LengthOfByteString = + let lengthOfByteStringDenotation :: BS.ByteString -> Int + lengthOfByteStringDenotation = BS.length + {-# INLINE lengthOfByteStringDenotation #-} + in makeBuiltinMeaning + lengthOfByteStringDenotation + (runCostingFunOneArgument . paramLengthOfByteString) + toBuiltinMeaning _semvar IndexByteString = + let indexByteStringDenotation :: BS.ByteString -> Int -> BuiltinResult Word8 + indexByteStringDenotation xs n = do + unless (n >= 0 && n < BS.length xs) $ + -- See Note [Structural vs operational errors within builtins]. + -- The arguments are going to be printed in the "cause" part of the error + -- message, so we don't need to repeat them here. + fail "Index out of bounds" + pure $ BS.index xs n + {-# INLINE indexByteStringDenotation #-} + in makeBuiltinMeaning + indexByteStringDenotation + (runCostingFunTwoArguments . paramIndexByteString) + toBuiltinMeaning _semvar EqualsByteString = + let equalsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool + equalsByteStringDenotation = (==) + {-# INLINE equalsByteStringDenotation #-} + in makeBuiltinMeaning + equalsByteStringDenotation + (runCostingFunTwoArguments . paramEqualsByteString) + toBuiltinMeaning _semvar LessThanByteString = + let lessThanByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool + lessThanByteStringDenotation = (<) + {-# INLINE lessThanByteStringDenotation #-} + in makeBuiltinMeaning + lessThanByteStringDenotation + (runCostingFunTwoArguments . paramLessThanByteString) + toBuiltinMeaning _semvar LessThanEqualsByteString = + let lessThanEqualsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool + lessThanEqualsByteStringDenotation = (<=) + {-# INLINE lessThanEqualsByteStringDenotation #-} + in makeBuiltinMeaning + lessThanEqualsByteStringDenotation + (runCostingFunTwoArguments . paramLessThanEqualsByteString) + -- Cryptography and hashes + toBuiltinMeaning _semvar Sha2_256 = + let sha2_256Denotation :: BS.ByteString -> BS.ByteString + sha2_256Denotation = Hash.sha2_256 + {-# INLINE sha2_256Denotation #-} + in makeBuiltinMeaning + sha2_256Denotation + (runCostingFunOneArgument . paramSha2_256) + toBuiltinMeaning _semvar Sha3_256 = + let sha3_256Denotation :: BS.ByteString -> BS.ByteString + sha3_256Denotation = Hash.sha3_256 + {-# INLINE sha3_256Denotation #-} + in makeBuiltinMeaning + sha3_256Denotation + (runCostingFunOneArgument . paramSha3_256) + toBuiltinMeaning _semvar Blake2b_256 = + let blake2b_256Denotation :: BS.ByteString -> BS.ByteString + blake2b_256Denotation = Hash.blake2b_256 + {-# INLINE blake2b_256Denotation #-} + in makeBuiltinMeaning + blake2b_256Denotation + (runCostingFunOneArgument . paramBlake2b_256) + toBuiltinMeaning _semvar VerifyEd25519Signature = + let verifyEd25519SignatureDenotation :: + BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool + verifyEd25519SignatureDenotation = verifyEd25519Signature + {-# INLINE verifyEd25519SignatureDenotation #-} + in makeBuiltinMeaning + verifyEd25519SignatureDenotation + -- Benchmarks indicate that the two variants have very similar + -- execution times, so it's safe to use the same costing function for + -- both. + (runCostingFunThreeArguments . paramVerifyEd25519Signature) + {- Note [ECDSA secp256k1 signature verification]. An ECDSA signature + consists of a pair of values (r,s), and for each value of r there are in + fact two valid values of s, one effectively the negative of the other. + The Bitcoin implementation that underlies `verifyEcdsaSecp256k1Signature` + expects that the lower of the two possible values of the s component of + the signature is used, returning `false` immediately if that's not the + case. It appears that this restriction is peculiar to Bitcoin, and ECDSA + schemes in general don't require it. Thus this function may be more + restrictive than expected. See + + https://github.com/bitcoin/bips/blob/master/bip-0146.mediawiki#LOW_S + + and the implementation of secp256k1_ecdsa_verify in + + https://github.com/bitcoin-core/secp256k1. + -} + toBuiltinMeaning _semvar VerifyEcdsaSecp256k1Signature = + let verifyEcdsaSecp256k1SignatureDenotation :: + BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool + verifyEcdsaSecp256k1SignatureDenotation = verifyEcdsaSecp256k1Signature + {-# INLINE verifyEcdsaSecp256k1SignatureDenotation #-} + in makeBuiltinMeaning + verifyEcdsaSecp256k1SignatureDenotation + (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature) + toBuiltinMeaning _semvar VerifySchnorrSecp256k1Signature = + let verifySchnorrSecp256k1SignatureDenotation :: + BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool + verifySchnorrSecp256k1SignatureDenotation = verifySchnorrSecp256k1Signature + {-# INLINE verifySchnorrSecp256k1SignatureDenotation #-} + in makeBuiltinMeaning + verifySchnorrSecp256k1SignatureDenotation + (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature) + -- Strings + toBuiltinMeaning _semvar AppendString = + let appendStringDenotation :: Text -> Text -> Text + appendStringDenotation = (<>) + {-# INLINE appendStringDenotation #-} + in makeBuiltinMeaning + appendStringDenotation + (runCostingFunTwoArguments . paramAppendString) + toBuiltinMeaning _semvar EqualsString = + let equalsStringDenotation :: Text -> Text -> Bool + equalsStringDenotation = (==) + {-# INLINE equalsStringDenotation #-} + in makeBuiltinMeaning + equalsStringDenotation + (runCostingFunTwoArguments . paramEqualsString) + toBuiltinMeaning _semvar EncodeUtf8 = + let encodeUtf8Denotation :: Text -> BS.ByteString + encodeUtf8Denotation = encodeUtf8 + {-# INLINE encodeUtf8Denotation #-} + in makeBuiltinMeaning + encodeUtf8Denotation + (runCostingFunOneArgument . paramEncodeUtf8) + toBuiltinMeaning _semvar DecodeUtf8 = + let decodeUtf8Denotation :: BS.ByteString -> BuiltinResult Text + decodeUtf8Denotation = eitherToBuiltinResult . decodeUtf8' + {-# INLINE decodeUtf8Denotation #-} + in makeBuiltinMeaning + decodeUtf8Denotation + (runCostingFunOneArgument . paramDecodeUtf8) + -- Bool + toBuiltinMeaning _semvar IfThenElse = + let ifThenElseDenotation :: Bool -> a -> a -> a + ifThenElseDenotation b x y = if b then x else y + {-# INLINE ifThenElseDenotation #-} + in makeBuiltinMeaning + ifThenElseDenotation + (runCostingFunThreeArguments . paramIfThenElse) + -- Unit + toBuiltinMeaning _semvar ChooseUnit = + let chooseUnitDenotation :: () -> a -> a + chooseUnitDenotation () x = x + {-# INLINE chooseUnitDenotation #-} + in makeBuiltinMeaning + chooseUnitDenotation + (runCostingFunTwoArguments . paramChooseUnit) + -- Tracing + toBuiltinMeaning _semvar Trace = + let traceDenotation :: Text -> a -> BuiltinResult a + traceDenotation text a = a <$ emit text + {-# INLINE traceDenotation #-} + in makeBuiltinMeaning + traceDenotation + (runCostingFunTwoArguments . paramTrace) + -- Pairs + toBuiltinMeaning _semvar FstPair = + let fstPairDenotation :: SomeConstant uni (a, b) -> BuiltinResult (Opaque val a) + fstPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = + case uniPairAB of + DefaultUniPair uniA _ -> pure . fromValueOf uniA $ fst xy + _ -> + -- See Note [Structural vs operational errors within builtins]. + throwError $ structuralUnliftingError "Expected a pair but got something else" + {-# INLINE fstPairDenotation #-} + in makeBuiltinMeaning + fstPairDenotation + (runCostingFunOneArgument . paramFstPair) + toBuiltinMeaning _semvar SndPair = + let sndPairDenotation :: SomeConstant uni (a, b) -> BuiltinResult (Opaque val b) + sndPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = + case uniPairAB of + DefaultUniPair _ uniB -> pure . fromValueOf uniB $ snd xy + _ -> + -- See Note [Structural vs operational errors within builtins]. + throwError $ structuralUnliftingError "Expected a pair but got something else" + {-# INLINE sndPairDenotation #-} + in makeBuiltinMeaning + sndPairDenotation + (runCostingFunOneArgument . paramSndPair) + -- Lists + toBuiltinMeaning _semvar ChooseList = + let chooseListDenotation :: SomeConstant uni [a] -> b -> b -> BuiltinResult b + chooseListDenotation (SomeConstant (Some (ValueOf uniListA xs))) a b = + case uniListA of + DefaultUniList _ -> pure $ case xs of + [] -> a + _ : _ -> b + _ -> + -- See Note [Structural vs operational errors within builtins]. + throwError $ structuralUnliftingError "Expected a list but got something else" + {-# INLINE chooseListDenotation #-} + in makeBuiltinMeaning + chooseListDenotation + (runCostingFunThreeArguments . paramChooseList) + toBuiltinMeaning _semvar MkCons = + let mkConsDenotation :: + SomeConstant uni a -> SomeConstant uni [a] -> BuiltinResult (Opaque val [a]) + mkConsDenotation + (SomeConstant (Some (ValueOf uniA x))) + (SomeConstant (Some (ValueOf uniListA xs))) = + -- See Note [Structural vs operational errors within builtins]. case uniListA of - DefaultUniList uniA -> pure $ fromValueOf (DefaultUniArray uniA) $ Vector.fromList xs - _ -> throwError $ structuralUnliftingError "Expected a list but got something else" - {-# INLINE listToArrayDenotation #-} - in makeBuiltinMeaning listToArrayDenotation (runCostingFunOneArgument . paramListToArray) - - toBuiltinMeaning _semvar IndexArray = - let indexArrayDenotation :: SomeConstant uni (Vector a) -> Int -> BuiltinResult (Opaque val a) - indexArrayDenotation (SomeConstant (Some (ValueOf uni vec))) n = - case uni of - DefaultUniArray arg -> do - case vec Vector.!? n of - Nothing -> fail "Array index out of bounds" - Just el -> pure $ fromValueOf arg el - _ -> - -- See Note [Structural vs operational errors within builtins]. - -- The arguments are going to be printed in the "cause" part of the error - -- message, so we don't need to repeat them here. - throwError $ structuralUnliftingError "Expected an array but got something else" - {-# INLINE indexArrayDenotation #-} - in makeBuiltinMeaning indexArrayDenotation (runCostingFunTwoArguments . paramIndexArray) - - toBuiltinMeaning _semvar Bls12_381_G1_multiScalarMul = - let bls12_381_G1_multiScalarMulDenotation - :: [Integer] -> [BLS12_381.G1.Element] -> BLS12_381.G1.Element - bls12_381_G1_multiScalarMulDenotation = BLS12_381.G1.multiScalarMul - {-# INLINE bls12_381_G1_multiScalarMulDenotation #-} - in makeBuiltinMeaning - bls12_381_G1_multiScalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_multiScalarMul) - - toBuiltinMeaning _semvar Bls12_381_G2_multiScalarMul = - let bls12_381_G2_multiScalarMulDenotation - :: [Integer] -> [BLS12_381.G2.Element] -> BLS12_381.G2.Element - bls12_381_G2_multiScalarMulDenotation = BLS12_381.G2.multiScalarMul - {-# INLINE bls12_381_G2_multiScalarMulDenotation #-} - in makeBuiltinMeaning - bls12_381_G2_multiScalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_multiScalarMul) - - toBuiltinMeaning _semvar InsertCoin = - let insertCoinDenotation :: ByteString -> ByteString -> Integer -> Value -> BuiltinResult Value - insertCoinDenotation = Value.insertCoin - {-# INLINE insertCoinDenotation #-} - in makeBuiltinMeaning - insertCoinDenotation - (runCostingFunFourArguments . unimplementedCostingFun) - - toBuiltinMeaning _semvar LookupCoin = - let lookupCoinDenotation :: ByteString -> ByteString -> Value -> Integer - lookupCoinDenotation = Value.lookupCoin - {-# INLINE lookupCoinDenotation #-} - in makeBuiltinMeaning - lookupCoinDenotation - (runCostingFunThreeArguments . unimplementedCostingFun) - - toBuiltinMeaning _semvar UnionValue = - let unionValueDenotation :: Value -> Value -> BuiltinResult Value - unionValueDenotation = Value.unionValue - {-# INLINE unionValueDenotation #-} - in makeBuiltinMeaning - unionValueDenotation - (runCostingFunTwoArguments . unimplementedCostingFun) - - toBuiltinMeaning _semvar ValueContains = - let valueContainsDenotation :: Value -> Value -> BuiltinResult Bool - valueContainsDenotation = Value.valueContains - {-# INLINE valueContainsDenotation #-} - in makeBuiltinMeaning - valueContainsDenotation - (runCostingFunTwoArguments . unimplementedCostingFun) - - toBuiltinMeaning _semvar ValueData = - let valueDataDenotation :: Value -> Data - valueDataDenotation = Value.valueData - {-# INLINE valueDataDenotation #-} - in makeBuiltinMeaning - valueDataDenotation - (runCostingFunOneArgument . unimplementedCostingFun) - - toBuiltinMeaning _semvar UnValueData = - let unValueDataDenotation :: Data -> BuiltinResult Value - unValueDataDenotation = Value.unValueData - {-# INLINE unValueDataDenotation #-} - in makeBuiltinMeaning - unValueDataDenotation - (runCostingFunOneArgument . unimplementedCostingFun) - - toBuiltinMeaning _semvar ScaleValue = - let unValueDataDenotation :: Integer -> Value -> BuiltinResult Value - unValueDataDenotation = Value.scaleValue - {-# INLINE unValueDataDenotation #-} - in makeBuiltinMeaning - unValueDataDenotation - (runCostingFunTwoArguments . unimplementedCostingFun) - - -- See Note [Inlining meanings of builtins]. - {-# INLINE toBuiltinMeaning #-} - - {- *** IMPORTANT! *** When you're adding a new builtin above you typically won't - be able to add a sensible costing function until the implementation is - complete and you can benchmark it. It's still necessary to supply - `toBuiltinMeaning` with some costing function though: this **MUST** be - `unimplementedCostingFun`: this will assign a very large cost to any - invocation of the function, preventing it from being used in places where - costs are important (for example on testnets) until the implementation is - complete and a proper costing function has been defined. Once the - builtin is ready for general use replace `unimplementedCostingFun` with - the appropriate `param` from BuiltinCostModelBase. - - Please leave this comment immediately after the definition of the final - builtin to maximise the chances of it being seen the next time someone - implements a new builtin. - -} + DefaultUniList uniA' -> case uniA `geq` uniA' of + Just Refl -> pure . fromValueOf uniListA $ x : xs + Nothing -> + throwError $ + structuralUnliftingError + "The type of the value does not match the type of elements in the list" + _ -> throwError $ structuralUnliftingError "Expected a list but got something else" + {-# INLINE mkConsDenotation #-} + in makeBuiltinMeaning + mkConsDenotation + (runCostingFunTwoArguments . paramMkCons) + toBuiltinMeaning _semvar HeadList = + let headListDenotation :: SomeConstant uni [a] -> BuiltinResult (Opaque val a) + headListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = + case uniListA of + DefaultUniList uniA -> case xs of + [] -> fail "Expected a non-empty list but got an empty one" + x : _ -> pure $ fromValueOf uniA x + _ -> throwError $ structuralUnliftingError "Expected a list but got something else" + {-# INLINE headListDenotation #-} + in makeBuiltinMeaning + headListDenotation + (runCostingFunOneArgument . paramHeadList) + toBuiltinMeaning _semvar TailList = + let tailListDenotation :: SomeConstant uni [a] -> BuiltinResult (Opaque val [a]) + tailListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = + case uniListA of + DefaultUniList _argUni -> + case xs of + [] -> fail "Expected a non-empty list but got an empty one" + _ : xs' -> pure $ fromValueOf uniListA xs' + _ -> throwError $ structuralUnliftingError "Expected a list but got something else" + {-# INLINE tailListDenotation #-} + in makeBuiltinMeaning + tailListDenotation + (runCostingFunOneArgument . paramTailList) + toBuiltinMeaning _semvar NullList = + let nullListDenotation :: SomeConstant uni [a] -> BuiltinResult Bool + nullListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = + case uniListA of + DefaultUniList _uniA -> pure $ null xs + _ -> throwError $ structuralUnliftingError "Expected a list but got something else" + {-# INLINE nullListDenotation #-} + in makeBuiltinMeaning + nullListDenotation + (runCostingFunOneArgument . paramNullList) + -- Data + toBuiltinMeaning _semvar ChooseData = + let chooseDataDenotation :: Data -> a -> a -> a -> a -> a -> a + chooseDataDenotation d xConstr xMap xList xI xB = + case d of + Constr {} -> xConstr + Map {} -> xMap + List {} -> xList + I {} -> xI + B {} -> xB + {-# INLINE chooseDataDenotation #-} + in makeBuiltinMeaning + chooseDataDenotation + (runCostingFunSixArguments . paramChooseData) + toBuiltinMeaning _semvar ConstrData = + let constrDataDenotation :: Integer -> [Data] -> Data + constrDataDenotation = Constr + {-# INLINE constrDataDenotation #-} + in makeBuiltinMeaning + constrDataDenotation + (runCostingFunTwoArguments . paramConstrData) + toBuiltinMeaning _semvar MapData = + let mapDataDenotation :: [(Data, Data)] -> Data + mapDataDenotation = Map + {-# INLINE mapDataDenotation #-} + in makeBuiltinMeaning + mapDataDenotation + (runCostingFunOneArgument . paramMapData) + toBuiltinMeaning _semvar ListData = + let listDataDenotation :: [Data] -> Data + listDataDenotation = List + {-# INLINE listDataDenotation #-} + in makeBuiltinMeaning + listDataDenotation + (runCostingFunOneArgument . paramListData) + toBuiltinMeaning _semvar IData = + let iDataDenotation :: Integer -> Data + iDataDenotation = I + {-# INLINE iDataDenotation #-} + in makeBuiltinMeaning + iDataDenotation + (runCostingFunOneArgument . paramIData) + toBuiltinMeaning _semvar BData = + let bDataDenotation :: BS.ByteString -> Data + bDataDenotation = B + {-# INLINE bDataDenotation #-} + in makeBuiltinMeaning + bDataDenotation + (runCostingFunOneArgument . paramBData) + toBuiltinMeaning _semvar UnConstrData = + let unConstrDataDenotation :: Data -> BuiltinResult (Integer, [Data]) + unConstrDataDenotation = \case + Constr i ds -> pure (i, ds) + _ -> + -- See Note [Structural vs operational errors within builtins]. + fail "Expected the Constr constructor but got a different one" + {-# INLINE unConstrDataDenotation #-} + in makeBuiltinMeaning + unConstrDataDenotation + (runCostingFunOneArgument . paramUnConstrData) + toBuiltinMeaning _semvar UnMapData = + let unMapDataDenotation :: Data -> BuiltinResult [(Data, Data)] + unMapDataDenotation = \case + Map es -> pure es + _ -> + -- See Note [Structural vs operational errors within builtins]. + fail "Expected the Map constructor but got a different one" + {-# INLINE unMapDataDenotation #-} + in makeBuiltinMeaning + unMapDataDenotation + (runCostingFunOneArgument . paramUnMapData) + toBuiltinMeaning _semvar UnListData = + let unListDataDenotation :: Data -> BuiltinResult [Data] + unListDataDenotation = \case + List ds -> pure ds + _ -> + -- See Note [Structural vs operational errors within builtins]. + fail "Expected the List constructor but got a different one" + {-# INLINE unListDataDenotation #-} + in makeBuiltinMeaning + unListDataDenotation + (runCostingFunOneArgument . paramUnListData) + toBuiltinMeaning _semvar UnIData = + let unIDataDenotation :: Data -> BuiltinResult Integer + unIDataDenotation = \case + I i -> pure i + _ -> + -- See Note [Structural vs operational errors within builtins]. + fail "Expected the I constructor but got a different one" + {-# INLINE unIDataDenotation #-} + in makeBuiltinMeaning + unIDataDenotation + (runCostingFunOneArgument . paramUnIData) + toBuiltinMeaning _semvar UnBData = + let unBDataDenotation :: Data -> BuiltinResult BS.ByteString + unBDataDenotation = \case + B b -> pure b + _ -> + -- See Note [Structural vs operational errors within builtins]. + fail "Expected the B constructor but got a different one" + {-# INLINE unBDataDenotation #-} + in makeBuiltinMeaning + unBDataDenotation + (runCostingFunOneArgument . paramUnBData) + toBuiltinMeaning _semvar EqualsData = + let equalsDataDenotation :: Data -> Data -> Bool + equalsDataDenotation = (==) + {-# INLINE equalsDataDenotation #-} + in makeBuiltinMeaning + equalsDataDenotation + (runCostingFunTwoArguments . paramEqualsData) + toBuiltinMeaning _semvar SerialiseData = + let serialiseDataDenotation :: Data -> BS.ByteString + serialiseDataDenotation = BSL.toStrict . serialise + {-# INLINE serialiseDataDenotation #-} + in makeBuiltinMeaning + serialiseDataDenotation + (runCostingFunOneArgument . paramSerialiseData) + -- Misc constructors + toBuiltinMeaning _semvar MkPairData = + let mkPairDataDenotation :: Data -> Data -> (Data, Data) + mkPairDataDenotation = (,) + {-# INLINE mkPairDataDenotation #-} + in makeBuiltinMeaning + mkPairDataDenotation + (runCostingFunTwoArguments . paramMkPairData) + toBuiltinMeaning _semvar MkNilData = + -- Nullary built-in functions don't work, so we need a unit argument. + -- We don't really need this built-in function, see Note [Constants vs built-in functions], + -- but we keep it around for historical reasons and convenience. + let mkNilDataDenotation :: () -> [Data] + mkNilDataDenotation () = [] + {-# INLINE mkNilDataDenotation #-} + in makeBuiltinMeaning + mkNilDataDenotation + (runCostingFunOneArgument . paramMkNilData) + toBuiltinMeaning _semvar MkNilPairData = + -- Nullary built-in functions don't work, so we need a unit argument. + -- We don't really need this built-in function, see Note [Constants vs built-in functions], + -- but we keep it around for historical reasons and convenience. + let mkNilPairDataDenotation :: () -> [(Data, Data)] + mkNilPairDataDenotation () = [] + {-# INLINE mkNilPairDataDenotation #-} + in makeBuiltinMeaning + mkNilPairDataDenotation + (runCostingFunOneArgument . paramMkNilPairData) + -- BLS12_381.G1 + toBuiltinMeaning _semvar Bls12_381_G1_add = + let bls12_381_G1_addDenotation :: + BLS12_381.G1.Element -> BLS12_381.G1.Element -> BLS12_381.G1.Element + bls12_381_G1_addDenotation = BLS12_381.G1.add + {-# INLINE bls12_381_G1_addDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_addDenotation + (runCostingFunTwoArguments . paramBls12_381_G1_add) + toBuiltinMeaning _semvar Bls12_381_G1_neg = + let bls12_381_G1_negDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element + bls12_381_G1_negDenotation = BLS12_381.G1.neg + {-# INLINE bls12_381_G1_negDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_negDenotation + (runCostingFunOneArgument . paramBls12_381_G1_neg) + toBuiltinMeaning _semvar Bls12_381_G1_scalarMul = + let bls12_381_G1_scalarMulDenotation :: + Integer -> BLS12_381.G1.Element -> BLS12_381.G1.Element + bls12_381_G1_scalarMulDenotation = BLS12_381.G1.scalarMul + {-# INLINE bls12_381_G1_scalarMulDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_scalarMulDenotation + (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul) + toBuiltinMeaning _semvar Bls12_381_G1_compress = + let bls12_381_G1_compressDenotation :: BLS12_381.G1.Element -> BS.ByteString + bls12_381_G1_compressDenotation = BLS12_381.G1.compress + {-# INLINE bls12_381_G1_compressDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_compressDenotation + (runCostingFunOneArgument . paramBls12_381_G1_compress) + toBuiltinMeaning _semvar Bls12_381_G1_uncompress = + let bls12_381_G1_uncompressDenotation :: + BS.ByteString -> BuiltinResult BLS12_381.G1.Element + bls12_381_G1_uncompressDenotation = eitherToBuiltinResult . BLS12_381.G1.uncompress + {-# INLINE bls12_381_G1_uncompressDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_uncompressDenotation + (runCostingFunOneArgument . paramBls12_381_G1_uncompress) + toBuiltinMeaning _semvar Bls12_381_G1_hashToGroup = + let bls12_381_G1_hashToGroupDenotation :: + BS.ByteString -> BS.ByteString -> BuiltinResult BLS12_381.G1.Element + bls12_381_G1_hashToGroupDenotation = eitherToBuiltinResult .* BLS12_381.G1.hashToGroup + {-# INLINE bls12_381_G1_hashToGroupDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_hashToGroupDenotation + (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup) + toBuiltinMeaning _semvar Bls12_381_G1_equal = + let bls12_381_G1_equalDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> Bool + bls12_381_G1_equalDenotation = (==) + {-# INLINE bls12_381_G1_equalDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_equalDenotation + (runCostingFunTwoArguments . paramBls12_381_G1_equal) + -- BLS12_381.G2 + toBuiltinMeaning _semvar Bls12_381_G2_add = + let bls12_381_G2_addDenotation :: + BLS12_381.G2.Element -> BLS12_381.G2.Element -> BLS12_381.G2.Element + bls12_381_G2_addDenotation = BLS12_381.G2.add + {-# INLINE bls12_381_G2_addDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_addDenotation + (runCostingFunTwoArguments . paramBls12_381_G2_add) + toBuiltinMeaning _semvar Bls12_381_G2_neg = + let bls12_381_G2_negDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element + bls12_381_G2_negDenotation = BLS12_381.G2.neg + {-# INLINE bls12_381_G2_negDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_negDenotation + (runCostingFunOneArgument . paramBls12_381_G2_neg) + toBuiltinMeaning _semvar Bls12_381_G2_scalarMul = + let bls12_381_G2_scalarMulDenotation :: + Integer -> BLS12_381.G2.Element -> BLS12_381.G2.Element + bls12_381_G2_scalarMulDenotation = BLS12_381.G2.scalarMul + {-# INLINE bls12_381_G2_scalarMulDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_scalarMulDenotation + (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul) + toBuiltinMeaning _semvar Bls12_381_G2_compress = + let bls12_381_G2_compressDenotation :: BLS12_381.G2.Element -> BS.ByteString + bls12_381_G2_compressDenotation = BLS12_381.G2.compress + {-# INLINE bls12_381_G2_compressDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_compressDenotation + (runCostingFunOneArgument . paramBls12_381_G2_compress) + toBuiltinMeaning _semvar Bls12_381_G2_uncompress = + let bls12_381_G2_uncompressDenotation :: + BS.ByteString -> BuiltinResult BLS12_381.G2.Element + bls12_381_G2_uncompressDenotation = eitherToBuiltinResult . BLS12_381.G2.uncompress + {-# INLINE bls12_381_G2_uncompressDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_uncompressDenotation + (runCostingFunOneArgument . paramBls12_381_G2_uncompress) + toBuiltinMeaning _semvar Bls12_381_G2_hashToGroup = + let bls12_381_G2_hashToGroupDenotation :: + BS.ByteString -> BS.ByteString -> BuiltinResult BLS12_381.G2.Element + bls12_381_G2_hashToGroupDenotation = eitherToBuiltinResult .* BLS12_381.G2.hashToGroup + {-# INLINE bls12_381_G2_hashToGroupDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_hashToGroupDenotation + (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup) + toBuiltinMeaning _semvar Bls12_381_G2_equal = + let bls12_381_G2_equalDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> Bool + bls12_381_G2_equalDenotation = (==) + {-# INLINE bls12_381_G2_equalDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_equalDenotation + (runCostingFunTwoArguments . paramBls12_381_G2_equal) + -- BLS12_381.Pairing + toBuiltinMeaning _semvar Bls12_381_millerLoop = + let bls12_381_millerLoopDenotation :: + BLS12_381.G1.Element -> BLS12_381.G2.Element -> BLS12_381.Pairing.MlResult + bls12_381_millerLoopDenotation = BLS12_381.Pairing.millerLoop + {-# INLINE bls12_381_millerLoopDenotation #-} + in makeBuiltinMeaning + bls12_381_millerLoopDenotation + (runCostingFunTwoArguments . paramBls12_381_millerLoop) + toBuiltinMeaning _semvar Bls12_381_mulMlResult = + let bls12_381_mulMlResultDenotation :: + BLS12_381.Pairing.MlResult -> + BLS12_381.Pairing.MlResult -> + BLS12_381.Pairing.MlResult + bls12_381_mulMlResultDenotation = BLS12_381.Pairing.mulMlResult + {-# INLINE bls12_381_mulMlResultDenotation #-} + in makeBuiltinMeaning + bls12_381_mulMlResultDenotation + (runCostingFunTwoArguments . paramBls12_381_mulMlResult) + toBuiltinMeaning _semvar Bls12_381_finalVerify = + let bls12_381_finalVerifyDenotation :: + BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult -> Bool + bls12_381_finalVerifyDenotation = BLS12_381.Pairing.finalVerify + {-# INLINE bls12_381_finalVerifyDenotation #-} + in makeBuiltinMeaning + bls12_381_finalVerifyDenotation + (runCostingFunTwoArguments . paramBls12_381_finalVerify) + toBuiltinMeaning _semvar Keccak_256 = + let keccak_256Denotation :: BS.ByteString -> BS.ByteString + keccak_256Denotation = Hash.keccak_256 + {-# INLINE keccak_256Denotation #-} + in makeBuiltinMeaning + keccak_256Denotation + (runCostingFunOneArgument . paramKeccak_256) + toBuiltinMeaning _semvar Blake2b_224 = + let blake2b_224Denotation :: BS.ByteString -> BS.ByteString + blake2b_224Denotation = Hash.blake2b_224 + {-# INLINE blake2b_224Denotation #-} + in makeBuiltinMeaning + blake2b_224Denotation + (runCostingFunOneArgument . paramBlake2b_224) + -- Extra bytestring operations + + -- Conversions + {- See Note [Input length limitation for IntegerToByteString] -} + toBuiltinMeaning _semvar IntegerToByteString = + let integerToByteStringDenotation :: Bool -> NumBytesCostedAsNumWords -> Integer -> BuiltinResult BS.ByteString + {- The second argument is wrapped in a NumBytesCostedAsNumWords to allow us to + interpret it as a size during costing. -} + integerToByteStringDenotation b (NumBytesCostedAsNumWords w) = Bitwise.integerToByteString b w + {-# INLINE integerToByteStringDenotation #-} + in makeBuiltinMeaning + integerToByteStringDenotation + (runCostingFunThreeArguments . paramIntegerToByteString) + toBuiltinMeaning _semvar ByteStringToInteger = + let byteStringToIntegerDenotation :: Bool -> BS.ByteString -> Integer + byteStringToIntegerDenotation = Bitwise.byteStringToInteger + {-# INLINE byteStringToIntegerDenotation #-} + in makeBuiltinMeaning + byteStringToIntegerDenotation + (runCostingFunTwoArguments . paramByteStringToInteger) + -- Logical + toBuiltinMeaning _semvar AndByteString = + let andByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + andByteStringDenotation = Bitwise.andByteString + {-# INLINE andByteStringDenotation #-} + in makeBuiltinMeaning + andByteStringDenotation + (runCostingFunThreeArguments . paramAndByteString) + toBuiltinMeaning _semvar OrByteString = + let orByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + orByteStringDenotation = Bitwise.orByteString + {-# INLINE orByteStringDenotation #-} + in makeBuiltinMeaning + orByteStringDenotation + (runCostingFunThreeArguments . paramOrByteString) + toBuiltinMeaning _semvar XorByteString = + let xorByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + xorByteStringDenotation = Bitwise.xorByteString + {-# INLINE xorByteStringDenotation #-} + in makeBuiltinMeaning + xorByteStringDenotation + (runCostingFunThreeArguments . paramXorByteString) + toBuiltinMeaning _semvar ComplementByteString = + let complementByteStringDenotation :: BS.ByteString -> BS.ByteString + complementByteStringDenotation = Bitwise.complementByteString + {-# INLINE complementByteStringDenotation #-} + in makeBuiltinMeaning + complementByteStringDenotation + (runCostingFunOneArgument . paramComplementByteString) + -- Bitwise operations + + toBuiltinMeaning _semvar ReadBit = + let readBitDenotation :: BS.ByteString -> Int -> BuiltinResult Bool + readBitDenotation = Bitwise.readBit + {-# INLINE readBitDenotation #-} + in makeBuiltinMeaning + readBitDenotation + (runCostingFunTwoArguments . paramReadBit) + toBuiltinMeaning _semvar WriteBits = + let writeBitsDenotation :: + BS.ByteString -> + [Integer] -> + Bool -> + BuiltinResult BS.ByteString + writeBitsDenotation s ixs = Bitwise.writeBits s ixs + {-# INLINE writeBitsDenotation #-} + in makeBuiltinMeaning + writeBitsDenotation + (runCostingFunThreeArguments . paramWriteBits) + toBuiltinMeaning _semvar ReplicateByte = + let replicateByteDenotation :: NumBytesCostedAsNumWords -> Word8 -> BuiltinResult BS.ByteString + replicateByteDenotation (NumBytesCostedAsNumWords n) = Bitwise.replicateByte n + {-# INLINE replicateByteDenotation #-} + in makeBuiltinMeaning + replicateByteDenotation + (runCostingFunTwoArguments . paramReplicateByte) + toBuiltinMeaning _semvar ShiftByteString = + let shiftByteStringDenotation :: BS.ByteString -> IntegerCostedLiterally -> BS.ByteString + shiftByteStringDenotation s (IntegerCostedLiterally n) = Bitwise.shiftByteString s n + {-# INLINE shiftByteStringDenotation #-} + in makeBuiltinMeaning + shiftByteStringDenotation + (runCostingFunTwoArguments . paramShiftByteString) + toBuiltinMeaning _semvar RotateByteString = + let rotateByteStringDenotation :: BS.ByteString -> IntegerCostedLiterally -> BS.ByteString + rotateByteStringDenotation s (IntegerCostedLiterally n) = Bitwise.rotateByteString s n + {-# INLINE rotateByteStringDenotation #-} + in makeBuiltinMeaning + rotateByteStringDenotation + (runCostingFunTwoArguments . paramRotateByteString) + toBuiltinMeaning _semvar CountSetBits = + let countSetBitsDenotation :: BS.ByteString -> Int + countSetBitsDenotation = Bitwise.countSetBits + {-# INLINE countSetBitsDenotation #-} + in makeBuiltinMeaning + countSetBitsDenotation + (runCostingFunOneArgument . paramCountSetBits) + toBuiltinMeaning _semvar FindFirstSetBit = + let findFirstSetBitDenotation :: BS.ByteString -> Int + findFirstSetBitDenotation = Bitwise.findFirstSetBit + {-# INLINE findFirstSetBitDenotation #-} + in makeBuiltinMeaning + findFirstSetBitDenotation + (runCostingFunOneArgument . paramFindFirstSetBit) + toBuiltinMeaning _semvar Ripemd_160 = + let ripemd_160Denotation :: BS.ByteString -> BS.ByteString + ripemd_160Denotation = Hash.ripemd_160 + {-# INLINE ripemd_160Denotation #-} + in makeBuiltinMeaning + ripemd_160Denotation + (runCostingFunOneArgument . paramRipemd_160) + -- Batch 6 + + toBuiltinMeaning _semvar ExpModInteger = + let expModIntegerDenotation :: + Integer -> + Integer -> + Integer -> + BuiltinResult Natural + expModIntegerDenotation a b m = + if m < 0 + then fail "expModInteger: negative modulus" + else ExpMod.expMod a b (naturalFromInteger m) + {-# INLINE expModIntegerDenotation #-} + in makeBuiltinMeaning + expModIntegerDenotation + (runCostingFunThreeArguments . paramExpModInteger) + toBuiltinMeaning _semvar DropList = + let dropListDenotation :: + IntegerCostedLiterally -> SomeConstant uni [a] -> BuiltinResult (Opaque val [a]) + dropListDenotation i (SomeConstant (Some (ValueOf uniListA xs))) = do + -- See Note [Operational vs structural errors within builtins]. + case uniListA of + DefaultUniList _ -> + -- The fastest way of dropping elements from a list is by operating on + -- an unboxed int (i.e. an 'Int#'). We could implement that manually, but + -- 'drop' in @Prelude@ already does that under the hood, so we just need to + -- convert the given 'Integer' to an 'Int' and call 'drop' over that. + fromValueOf uniListA <$> case unIntegerCostedLiterally i of + IS i# -> pure $ drop (I# i#) xs + IN _ -> pure xs + -- If the given 'Integer' is higher than @maxBound :: Int@, then we + -- call 'drop' over the latter instead to get the same performance as in + -- the previous case. This will produce a different result when the + -- list is longer than @maxBound :: Int@, but in practice not only is + -- the budget going to get exhausted long before a @maxBound@ number of + -- elements is skipped, it's not even feasible to skip so many elements + -- for 'Int64' (and we enforce @Int = Int64@ in the @Universe@ module) + -- as that'll take ~3000 years assuming it takes a second to skip + -- @10^8@ elements. + -- + -- We could "optimistically" return '[]' directly without doing any + -- skipping at all, but then we'd be occasionally returning the wrong + -- answer immediately rather than in 3000 years and that doesn't sound + -- like a good idea. Particularly given that costing for this builtin is + -- oblivious to such implementation details anyway, so we wouldn't even + -- be able to capitalize on the fast and loose approach. + -- + -- Instead of using 'drop' we could've made it something like + -- @foldl' const []@, which would be a tad faster while taking even more + -- than 3000 years to return the wrong result, but with the current + -- approach the wrong result is an error, while with the foldl-based one + -- it'd be an actual incorrect value. Plus, it's best not to rely on + -- GHC not optimizing such an expression away to just '[]' (it really + -- shouldn't, but not taking chances with GHC is the best approach). And + -- again, we wouldn't be able to capitalize on such a speedup anyway. + IP _ -> case drop maxBound xs of + [] -> pure [] + _ -> + throwError $ + structuralUnliftingError + "Panic: unreachable clause executed" + _ -> throwError $ structuralUnliftingError "Expected a list but got something else" + {-# INLINE dropListDenotation #-} + in makeBuiltinMeaning + dropListDenotation + (runCostingFunTwoArguments . paramDropList) + toBuiltinMeaning _semvar LengthOfArray = + let lengthOfArrayDenotation :: SomeConstant uni (Vector a) -> BuiltinResult Int + lengthOfArrayDenotation (SomeConstant (Some (ValueOf uni vec))) = + case uni of + DefaultUniArray _uniA -> pure $ Vector.length vec + _ -> throwError $ structuralUnliftingError "Expected an array but got something else" + {-# INLINE lengthOfArrayDenotation #-} + in makeBuiltinMeaning lengthOfArrayDenotation (runCostingFunOneArgument . paramLengthOfArray) + toBuiltinMeaning _semvar ListToArray = + let listToArrayDenotation :: SomeConstant uni [a] -> BuiltinResult (Opaque val (Vector a)) + listToArrayDenotation (SomeConstant (Some (ValueOf uniListA xs))) = + case uniListA of + DefaultUniList uniA -> pure $ fromValueOf (DefaultUniArray uniA) $ Vector.fromList xs + _ -> throwError $ structuralUnliftingError "Expected a list but got something else" + {-# INLINE listToArrayDenotation #-} + in makeBuiltinMeaning listToArrayDenotation (runCostingFunOneArgument . paramListToArray) + toBuiltinMeaning _semvar IndexArray = + let indexArrayDenotation :: SomeConstant uni (Vector a) -> Int -> BuiltinResult (Opaque val a) + indexArrayDenotation (SomeConstant (Some (ValueOf uni vec))) n = + case uni of + DefaultUniArray arg -> do + case vec Vector.!? n of + Nothing -> fail "Array index out of bounds" + Just el -> pure $ fromValueOf arg el + _ -> + -- See Note [Structural vs operational errors within builtins]. + -- The arguments are going to be printed in the "cause" part of the error + -- message, so we don't need to repeat them here. + throwError $ structuralUnliftingError "Expected an array but got something else" + {-# INLINE indexArrayDenotation #-} + in makeBuiltinMeaning indexArrayDenotation (runCostingFunTwoArguments . paramIndexArray) + toBuiltinMeaning _semvar Bls12_381_G1_multiScalarMul = + let bls12_381_G1_multiScalarMulDenotation :: + [Integer] -> [BLS12_381.G1.Element] -> BLS12_381.G1.Element + bls12_381_G1_multiScalarMulDenotation = BLS12_381.G1.multiScalarMul + {-# INLINE bls12_381_G1_multiScalarMulDenotation #-} + in makeBuiltinMeaning + bls12_381_G1_multiScalarMulDenotation + (runCostingFunTwoArguments . paramBls12_381_G1_multiScalarMul) + toBuiltinMeaning _semvar Bls12_381_G2_multiScalarMul = + let bls12_381_G2_multiScalarMulDenotation :: + [Integer] -> [BLS12_381.G2.Element] -> BLS12_381.G2.Element + bls12_381_G2_multiScalarMulDenotation = BLS12_381.G2.multiScalarMul + {-# INLINE bls12_381_G2_multiScalarMulDenotation #-} + in makeBuiltinMeaning + bls12_381_G2_multiScalarMulDenotation + (runCostingFunTwoArguments . paramBls12_381_G2_multiScalarMul) + toBuiltinMeaning _semvar InsertCoin = + let insertCoinDenotation :: ByteString -> ByteString -> Integer -> Value -> BuiltinResult Value + insertCoinDenotation = Value.insertCoin + {-# INLINE insertCoinDenotation #-} + in makeBuiltinMeaning + insertCoinDenotation + (runCostingFunFourArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar LookupCoin = + let lookupCoinDenotation :: ByteString -> ByteString -> Value -> Integer + lookupCoinDenotation = Value.lookupCoin + {-# INLINE lookupCoinDenotation #-} + in makeBuiltinMeaning + lookupCoinDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar UnionValue = + let unionValueDenotation :: Value -> Value -> BuiltinResult Value + unionValueDenotation = Value.unionValue + {-# INLINE unionValueDenotation #-} + in makeBuiltinMeaning + unionValueDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar ValueContains = + let valueContainsDenotation :: Value -> Value -> BuiltinResult Bool + valueContainsDenotation = Value.valueContains + {-# INLINE valueContainsDenotation #-} + in makeBuiltinMeaning + valueContainsDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar ValueData = + let valueDataDenotation :: Value -> Data + valueDataDenotation = Value.valueData + {-# INLINE valueDataDenotation #-} + in makeBuiltinMeaning + valueDataDenotation + (runCostingFunOneArgument . unimplementedCostingFun) + toBuiltinMeaning _semvar UnValueData = + let unValueDataDenotation :: Data -> BuiltinResult Value + unValueDataDenotation = Value.unValueData + {-# INLINE unValueDataDenotation #-} + in makeBuiltinMeaning + unValueDataDenotation + (runCostingFunOneArgument . unimplementedCostingFun) + toBuiltinMeaning _semvar ScaleValue = + let unValueDataDenotation :: Integer -> Value -> BuiltinResult Value + unValueDataDenotation = Value.scaleValue + {-# INLINE unValueDataDenotation #-} + in makeBuiltinMeaning + unValueDataDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + -- See Note [Inlining meanings of builtins]. + {-# INLINE toBuiltinMeaning #-} + +-- \*** IMPORTANT! *** When you're adding a new builtin above you typically won't +-- be able to add a sensible costing function until the implementation is +-- complete and you can benchmark it. It's still necessary to supply +-- `toBuiltinMeaning` with some costing function though: this **MUST** be +-- `unimplementedCostingFun`: this will assign a very large cost to any +-- invocation of the function, preventing it from being used in places where +-- costs are important (for example on testnets) until the implementation is +-- complete and a proper costing function has been defined. Once the +-- builtin is ready for general use replace `unimplementedCostingFun` with +-- the appropriate `param` from BuiltinCostModelBase. +-- +-- Please leave this comment immediately after the definition of the final +-- builtin to maximise the chances of it being seen the next time someone +-- implements a new builtin. +-- instance Default (BuiltinSemanticsVariant DefaultFun) where - def = maxBound + def = maxBound instance Pretty (BuiltinSemanticsVariant DefaultFun) where - pretty = viaShow + pretty = viaShow -- It's set deliberately to give us "extra room" in the binary format to add things without running -- out of space for tags (expanding the space would change the binary format for people who're -- implementing it manually). So we have to set it manually. + -- | Using 7 bits to encode builtin tags. builtinTagWidth :: NumBits builtinTagWidth = 7 @@ -2143,230 +2050,216 @@ decodeBuiltin = dBEBits8 builtinTagWidth -- See Note [Stable encoding of TPLC] instance Flat DefaultFun where - encode = encodeBuiltin . \case - AddInteger -> 0 - SubtractInteger -> 1 - MultiplyInteger -> 2 - DivideInteger -> 3 - QuotientInteger -> 4 - RemainderInteger -> 5 - ModInteger -> 6 - EqualsInteger -> 7 - LessThanInteger -> 8 - LessThanEqualsInteger -> 9 - - AppendByteString -> 10 - ConsByteString -> 11 - SliceByteString -> 12 - LengthOfByteString -> 13 - IndexByteString -> 14 - EqualsByteString -> 15 - LessThanByteString -> 16 - LessThanEqualsByteString -> 17 - - Sha2_256 -> 18 - Sha3_256 -> 19 - Blake2b_256 -> 20 - VerifyEd25519Signature -> 21 - - AppendString -> 22 - EqualsString -> 23 - EncodeUtf8 -> 24 - DecodeUtf8 -> 25 - - IfThenElse -> 26 - - ChooseUnit -> 27 - - Trace -> 28 - - FstPair -> 29 - SndPair -> 30 - - ChooseList -> 31 - MkCons -> 32 - HeadList -> 33 - TailList -> 34 - NullList -> 35 - - ChooseData -> 36 - ConstrData -> 37 - MapData -> 38 - ListData -> 39 - IData -> 40 - BData -> 41 - UnConstrData -> 42 - UnMapData -> 43 - UnListData -> 44 - UnIData -> 45 - UnBData -> 46 - EqualsData -> 47 - MkPairData -> 48 - MkNilData -> 49 - MkNilPairData -> 50 - SerialiseData -> 51 - VerifyEcdsaSecp256k1Signature -> 52 - VerifySchnorrSecp256k1Signature -> 53 - Bls12_381_G1_add -> 54 - Bls12_381_G1_neg -> 55 - Bls12_381_G1_scalarMul -> 56 - Bls12_381_G1_equal -> 57 - Bls12_381_G1_compress -> 58 - Bls12_381_G1_uncompress -> 59 - Bls12_381_G1_hashToGroup -> 60 - Bls12_381_G2_add -> 61 - Bls12_381_G2_neg -> 62 - Bls12_381_G2_scalarMul -> 63 - Bls12_381_G2_equal -> 64 - Bls12_381_G2_compress -> 65 - Bls12_381_G2_uncompress -> 66 - Bls12_381_G2_hashToGroup -> 67 - Bls12_381_millerLoop -> 68 - Bls12_381_mulMlResult -> 69 - Bls12_381_finalVerify -> 70 - Keccak_256 -> 71 - Blake2b_224 -> 72 - - IntegerToByteString -> 73 - ByteStringToInteger -> 74 - AndByteString -> 75 - OrByteString -> 76 - XorByteString -> 77 - ComplementByteString -> 78 - ReadBit -> 79 - WriteBits -> 80 - ReplicateByte -> 81 - - ShiftByteString -> 82 - RotateByteString -> 83 - CountSetBits -> 84 - FindFirstSetBit -> 85 - Ripemd_160 -> 86 - - ExpModInteger -> 87 - - DropList -> 88 - - LengthOfArray -> 89 - ListToArray -> 90 - IndexArray -> 91 - - Bls12_381_G1_multiScalarMul -> 92 - Bls12_381_G2_multiScalarMul -> 93 - - InsertCoin -> 94 - LookupCoin -> 95 - UnionValue -> 96 - ValueContains -> 97 - ValueData -> 98 - UnValueData -> 99 - ScaleValue -> 100 - - decode = go =<< decodeBuiltin - where go 0 = pure AddInteger - go 1 = pure SubtractInteger - go 2 = pure MultiplyInteger - go 3 = pure DivideInteger - go 4 = pure QuotientInteger - go 5 = pure RemainderInteger - go 6 = pure ModInteger - go 7 = pure EqualsInteger - go 8 = pure LessThanInteger - go 9 = pure LessThanEqualsInteger - go 10 = pure AppendByteString - go 11 = pure ConsByteString - go 12 = pure SliceByteString - go 13 = pure LengthOfByteString - go 14 = pure IndexByteString - go 15 = pure EqualsByteString - go 16 = pure LessThanByteString - go 17 = pure LessThanEqualsByteString - go 18 = pure Sha2_256 - go 19 = pure Sha3_256 - go 20 = pure Blake2b_256 - go 21 = pure VerifyEd25519Signature - go 22 = pure AppendString - go 23 = pure EqualsString - go 24 = pure EncodeUtf8 - go 25 = pure DecodeUtf8 - go 26 = pure IfThenElse - go 27 = pure ChooseUnit - go 28 = pure Trace - go 29 = pure FstPair - go 30 = pure SndPair - go 31 = pure ChooseList - go 32 = pure MkCons - go 33 = pure HeadList - go 34 = pure TailList - go 35 = pure NullList - go 36 = pure ChooseData - go 37 = pure ConstrData - go 38 = pure MapData - go 39 = pure ListData - go 40 = pure IData - go 41 = pure BData - go 42 = pure UnConstrData - go 43 = pure UnMapData - go 44 = pure UnListData - go 45 = pure UnIData - go 46 = pure UnBData - go 47 = pure EqualsData - go 48 = pure MkPairData - go 49 = pure MkNilData - go 50 = pure MkNilPairData - go 51 = pure SerialiseData - go 52 = pure VerifyEcdsaSecp256k1Signature - go 53 = pure VerifySchnorrSecp256k1Signature - go 54 = pure Bls12_381_G1_add - go 55 = pure Bls12_381_G1_neg - go 56 = pure Bls12_381_G1_scalarMul - go 57 = pure Bls12_381_G1_equal - go 58 = pure Bls12_381_G1_compress - go 59 = pure Bls12_381_G1_uncompress - go 60 = pure Bls12_381_G1_hashToGroup - go 61 = pure Bls12_381_G2_add - go 62 = pure Bls12_381_G2_neg - go 63 = pure Bls12_381_G2_scalarMul - go 64 = pure Bls12_381_G2_equal - go 65 = pure Bls12_381_G2_compress - go 66 = pure Bls12_381_G2_uncompress - go 67 = pure Bls12_381_G2_hashToGroup - go 68 = pure Bls12_381_millerLoop - go 69 = pure Bls12_381_mulMlResult - go 70 = pure Bls12_381_finalVerify - go 71 = pure Keccak_256 - go 72 = pure Blake2b_224 - go 73 = pure IntegerToByteString - go 74 = pure ByteStringToInteger - go 75 = pure AndByteString - go 76 = pure OrByteString - go 77 = pure XorByteString - go 78 = pure ComplementByteString - go 79 = pure ReadBit - go 80 = pure WriteBits - go 81 = pure ReplicateByte - go 82 = pure ShiftByteString - go 83 = pure RotateByteString - go 84 = pure CountSetBits - go 85 = pure FindFirstSetBit - go 86 = pure Ripemd_160 - go 87 = pure ExpModInteger - go 88 = pure DropList - go 89 = pure LengthOfArray - go 90 = pure ListToArray - go 91 = pure IndexArray - go 92 = pure Bls12_381_G1_multiScalarMul - go 93 = pure Bls12_381_G2_multiScalarMul - go 94 = pure InsertCoin - go 95 = pure LookupCoin - go 96 = pure UnionValue - go 97 = pure ValueContains - go 98 = pure ValueData - go 99 = pure UnValueData - go 100 = pure ScaleValue - go t = fail $ "Failed to decode builtin tag, got: " ++ show t - - size _ n = n + builtinTagWidth + encode = + encodeBuiltin . \case + AddInteger -> 0 + SubtractInteger -> 1 + MultiplyInteger -> 2 + DivideInteger -> 3 + QuotientInteger -> 4 + RemainderInteger -> 5 + ModInteger -> 6 + EqualsInteger -> 7 + LessThanInteger -> 8 + LessThanEqualsInteger -> 9 + AppendByteString -> 10 + ConsByteString -> 11 + SliceByteString -> 12 + LengthOfByteString -> 13 + IndexByteString -> 14 + EqualsByteString -> 15 + LessThanByteString -> 16 + LessThanEqualsByteString -> 17 + Sha2_256 -> 18 + Sha3_256 -> 19 + Blake2b_256 -> 20 + VerifyEd25519Signature -> 21 + AppendString -> 22 + EqualsString -> 23 + EncodeUtf8 -> 24 + DecodeUtf8 -> 25 + IfThenElse -> 26 + ChooseUnit -> 27 + Trace -> 28 + FstPair -> 29 + SndPair -> 30 + ChooseList -> 31 + MkCons -> 32 + HeadList -> 33 + TailList -> 34 + NullList -> 35 + ChooseData -> 36 + ConstrData -> 37 + MapData -> 38 + ListData -> 39 + IData -> 40 + BData -> 41 + UnConstrData -> 42 + UnMapData -> 43 + UnListData -> 44 + UnIData -> 45 + UnBData -> 46 + EqualsData -> 47 + MkPairData -> 48 + MkNilData -> 49 + MkNilPairData -> 50 + SerialiseData -> 51 + VerifyEcdsaSecp256k1Signature -> 52 + VerifySchnorrSecp256k1Signature -> 53 + Bls12_381_G1_add -> 54 + Bls12_381_G1_neg -> 55 + Bls12_381_G1_scalarMul -> 56 + Bls12_381_G1_equal -> 57 + Bls12_381_G1_compress -> 58 + Bls12_381_G1_uncompress -> 59 + Bls12_381_G1_hashToGroup -> 60 + Bls12_381_G2_add -> 61 + Bls12_381_G2_neg -> 62 + Bls12_381_G2_scalarMul -> 63 + Bls12_381_G2_equal -> 64 + Bls12_381_G2_compress -> 65 + Bls12_381_G2_uncompress -> 66 + Bls12_381_G2_hashToGroup -> 67 + Bls12_381_millerLoop -> 68 + Bls12_381_mulMlResult -> 69 + Bls12_381_finalVerify -> 70 + Keccak_256 -> 71 + Blake2b_224 -> 72 + IntegerToByteString -> 73 + ByteStringToInteger -> 74 + AndByteString -> 75 + OrByteString -> 76 + XorByteString -> 77 + ComplementByteString -> 78 + ReadBit -> 79 + WriteBits -> 80 + ReplicateByte -> 81 + ShiftByteString -> 82 + RotateByteString -> 83 + CountSetBits -> 84 + FindFirstSetBit -> 85 + Ripemd_160 -> 86 + ExpModInteger -> 87 + DropList -> 88 + LengthOfArray -> 89 + ListToArray -> 90 + IndexArray -> 91 + Bls12_381_G1_multiScalarMul -> 92 + Bls12_381_G2_multiScalarMul -> 93 + InsertCoin -> 94 + LookupCoin -> 95 + UnionValue -> 96 + ValueContains -> 97 + ValueData -> 98 + UnValueData -> 99 + ScaleValue -> 100 + + decode = go =<< decodeBuiltin + where + go 0 = pure AddInteger + go 1 = pure SubtractInteger + go 2 = pure MultiplyInteger + go 3 = pure DivideInteger + go 4 = pure QuotientInteger + go 5 = pure RemainderInteger + go 6 = pure ModInteger + go 7 = pure EqualsInteger + go 8 = pure LessThanInteger + go 9 = pure LessThanEqualsInteger + go 10 = pure AppendByteString + go 11 = pure ConsByteString + go 12 = pure SliceByteString + go 13 = pure LengthOfByteString + go 14 = pure IndexByteString + go 15 = pure EqualsByteString + go 16 = pure LessThanByteString + go 17 = pure LessThanEqualsByteString + go 18 = pure Sha2_256 + go 19 = pure Sha3_256 + go 20 = pure Blake2b_256 + go 21 = pure VerifyEd25519Signature + go 22 = pure AppendString + go 23 = pure EqualsString + go 24 = pure EncodeUtf8 + go 25 = pure DecodeUtf8 + go 26 = pure IfThenElse + go 27 = pure ChooseUnit + go 28 = pure Trace + go 29 = pure FstPair + go 30 = pure SndPair + go 31 = pure ChooseList + go 32 = pure MkCons + go 33 = pure HeadList + go 34 = pure TailList + go 35 = pure NullList + go 36 = pure ChooseData + go 37 = pure ConstrData + go 38 = pure MapData + go 39 = pure ListData + go 40 = pure IData + go 41 = pure BData + go 42 = pure UnConstrData + go 43 = pure UnMapData + go 44 = pure UnListData + go 45 = pure UnIData + go 46 = pure UnBData + go 47 = pure EqualsData + go 48 = pure MkPairData + go 49 = pure MkNilData + go 50 = pure MkNilPairData + go 51 = pure SerialiseData + go 52 = pure VerifyEcdsaSecp256k1Signature + go 53 = pure VerifySchnorrSecp256k1Signature + go 54 = pure Bls12_381_G1_add + go 55 = pure Bls12_381_G1_neg + go 56 = pure Bls12_381_G1_scalarMul + go 57 = pure Bls12_381_G1_equal + go 58 = pure Bls12_381_G1_compress + go 59 = pure Bls12_381_G1_uncompress + go 60 = pure Bls12_381_G1_hashToGroup + go 61 = pure Bls12_381_G2_add + go 62 = pure Bls12_381_G2_neg + go 63 = pure Bls12_381_G2_scalarMul + go 64 = pure Bls12_381_G2_equal + go 65 = pure Bls12_381_G2_compress + go 66 = pure Bls12_381_G2_uncompress + go 67 = pure Bls12_381_G2_hashToGroup + go 68 = pure Bls12_381_millerLoop + go 69 = pure Bls12_381_mulMlResult + go 70 = pure Bls12_381_finalVerify + go 71 = pure Keccak_256 + go 72 = pure Blake2b_224 + go 73 = pure IntegerToByteString + go 74 = pure ByteStringToInteger + go 75 = pure AndByteString + go 76 = pure OrByteString + go 77 = pure XorByteString + go 78 = pure ComplementByteString + go 79 = pure ReadBit + go 80 = pure WriteBits + go 81 = pure ReplicateByte + go 82 = pure ShiftByteString + go 83 = pure RotateByteString + go 84 = pure CountSetBits + go 85 = pure FindFirstSetBit + go 86 = pure Ripemd_160 + go 87 = pure ExpModInteger + go 88 = pure DropList + go 89 = pure LengthOfArray + go 90 = pure ListToArray + go 91 = pure IndexArray + go 92 = pure Bls12_381_G1_multiScalarMul + go 93 = pure Bls12_381_G2_multiScalarMul + go 94 = pure InsertCoin + go 95 = pure LookupCoin + go 96 = pure UnionValue + go 97 = pure ValueContains + go 98 = pure ValueData + go 99 = pure UnValueData + go 100 = pure ScaleValue + go t = fail $ "Failed to decode builtin tag, got: " ++ show t + + size _ n = n + builtinTagWidth {- Note [Legacy pattern matching on built-in types] We used to only support direct pattern matching on enumeration types: 'Void', 'Unit', 'Bool' diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs index ba3615787f7..64a553d01d2 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs @@ -5,28 +5,27 @@ -- are redundant (which they are), but we don't care because it only exists -- to test that some constraints are solvable {-# OPTIONS -Wno-redundant-constraints #-} - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} #include "MachDeps.h" -- effectfully: to the best of my experimentation, -O2 here improves @@ -34,14 +33,14 @@ {-# OPTIONS_GHC -O2 #-} -- | The universe used by default and its instances. -module PlutusCore.Default.Universe - ( DefaultUni (..) - , pattern DefaultUniList - , pattern DefaultUniArray - , pattern DefaultUniPair - , noMoreTypeFunctions - , module Export -- Re-exporting universes infrastructure for convenience. - ) where +module PlutusCore.Default.Universe ( + DefaultUni (..), + pattern DefaultUniList, + pattern DefaultUniArray, + pattern DefaultUniPair, + noMoreTypeFunctions, + module Export, -- Re-exporting universes infrastructure for convenience. +) where import PlutusPrelude @@ -51,8 +50,10 @@ import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing import PlutusCore.Data (Data) -import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally (..), - NumBytesCostedAsNumWords (..)) +import PlutusCore.Evaluation.Machine.ExMemoryUsage ( + IntegerCostedLiterally (..), + NumBytesCostedAsNumWords (..), + ) import PlutusCore.Pretty.Extra (juxtRenderContext) import PlutusCore.Value (Value) @@ -105,324 +106,366 @@ feature and have meta-constructors as built-in functions. -} -- See Note [Representing polymorphism]. + -- | The universe used by default. data DefaultUni a where - DefaultUniInteger :: DefaultUni (Esc Integer) - DefaultUniByteString :: DefaultUni (Esc ByteString) - DefaultUniString :: DefaultUni (Esc Text) - DefaultUniUnit :: DefaultUni (Esc ()) - DefaultUniBool :: DefaultUni (Esc Bool) - DefaultUniProtoArray :: DefaultUni (Esc Strict.Vector) - DefaultUniProtoList :: DefaultUni (Esc []) - DefaultUniProtoPair :: DefaultUni (Esc (,)) - DefaultUniApply :: !(DefaultUni (Esc f)) -> !(DefaultUni (Esc a)) -> DefaultUni (Esc (f a)) - DefaultUniData :: DefaultUni (Esc Data) - DefaultUniBLS12_381_G1_Element :: DefaultUni (Esc BLS12_381.G1.Element) - DefaultUniBLS12_381_G2_Element :: DefaultUni (Esc BLS12_381.G2.Element) - DefaultUniBLS12_381_MlResult :: DefaultUni (Esc BLS12_381.Pairing.MlResult) - DefaultUniValue :: DefaultUni (Esc Value) + DefaultUniInteger :: DefaultUni (Esc Integer) + DefaultUniByteString :: DefaultUni (Esc ByteString) + DefaultUniString :: DefaultUni (Esc Text) + DefaultUniUnit :: DefaultUni (Esc ()) + DefaultUniBool :: DefaultUni (Esc Bool) + DefaultUniProtoArray :: DefaultUni (Esc Strict.Vector) + DefaultUniProtoList :: DefaultUni (Esc []) + DefaultUniProtoPair :: DefaultUni (Esc (,)) + DefaultUniApply :: !(DefaultUni (Esc f)) -> !(DefaultUni (Esc a)) -> DefaultUni (Esc (f a)) + DefaultUniData :: DefaultUni (Esc Data) + DefaultUniBLS12_381_G1_Element :: DefaultUni (Esc BLS12_381.G1.Element) + DefaultUniBLS12_381_G2_Element :: DefaultUni (Esc BLS12_381.G2.Element) + DefaultUniBLS12_381_MlResult :: DefaultUni (Esc BLS12_381.Pairing.MlResult) + DefaultUniValue :: DefaultUni (Esc Value) -- GHC infers crazy types for these two and the straightforward ones break pattern matching, -- so we just leave GHC with its craziness. pattern DefaultUniList uniA = - DefaultUniProtoList `DefaultUniApply` uniA + DefaultUniProtoList `DefaultUniApply` uniA pattern DefaultUniArray uniA = - DefaultUniProtoArray `DefaultUniApply` uniA + DefaultUniProtoArray `DefaultUniApply` uniA pattern DefaultUniPair uniA uniB = - DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB + DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB -- Removing 'LoopBreaker' didn't change anything at the time this comment was written, but we kept -- it, because it hopefully provides some additional assurance that 'geqL' will not get elaborated -- as a recursive definition. instance AllBuiltinArgs DefaultUni (GEqL DefaultUni) a => GEqL DefaultUni a where - geqL DefaultUniInteger a2 = do + geqL DefaultUniInteger a2 = do + DefaultUniInteger <- pure a2 + pure Refl + geqL DefaultUniByteString a2 = do + DefaultUniByteString <- pure a2 + pure Refl + geqL DefaultUniString a2 = do + DefaultUniString <- pure a2 + pure Refl + geqL DefaultUniUnit a2 = do + DefaultUniUnit <- pure a2 + pure Refl + geqL DefaultUniBool a2 = do + DefaultUniBool <- pure a2 + pure Refl + geqL (DefaultUniProtoList `DefaultUniApply` a1) listA2 = do + DefaultUniProtoList `DefaultUniApply` a2 <- pure listA2 + Refl <- geqL (LoopBreaker a1) (LoopBreaker a2) + pure Refl + geqL (DefaultUniProtoArray `DefaultUniApply` a1) arrayA2 = do + DefaultUniProtoArray `DefaultUniApply` a2 <- pure arrayA2 + Refl <- geqL (LoopBreaker a1) (LoopBreaker a2) + pure Refl + geqL (DefaultUniProtoPair `DefaultUniApply` a1 `DefaultUniApply` b1) pairA2 = do + DefaultUniProtoPair `DefaultUniApply` a2 `DefaultUniApply` b2 <- pure pairA2 + Refl <- geqL (LoopBreaker a1) (LoopBreaker a2) + Refl <- geqL (LoopBreaker b1) (LoopBreaker b2) + pure Refl + geqL (f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _) _ = + noMoreTypeFunctions f + geqL DefaultUniData a2 = do + DefaultUniData <- pure a2 + pure Refl + geqL DefaultUniBLS12_381_G1_Element a2 = do + DefaultUniBLS12_381_G1_Element <- pure a2 + pure Refl + geqL DefaultUniBLS12_381_G2_Element a2 = do + DefaultUniBLS12_381_G2_Element <- pure a2 + pure Refl + geqL DefaultUniBLS12_381_MlResult a2 = do + DefaultUniBLS12_381_MlResult <- pure a2 + pure Refl + geqL DefaultUniValue a2 = do + DefaultUniValue <- pure a2 + pure Refl + {-# INLINE geqL #-} + +instance GEq DefaultUni where + -- We define 'geq' manually instead of using 'deriveGEq', because the latter creates a single + -- recursive definition and we want two instead. The reason why we want two is because this + -- allows GHC to inline the initial step that appears non-recursive to GHC, because recursion + -- is hidden in the other function that is marked as @OPAQUE@ and is chosen by GHC as a + -- loop-breaker, see https://wiki.haskell.org/Inlining_and_Specialisation#What_is_a_loop-breaker + -- (we're not really sure if this is a reliable solution, but if it stops working, we won't miss + -- very much and we've failed to settle on any other approach). + -- + -- On the critical path this definition should only be used for builtins that perform equality + -- checking of statically unknown runtime type tags ('MkCons' is one such builtin for + -- example). All other builtins should use 'geqL' (the latter is internal to 'readKnownConstant' + -- and is therefore hidden from the person adding a new builtin). + -- + -- We use @NOINLINE@ instead of @OPAQUE@, because we don't actually care about the recursive + -- definition not being inlined, we just want it to be chosen as the loop breaker. + geq = goStep + where + goStep, goRec :: DefaultUni a1 -> DefaultUni a2 -> Maybe (a1 :~: a2) + goStep DefaultUniInteger a2 = do DefaultUniInteger <- pure a2 pure Refl - geqL DefaultUniByteString a2 = do + goStep DefaultUniByteString a2 = do DefaultUniByteString <- pure a2 pure Refl - geqL DefaultUniString a2 = do + goStep DefaultUniString a2 = do DefaultUniString <- pure a2 pure Refl - geqL DefaultUniUnit a2 = do + goStep DefaultUniUnit a2 = do DefaultUniUnit <- pure a2 pure Refl - geqL DefaultUniBool a2 = do + goStep DefaultUniBool a2 = do DefaultUniBool <- pure a2 pure Refl - geqL (DefaultUniProtoList `DefaultUniApply` a1) listA2 = do - DefaultUniProtoList `DefaultUniApply` a2 <- pure listA2 - Refl <- geqL (LoopBreaker a1) (LoopBreaker a2) + goStep DefaultUniProtoList a2 = do + DefaultUniProtoList <- pure a2 + pure Refl + goStep DefaultUniProtoArray a2 = do + DefaultUniProtoArray <- pure a2 pure Refl - geqL (DefaultUniProtoArray `DefaultUniApply` a1) arrayA2 = do - DefaultUniProtoArray `DefaultUniApply` a2 <- pure arrayA2 - Refl <- geqL (LoopBreaker a1) (LoopBreaker a2) + goStep DefaultUniProtoPair a2 = do + DefaultUniProtoPair <- pure a2 pure Refl - geqL (DefaultUniProtoPair `DefaultUniApply` a1 `DefaultUniApply` b1) pairA2 = do - DefaultUniProtoPair `DefaultUniApply` a2 `DefaultUniApply` b2 <- pure pairA2 - Refl <- geqL (LoopBreaker a1) (LoopBreaker a2) - Refl <- geqL (LoopBreaker b1) (LoopBreaker b2) + goStep (DefaultUniApply f1 x1) a2 = do + DefaultUniApply f2 x2 <- pure a2 + Refl <- goRec f1 f2 + Refl <- goRec x1 x2 pure Refl - geqL (f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _) _ = - noMoreTypeFunctions f - geqL DefaultUniData a2 = do + goStep DefaultUniData a2 = do DefaultUniData <- pure a2 pure Refl - geqL DefaultUniBLS12_381_G1_Element a2 = do + goStep DefaultUniBLS12_381_G1_Element a2 = do DefaultUniBLS12_381_G1_Element <- pure a2 pure Refl - geqL DefaultUniBLS12_381_G2_Element a2 = do + goStep DefaultUniBLS12_381_G2_Element a2 = do DefaultUniBLS12_381_G2_Element <- pure a2 pure Refl - geqL DefaultUniBLS12_381_MlResult a2 = do + goStep DefaultUniBLS12_381_MlResult a2 = do DefaultUniBLS12_381_MlResult <- pure a2 pure Refl - geqL DefaultUniValue a2 = do + goStep DefaultUniValue a2 = do DefaultUniValue <- pure a2 pure Refl - {-# INLINE geqL #-} + {-# INLINE goStep #-} -instance GEq DefaultUni where - -- We define 'geq' manually instead of using 'deriveGEq', because the latter creates a single - -- recursive definition and we want two instead. The reason why we want two is because this - -- allows GHC to inline the initial step that appears non-recursive to GHC, because recursion - -- is hidden in the other function that is marked as @OPAQUE@ and is chosen by GHC as a - -- loop-breaker, see https://wiki.haskell.org/Inlining_and_Specialisation#What_is_a_loop-breaker - -- (we're not really sure if this is a reliable solution, but if it stops working, we won't miss - -- very much and we've failed to settle on any other approach). - -- - -- On the critical path this definition should only be used for builtins that perform equality - -- checking of statically unknown runtime type tags ('MkCons' is one such builtin for - -- example). All other builtins should use 'geqL' (the latter is internal to 'readKnownConstant' - -- and is therefore hidden from the person adding a new builtin). - -- - -- We use @NOINLINE@ instead of @OPAQUE@, because we don't actually care about the recursive - -- definition not being inlined, we just want it to be chosen as the loop breaker. - geq = goStep where - goStep, goRec :: DefaultUni a1 -> DefaultUni a2 -> Maybe (a1 :~: a2) - goStep DefaultUniInteger a2 = do - DefaultUniInteger <- pure a2 - pure Refl - goStep DefaultUniByteString a2 = do - DefaultUniByteString <- pure a2 - pure Refl - goStep DefaultUniString a2 = do - DefaultUniString <- pure a2 - pure Refl - goStep DefaultUniUnit a2 = do - DefaultUniUnit <- pure a2 - pure Refl - goStep DefaultUniBool a2 = do - DefaultUniBool <- pure a2 - pure Refl - goStep DefaultUniProtoList a2 = do - DefaultUniProtoList <- pure a2 - pure Refl - goStep DefaultUniProtoArray a2 = do - DefaultUniProtoArray <- pure a2 - pure Refl - goStep DefaultUniProtoPair a2 = do - DefaultUniProtoPair <- pure a2 - pure Refl - goStep (DefaultUniApply f1 x1) a2 = do - DefaultUniApply f2 x2 <- pure a2 - Refl <- goRec f1 f2 - Refl <- goRec x1 x2 - pure Refl - goStep DefaultUniData a2 = do - DefaultUniData <- pure a2 - pure Refl - goStep DefaultUniBLS12_381_G1_Element a2 = do - DefaultUniBLS12_381_G1_Element <- pure a2 - pure Refl - goStep DefaultUniBLS12_381_G2_Element a2 = do - DefaultUniBLS12_381_G2_Element <- pure a2 - pure Refl - goStep DefaultUniBLS12_381_MlResult a2 = do - DefaultUniBLS12_381_MlResult <- pure a2 - pure Refl - goStep DefaultUniValue a2 = do - DefaultUniValue <- pure a2 - pure Refl - {-# INLINE goStep #-} - - goRec = goStep - {-# NOINLINE goRec #-} + goRec = goStep + {-# NOINLINE goRec #-} -- | For pleasing the coverage checker. noMoreTypeFunctions :: DefaultUni (Esc (f :: a -> b -> c -> d)) -> any noMoreTypeFunctions (f `DefaultUniApply` _) = noMoreTypeFunctions f instance ToKind DefaultUni where - toSingKind DefaultUniInteger = knownKind - toSingKind DefaultUniByteString = knownKind - toSingKind DefaultUniString = knownKind - toSingKind DefaultUniUnit = knownKind - toSingKind DefaultUniBool = knownKind - toSingKind DefaultUniProtoList = knownKind - toSingKind DefaultUniProtoArray = knownKind - toSingKind DefaultUniProtoPair = knownKind - toSingKind (DefaultUniApply uniF _) = case toSingKind uniF of _ `SingKindArrow` cod -> cod - toSingKind DefaultUniData = knownKind - toSingKind DefaultUniBLS12_381_G1_Element = knownKind - toSingKind DefaultUniBLS12_381_G2_Element = knownKind - toSingKind DefaultUniBLS12_381_MlResult = knownKind - toSingKind DefaultUniValue = knownKind + toSingKind DefaultUniInteger = knownKind + toSingKind DefaultUniByteString = knownKind + toSingKind DefaultUniString = knownKind + toSingKind DefaultUniUnit = knownKind + toSingKind DefaultUniBool = knownKind + toSingKind DefaultUniProtoList = knownKind + toSingKind DefaultUniProtoArray = knownKind + toSingKind DefaultUniProtoPair = knownKind + toSingKind (DefaultUniApply uniF _) = case toSingKind uniF of _ `SingKindArrow` cod -> cod + toSingKind DefaultUniData = knownKind + toSingKind DefaultUniBLS12_381_G1_Element = knownKind + toSingKind DefaultUniBLS12_381_G2_Element = knownKind + toSingKind DefaultUniBLS12_381_MlResult = knownKind + toSingKind DefaultUniValue = knownKind instance HasUniApply DefaultUni where - uniApply = DefaultUniApply + uniApply = DefaultUniApply - matchUniApply (DefaultUniApply f a) _ h = h f a - matchUniApply _ z _ = z + matchUniApply (DefaultUniApply f a) _ h = h f a + matchUniApply _ z _ = z deriving stock instance Show (DefaultUni a) instance GShow DefaultUni where gshowsPrec = showsPrec instance PrettyBy RenderContext (DefaultUni a) where - prettyBy = inContextM $ \case - DefaultUniInteger -> "integer" - DefaultUniByteString -> "bytestring" - DefaultUniString -> "string" - DefaultUniUnit -> "unit" - DefaultUniBool -> "bool" - DefaultUniProtoList -> "list" - DefaultUniProtoArray -> "array" - DefaultUniProtoPair -> "pair" - DefaultUniApply uniF uniA -> uniF `juxtPrettyM` uniA - DefaultUniData -> "data" - DefaultUniBLS12_381_G1_Element -> "bls12_381_G1_element" - DefaultUniBLS12_381_G2_Element -> "bls12_381_G2_element" - DefaultUniBLS12_381_MlResult -> "bls12_381_mlresult" - DefaultUniValue -> "value" + prettyBy = inContextM $ \case + DefaultUniInteger -> "integer" + DefaultUniByteString -> "bytestring" + DefaultUniString -> "string" + DefaultUniUnit -> "unit" + DefaultUniBool -> "bool" + DefaultUniProtoList -> "list" + DefaultUniProtoArray -> "array" + DefaultUniProtoPair -> "pair" + DefaultUniApply uniF uniA -> uniF `juxtPrettyM` uniA + DefaultUniData -> "data" + DefaultUniBLS12_381_G1_Element -> "bls12_381_G1_element" + DefaultUniBLS12_381_G2_Element -> "bls12_381_G2_element" + DefaultUniBLS12_381_MlResult -> "bls12_381_mlresult" + DefaultUniValue -> "value" instance PrettyBy RenderContext (SomeTypeIn DefaultUni) where - prettyBy config (SomeTypeIn uni) = prettyBy config uni + prettyBy config (SomeTypeIn uni) = prettyBy config uni -- | This always pretty-prints parens around type applications (e.g. @(list bool)@) and -- doesn't pretty-print them otherwise (e.g. @integer@). instance Pretty (DefaultUni a) where - pretty = prettyBy juxtRenderContext + pretty = prettyBy juxtRenderContext + instance Pretty (SomeTypeIn DefaultUni) where - pretty (SomeTypeIn uni) = pretty uni + pretty (SomeTypeIn uni) = pretty uni -- | Elaborate a built-in type (see 'ElaborateBuiltin') from 'DefaultUni'. type ElaborateBuiltinDefaultUni :: forall a. a -> a type family ElaborateBuiltinDefaultUni x where - ElaborateBuiltinDefaultUni (f x) = ElaborateBuiltinDefaultUni f `TyAppRep` x - ElaborateBuiltinDefaultUni x = BuiltinHead x + ElaborateBuiltinDefaultUni (f x) = ElaborateBuiltinDefaultUni f `TyAppRep` x + ElaborateBuiltinDefaultUni x = BuiltinHead x type instance ElaborateBuiltin DefaultUni x = ElaborateBuiltinDefaultUni x instance (DefaultUni `Contains` f, DefaultUni `Contains` a) => DefaultUni `Contains` f a where - knownUni = knownUni `DefaultUniApply` knownUni + knownUni = knownUni `DefaultUniApply` knownUni instance DefaultUni `Contains` Integer where - knownUni = DefaultUniInteger + knownUni = DefaultUniInteger instance DefaultUni `Contains` ByteString where - knownUni = DefaultUniByteString + knownUni = DefaultUniByteString instance DefaultUni `Contains` Text where - knownUni = DefaultUniString + knownUni = DefaultUniString instance DefaultUni `Contains` () where - knownUni = DefaultUniUnit + knownUni = DefaultUniUnit instance DefaultUni `Contains` Bool where - knownUni = DefaultUniBool + knownUni = DefaultUniBool instance DefaultUni `Contains` Value where - knownUni = DefaultUniValue + knownUni = DefaultUniValue instance DefaultUni `Contains` [] where - knownUni = DefaultUniProtoList + knownUni = DefaultUniProtoList instance DefaultUni `Contains` Strict.Vector where - knownUni = DefaultUniProtoArray + knownUni = DefaultUniProtoArray instance DefaultUni `Contains` (,) where - knownUni = DefaultUniProtoPair + knownUni = DefaultUniProtoPair instance DefaultUni `Contains` Data where - knownUni = DefaultUniData + knownUni = DefaultUniData instance DefaultUni `Contains` BLS12_381.G1.Element where - knownUni = DefaultUniBLS12_381_G1_Element + knownUni = DefaultUniBLS12_381_G1_Element instance DefaultUni `Contains` BLS12_381.G2.Element where - knownUni = DefaultUniBLS12_381_G2_Element + knownUni = DefaultUniBLS12_381_G2_Element instance DefaultUni `Contains` BLS12_381.Pairing.MlResult where - knownUni = DefaultUniBLS12_381_MlResult - -instance KnownBuiltinTypeAst tyname DefaultUni Integer => - KnownTypeAst tyname DefaultUni Integer -instance KnownBuiltinTypeAst tyname DefaultUni ByteString => - KnownTypeAst tyname DefaultUni ByteString -instance KnownBuiltinTypeAst tyname DefaultUni Text => - KnownTypeAst tyname DefaultUni Text -instance KnownBuiltinTypeAst tyname DefaultUni () => - KnownTypeAst tyname DefaultUni () -instance KnownBuiltinTypeAst tyname DefaultUni Bool => - KnownTypeAst tyname DefaultUni Bool -instance KnownBuiltinTypeAst tyname DefaultUni [a] => - KnownTypeAst tyname DefaultUni [a] -instance KnownBuiltinTypeAst tyname DefaultUni (Strict.Vector a) => - KnownTypeAst tyname DefaultUni (Strict.Vector a) -instance KnownBuiltinTypeAst tyname DefaultUni (a, b) => - KnownTypeAst tyname DefaultUni (a, b) -instance KnownBuiltinTypeAst tyname DefaultUni Data => - KnownTypeAst tyname DefaultUni Data -instance KnownBuiltinTypeAst tyname DefaultUni BLS12_381.G1.Element => - KnownTypeAst tyname DefaultUni BLS12_381.G1.Element -instance KnownBuiltinTypeAst tyname DefaultUni BLS12_381.G2.Element => - KnownTypeAst tyname DefaultUni BLS12_381.G2.Element -instance KnownBuiltinTypeAst tyname DefaultUni BLS12_381.Pairing.MlResult => - KnownTypeAst tyname DefaultUni BLS12_381.Pairing.MlResult -instance KnownBuiltinTypeAst tyname DefaultUni Value => - KnownTypeAst tyname DefaultUni Value - -instance KnownBuiltinTypeIn DefaultUni term Integer => - ReadKnownIn DefaultUni term Integer -instance KnownBuiltinTypeIn DefaultUni term ByteString => - ReadKnownIn DefaultUni term ByteString -instance KnownBuiltinTypeIn DefaultUni term Text => - ReadKnownIn DefaultUni term Text -instance KnownBuiltinTypeIn DefaultUni term () => - ReadKnownIn DefaultUni term () -instance KnownBuiltinTypeIn DefaultUni term Bool => - ReadKnownIn DefaultUni term Bool -instance KnownBuiltinTypeIn DefaultUni term Data => - ReadKnownIn DefaultUni term Data -instance KnownBuiltinTypeIn DefaultUni term [a] => - ReadKnownIn DefaultUni term [a] -instance KnownBuiltinTypeIn DefaultUni term (Strict.Vector a) => - ReadKnownIn DefaultUni term (Strict.Vector a) -instance KnownBuiltinTypeIn DefaultUni term (a, b) => - ReadKnownIn DefaultUni term (a, b) -instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G1.Element => - ReadKnownIn DefaultUni term BLS12_381.G1.Element -instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G2.Element => - ReadKnownIn DefaultUni term BLS12_381.G2.Element -instance KnownBuiltinTypeIn DefaultUni term BLS12_381.Pairing.MlResult => - ReadKnownIn DefaultUni term BLS12_381.Pairing.MlResult -instance KnownBuiltinTypeIn DefaultUni term Value => - ReadKnownIn DefaultUni term Value - -instance KnownBuiltinTypeIn DefaultUni term Integer => - MakeKnownIn DefaultUni term Integer -instance KnownBuiltinTypeIn DefaultUni term ByteString => - MakeKnownIn DefaultUni term ByteString -instance KnownBuiltinTypeIn DefaultUni term Text => - MakeKnownIn DefaultUni term Text -instance KnownBuiltinTypeIn DefaultUni term () => - MakeKnownIn DefaultUni term () -instance KnownBuiltinTypeIn DefaultUni term Bool => - MakeKnownIn DefaultUni term Bool -instance KnownBuiltinTypeIn DefaultUni term Data => - MakeKnownIn DefaultUni term Data -instance KnownBuiltinTypeIn DefaultUni term [a] => - MakeKnownIn DefaultUni term [a] -instance KnownBuiltinTypeIn DefaultUni term (Strict.Vector a) => - MakeKnownIn DefaultUni term (Strict.Vector a) -instance KnownBuiltinTypeIn DefaultUni term (a, b) => - MakeKnownIn DefaultUni term (a, b) -instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G1.Element => - MakeKnownIn DefaultUni term BLS12_381.G1.Element -instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G2.Element => - MakeKnownIn DefaultUni term BLS12_381.G2.Element -instance KnownBuiltinTypeIn DefaultUni term BLS12_381.Pairing.MlResult => - MakeKnownIn DefaultUni term BLS12_381.Pairing.MlResult -instance KnownBuiltinTypeIn DefaultUni term Value => - MakeKnownIn DefaultUni term Value + knownUni = DefaultUniBLS12_381_MlResult + +instance + KnownBuiltinTypeAst tyname DefaultUni Integer => + KnownTypeAst tyname DefaultUni Integer +instance + KnownBuiltinTypeAst tyname DefaultUni ByteString => + KnownTypeAst tyname DefaultUni ByteString +instance + KnownBuiltinTypeAst tyname DefaultUni Text => + KnownTypeAst tyname DefaultUni Text +instance + KnownBuiltinTypeAst tyname DefaultUni () => + KnownTypeAst tyname DefaultUni () +instance + KnownBuiltinTypeAst tyname DefaultUni Bool => + KnownTypeAst tyname DefaultUni Bool +instance + KnownBuiltinTypeAst tyname DefaultUni [a] => + KnownTypeAst tyname DefaultUni [a] +instance + KnownBuiltinTypeAst tyname DefaultUni (Strict.Vector a) => + KnownTypeAst tyname DefaultUni (Strict.Vector a) +instance + KnownBuiltinTypeAst tyname DefaultUni (a, b) => + KnownTypeAst tyname DefaultUni (a, b) +instance + KnownBuiltinTypeAst tyname DefaultUni Data => + KnownTypeAst tyname DefaultUni Data +instance + KnownBuiltinTypeAst tyname DefaultUni BLS12_381.G1.Element => + KnownTypeAst tyname DefaultUni BLS12_381.G1.Element +instance + KnownBuiltinTypeAst tyname DefaultUni BLS12_381.G2.Element => + KnownTypeAst tyname DefaultUni BLS12_381.G2.Element +instance + KnownBuiltinTypeAst tyname DefaultUni BLS12_381.Pairing.MlResult => + KnownTypeAst tyname DefaultUni BLS12_381.Pairing.MlResult +instance + KnownBuiltinTypeAst tyname DefaultUni Value => + KnownTypeAst tyname DefaultUni Value + +instance + KnownBuiltinTypeIn DefaultUni term Integer => + ReadKnownIn DefaultUni term Integer +instance + KnownBuiltinTypeIn DefaultUni term ByteString => + ReadKnownIn DefaultUni term ByteString +instance + KnownBuiltinTypeIn DefaultUni term Text => + ReadKnownIn DefaultUni term Text +instance + KnownBuiltinTypeIn DefaultUni term () => + ReadKnownIn DefaultUni term () +instance + KnownBuiltinTypeIn DefaultUni term Bool => + ReadKnownIn DefaultUni term Bool +instance + KnownBuiltinTypeIn DefaultUni term Data => + ReadKnownIn DefaultUni term Data +instance + KnownBuiltinTypeIn DefaultUni term [a] => + ReadKnownIn DefaultUni term [a] +instance + KnownBuiltinTypeIn DefaultUni term (Strict.Vector a) => + ReadKnownIn DefaultUni term (Strict.Vector a) +instance + KnownBuiltinTypeIn DefaultUni term (a, b) => + ReadKnownIn DefaultUni term (a, b) +instance + KnownBuiltinTypeIn DefaultUni term BLS12_381.G1.Element => + ReadKnownIn DefaultUni term BLS12_381.G1.Element +instance + KnownBuiltinTypeIn DefaultUni term BLS12_381.G2.Element => + ReadKnownIn DefaultUni term BLS12_381.G2.Element +instance + KnownBuiltinTypeIn DefaultUni term BLS12_381.Pairing.MlResult => + ReadKnownIn DefaultUni term BLS12_381.Pairing.MlResult +instance + KnownBuiltinTypeIn DefaultUni term Value => + ReadKnownIn DefaultUni term Value + +instance + KnownBuiltinTypeIn DefaultUni term Integer => + MakeKnownIn DefaultUni term Integer +instance + KnownBuiltinTypeIn DefaultUni term ByteString => + MakeKnownIn DefaultUni term ByteString +instance + KnownBuiltinTypeIn DefaultUni term Text => + MakeKnownIn DefaultUni term Text +instance + KnownBuiltinTypeIn DefaultUni term () => + MakeKnownIn DefaultUni term () +instance + KnownBuiltinTypeIn DefaultUni term Bool => + MakeKnownIn DefaultUni term Bool +instance + KnownBuiltinTypeIn DefaultUni term Data => + MakeKnownIn DefaultUni term Data +instance + KnownBuiltinTypeIn DefaultUni term [a] => + MakeKnownIn DefaultUni term [a] +instance + KnownBuiltinTypeIn DefaultUni term (Strict.Vector a) => + MakeKnownIn DefaultUni term (Strict.Vector a) +instance + KnownBuiltinTypeIn DefaultUni term (a, b) => + MakeKnownIn DefaultUni term (a, b) +instance + KnownBuiltinTypeIn DefaultUni term BLS12_381.G1.Element => + MakeKnownIn DefaultUni term BLS12_381.G1.Element +instance + KnownBuiltinTypeIn DefaultUni term BLS12_381.G2.Element => + MakeKnownIn DefaultUni term BLS12_381.G2.Element +instance + KnownBuiltinTypeIn DefaultUni term BLS12_381.Pairing.MlResult => + MakeKnownIn DefaultUni term BLS12_381.Pairing.MlResult +instance + KnownBuiltinTypeIn DefaultUni term Value => + MakeKnownIn DefaultUni term Value -- If this tells you an instance is missing, add it right above, following the pattern. instance TestTypesFromTheUniverseAreAllKnown DefaultUni @@ -455,16 +498,18 @@ manually. -} -- | 'coerce' the argument, then call 'makeKnown'. -makeKnownCoerce - :: forall b term a. (MakeKnownIn DefaultUni term b, Coercible a b) - => a -> BuiltinResult term +makeKnownCoerce :: + forall b term a. + (MakeKnownIn DefaultUni term b, Coercible a b) => + a -> BuiltinResult term makeKnownCoerce = coerceArg $ makeKnown @_ @_ @b {-# INLINE makeKnownCoerce #-} -- | Call 'readKnown', then 'coerce' the argument. -readKnownCoerce - :: forall b term a. (ReadKnownIn DefaultUni term b, Coercible b a) - => term -> ReadKnownM a +readKnownCoerce :: + forall b term a. + (ReadKnownIn DefaultUni term b, Coercible b a) => + term -> ReadKnownM a readKnownCoerce = fmap coerce #. readKnown @_ @_ @b {-# INLINE readKnownCoerce #-} @@ -473,36 +518,39 @@ readKnownCoerce = fmap coerce #. readKnown @_ @_ @b data AsInteger a instance KnownTypeAst tyname DefaultUni (AsInteger a) where - type IsBuiltin _ _ = 'False - type ToHoles _ _ _ = '[] - type ToBinds _ acc _ = acc - typeAst = toTypeAst $ Proxy @Integer - -makeKnownAsInteger - :: forall term a. (KnownBuiltinTypeIn DefaultUni term Integer, Integral a) - => a -> BuiltinResult term + type IsBuiltin _ _ = 'False + type ToHoles _ _ _ = '[] + type ToBinds _ acc _ = acc + typeAst = toTypeAst $ Proxy @Integer + +makeKnownAsInteger :: + forall term a. + (KnownBuiltinTypeIn DefaultUni term Integer, Integral a) => + a -> BuiltinResult term makeKnownAsInteger = makeKnown . toInteger {-# INLINE makeKnownAsInteger #-} -readKnownAsInteger - :: forall term a. - (KnownBuiltinTypeIn DefaultUni term Integer, Integral a, Bounded a, Typeable a) - => term -> ReadKnownM a +readKnownAsInteger :: + forall term a. + (KnownBuiltinTypeIn DefaultUni term Integer, Integral a, Bounded a, Typeable a) => + term -> ReadKnownM a readKnownAsInteger term = - -- See Note [Performance of ReadKnownIn and MakeKnownIn instances]. - -- Funnily, we don't need 'inline' here, unlike in the default implementation of 'readKnown' - -- (go figure why). - inline readKnownConstant term >>= oneShot \(i :: Integer) -> - -- We don't make use here of 'toIntegralSized' because of performance considerations, - -- see: https://gitlab.haskell.org/ghc/ghc/-/issues/19641 - -- TODO: benchmark an alternative 'integerToIntMaybe', modified from @ghc-bignum@ - if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) - then pure $ fromIntegral i - else throwError . operationalUnliftingError $ fold - [ Text.pack $ show i - , " is not within the bounds of " - , Text.pack . show . typeRep $ Proxy @a - ] + -- See Note [Performance of ReadKnownIn and MakeKnownIn instances]. + -- Funnily, we don't need 'inline' here, unlike in the default implementation of 'readKnown' + -- (go figure why). + inline readKnownConstant term >>= oneShot \(i :: Integer) -> + -- We don't make use here of 'toIntegralSized' because of performance considerations, + -- see: https://gitlab.haskell.org/ghc/ghc/-/issues/19641 + -- TODO: benchmark an alternative 'integerToIntMaybe', modified from @ghc-bignum@ + if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) + then pure $ fromIntegral i + else + throwError . operationalUnliftingError $ + fold + [ Text.pack $ show i + , " is not within the bounds of " + , Text.pack . show . typeRep $ Proxy @a + ] {-# INLINE readKnownAsInteger #-} #if WORD_SIZE_IN_BITS == 64 @@ -526,126 +574,159 @@ instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni te {-# INLINE readKnown #-} #endif -deriving via AsInteger Int8 instance - KnownTypeAst tyname DefaultUni Int8 +deriving via + AsInteger Int8 + instance + KnownTypeAst tyname DefaultUni Int8 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Int8 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Int8 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} -deriving via AsInteger Int16 instance - KnownTypeAst tyname DefaultUni Int16 +deriving via + AsInteger Int16 + instance + KnownTypeAst tyname DefaultUni Int16 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Int16 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Int16 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} -deriving via AsInteger Int32 instance - KnownTypeAst tyname DefaultUni Int32 +deriving via + AsInteger Int32 + instance + KnownTypeAst tyname DefaultUni Int32 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Int32 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Int32 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} -deriving via AsInteger Int64 instance - KnownTypeAst tyname DefaultUni Int64 +deriving via + AsInteger Int64 + instance + KnownTypeAst tyname DefaultUni Int64 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Int64 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Int64 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} -deriving via AsInteger Word8 instance - KnownTypeAst tyname DefaultUni Word8 +deriving via + AsInteger Word8 + instance + KnownTypeAst tyname DefaultUni Word8 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Word8 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Word8 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} -deriving via AsInteger Word16 instance - KnownTypeAst tyname DefaultUni Word16 +deriving via + AsInteger Word16 + instance + KnownTypeAst tyname DefaultUni Word16 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Word16 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Word16 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} -deriving via AsInteger Word32 instance - KnownTypeAst tyname DefaultUni Word32 +deriving via + AsInteger Word32 + instance + KnownTypeAst tyname DefaultUni Word32 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Word32 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Word32 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} -deriving via AsInteger Word64 instance - KnownTypeAst tyname DefaultUni Word64 +deriving via + AsInteger Word64 + instance + KnownTypeAst tyname DefaultUni Word64 instance KnownBuiltinTypeIn DefaultUni term Integer => MakeKnownIn DefaultUni term Word64 where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} instance KnownBuiltinTypeIn DefaultUni term Integer => ReadKnownIn DefaultUni term Word64 where - readKnown = readKnownAsInteger - {-# INLINE readKnown #-} + readKnown = readKnownAsInteger + {-# INLINE readKnown #-} deriving newtype instance - KnownTypeAst tyname DefaultUni NumBytesCostedAsNumWords -instance KnownBuiltinTypeIn DefaultUni term Integer => - MakeKnownIn DefaultUni term NumBytesCostedAsNumWords where - makeKnown = makeKnownCoerce @Integer - {-# INLINE makeKnown #-} - -instance KnownBuiltinTypeIn DefaultUni term Integer => - ReadKnownIn DefaultUni term NumBytesCostedAsNumWords where - readKnown = readKnownCoerce @Integer - {-# INLINE readKnown #-} + KnownTypeAst tyname DefaultUni NumBytesCostedAsNumWords +instance + KnownBuiltinTypeIn DefaultUni term Integer => + MakeKnownIn DefaultUni term NumBytesCostedAsNumWords + where + makeKnown = makeKnownCoerce @Integer + {-# INLINE makeKnown #-} + +instance + KnownBuiltinTypeIn DefaultUni term Integer => + ReadKnownIn DefaultUni term NumBytesCostedAsNumWords + where + readKnown = readKnownCoerce @Integer + {-# INLINE readKnown #-} deriving newtype instance - KnownTypeAst tyname DefaultUni IntegerCostedLiterally -instance KnownBuiltinTypeIn DefaultUni term Integer => - MakeKnownIn DefaultUni term IntegerCostedLiterally where - makeKnown = makeKnownCoerce @Integer - {-# INLINE makeKnown #-} -instance KnownBuiltinTypeIn DefaultUni term Integer => - ReadKnownIn DefaultUni term IntegerCostedLiterally where - readKnown = readKnownCoerce @Integer - {-# INLINE readKnown #-} - -deriving via AsInteger Natural instance - KnownTypeAst tyname DefaultUni Natural -instance KnownBuiltinTypeIn DefaultUni term Integer => - MakeKnownIn DefaultUni term Natural where - makeKnown = makeKnownAsInteger - {-# INLINE makeKnown #-} -instance KnownBuiltinTypeIn DefaultUni term Integer => - ReadKnownIn DefaultUni term Natural where - readKnown term = - -- See Note [Performance of ReadKnownIn and MakeKnownIn instances]. - -- Funnily, we don't really need 'inline' here, unlike in the default implementation of - -- 'readKnown' (go figure why), but we still use it just to be sure. - inline readKnownConstant term >>= oneShot \(i :: Integer) -> - -- TODO: benchmark alternatives:signumInteger,integerIsNegative,integerToNaturalThrow - if i >= 0 - -- TODO: benchmark alternatives: ghc>=9 integerToNatural - then pure $ fromInteger i - else throwError . operationalUnliftingError $ fold - [ Text.pack $ show i - , " is not within the bounds of Natural" - ] - {-# INLINE readKnown #-} + KnownTypeAst tyname DefaultUni IntegerCostedLiterally +instance + KnownBuiltinTypeIn DefaultUni term Integer => + MakeKnownIn DefaultUni term IntegerCostedLiterally + where + makeKnown = makeKnownCoerce @Integer + {-# INLINE makeKnown #-} +instance + KnownBuiltinTypeIn DefaultUni term Integer => + ReadKnownIn DefaultUni term IntegerCostedLiterally + where + readKnown = readKnownCoerce @Integer + {-# INLINE readKnown #-} + +deriving via + AsInteger Natural + instance + KnownTypeAst tyname DefaultUni Natural +instance + KnownBuiltinTypeIn DefaultUni term Integer => + MakeKnownIn DefaultUni term Natural + where + makeKnown = makeKnownAsInteger + {-# INLINE makeKnown #-} +instance + KnownBuiltinTypeIn DefaultUni term Integer => + ReadKnownIn DefaultUni term Natural + where + readKnown term = + -- See Note [Performance of ReadKnownIn and MakeKnownIn instances]. + -- Funnily, we don't really need 'inline' here, unlike in the default implementation of + -- 'readKnown' (go figure why), but we still use it just to be sure. + inline readKnownConstant term >>= oneShot \(i :: Integer) -> + -- TODO: benchmark alternatives:signumInteger,integerIsNegative,integerToNaturalThrow + if i >= 0 + -- TODO: benchmark alternatives: ghc>=9 integerToNatural + then pure $ fromInteger i + else + throwError . operationalUnliftingError $ + fold + [ Text.pack $ show i + , " is not within the bounds of Natural" + ] + {-# INLINE readKnown #-} outOfBoundsErr :: Pretty a => a -> Vector.Vector term -> Text -outOfBoundsErr x branches = fold +outOfBoundsErr x branches = + fold [ "'case " , display x , "' is out of bounds for the given number of branches: " @@ -653,63 +734,63 @@ outOfBoundsErr x branches = fold ] instance AnnotateCaseBuiltin DefaultUni where - annotateCaseBuiltin ty branches = case ty of - TyBuiltin _ (SomeTypeIn DefaultUniUnit) -> - case branches of - [x] -> Right $ [(x, [])] - _ -> Left "Casing on unit only allows exactly one branch" - TyBuiltin _ (SomeTypeIn DefaultUniBool) -> - case branches of - [f] -> Right $ [(f, [])] - [f, t] -> Right $ [(f, []), (t, [])] - _ -> Left "Casing on bool requires exactly one branch or two branches" - TyBuiltin _ (SomeTypeIn DefaultUniInteger) -> - Right $ map (, []) branches - listTy@(TyApp _ (TyBuiltin _ (SomeTypeIn DefaultUniProtoList)) argTy) -> - case branches of - [cons] -> Right [(cons, [argTy, listTy])] - [cons, nil] -> Right [(cons, [argTy, listTy]), (nil, [])] - _ -> Left "Casing on list requires exactly one branch or two branches" - (TyApp _ (TyApp _ (TyBuiltin _ (SomeTypeIn DefaultUniProtoPair)) lTyArg) rTyArg) -> - case branches of - [f] -> Right [(f, [lTyArg, rTyArg])] - _ -> Left "Casing on pair requires exactly one branch" - _ -> Left $ display (() <$ ty) <> " isn't supported in 'case'" + annotateCaseBuiltin ty branches = case ty of + TyBuiltin _ (SomeTypeIn DefaultUniUnit) -> + case branches of + [x] -> Right $ [(x, [])] + _ -> Left "Casing on unit only allows exactly one branch" + TyBuiltin _ (SomeTypeIn DefaultUniBool) -> + case branches of + [f] -> Right $ [(f, [])] + [f, t] -> Right $ [(f, []), (t, [])] + _ -> Left "Casing on bool requires exactly one branch or two branches" + TyBuiltin _ (SomeTypeIn DefaultUniInteger) -> + Right $ map (,[]) branches + listTy@(TyApp _ (TyBuiltin _ (SomeTypeIn DefaultUniProtoList)) argTy) -> + case branches of + [cons] -> Right [(cons, [argTy, listTy])] + [cons, nil] -> Right [(cons, [argTy, listTy]), (nil, [])] + _ -> Left "Casing on list requires exactly one branch or two branches" + (TyApp _ (TyApp _ (TyBuiltin _ (SomeTypeIn DefaultUniProtoPair)) lTyArg) rTyArg) -> + case branches of + [f] -> Right [(f, [lTyArg, rTyArg])] + _ -> Left "Casing on pair requires exactly one branch" + _ -> Left $ display (() <$ ty) <> " isn't supported in 'case'" instance CaseBuiltin DefaultUni where - caseBuiltin someVal@(Some (ValueOf uni x)) branches = case uni of - DefaultUniUnit - | 1 == len -> Right $ HeadOnly $ branches Vector.! 0 - | otherwise -> Left $ outOfBoundsErr someVal branches - DefaultUniBool -> case x of - -- We allow there to be only one branch as long as the scrutinee is 'False'. - -- This is strictly to save size by not having the 'True' branch if it was gonna be - -- 'Error' anyway. - False | len == 1 || len == 2 -> Right $ HeadOnly $ branches Vector.! 0 - True | len == 2 -> Right $ HeadOnly $ branches Vector.! 1 - _ -> Left $ outOfBoundsErr someVal branches - DefaultUniInteger - | 0 <= x && x < toInteger len -> Right $ HeadOnly $ branches Vector.! fromInteger x - | otherwise -> Left $ outOfBoundsErr someVal branches - DefaultUniList ty - | len == 1 -> - case x of - [] -> Left "Expected non-empty list, got empty list for casing list" - (y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys] - | len == 2 -> - case x of - [] -> Right $ HeadOnly $ branches Vector.! 1 - (y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys] - | otherwise -> Left $ outOfBoundsErr someVal branches - DefaultUniPair tyL tyR - | len == 1 -> - case x of - (l, r) -> Right $ headSpine (branches Vector.! 0) [someValueOf tyL l, someValueOf tyR r] - | otherwise -> Left $ outOfBoundsErr someVal branches - _ -> Left $ display uni <> " isn't supported in 'case'" - where - !len = Vector.length branches - {-# INLINE caseBuiltin #-} + caseBuiltin someVal@(Some (ValueOf uni x)) branches = case uni of + DefaultUniUnit + | 1 == len -> Right $ HeadOnly $ branches Vector.! 0 + | otherwise -> Left $ outOfBoundsErr someVal branches + DefaultUniBool -> case x of + -- We allow there to be only one branch as long as the scrutinee is 'False'. + -- This is strictly to save size by not having the 'True' branch if it was gonna be + -- 'Error' anyway. + False | len == 1 || len == 2 -> Right $ HeadOnly $ branches Vector.! 0 + True | len == 2 -> Right $ HeadOnly $ branches Vector.! 1 + _ -> Left $ outOfBoundsErr someVal branches + DefaultUniInteger + | 0 <= x && x < toInteger len -> Right $ HeadOnly $ branches Vector.! fromInteger x + | otherwise -> Left $ outOfBoundsErr someVal branches + DefaultUniList ty + | len == 1 -> + case x of + [] -> Left "Expected non-empty list, got empty list for casing list" + (y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys] + | len == 2 -> + case x of + [] -> Right $ HeadOnly $ branches Vector.! 1 + (y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys] + | otherwise -> Left $ outOfBoundsErr someVal branches + DefaultUniPair tyL tyR + | len == 1 -> + case x of + (l, r) -> Right $ headSpine (branches Vector.! 0) [someValueOf tyL l, someValueOf tyR r] + | otherwise -> Left $ outOfBoundsErr someVal branches + _ -> Left $ display uni <> " isn't supported in 'case'" + where + !len = Vector.length branches + {-# INLINE caseBuiltin #-} {- Note [Stable encoding of tags] 'encodeUni' and 'decodeUni' are used for serialisation and deserialisation of types from the @@ -720,80 +801,84 @@ See Note [Stable encoding of TPLC] -} instance Closed DefaultUni where - type DefaultUni `Everywhere` constr = - ( constr `Permits` Integer - , constr `Permits` ByteString - , constr `Permits` Text - , constr `Permits` () - , constr `Permits` Bool - , constr `Permits` Value - , constr `Permits` [] - , constr `Permits` Strict.Vector - , constr `Permits` (,) - , constr `Permits` Data - , constr `Permits` BLS12_381.G1.Element - , constr `Permits` BLS12_381.G2.Element - , constr `Permits` BLS12_381.Pairing.MlResult - ) - - -- See Note [Stable encoding of tags]. - -- IF YOU'RE GETTING A WARNING HERE, DON'T FORGET TO AMEND 'withDecodedUni' RIGHT BELOW. - encodeUni DefaultUniInteger = [0] - encodeUni DefaultUniByteString = [1] - encodeUni DefaultUniString = [2] - encodeUni DefaultUniUnit = [3] - encodeUni DefaultUniBool = [4] - encodeUni DefaultUniProtoList = [5] - encodeUni DefaultUniProtoPair = [6] - encodeUni (DefaultUniApply uniF uniA) = 7 : encodeUni uniF ++ encodeUni uniA - encodeUni DefaultUniData = [8] - encodeUni DefaultUniBLS12_381_G1_Element = [9] - encodeUni DefaultUniBLS12_381_G2_Element = [10] - encodeUni DefaultUniBLS12_381_MlResult = [11] - encodeUni DefaultUniProtoArray = [12] - encodeUni DefaultUniValue = [13] - - -- See Note [Decoding universes]. - -- See Note [Stable encoding of tags]. - withDecodedUni k = peelUniTag >>= \case - 0 -> k DefaultUniInteger - 1 -> k DefaultUniByteString - 2 -> k DefaultUniString - 3 -> k DefaultUniUnit - 4 -> k DefaultUniBool - 5 -> k DefaultUniProtoList - 6 -> k DefaultUniProtoPair - 7 -> - withDecodedUni @DefaultUni $ \uniF -> - withDecodedUni @DefaultUni $ \uniA -> - withApplicable uniF uniA $ - k $ uniF `DefaultUniApply` uniA - 8 -> k DefaultUniData - 9 -> k DefaultUniBLS12_381_G1_Element - 10 -> k DefaultUniBLS12_381_G2_Element - 11 -> k DefaultUniBLS12_381_MlResult - 12 -> k DefaultUniProtoArray - 13 -> k DefaultUniValue - _ -> empty - - bring - :: forall constr a r proxy. DefaultUni `Everywhere` constr - => proxy constr -> DefaultUni (Esc a) -> (constr a => r) -> r - bring _ DefaultUniInteger r = r - bring _ DefaultUniByteString r = r - bring _ DefaultUniString r = r - bring _ DefaultUniUnit r = r - bring _ DefaultUniBool r = r - bring p (DefaultUniProtoList `DefaultUniApply` uniA) r = - bring p uniA r - bring p (DefaultUniProtoArray `DefaultUniApply` uniA) r = - bring p uniA r - bring p (DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB) r = - bring p uniA $ bring p uniB r - bring _ (f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _) _ = - noMoreTypeFunctions f - bring _ DefaultUniData r = r - bring _ DefaultUniBLS12_381_G1_Element r = r - bring _ DefaultUniBLS12_381_G2_Element r = r - bring _ DefaultUniBLS12_381_MlResult r = r - bring _ DefaultUniValue r = r + type + DefaultUni `Everywhere` constr = + ( constr `Permits` Integer + , constr `Permits` ByteString + , constr `Permits` Text + , constr `Permits` () + , constr `Permits` Bool + , constr `Permits` Value + , constr `Permits` [] + , constr `Permits` Strict.Vector + , constr `Permits` (,) + , constr `Permits` Data + , constr `Permits` BLS12_381.G1.Element + , constr `Permits` BLS12_381.G2.Element + , constr `Permits` BLS12_381.Pairing.MlResult + ) + + -- See Note [Stable encoding of tags]. + -- IF YOU'RE GETTING A WARNING HERE, DON'T FORGET TO AMEND 'withDecodedUni' RIGHT BELOW. + encodeUni DefaultUniInteger = [0] + encodeUni DefaultUniByteString = [1] + encodeUni DefaultUniString = [2] + encodeUni DefaultUniUnit = [3] + encodeUni DefaultUniBool = [4] + encodeUni DefaultUniProtoList = [5] + encodeUni DefaultUniProtoPair = [6] + encodeUni (DefaultUniApply uniF uniA) = 7 : encodeUni uniF ++ encodeUni uniA + encodeUni DefaultUniData = [8] + encodeUni DefaultUniBLS12_381_G1_Element = [9] + encodeUni DefaultUniBLS12_381_G2_Element = [10] + encodeUni DefaultUniBLS12_381_MlResult = [11] + encodeUni DefaultUniProtoArray = [12] + encodeUni DefaultUniValue = [13] + + -- See Note [Decoding universes]. + -- See Note [Stable encoding of tags]. + withDecodedUni k = + peelUniTag >>= \case + 0 -> k DefaultUniInteger + 1 -> k DefaultUniByteString + 2 -> k DefaultUniString + 3 -> k DefaultUniUnit + 4 -> k DefaultUniBool + 5 -> k DefaultUniProtoList + 6 -> k DefaultUniProtoPair + 7 -> + withDecodedUni @DefaultUni $ \uniF -> + withDecodedUni @DefaultUni $ \uniA -> + withApplicable uniF uniA $ + k $ + uniF `DefaultUniApply` uniA + 8 -> k DefaultUniData + 9 -> k DefaultUniBLS12_381_G1_Element + 10 -> k DefaultUniBLS12_381_G2_Element + 11 -> k DefaultUniBLS12_381_MlResult + 12 -> k DefaultUniProtoArray + 13 -> k DefaultUniValue + _ -> empty + + bring :: + forall constr a r proxy. + DefaultUni `Everywhere` constr => + proxy constr -> DefaultUni (Esc a) -> (constr a => r) -> r + bring _ DefaultUniInteger r = r + bring _ DefaultUniByteString r = r + bring _ DefaultUniString r = r + bring _ DefaultUniUnit r = r + bring _ DefaultUniBool r = r + bring p (DefaultUniProtoList `DefaultUniApply` uniA) r = + bring p uniA r + bring p (DefaultUniProtoArray `DefaultUniApply` uniA) r = + bring p uniA r + bring p (DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB) r = + bring p uniA $ bring p uniB r + bring _ (f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _) _ = + noMoreTypeFunctions f + bring _ DefaultUniData r = r + bring _ DefaultUniBLS12_381_G1_Element r = r + bring _ DefaultUniBLS12_381_G2_Element r = r + bring _ DefaultUniBLS12_381_MlResult r = r + bring _ DefaultUniValue r = r diff --git a/plutus-core/plutus-core/src/PlutusCore/Eq.hs b/plutus-core/plutus-core/src/PlutusCore/Eq.hs index 3f65b1be2da..a788f0c72f0 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Eq.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Eq.hs @@ -1,22 +1,21 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + -- | An internal module that defines functions for deciding equality of values of data types -- that encode things with binders. - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Eq - ( LR (..) - , RL (..) - , EqRename - , ScopedEqRename - , runEqRename - , withTwinBindings - , eqNameM - , eqM - ) where +module PlutusCore.Eq ( + LR (..), + RL (..), + EqRename, + ScopedEqRename, + runEqRename, + withTwinBindings, + eqNameM, + eqM, +) where import PlutusPrelude @@ -104,23 +103,28 @@ type-level renaming). -} -- See Note [Side tracking]. + -- | From left to right. newtype LR a = LR - { unLR :: a - } deriving stock (Generic) + { unLR :: a + } + deriving stock (Generic) -- See Note [Side tracking]. + -- | From right to left. newtype RL a = RL - { unRL :: a - } deriving stock (Generic) + { unRL :: a + } + deriving stock (Generic) -- See Note [Side tracking]. + -- | A left @a@ and a right @a@. data Bilateral a = Bilateral - { _bilateralL :: a - , _bilateralR :: a - } + { _bilateralL :: a + , _bilateralR :: a + } makeLenses ''Bilateral @@ -130,23 +134,24 @@ instance HasUnique name unique => HasUnique (LR name) (LR unique) instance HasUnique name unique => HasUnique (RL name) (RL unique) instance Semigroup a => Semigroup (Bilateral a) where - Bilateral l1 r1 <> Bilateral l2 r2 = Bilateral (l1 <> l2) (r1 <> r2) + Bilateral l1 r1 <> Bilateral l2 r2 = Bilateral (l1 <> l2) (r1 <> r2) instance Monoid a => Monoid (Bilateral a) where - mempty = Bilateral mempty mempty + mempty = Bilateral mempty mempty -- To rename from left to right is to update the left renaming. instance HasRenaming ren unique => HasRenaming (Bilateral ren) (LR unique) where - renaming = bilateralL . renaming . coerced @(Renaming unique) + renaming = bilateralL . renaming . coerced @(Renaming unique) -- To rename from right to left is to update the right renaming. instance HasRenaming ren unique => HasRenaming (Bilateral ren) (RL unique) where - renaming = bilateralR . renaming . coerced @(Renaming unique) + renaming = bilateralR . renaming . coerced @(Renaming unique) -- | The type of a runnable equality check. @Maybe ()@ is isomorphic to 'Bool' and we use it -- instead of 'Bool', because this unlocks the convenient and readable do-notation and allows for -- automatic short-circuiting, which would be tedious with @Rename (Bilateral ren) Bool@. type EqRename ren = RenameT (Bilateral ren) Maybe () + type ScopedEqRename = EqRename ScopedRenaming -- | Run an 'EqRename' computation. @@ -154,28 +159,30 @@ runEqRename :: Monoid ren => EqRename ren -> Bool runEqRename = isJust . runRenameT -- See Note [Modulo alpha]. + -- | Record that two names map to each other. -withTwinBindings - :: (HasRenaming ren unique, HasUnique name unique, Monad m) - => name -> name -> RenameT (Bilateral ren) m c -> RenameT (Bilateral ren) m c +withTwinBindings :: + (HasRenaming ren unique, HasUnique name unique, Monad m) => + name -> name -> RenameT (Bilateral ren) m c -> RenameT (Bilateral ren) m c withTwinBindings name1 name2 k = - withRenamedName (LR name1) (LR name2) $ + withRenamedName (LR name1) (LR name2) $ withRenamedName (RL name2) (RL name1) k -- See Note [Modulo alpha]. + -- | Check equality of two names. -eqNameM - :: (HasRenaming ren unique, HasUnique name unique, Eq unique) - => name -> name -> EqRename ren +eqNameM :: + (HasRenaming ren unique, HasUnique name unique, Eq unique) => + name -> name -> EqRename ren eqNameM name1 name2 = do - mayUniq2' <- lookupNameM $ LR name1 - mayUniq1' <- lookupNameM $ RL name2 - let uniq1 = name1 ^. unique - uniq2 = name2 ^. unique - guard $ case (mayUniq1', mayUniq2') of - (Nothing , Nothing ) -> uniq1 == uniq2 - (Just (RL uniq1'), Just (LR uniq2')) -> uniq1 == uniq1' && uniq2 == uniq2' - (_ , _ ) -> False + mayUniq2' <- lookupNameM $ LR name1 + mayUniq1' <- lookupNameM $ RL name2 + let uniq1 = name1 ^. unique + uniq2 = name2 ^. unique + guard $ case (mayUniq1', mayUniq2') of + (Nothing, Nothing) -> uniq1 == uniq2 + (Just (RL uniq1'), Just (LR uniq2')) -> uniq1 == uniq1' && uniq2 == uniq2' + (_, _) -> False -- | Check equality of things having an 'Eq' instance. eqM :: Eq a => a -> a -> EqRename ren diff --git a/plutus-core/plutus-core/src/PlutusCore/Error.hs b/plutus-core/plutus-core/src/PlutusCore/Error.hs index 864f451ba21..9fb74a06b3d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Error.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Error.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + -- appears in the generated instances -module PlutusCore.Error - ( ParserError (..) - , ParserErrorBundle (..) - , NormCheckError (..) - , UniqueError (..) - , ExpectedShapeOr (..) - , TypeError (..) - , FreeVariableError (..) - , Error (..) - , throwingEither - , ShowErrorComponent (..) - , ApplyProgramError (..) - ) where +module PlutusCore.Error ( + ParserError (..), + ParserErrorBundle (..), + NormCheckError (..), + UniqueError (..), + ExpectedShapeOr (..), + TypeError (..), + FreeVariableError (..), + Error (..), + throwingEither, + ShowErrorComponent (..), + ApplyProgramError (..), +) where import PlutusPrelude @@ -44,49 +44,52 @@ import Universe -- | Lifts an 'Either' into an error context where we can embed the 'Left' value into the error. throwingEither :: MonadError e m => AReview e t -> Either t a -> m a throwingEither r e = case e of - Left t -> throwing r t - Right v -> pure v + Left t -> throwing r t + Right v -> pure v -- | An error encountered during parsing. data ParserError - = BuiltinTypeNotAStar !T.Text !SourcePos - | UnknownBuiltinFunction !T.Text !SourcePos ![T.Text] - | InvalidBuiltinConstant !T.Text !T.Text !SourcePos - deriving stock (Eq, Ord, Generic) - deriving anyclass (NFData) + = BuiltinTypeNotAStar !T.Text !SourcePos + | UnknownBuiltinFunction !T.Text !SourcePos ![T.Text] + | InvalidBuiltinConstant !T.Text !T.Text !SourcePos + deriving stock (Eq, Ord, Generic) + deriving anyclass (NFData) -instance Show ParserError - where - show = show . pretty +instance Show ParserError where + show = show . pretty data UniqueError ann - = MultiplyDefined !Unique !ann !ann - | IncoherentUsage !Unique !ann !ann - | FreeVariable !Unique !ann - deriving stock (Show, Eq, Generic, Functor) - deriving anyclass (NFData) + = MultiplyDefined !Unique !ann !ann + | IncoherentUsage !Unique !ann !ann + | FreeVariable !Unique !ann + deriving stock (Show, Eq, Generic, Functor) + deriving anyclass (NFData) instance Exception (UniqueError SrcSpan) data NormCheckError tyname name uni fun ann - = BadType !ann !(Type tyname uni ann) !T.Text - | BadTerm !ann !(Term tyname name uni fun ann) !T.Text - deriving stock (Functor, Generic) + = BadType !ann !(Type tyname uni ann) !T.Text + | BadTerm !ann !(Term tyname name uni fun ann) !T.Text + deriving stock (Functor, Generic) deriving anyclass instance - (NFData tyname, NFData name, Closed uni, Everywhere uni NFData, NFData fun, NFData ann) => - NFData (NormCheckError tyname name uni fun ann) + (NFData tyname, NFData name, Closed uni, Everywhere uni NFData, NFData fun, NFData ann) => + NFData (NormCheckError tyname name uni fun ann) deriving stock instance - (Show tyname, Show name, Closed uni, Everywhere uni Show, Show fun, Show ann, GShow uni) => - Show (NormCheckError tyname name uni fun ann) + (Show tyname, Show name, Closed uni, Everywhere uni Show, Show fun, Show ann, GShow uni) => + Show (NormCheckError tyname name uni fun ann) deriving stock instance - ( Eq (Term tyname name uni fun ann) - , Eq (Type tyname uni ann) - , GEq uni, Closed uni, uni `Everywhere` Eq - , Eq fun, Eq ann - ) => Eq (NormCheckError tyname name uni fun ann) + ( Eq (Term tyname name uni fun ann) + , Eq (Type tyname uni ann) + , GEq uni + , Closed uni + , uni `Everywhere` Eq + , Eq fun + , Eq ann + ) => + Eq (NormCheckError tyname name uni fun ann) -- | This is needed for nice kind/type checking error messages. In some cases the type checker knows -- the exact type that an expression has to have for type checking to succeed (see any of @@ -97,110 +100,143 @@ deriving stock instance -- it allows one to specify the shape of an expected type with some existential variables in it when -- it's impossible to provide an exact type. data ExpectedShapeOr a - = ExpectedShape - !T.Text - -- ^ The expected shape potentially referencing existential variables. - ![T.Text] - -- ^ The list of existential variables. - | ExpectedExact !a - deriving stock (Show, Eq, Generic, Functor) - deriving anyclass (NFData) + = ExpectedShape + -- | The expected shape potentially referencing existential variables. + !T.Text + -- | The list of existential variables. + ![T.Text] + | ExpectedExact !a + deriving stock (Show, Eq, Generic, Functor) + deriving anyclass (NFData) data TypeError term uni fun ann - = KindMismatch !ann - !(Type TyName uni ()) - !(ExpectedShapeOr (Kind ())) - -- ^ The expected type or the shape of a kind. - !(Kind ()) - -- ^ The actual kind. - | TypeMismatch !ann - !term - !(ExpectedShapeOr (Type TyName uni ())) - -- ^ The expected type or the shape of a type. - !(Normalized (Type TyName uni ())) - -- ^ The actual type. - | TyNameMismatch !ann !TyName !TyName - | NameMismatch !ann !Name !Name - | FreeTypeVariableE !ann !TyName - | FreeVariableE !ann !Name - | UnknownBuiltinFunctionE !ann !fun - | UnsupportedCaseBuiltin !ann !T.Text - deriving stock (Show, Eq, Generic, Functor) - deriving anyclass (NFData) + = KindMismatch + !ann + !(Type TyName uni ()) + -- | The expected type or the shape of a kind. + !(ExpectedShapeOr (Kind ())) + -- | The actual kind. + !(Kind ()) + | TypeMismatch + !ann + !term + -- | The expected type or the shape of a type. + !(ExpectedShapeOr (Type TyName uni ())) + -- | The actual type. + !(Normalized (Type TyName uni ())) + | TyNameMismatch !ann !TyName !TyName + | NameMismatch !ann !Name !Name + | FreeTypeVariableE !ann !TyName + | FreeVariableE !ann !Name + | UnknownBuiltinFunctionE !ann !fun + | UnsupportedCaseBuiltin !ann !T.Text + deriving stock (Show, Eq, Generic, Functor) + deriving anyclass (NFData) -- Make a custom data type and wrap @ParseErrorBundle@ in it so I can use @makeClassyPrisms@ -- on @ParseErrorBundle@. -- TODO: this can be killed data ParserErrorBundle - = ParseErrorB !(ParseErrorBundle T.Text ParserError) - deriving stock (Eq, Generic) - deriving anyclass (NFData) + = ParseErrorB !(ParseErrorBundle T.Text ParserError) + deriving stock (Eq, Generic) + deriving anyclass (NFData) instance Pretty ParserErrorBundle where - pretty (ParseErrorB err) = pretty $ errorBundlePretty err + pretty (ParseErrorB err) = pretty $ errorBundlePretty err instance Show ParserErrorBundle where - show (ParseErrorB peb) = errorBundlePretty peb + show (ParseErrorB peb) = errorBundlePretty peb data Error uni fun ann - = ParseErrorE !ParserErrorBundle - | UniqueCoherencyErrorE !(UniqueError ann) - | TypeErrorE !(TypeError (Term TyName Name uni fun ()) uni fun ann) - | NormCheckErrorE !(NormCheckError TyName Name uni fun ann) - | FreeVariableErrorE !FreeVariableError - deriving stock (Generic, Functor) + = ParseErrorE !ParserErrorBundle + | UniqueCoherencyErrorE !(UniqueError ann) + | TypeErrorE !(TypeError (Term TyName Name uni fun ()) uni fun ann) + | NormCheckErrorE !(NormCheckError TyName Name uni fun ann) + | FreeVariableErrorE !FreeVariableError + deriving stock (Generic, Functor) deriving stock instance - (Eq fun, Eq ann, Closed uni, Everywhere uni Eq, GEq uni, Eq ParserError) => - Eq (Error uni fun ann) + (Eq fun, Eq ann, Closed uni, Everywhere uni Eq, GEq uni, Eq ParserError) => + Eq (Error uni fun ann) deriving anyclass instance - (NFData fun, NFData ann, Closed uni, Everywhere uni NFData, NFData ParserError) => - NFData (Error uni fun ann) + (NFData fun, NFData ann, Closed uni, Everywhere uni NFData, NFData ParserError) => + NFData (Error uni fun ann) deriving stock instance - (Show fun, Show ann, Closed uni, Everywhere uni Show, GShow uni, Show ParserError) => - Show (Error uni fun ann) + (Show fun, Show ann, Closed uni, Everywhere uni Show, GShow uni, Show ParserError) => + Show (Error uni fun ann) instance Pretty SourcePos where - pretty = pretty . sourcePosPretty + pretty = pretty . sourcePosPretty instance Pretty ParserError where - pretty (BuiltinTypeNotAStar ty loc) = - "Expected a type of kind star (to later parse a constant), but got:" <+> - squotes (pretty ty) <+> "at" <+> pretty loc - pretty (UnknownBuiltinFunction s loc lBuiltin) = - "Unknown built-in function" <+> squotes (pretty s) <+> "at" <+> pretty loc <> - "." <> hardline <> "Parsable functions are " <+> pretty lBuiltin - pretty (InvalidBuiltinConstant c s loc) = - "Invalid constant" <+> squotes (pretty c) <+> "of type" <+> squotes (pretty s) <+> "at" <+> - pretty loc + pretty (BuiltinTypeNotAStar ty loc) = + "Expected a type of kind star (to later parse a constant), but got:" + <+> squotes (pretty ty) + <+> "at" + <+> pretty loc + pretty (UnknownBuiltinFunction s loc lBuiltin) = + "Unknown built-in function" + <+> squotes (pretty s) + <+> "at" + <+> pretty loc + <> "." + <> hardline + <> "Parsable functions are " + <+> pretty lBuiltin + pretty (InvalidBuiltinConstant c s loc) = + "Invalid constant" + <+> squotes (pretty c) + <+> "of type" + <+> squotes (pretty s) + <+> "at" + <+> pretty loc instance ShowErrorComponent ParserError where - showErrorComponent = show . pretty + showErrorComponent = show . pretty instance Pretty ann => Pretty (UniqueError ann) where - pretty (MultiplyDefined u defd redefd) = - "Variable" <+> pretty u <+> "defined at" <+> pretty defd <+> - "is redefined at" <+> pretty redefd - pretty (IncoherentUsage u defd use) = - "Variable" <+> pretty u <+> "defined at" <+> pretty defd <+> - "is used in a different scope at" <+> pretty use - pretty (FreeVariable u use) = - "Variable" <+> pretty u <+> "is free at" <+> pretty use - -instance ( Pretty ann - , PrettyBy config (Type tyname uni ann) - , PrettyBy config (Term tyname name uni fun ann) - ) => PrettyBy config (NormCheckError tyname name uni fun ann) where - prettyBy config (BadType ann ty expct) = - "Malformed type at" <+> pretty ann <> - ". Type" <+> squotes (prettyBy config ty) <+> - "is not a" <+> pretty expct <> "." - prettyBy config (BadTerm ann t expct) = - "Malformed term at" <+> pretty ann <> - ". Term" <+> squotes (prettyBy config t) <+> - "is not a" <+> pretty expct <> "." + pretty (MultiplyDefined u defd redefd) = + "Variable" + <+> pretty u + <+> "defined at" + <+> pretty defd + <+> "is redefined at" + <+> pretty redefd + pretty (IncoherentUsage u defd use) = + "Variable" + <+> pretty u + <+> "defined at" + <+> pretty defd + <+> "is used in a different scope at" + <+> pretty use + pretty (FreeVariable u use) = + "Variable" <+> pretty u <+> "is free at" <+> pretty use + +instance + ( Pretty ann + , PrettyBy config (Type tyname uni ann) + , PrettyBy config (Term tyname name uni fun ann) + ) => + PrettyBy config (NormCheckError tyname name uni fun ann) + where + prettyBy config (BadType ann ty expct) = + "Malformed type at" + <+> pretty ann + <> ". Type" + <+> squotes (prettyBy config ty) + <+> "is not a" + <+> pretty expct + <> "." + prettyBy config (BadTerm ann t expct) = + "Malformed term at" + <+> pretty ann + <> ". Term" + <+> squotes (prettyBy config t) + <+> "is not a" + <+> pretty expct + <> "." -- | Align a list of existential variables in a pretty way. -- @@ -214,85 +250,108 @@ instance ( Pretty ann -- for some 'a', 'b' and 'c' existentialVars :: [Doc ann] -> Doc ann existentialVars [] = "" -existentialVars (x0:xs0) = " for some " <> go x0 xs0 where - go x [] = x - go x [y] = x <> " and " <> y - go x (y:xs) = x <> ", " <> go y xs +existentialVars (x0 : xs0) = " for some " <> go x0 xs0 + where + go x [] = x + go x [y] = x <> " and " <> y + go x (y : xs) = x <> ", " <> go y xs instance PrettyBy PrettyConfigPlc a => PrettyBy PrettyConfigPlc (ExpectedShapeOr a) where - prettyBy _ (ExpectedShape shape vars) = - squotes (sexp (pretty shape) []) <> existentialVars (map (squotes . pretty) vars) - prettyBy config (ExpectedExact thing) = squotes (prettyBy config thing) - -instance (Pretty term, PrettyUni uni, Pretty fun, Pretty ann) => - PrettyBy PrettyConfigPlc (TypeError term uni fun ann) where - prettyBy config (KindMismatch ann ty shapeOrK k') = - "Kind mismatch at" <+> pretty ann <> - hardline <> - "Expected a type of kind" <> hardline <> indent 2 (prettyBy config shapeOrK) <> - hardline <> - "But found one of kind" <> hardline <> indent 2 (squotes (prettyBy config k')) <> - hardline <> - "Namely," <> hardline <> indent 2 (squotes (prettyBy config ty)) - prettyBy config (TypeMismatch ann t shapeOrTy ty') = - "Type mismatch at" <+> pretty ann <> - hardline <> - "Expected a term of type" <> hardline <> indent 2 (prettyBy config shapeOrTy) <> - hardline <> - "But found one of type" <> hardline <> indent 2 (squotes (prettyBy config ty')) <> - (if _pcpoCondensedErrors (_pcpOptions config) == CondensedErrorsYes - then mempty - -- TODO: we should use prettyBy here but the problem is - -- that `instance PrettyClassic PIR.Term` whereas `instance PrettyPLC PLC.Term` - else hardline <> "Namely," <> hardline <> indent 2 (squotes (pretty t))) - prettyBy config (FreeTypeVariableE ann name) = - "Free type variable at " <+> pretty ann <+> ": " <+> prettyBy config name - prettyBy config (FreeVariableE ann name) = - "Free variable at " <+> pretty ann <+> ": " <+> prettyBy config name - prettyBy _ (UnknownBuiltinFunctionE ann fun) = - "An unknown built-in function at" <+> pretty ann <> ":" <+> pretty fun - prettyBy _ (TyNameMismatch ann name1 name2) = hsep - [ "Type-level name mismatch at" - , pretty ann <> ":" - , pretty $ name1 ^. theText - , "is in scope, but" - , pretty $ name2 ^. theText - , "having the same Unique" - , pretty $ name1 ^. theUnique - , "is attempted to be referenced" - ] - prettyBy _ (NameMismatch ann name1 name2) = hsep - [ "Term-level name mismatch at" - , pretty ann <> ":" - , pretty $ name1 ^. theText - , "is in scope, but" - , pretty $ name2 ^. theText - , "having the same Unique" - , pretty $ name1 ^. theUnique - , "is attempted to be referenced" - ] - prettyBy _ (UnsupportedCaseBuiltin ann err) = hsep - [ "Unsupported 'case' of a value of a built-in type at" - , pretty ann <> ":" - , hardline - , pretty err - ] - -instance (PrettyUni uni, Pretty fun, Pretty ann) => - PrettyBy PrettyConfigPlc (Error uni fun ann) where - prettyBy _ (ParseErrorE e) = pretty e - prettyBy _ (UniqueCoherencyErrorE e) = pretty e - prettyBy config (TypeErrorE e) = prettyBy config e - prettyBy config (NormCheckErrorE e) = prettyBy config e - prettyBy _ (FreeVariableErrorE e) = pretty e + prettyBy _ (ExpectedShape shape vars) = + squotes (sexp (pretty shape) []) <> existentialVars (map (squotes . pretty) vars) + prettyBy config (ExpectedExact thing) = squotes (prettyBy config thing) + +instance + (Pretty term, PrettyUni uni, Pretty fun, Pretty ann) => + PrettyBy PrettyConfigPlc (TypeError term uni fun ann) + where + prettyBy config (KindMismatch ann ty shapeOrK k') = + "Kind mismatch at" + <+> pretty ann + <> hardline + <> "Expected a type of kind" + <> hardline + <> indent 2 (prettyBy config shapeOrK) + <> hardline + <> "But found one of kind" + <> hardline + <> indent 2 (squotes (prettyBy config k')) + <> hardline + <> "Namely," + <> hardline + <> indent 2 (squotes (prettyBy config ty)) + prettyBy config (TypeMismatch ann t shapeOrTy ty') = + "Type mismatch at" + <+> pretty ann + <> hardline + <> "Expected a term of type" + <> hardline + <> indent 2 (prettyBy config shapeOrTy) + <> hardline + <> "But found one of type" + <> hardline + <> indent 2 (squotes (prettyBy config ty')) + <> ( if _pcpoCondensedErrors (_pcpOptions config) == CondensedErrorsYes + then mempty + -- TODO: we should use prettyBy here but the problem is + -- that `instance PrettyClassic PIR.Term` whereas `instance PrettyPLC PLC.Term` + else hardline <> "Namely," <> hardline <> indent 2 (squotes (pretty t)) + ) + prettyBy config (FreeTypeVariableE ann name) = + "Free type variable at " <+> pretty ann <+> ": " <+> prettyBy config name + prettyBy config (FreeVariableE ann name) = + "Free variable at " <+> pretty ann <+> ": " <+> prettyBy config name + prettyBy _ (UnknownBuiltinFunctionE ann fun) = + "An unknown built-in function at" <+> pretty ann <> ":" <+> pretty fun + prettyBy _ (TyNameMismatch ann name1 name2) = + hsep + [ "Type-level name mismatch at" + , pretty ann <> ":" + , pretty $ name1 ^. theText + , "is in scope, but" + , pretty $ name2 ^. theText + , "having the same Unique" + , pretty $ name1 ^. theUnique + , "is attempted to be referenced" + ] + prettyBy _ (NameMismatch ann name1 name2) = + hsep + [ "Term-level name mismatch at" + , pretty ann <> ":" + , pretty $ name1 ^. theText + , "is in scope, but" + , pretty $ name2 ^. theText + , "having the same Unique" + , pretty $ name1 ^. theUnique + , "is attempted to be referenced" + ] + prettyBy _ (UnsupportedCaseBuiltin ann err) = + hsep + [ "Unsupported 'case' of a value of a built-in type at" + , pretty ann <> ":" + , hardline + , pretty err + ] + +instance + (PrettyUni uni, Pretty fun, Pretty ann) => + PrettyBy PrettyConfigPlc (Error uni fun ann) + where + prettyBy _ (ParseErrorE e) = pretty e + prettyBy _ (UniqueCoherencyErrorE e) = pretty e + prettyBy config (TypeErrorE e) = prettyBy config e + prettyBy config (NormCheckErrorE e) = prettyBy config e + prettyBy _ (FreeVariableErrorE e) = pretty e -- | Errors from `applyProgram` for PIR, PLC, UPLC. -data ApplyProgramError = - MkApplyProgramError Version Version +data ApplyProgramError + = MkApplyProgramError Version Version instance Show ApplyProgramError where - show (MkApplyProgramError v1 v2) = - "Cannot apply two programs together: the first program has version " <> show v1 - <> " but the second program has version " <> show v2 + show (MkApplyProgramError v1 v2) = + "Cannot apply two programs together: the first program has version " + <> show v1 + <> " but the second program has version " + <> show v2 instance Exception ApplyProgramError diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs index a294f1c40e7..0f6a9d45694 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs @@ -1,22 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- editorconfig-checker-disable-file --- | The exceptions that an abstract machine can throw. - -- appears in the generated instances {-# OPTIONS_GHC -Wno-overlapping-patterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Evaluation.Error - ( EvaluationError (..) - ) where +-- | The exceptions that an abstract machine can throw. +module PlutusCore.Evaluation.Error ( + EvaluationError (..), +) where import PlutusPrelude @@ -24,54 +22,58 @@ import Control.Lens import Data.Bifoldable import Data.Bitraversable -{- | The type of errors that can occur during evaluation. There are two kinds of errors: - -1. Structural ones -- these are errors that are indicative of the _structure_ of the program being - wrong. For example, a free variable was encountered during evaluation, a non-function was - applied to an argument or 'tailList' was applied to a non-list. -2. Operational ones -- these are errors that are indicative of the _logic_ of the program being - wrong. For example, 'error' was executed, 'tailList' was applied to an empty list or evaluation - ran out of gas. - -On the chain both of these are just regular failures and we don't distinguish between them there: -if a script fails, it fails, it doesn't matter what the reason was. However in the tests it does -matter why the failure occurred: a structural error may indicate that the test was written -incorrectly while an operational error may be entirely expected. - -In other words, structural errors are \"runtime type errors\" and operational errors are regular -runtime errors. Which means that evaluating an (erased) well-typed program should never produce a -structural error, only an operational one. This creates a sort of \"runtime type system\" for UPLC -and it would be great to stick to it and enforce in tests etc, but we currently don't. --} +-- | The type of errors that can occur during evaluation. There are two kinds of errors: +-- +-- 1. Structural ones -- these are errors that are indicative of the _structure_ of the program being +-- wrong. For example, a free variable was encountered during evaluation, a non-function was +-- applied to an argument or 'tailList' was applied to a non-list. +-- 2. Operational ones -- these are errors that are indicative of the _logic_ of the program being +-- wrong. For example, 'error' was executed, 'tailList' was applied to an empty list or evaluation +-- ran out of gas. +-- +-- On the chain both of these are just regular failures and we don't distinguish between them there: +-- if a script fails, it fails, it doesn't matter what the reason was. However in the tests it does +-- matter why the failure occurred: a structural error may indicate that the test was written +-- incorrectly while an operational error may be entirely expected. +-- +-- In other words, structural errors are \"runtime type errors\" and operational errors are regular +-- runtime errors. Which means that evaluating an (erased) well-typed program should never produce a +-- structural error, only an operational one. This creates a sort of \"runtime type system\" for UPLC +-- and it would be great to stick to it and enforce in tests etc, but we currently don't. data EvaluationError structural operational - = StructuralError !structural - | OperationalError !operational - deriving stock (Show, Eq, Functor, Generic) - deriving anyclass (NFData) + = StructuralError !structural + | OperationalError !operational + deriving stock (Show, Eq, Functor, Generic) + deriving anyclass (NFData) instance Bifunctor EvaluationError where - bimap f _ (StructuralError err) = StructuralError $ f err - bimap _ g (OperationalError err) = OperationalError $ g err - {-# INLINE bimap #-} + bimap f _ (StructuralError err) = StructuralError $ f err + bimap _ g (OperationalError err) = OperationalError $ g err + {-# INLINE bimap #-} instance Bifoldable EvaluationError where - bifoldMap f _ (StructuralError err) = f err - bifoldMap _ g (OperationalError err) = g err - {-# INLINE bifoldMap #-} + bifoldMap f _ (StructuralError err) = f err + bifoldMap _ g (OperationalError err) = g err + {-# INLINE bifoldMap #-} instance Bitraversable EvaluationError where - bitraverse f _ (StructuralError err) = StructuralError <$> f err - bitraverse _ g (OperationalError err) = OperationalError <$> g err - {-# INLINE bitraverse #-} + bitraverse f _ (StructuralError err) = StructuralError <$> f err + bitraverse _ g (OperationalError err) = OperationalError <$> g err + {-# INLINE bitraverse #-} instance - ( HasPrettyDefaults config ~ 'True - , PrettyBy config structural, Pretty operational - ) => PrettyBy config (EvaluationError structural operational) where - prettyBy config (StructuralError structural) = prettyBy config structural - prettyBy _ (OperationalError operational) = pretty operational + ( HasPrettyDefaults config ~ 'True + , PrettyBy config structural + , Pretty operational + ) => + PrettyBy config (EvaluationError structural operational) + where + prettyBy config (StructuralError structural) = prettyBy config structural + prettyBy _ (OperationalError operational) = pretty operational -instance (Pretty structural, Pretty operational) => - Pretty (EvaluationError structural operational) where - pretty (StructuralError structural) = pretty structural - pretty (OperationalError operational) = pretty operational +instance + (Pretty structural, Pretty operational) => + Pretty (EvaluationError structural operational) + where + pretty (StructuralError structural) = pretty structural + pretty (OperationalError operational) = pretty operational diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs index 37d3e5fad89..677b43b7f45 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -module PlutusCore.Evaluation.ErrorWithCause - ( ErrorWithCause (..) - , throwErrorWithCause - ) where +module PlutusCore.Evaluation.ErrorWithCause ( + ErrorWithCause (..), + throwErrorWithCause, +) where import PlutusPrelude @@ -22,40 +22,47 @@ import Prettyprinter -- | An error and (optionally) what caused it. data ErrorWithCause err cause = ErrorWithCause - { _ewcError :: !err - , _ewcCause :: !(Maybe cause) - } deriving stock (Eq, Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData) + { _ewcError :: !err + , _ewcCause :: !(Maybe cause) + } + deriving stock (Eq, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData) instance Bifunctor ErrorWithCause where - bimap f g (ErrorWithCause err cause) = ErrorWithCause (f err) (g <$> cause) - {-# INLINE bimap #-} + bimap f g (ErrorWithCause err cause) = ErrorWithCause (f err) (g <$> cause) + {-# INLINE bimap #-} instance (Pretty err, Pretty cause) => Pretty (ErrorWithCause err cause) where - pretty (ErrorWithCause e c) = pretty e <+> "caused by:" <+> pretty c - -instance (PrettyBy config cause, PrettyBy config err) => - PrettyBy config (ErrorWithCause err cause) where - prettyBy config (ErrorWithCause err mayCause) = fold - [ "An error has occurred:" - , hardline - , prettyBy config err - , case mayCause of - Nothing -> mempty - Just cause -> hardline <> "Caused by:" <+> prettyBy config cause - ] - -instance (PrettyPlc cause, PrettyPlc err) => - Show (ErrorWithCause err cause) where - show = render . prettyPlcReadable - -deriving anyclass instance (PrettyPlc cause, PrettyPlc err, Typeable cause, Typeable err) => - Exception (ErrorWithCause err cause) - -throwErrorWithCause - :: MonadError (ErrorWithCause e cause) m - => e - -> cause - -> m x + pretty (ErrorWithCause e c) = pretty e <+> "caused by:" <+> pretty c + +instance + (PrettyBy config cause, PrettyBy config err) => + PrettyBy config (ErrorWithCause err cause) + where + prettyBy config (ErrorWithCause err mayCause) = + fold + [ "An error has occurred:" + , hardline + , prettyBy config err + , case mayCause of + Nothing -> mempty + Just cause -> hardline <> "Caused by:" <+> prettyBy config cause + ] + +instance + (PrettyPlc cause, PrettyPlc err) => + Show (ErrorWithCause err cause) + where + show = render . prettyPlcReadable + +deriving anyclass instance + (PrettyPlc cause, PrettyPlc err, Typeable cause, Typeable err) => + Exception (ErrorWithCause err cause) + +throwErrorWithCause :: + MonadError (ErrorWithCause e cause) m => + e -> + cause -> + m x throwErrorWithCause e = throwError . ErrorWithCause e . Just {-# INLINE throwErrorWithCause #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs index 9cb77e0bb64..5ca4c7b29e7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs @@ -1,56 +1,55 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE StrictData #-} -- So that we don't spend a lot of time optimizing loads of Core whose performance doesn't matter. -{-# OPTIONS_GHC -O0 #-} +{-# OPTIONS_GHC -O0 #-} -module PlutusCore.Evaluation.Machine.BuiltinCostModel - ( BuiltinCostModel - , BuiltinCostModelBase(..) - , CostingFun(..) - , UnimplementedCostingFun(..) - , Intercept(..) - , Slope(..) - , Coefficient0(..) - , Coefficient1(..) - , Coefficient2(..) - , Coefficient00(..) - , Coefficient10(..) - , Coefficient01(..) - , Coefficient20(..) - , Coefficient11(..) - , Coefficient02(..) - , Coefficient12(..) - , OneVariableLinearFunction(..) - , OneVariableQuadraticFunction(..) - , TwoVariableLinearFunction(..) - , TwoVariableQuadraticFunction(..) - , ExpModCostingFunction(..) - , ModelSubtractedSizes(..) - , ModelConstantOrOneArgument(..) - , ModelConstantOrTwoArguments(..) - , ModelConstantOrLinear(..) -- Deprecated: see Note [Backward compatibility for costing functions] - , ModelOneArgument(..) - , ModelTwoArguments(..) - , ModelThreeArguments(..) - , ModelFourArguments(..) - , ModelFiveArguments(..) - , ModelSixArguments(..) - , runCostingFunOneArgument - , runCostingFunTwoArguments - , runCostingFunThreeArguments - , runCostingFunFourArguments - , runCostingFunFiveArguments - , runCostingFunSixArguments - , Hashable - , MCostingFun (..) - ) +module PlutusCore.Evaluation.Machine.BuiltinCostModel ( + BuiltinCostModel, + BuiltinCostModelBase (..), + CostingFun (..), + UnimplementedCostingFun (..), + Intercept (..), + Slope (..), + Coefficient0 (..), + Coefficient1 (..), + Coefficient2 (..), + Coefficient00 (..), + Coefficient10 (..), + Coefficient01 (..), + Coefficient20 (..), + Coefficient11 (..), + Coefficient02 (..), + Coefficient12 (..), + OneVariableLinearFunction (..), + OneVariableQuadraticFunction (..), + TwoVariableLinearFunction (..), + TwoVariableQuadraticFunction (..), + ExpModCostingFunction (..), + ModelSubtractedSizes (..), + ModelConstantOrOneArgument (..), + ModelConstantOrTwoArguments (..), + ModelConstantOrLinear (..), -- Deprecated: see Note [Backward compatibility for costing functions] + ModelOneArgument (..), + ModelTwoArguments (..), + ModelThreeArguments (..), + ModelFourArguments (..), + ModelFiveArguments (..), + ModelSixArguments (..), + runCostingFunOneArgument, + runCostingFunTwoArguments, + runCostingFunThreeArguments, + runCostingFunFourArguments, + runCostingFunFiveArguments, + runCostingFunSixArguments, + Hashable, + MCostingFun (..), +) where import PlutusPrelude hiding (toList) @@ -78,152 +77,163 @@ type BuiltinCostModel = BuiltinCostModelBase CostingFun -- | The main model which contains all data required to predict the cost of -- builtin functions. See 'CostModelGeneration.md' for how this is -- generated. Calibrated for the CEK machine. +data BuiltinCostModelBase f + = BuiltinCostModelBase + { -- Integers + paramAddInteger :: f ModelTwoArguments + , paramSubtractInteger :: f ModelTwoArguments + , paramMultiplyInteger :: f ModelTwoArguments + , paramDivideInteger :: f ModelTwoArguments + , paramQuotientInteger :: f ModelTwoArguments + , paramRemainderInteger :: f ModelTwoArguments + , paramModInteger :: f ModelTwoArguments + , paramEqualsInteger :: f ModelTwoArguments + , paramLessThanInteger :: f ModelTwoArguments + , paramLessThanEqualsInteger :: f ModelTwoArguments + , -- Bytestrings + paramAppendByteString :: f ModelTwoArguments + , paramConsByteString :: f ModelTwoArguments + , paramSliceByteString :: f ModelThreeArguments + , paramLengthOfByteString :: f ModelOneArgument + , paramIndexByteString :: f ModelTwoArguments + , paramEqualsByteString :: f ModelTwoArguments + , paramLessThanByteString :: f ModelTwoArguments + , paramLessThanEqualsByteString :: f ModelTwoArguments + , -- Cryptography and hashes + paramSha2_256 :: f ModelOneArgument + , paramSha3_256 :: f ModelOneArgument + , paramBlake2b_256 :: f ModelOneArgument + , paramVerifyEd25519Signature :: f ModelThreeArguments + , paramVerifyEcdsaSecp256k1Signature :: f ModelThreeArguments + , paramVerifySchnorrSecp256k1Signature :: f ModelThreeArguments + , -- Strings + paramAppendString :: f ModelTwoArguments + , paramEqualsString :: f ModelTwoArguments + , paramEncodeUtf8 :: f ModelOneArgument + , paramDecodeUtf8 :: f ModelOneArgument + , -- Bool + paramIfThenElse :: f ModelThreeArguments + , -- Unit + paramChooseUnit :: f ModelTwoArguments + , -- Tracing + paramTrace :: f ModelTwoArguments + , -- Pairs + paramFstPair :: f ModelOneArgument + , paramSndPair :: f ModelOneArgument + , -- Lists + paramChooseList :: f ModelThreeArguments + , paramMkCons :: f ModelTwoArguments + , paramHeadList :: f ModelOneArgument + , paramTailList :: f ModelOneArgument + , paramNullList :: f ModelOneArgument + , -- Data + paramChooseData :: f ModelSixArguments + , paramConstrData :: f ModelTwoArguments + , paramMapData :: f ModelOneArgument + , paramListData :: f ModelOneArgument + , paramIData :: f ModelOneArgument + , paramBData :: f ModelOneArgument + , paramUnConstrData :: f ModelOneArgument + , paramUnMapData :: f ModelOneArgument + , paramUnListData :: f ModelOneArgument + , paramUnIData :: f ModelOneArgument + , paramUnBData :: f ModelOneArgument + , paramEqualsData :: f ModelTwoArguments + , -- Misc constructors + paramMkPairData :: f ModelTwoArguments + , paramMkNilData :: f ModelOneArgument + , paramMkNilPairData :: f ModelOneArgument + , paramSerialiseData :: f ModelOneArgument + , -- BLS12-381 + paramBls12_381_G1_add :: f ModelTwoArguments + , paramBls12_381_G1_neg :: f ModelOneArgument + , paramBls12_381_G1_scalarMul :: f ModelTwoArguments + , paramBls12_381_G1_multiScalarMul :: f ModelTwoArguments + , paramBls12_381_G1_equal :: f ModelTwoArguments + , paramBls12_381_G1_compress :: f ModelOneArgument + , paramBls12_381_G1_uncompress :: f ModelOneArgument + , paramBls12_381_G1_hashToGroup :: f ModelTwoArguments + , paramBls12_381_G2_add :: f ModelTwoArguments + , paramBls12_381_G2_neg :: f ModelOneArgument + , paramBls12_381_G2_scalarMul :: f ModelTwoArguments + , paramBls12_381_G2_equal :: f ModelTwoArguments + , paramBls12_381_G2_multiScalarMul :: f ModelTwoArguments + , paramBls12_381_G2_compress :: f ModelOneArgument + , paramBls12_381_G2_uncompress :: f ModelOneArgument + , paramBls12_381_G2_hashToGroup :: f ModelTwoArguments + , paramBls12_381_millerLoop :: f ModelTwoArguments + , paramBls12_381_mulMlResult :: f ModelTwoArguments + , paramBls12_381_finalVerify :: f ModelTwoArguments + , -- Keccak_256, Blake2b_224 + paramKeccak_256 :: f ModelOneArgument + , paramBlake2b_224 :: f ModelOneArgument + , -- Bitwise operations + paramIntegerToByteString :: f ModelThreeArguments + , paramByteStringToInteger :: f ModelTwoArguments + , paramAndByteString :: f ModelThreeArguments + , paramOrByteString :: f ModelThreeArguments + , paramXorByteString :: f ModelThreeArguments + , paramComplementByteString :: f ModelOneArgument + , paramReadBit :: f ModelTwoArguments + , paramWriteBits :: f ModelThreeArguments + , paramReplicateByte :: f ModelTwoArguments + , paramShiftByteString :: f ModelTwoArguments + , paramRotateByteString :: f ModelTwoArguments + , paramCountSetBits :: f ModelOneArgument + , paramFindFirstSetBit :: f ModelOneArgument + , -- Ripemd_160 + paramRipemd_160 :: f ModelOneArgument + , -- Batch 6 + paramExpModInteger :: f ModelThreeArguments + , paramDropList :: f ModelTwoArguments + , -- Arrays + paramLengthOfArray :: f ModelOneArgument + , paramListToArray :: f ModelOneArgument + , paramIndexArray :: f ModelTwoArguments + } + deriving stock (Generic) + deriving anyclass (FunctorB, TraversableB, ConstraintsB) -data BuiltinCostModelBase f = - BuiltinCostModelBase - { - -- Integers - paramAddInteger :: f ModelTwoArguments - , paramSubtractInteger :: f ModelTwoArguments - , paramMultiplyInteger :: f ModelTwoArguments - , paramDivideInteger :: f ModelTwoArguments - , paramQuotientInteger :: f ModelTwoArguments - , paramRemainderInteger :: f ModelTwoArguments - , paramModInteger :: f ModelTwoArguments - , paramEqualsInteger :: f ModelTwoArguments - , paramLessThanInteger :: f ModelTwoArguments - , paramLessThanEqualsInteger :: f ModelTwoArguments - -- Bytestrings - , paramAppendByteString :: f ModelTwoArguments - , paramConsByteString :: f ModelTwoArguments - , paramSliceByteString :: f ModelThreeArguments - , paramLengthOfByteString :: f ModelOneArgument - , paramIndexByteString :: f ModelTwoArguments - , paramEqualsByteString :: f ModelTwoArguments - , paramLessThanByteString :: f ModelTwoArguments - , paramLessThanEqualsByteString :: f ModelTwoArguments - -- Cryptography and hashes - , paramSha2_256 :: f ModelOneArgument - , paramSha3_256 :: f ModelOneArgument - , paramBlake2b_256 :: f ModelOneArgument - , paramVerifyEd25519Signature :: f ModelThreeArguments - , paramVerifyEcdsaSecp256k1Signature :: f ModelThreeArguments - , paramVerifySchnorrSecp256k1Signature :: f ModelThreeArguments - -- Strings - , paramAppendString :: f ModelTwoArguments - , paramEqualsString :: f ModelTwoArguments - , paramEncodeUtf8 :: f ModelOneArgument - , paramDecodeUtf8 :: f ModelOneArgument - -- Bool - , paramIfThenElse :: f ModelThreeArguments - -- Unit - , paramChooseUnit :: f ModelTwoArguments - -- Tracing - , paramTrace :: f ModelTwoArguments - -- Pairs - , paramFstPair :: f ModelOneArgument - , paramSndPair :: f ModelOneArgument - -- Lists - , paramChooseList :: f ModelThreeArguments - , paramMkCons :: f ModelTwoArguments - , paramHeadList :: f ModelOneArgument - , paramTailList :: f ModelOneArgument - , paramNullList :: f ModelOneArgument - -- Data - , paramChooseData :: f ModelSixArguments - , paramConstrData :: f ModelTwoArguments - , paramMapData :: f ModelOneArgument - , paramListData :: f ModelOneArgument - , paramIData :: f ModelOneArgument - , paramBData :: f ModelOneArgument - , paramUnConstrData :: f ModelOneArgument - , paramUnMapData :: f ModelOneArgument - , paramUnListData :: f ModelOneArgument - , paramUnIData :: f ModelOneArgument - , paramUnBData :: f ModelOneArgument - , paramEqualsData :: f ModelTwoArguments - -- Misc constructors - , paramMkPairData :: f ModelTwoArguments - , paramMkNilData :: f ModelOneArgument - , paramMkNilPairData :: f ModelOneArgument - , paramSerialiseData :: f ModelOneArgument - -- BLS12-381 - , paramBls12_381_G1_add :: f ModelTwoArguments - , paramBls12_381_G1_neg :: f ModelOneArgument - , paramBls12_381_G1_scalarMul :: f ModelTwoArguments - , paramBls12_381_G1_multiScalarMul :: f ModelTwoArguments - , paramBls12_381_G1_equal :: f ModelTwoArguments - , paramBls12_381_G1_compress :: f ModelOneArgument - , paramBls12_381_G1_uncompress :: f ModelOneArgument - , paramBls12_381_G1_hashToGroup :: f ModelTwoArguments - , paramBls12_381_G2_add :: f ModelTwoArguments - , paramBls12_381_G2_neg :: f ModelOneArgument - , paramBls12_381_G2_scalarMul :: f ModelTwoArguments - , paramBls12_381_G2_equal :: f ModelTwoArguments - , paramBls12_381_G2_multiScalarMul :: f ModelTwoArguments - , paramBls12_381_G2_compress :: f ModelOneArgument - , paramBls12_381_G2_uncompress :: f ModelOneArgument - , paramBls12_381_G2_hashToGroup :: f ModelTwoArguments - , paramBls12_381_millerLoop :: f ModelTwoArguments - , paramBls12_381_mulMlResult :: f ModelTwoArguments - , paramBls12_381_finalVerify :: f ModelTwoArguments - -- Keccak_256, Blake2b_224 - , paramKeccak_256 :: f ModelOneArgument - , paramBlake2b_224 :: f ModelOneArgument - -- Bitwise operations - , paramIntegerToByteString :: f ModelThreeArguments - , paramByteStringToInteger :: f ModelTwoArguments - , paramAndByteString :: f ModelThreeArguments - , paramOrByteString :: f ModelThreeArguments - , paramXorByteString :: f ModelThreeArguments - , paramComplementByteString :: f ModelOneArgument - , paramReadBit :: f ModelTwoArguments - , paramWriteBits :: f ModelThreeArguments - , paramReplicateByte :: f ModelTwoArguments - , paramShiftByteString :: f ModelTwoArguments - , paramRotateByteString :: f ModelTwoArguments - , paramCountSetBits :: f ModelOneArgument - , paramFindFirstSetBit :: f ModelOneArgument - -- Ripemd_160 - , paramRipemd_160 :: f ModelOneArgument - -- Batch 6 - , paramExpModInteger :: f ModelThreeArguments - , paramDropList :: f ModelTwoArguments - -- Arrays - , paramLengthOfArray :: f ModelOneArgument - , paramListToArray :: f ModelOneArgument - , paramIndexArray :: f ModelTwoArguments - } - deriving stock (Generic) - deriving anyclass (FunctorB, TraversableB, ConstraintsB) - -deriving via CustomJSON '[FieldLabelModifier (StripPrefix "param", LowerInitialCharacter)] - (BuiltinCostModelBase CostingFun) instance ToJSON (BuiltinCostModelBase CostingFun) -deriving via CustomJSON '[FieldLabelModifier (StripPrefix "param", LowerInitialCharacter)] - (BuiltinCostModelBase CostingFun) instance FromJSON (BuiltinCostModelBase CostingFun) +deriving via + CustomJSON + '[FieldLabelModifier (StripPrefix "param", LowerInitialCharacter)] + (BuiltinCostModelBase CostingFun) + instance + ToJSON (BuiltinCostModelBase CostingFun) +deriving via + CustomJSON + '[FieldLabelModifier (StripPrefix "param", LowerInitialCharacter)] + (BuiltinCostModelBase CostingFun) + instance + FromJSON (BuiltinCostModelBase CostingFun) -- | Same as 'CostingFun' but maybe missing. -- We could use 'Compose Maybe CostinFun' instead but we would then need an orphan ToJSON instance. newtype MCostingFun a = MCostingFun (Maybe (CostingFun a)) - deriving newtype (ToJSON) - deriving (Semigroup, Monoid) via (Alt Maybe (CostingFun a)) -- for mempty == MCostingFun Nothing + deriving newtype (ToJSON) + deriving (Semigroup, Monoid) via (Alt Maybe (CostingFun a)) -- for mempty == MCostingFun Nothing -- Omit generating JSON for any costing functions that have not been set (are missing). -deriving via CustomJSON '[OmitNothingFields, FieldLabelModifier (StripPrefix "param", LowerInitialCharacter)] - (BuiltinCostModelBase MCostingFun) instance ToJSON (BuiltinCostModelBase MCostingFun) +deriving via + CustomJSON + '[OmitNothingFields, FieldLabelModifier (StripPrefix "param", LowerInitialCharacter)] + (BuiltinCostModelBase MCostingFun) + instance + ToJSON (BuiltinCostModelBase MCostingFun) -- Needed to help derive various instances for BuiltinCostModelBase type AllArgumentModels (constraint :: Kind.Type -> Kind.Constraint) f = - ( constraint (f ModelOneArgument) - , constraint (f ModelTwoArguments) - , constraint (f ModelThreeArguments) - , constraint (f ModelFourArguments) - , constraint (f ModelFiveArguments) - , constraint (f ModelSixArguments)) + ( constraint (f ModelOneArgument) + , constraint (f ModelTwoArguments) + , constraint (f ModelThreeArguments) + , constraint (f ModelFourArguments) + , constraint (f ModelFiveArguments) + , constraint (f ModelSixArguments) + ) -- HLS doesn't like the AllBF from Barbies. -deriving anyclass instance AllArgumentModels NFData f => NFData (BuiltinCostModelBase f) +deriving anyclass instance AllArgumentModels NFData f => NFData (BuiltinCostModelBase f) deriving anyclass instance AllArgumentModels Default f => Default (BuiltinCostModelBase f) -deriving stock instance AllArgumentModels Lift f => Lift (BuiltinCostModelBase f) -deriving stock instance AllArgumentModels Show f => Show (BuiltinCostModelBase f) -deriving stock instance AllArgumentModels Eq f => Eq (BuiltinCostModelBase f) +deriving stock instance AllArgumentModels Lift f => Lift (BuiltinCostModelBase f) +deriving stock instance AllArgumentModels Show f => Show (BuiltinCostModelBase f) +deriving stock instance AllArgumentModels Eq f => Eq (BuiltinCostModelBase f) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs index 21094d2af37..f749fb3e1ca 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs @@ -1,36 +1,35 @@ -- editorconfig-checker-disable-file --- | The CK machine. - -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Evaluation.Machine.Ck - ( EvaluationResult (..) - , CkEvaluationException - , CkM - , CkValue - , runCk - , splitStructuralOperational - , unsafeSplitStructuralOperational - , evaluateCk - , evaluateCkNoEmit - , readKnownCk - ) where +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | The CK machine. +module PlutusCore.Evaluation.Machine.Ck ( + EvaluationResult (..), + CkEvaluationException, + CkM, + CkValue, + runCk, + splitStructuralOperational, + unsafeSplitStructuralOperational, + evaluateCk, + evaluateCkNoEmit, + readKnownCk, +) where import PlutusPrelude import PlutusCore.Builtin import PlutusCore.Core -import PlutusCore.Evaluation.Machine.Exception import PlutusCore.Evaluation.Machine.ExMemoryUsage +import PlutusCore.Evaluation.Machine.Exception import PlutusCore.Evaluation.Result import PlutusCore.Name.Unique import PlutusCore.Pretty @@ -55,60 +54,66 @@ infix 4 |>, <| -- See Note [Show instance for BuiltinRuntime] in the CEK machine. instance Show (BuiltinRuntime (CkValue uni fun)) where - show _ = "" + show _ = "" -data CkValue uni fun = - VCon (Some (ValueOf uni)) +data CkValue uni fun + = VCon (Some (ValueOf uni)) | VTyAbs TyName (Kind ()) (Term TyName Name uni fun ()) | VLamAbs Name (Type TyName uni ()) (Term TyName Name uni fun ()) | VIWrap (Type TyName uni ()) (Type TyName uni ()) (CkValue uni fun) | VBuiltin (Term TyName Name uni fun ()) (BuiltinRuntime (CkValue uni fun)) | VConstr (Type TyName uni ()) Word64 [CkValue uni fun] -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Closed uni) - => Show (CkValue uni fun) +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Closed uni) => + Show (CkValue uni fun) ckValueToTerm :: CkValue uni fun -> Term TyName Name uni fun () ckValueToTerm = \case - VCon val -> Constant () val - VTyAbs tn k body -> TyAbs () tn k body - VLamAbs name ty body -> LamAbs () name ty body - VIWrap ty1 ty2 val -> IWrap () ty1 ty2 $ ckValueToTerm val - VBuiltin term _ -> term - VConstr ty i es -> Constr () ty i (fmap ckValueToTerm es) + VCon val -> Constant () val + VTyAbs tn k body -> TyAbs () tn k body + VLamAbs name ty body -> LamAbs () name ty body + VIWrap ty1 ty2 val -> IWrap () ty1 ty2 $ ckValueToTerm val + VBuiltin term _ -> term + VConstr ty i es -> Constr () ty i (fmap ckValueToTerm es) data CkEnv uni fun s = CkEnv - { ckEnvRuntime :: BuiltinsRuntime fun (CkValue uni fun) - , ckCaserBuiltin :: CaserBuiltin uni - -- 'Nothing' means no logging. 'DList' is due to the fact that we need efficient append + { ckEnvRuntime :: BuiltinsRuntime fun (CkValue uni fun) + , ckCaserBuiltin :: CaserBuiltin uni + , -- 'Nothing' means no logging. 'DList' is due to the fact that we need efficient append -- as we store logs as "latest go last". - , ckEnvMayEmitRef :: Maybe (STRef s (DList Text)) - } + ckEnvMayEmitRef :: Maybe (STRef s (DList Text)) + } instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (CkValue uni fun) where - prettyBy cfg = prettyBy cfg . ckValueToTerm + prettyBy cfg = prettyBy cfg . ckValueToTerm data CkUserError - = CkCaseBuiltinError Text -- ^ 'Case' over a value of a built-in type failed. - | CkEvaluationFailure -- Error has been called or a builtin application has failed - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) + = -- | 'Case' over a value of a built-in type failed. + CkCaseBuiltinError Text + | CkEvaluationFailure -- Error has been called or a builtin application has failed + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) -- | The CK machine-specific 'EvaluationException'. type CkEvaluationException uni fun = - EvaluationException (MachineError fun) CkUserError (Term TyName Name uni fun ()) + EvaluationException (MachineError fun) CkUserError (Term TyName Name uni fun ()) type CkM uni fun s = - ReaderT (CkEnv uni fun s) - (ExceptT (CkEvaluationException uni fun) - (ST s)) + ReaderT + (CkEnv uni fun s) + ( ExceptT + (CkEvaluationException uni fun) + (ST s) + ) instance Pretty CkUserError where - pretty (CkCaseBuiltinError err) = vcat - [ "'case' over a value of a built-in type failed with" - , pretty err - ] - pretty CkEvaluationFailure = "The provided Plutus code called 'error'." + pretty (CkCaseBuiltinError err) = + vcat + [ "'case' over a value of a built-in type failed with" + , pretty err + ] + pretty CkEvaluationFailure = "The provided Plutus code called 'error'." instance BuiltinErrorToEvaluationError (MachineError fun) CkUserError where builtinErrorToEvaluationError (BuiltinUnliftingEvaluationError err) = @@ -120,54 +125,62 @@ instance BuiltinErrorToEvaluationError (MachineError fun) CkUserError where -- The 'DList' is just be consistent with the CEK machine (see Note [DList-based emitting]). emitCkM :: DList Text -> CkM uni fun s () emitCkM logs = do - mayLogsRef <- asks ckEnvMayEmitRef - case mayLogsRef of - Nothing -> pure () - Just logsRef -> lift . lift $ modifySTRef logsRef (`DList.append` logs) + mayLogsRef <- asks ckEnvMayEmitRef + case mayLogsRef of + Nothing -> pure () + Just logsRef -> lift . lift $ modifySTRef logsRef (`DList.append` logs) type instance UniOf (CkValue uni fun) = uni instance HasConstant (CkValue uni fun) where - asConstant (VCon val) = pure val - asConstant _ = throwError notAConstant + asConstant (VCon val) = pure val + asConstant _ = throwError notAConstant - fromConstant = VCon + fromConstant = VCon data Frame uni fun - = FrameAwaitArg (CkValue uni fun) -- ^ @[V _]@ - | FrameAwaitFunTerm (Term TyName Name uni fun ()) -- ^ @[_ N]@ - | FrameAwaitFunValue (CkValue uni fun) -- ^ @[_ V]@ - | FrameTyInstArg (Type TyName uni ()) -- ^ @{_ A}@ - | FrameUnwrap -- ^ @(unwrap _)@ - | FrameIWrap (Type TyName uni ()) (Type TyName uni ()) -- ^ @(iwrap A B _)@ - | FrameConstr (Type TyName uni ()) Word64 [Term TyName Name uni fun ()] [CkValue uni fun] - | FrameCase [Term TyName Name uni fun ()] - -deriving stock instance (GShow uni, Closed uni, uni `Everywhere` Show, Show fun) => - Show (Frame uni fun) + = -- | @[V _]@ + FrameAwaitArg (CkValue uni fun) + | -- | @[_ N]@ + FrameAwaitFunTerm (Term TyName Name uni fun ()) + | -- | @[_ V]@ + FrameAwaitFunValue (CkValue uni fun) + | -- | @{_ A}@ + FrameTyInstArg (Type TyName uni ()) + | -- | @(unwrap _)@ + FrameUnwrap + | -- | @(iwrap A B _)@ + FrameIWrap (Type TyName uni ()) (Type TyName uni ()) + | FrameConstr (Type TyName uni ()) Word64 [Term TyName Name uni fun ()] [CkValue uni fun] + | FrameCase [Term TyName Name uni fun ()] + +deriving stock instance + (GShow uni, Closed uni, uni `Everywhere` Show, Show fun) => + Show (Frame uni fun) type Context uni fun = [Frame uni fun] -- See Note [ExMemoryUsage instances for non-constants]. instance ExMemoryUsage (CkValue uni fun) where - memoryUsage = error "Internal error: 'memoryUsage' for 'CkValue' is not supposed to be forced" - -runCkM - :: BuiltinsRuntime fun (CkValue uni fun) - -> CaserBuiltin uni - -> Bool - -> (forall s. CkM uni fun s a) - -> (Either (CkEvaluationException uni fun) a, [Text]) + memoryUsage = error "Internal error: 'memoryUsage' for 'CkValue' is not supposed to be forced" + +runCkM :: + BuiltinsRuntime fun (CkValue uni fun) -> + CaserBuiltin uni -> + Bool -> + (forall s. CkM uni fun s a) -> + (Either (CkEvaluationException uni fun) a, [Text]) runCkM runtime caser emitting a = runST $ do - mayLogsRef <- if emitting then Just <$> newSTRef DList.empty else pure Nothing - errOrRes <- runExceptT . runReaderT a $ CkEnv runtime caser mayLogsRef - logs <- case mayLogsRef of - Nothing -> pure [] - Just logsRef -> DList.toList <$> readSTRef logsRef - pure (errOrRes, logs) + mayLogsRef <- if emitting then Just <$> newSTRef DList.empty else pure Nothing + errOrRes <- runExceptT . runReaderT a $ CkEnv runtime caser mayLogsRef + logs <- case mayLogsRef of + Nothing -> pure [] + Just logsRef -> DList.toList <$> readSTRef logsRef + pure (errOrRes, logs) -- FIXME: make sure that the specification is up to date and that this matches. -- Tracked by https://github.com/IntersectMBO/plutus-private/issues/1552. + -- | The computing part of the CK machine. Rules are as follows: -- -- > s ▷ {M A} ↦ s , {_ A} ▷ M @@ -181,29 +194,30 @@ runCkM runtime caser emitting a = runST $ do -- > s ▻ constr I T0 .. Tn ↦ s , (constr I _ T1 Tn) ▻ T0 -- > s ▻ case S C0 ... Cn ↦ s , (case _ C0 ... Cn) ▻ S -- > s ▷ error A ↦ ◆ -(|>) - :: Context uni fun -> Term TyName Name uni fun () -> CkM uni fun s (Term TyName Name uni fun ()) -stack |> TyInst _ fun ty = FrameTyInstArg ty : stack |> fun -stack |> Apply _ fun arg = FrameAwaitFunTerm arg : stack |> fun -stack |> IWrap _ pat arg term = FrameIWrap pat arg : stack |> term -stack |> Unwrap _ term = FrameUnwrap : stack |> term -stack |> TyAbs _ tn k term = stack <| VTyAbs tn k term -stack |> LamAbs _ name ty body = stack <| VLamAbs name ty body -stack |> Builtin _ bn = do - runtime <- lookupBuiltin bn . ckEnvRuntime <$> ask - stack <| VBuiltin (Builtin () bn) runtime -stack |> Constant _ val = stack <| VCon val -stack |> Constr _ ty i es = case es of - [] -> stack <| VConstr ty i [] - t : ts -> FrameConstr ty i ts [] : stack |> t -stack |> Case _ _ arg cs = FrameCase cs : stack |> arg -_ |> err@Error{} = - throwErrorWithCause (OperationalError CkEvaluationFailure) $ void err -_ |> var@Var{} = - throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) var +(|>) :: + Context uni fun -> Term TyName Name uni fun () -> CkM uni fun s (Term TyName Name uni fun ()) +stack |> TyInst _ fun ty = FrameTyInstArg ty : stack |> fun +stack |> Apply _ fun arg = FrameAwaitFunTerm arg : stack |> fun +stack |> IWrap _ pat arg term = FrameIWrap pat arg : stack |> term +stack |> Unwrap _ term = FrameUnwrap : stack |> term +stack |> TyAbs _ tn k term = stack <| VTyAbs tn k term +stack |> LamAbs _ name ty body = stack <| VLamAbs name ty body +stack |> Builtin _ bn = do + runtime <- lookupBuiltin bn . ckEnvRuntime <$> ask + stack <| VBuiltin (Builtin () bn) runtime +stack |> Constant _ val = stack <| VCon val +stack |> Constr _ ty i es = case es of + [] -> stack <| VConstr ty i [] + t : ts -> FrameConstr ty i ts [] : stack |> t +stack |> Case _ _ arg cs = FrameCase cs : stack |> arg +_ |> err@Error {} = + throwErrorWithCause (OperationalError CkEvaluationFailure) $ void err +_ |> var@Var {} = + throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) var -- FIXME: make sure that the specification is up to date and that this matches. -- Tracked by https://github.com/IntersectMBO/plutus-private/issues/1552. + -- | The returning part of the CK machine. Rules are as follows: -- -- > s , {_ A} ◁ abs α K M ↦ s ▷ {A/α}M @@ -217,39 +231,39 @@ _ |> var@Var{} = -- > s , (unwrap _) ◁ wrap α A V ↦ s ◁ V -- > s , (constr I V0 ... Vj-1 _ Tj+1 ... Tn) ◅ Vj ↦ s , (constr i V0 ... Vj _ Tj+2... Tn) ▻ Tj+1 -- > s , (case _ C0 ... CN) ◅ (constr i V1 .. Vm) ↦ s , [_ V1 ... Vm] ▻ Ci -(<|) - :: Context uni fun -> CkValue uni fun -> CkM uni fun s (Term TyName Name uni fun ()) -[] <| val = pure $ ckValueToTerm val -FrameTyInstArg ty : stack <| fun = instantiateEvaluate stack ty fun -FrameAwaitFunTerm arg : stack <| fun = FrameAwaitArg fun : stack |> arg -FrameAwaitArg fun : stack <| arg = applyEvaluate stack fun arg +(<|) :: + Context uni fun -> CkValue uni fun -> CkM uni fun s (Term TyName Name uni fun ()) +[] <| val = pure $ ckValueToTerm val +FrameTyInstArg ty : stack <| fun = instantiateEvaluate stack ty fun +FrameAwaitFunTerm arg : stack <| fun = FrameAwaitArg fun : stack |> arg +FrameAwaitArg fun : stack <| arg = applyEvaluate stack fun arg FrameAwaitFunValue arg : stack <| fun = applyEvaluate stack fun arg -FrameIWrap pat arg : stack <| value = stack <| VIWrap pat arg value -FrameUnwrap : stack <| wrapped = case wrapped of - VIWrap _ _ term -> stack <| term - _ -> - throwErrorWithCause (StructuralError NonWrapUnwrappedMachineError) $ ckValueToTerm wrapped +FrameIWrap pat arg : stack <| value = stack <| VIWrap pat arg value +FrameUnwrap : stack <| wrapped = case wrapped of + VIWrap _ _ term -> stack <| term + _ -> + throwErrorWithCause (StructuralError NonWrapUnwrappedMachineError) $ ckValueToTerm wrapped FrameConstr ty i todo done : stack <| e = - let done' = e:done - in case todo of + let done' = e : done + in case todo of t : ts -> FrameConstr ty i ts done' : stack |> t - [] -> stack <| VConstr ty i (reverse done') + [] -> stack <| VConstr ty i (reverse done') FrameCase cs : stack <| e = case e of - VConstr _ i args -> case cs ^? wix i of - Just t -> go (reverse args) stack |> t - where - go [] s = s - go (arg:rest) s = go rest (FrameAwaitFunValue arg : s) - Nothing -> - throwErrorWithCause (StructuralError $ MissingCaseBranchMachineError i) $ ckValueToTerm e - VCon val -> do - caser <- asks ckCaserBuiltin - case unCaserBuiltin caser val $ Vector.fromList cs of - Left err -> - throwErrorWithCause (OperationalError $ CkCaseBuiltinError err) $ ckValueToTerm e - Right (HeadOnly fX) -> stack |> fX - Right (HeadSpine f xs) -> transferConstantSpine xs stack |> f - _ -> throwErrorWithCause (StructuralError NonConstrScrutinizedMachineError) $ ckValueToTerm e + VConstr _ i args -> case cs ^? wix i of + Just t -> go (reverse args) stack |> t + where + go [] s = s + go (arg : rest) s = go rest (FrameAwaitFunValue arg : s) + Nothing -> + throwErrorWithCause (StructuralError $ MissingCaseBranchMachineError i) $ ckValueToTerm e + VCon val -> do + caser <- asks ckCaserBuiltin + case unCaserBuiltin caser val $ Vector.fromList cs of + Left err -> + throwErrorWithCause (OperationalError $ CkCaseBuiltinError err) $ ckValueToTerm e + Right (HeadOnly fX) -> stack |> fX + Right (HeadSpine f xs) -> transferConstantSpine xs stack |> f + _ -> throwErrorWithCause (StructuralError NonConstrScrutinizedMachineError) $ ckValueToTerm e transferConstantSpine :: Spine (Some (ValueOf uni)) -> Context uni fun -> Context uni fun transferConstantSpine args ctx = foldr ((:) . FrameAwaitFunValue . VCon) ctx args @@ -261,96 +275,96 @@ transferConstantSpine args ctx = foldr ((:) . FrameAwaitFunValue . VCon) ctx arg -- - or create a partial builtin application otherwise -- -- and proceed with the returning phase of the CK machine. -evalBuiltinApp - :: Context uni fun - -> Term TyName Name uni fun () - -> BuiltinRuntime (CkValue uni fun) - -> CkM uni fun s (Term TyName Name uni fun ()) +evalBuiltinApp :: + Context uni fun -> + Term TyName Name uni fun () -> + BuiltinRuntime (CkValue uni fun) -> + CkM uni fun s (Term TyName Name uni fun ()) evalBuiltinApp stack term runtime = case runtime of - BuiltinCostedResult _ getFXs -> case getFXs of - BuiltinSuccess y -> stack <| y - BuiltinSuccessWithLogs logs y -> emitCkM logs *> (stack <| y) - BuiltinFailure logs err -> emitCkM logs *> throwBuiltinErrorWithCause term err - _ -> stack <| VBuiltin term runtime + BuiltinCostedResult _ getFXs -> case getFXs of + BuiltinSuccess y -> stack <| y + BuiltinSuccessWithLogs logs y -> emitCkM logs *> (stack <| y) + BuiltinFailure logs err -> emitCkM logs *> throwBuiltinErrorWithCause term err + _ -> stack <| VBuiltin term runtime -- | Instantiate a term with a type and proceed. -- In case of 'TyAbs' just ignore the type. Otherwise check if the term is builtin application -- expecting a type argument, in which case either calculate the builtin application or stick a -- 'TyInst' on top of its 'Term' representation depending on whether the application is saturated or -- not. In any other case, fail. -instantiateEvaluate - :: Context uni fun - -> Type TyName uni () - -> CkValue uni fun - -> CkM uni fun s (Term TyName Name uni fun ()) +instantiateEvaluate :: + Context uni fun -> + Type TyName uni () -> + CkValue uni fun -> + CkM uni fun s (Term TyName Name uni fun ()) instantiateEvaluate stack ty (VTyAbs tn _k body) = - -- No kind check - too expensive at run time. - stack |> termSubstClosedType tn ty body + -- No kind check - too expensive at run time. + stack |> termSubstClosedType tn ty body instantiateEvaluate stack ty (VBuiltin term runtime) = do - let term' = TyInst () term ty - case runtime of - -- We allow a type argument to appear last in the type of a built-in function, - -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the - -- application. - BuiltinExpectForce runtime' -> evalBuiltinApp stack term' runtime' - _ -> throwErrorWithCause (StructuralError BuiltinTermArgumentExpectedMachineError) term' + let term' = TyInst () term ty + case runtime of + -- We allow a type argument to appear last in the type of a built-in function, + -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the + -- application. + BuiltinExpectForce runtime' -> evalBuiltinApp stack term' runtime' + _ -> throwErrorWithCause (StructuralError BuiltinTermArgumentExpectedMachineError) term' instantiateEvaluate _ _ val = - throwErrorWithCause (StructuralError NonPolymorphicInstantiationMachineError) $ ckValueToTerm val + throwErrorWithCause (StructuralError NonPolymorphicInstantiationMachineError) $ ckValueToTerm val -- | Apply a function to an argument and proceed. -- If the function is a lambda, then perform substitution and proceed. -- If the function is a builtin application then check that it's expecting a term argument, -- and either calculate the builtin application or stick a 'Apply' on top of its 'Term' -- representation depending on whether the application is saturated or not. -applyEvaluate - :: Context uni fun - -> CkValue uni fun - -> CkValue uni fun - -> CkM uni fun s (Term TyName Name uni fun ()) +applyEvaluate :: + Context uni fun -> + CkValue uni fun -> + CkValue uni fun -> + CkM uni fun s (Term TyName Name uni fun ()) applyEvaluate stack (VLamAbs name _ body) arg = - stack |> termSubstClosedTerm name (ckValueToTerm arg) body + stack |> termSubstClosedTerm name (ckValueToTerm arg) body applyEvaluate stack (VBuiltin term runtime) arg = do - let argTerm = ckValueToTerm arg - term' = Apply () term argTerm - case runtime of - -- It's only possible to apply a builtin application if the builtin expects a term - -- argument next. - BuiltinExpectArgument f -> do - evalBuiltinApp stack term' $ f arg - _ -> - throwErrorWithCause (StructuralError UnexpectedBuiltinTermArgumentMachineError) term' + let argTerm = ckValueToTerm arg + term' = Apply () term argTerm + case runtime of + -- It's only possible to apply a builtin application if the builtin expects a term + -- argument next. + BuiltinExpectArgument f -> do + evalBuiltinApp stack term' $ f arg + _ -> + throwErrorWithCause (StructuralError UnexpectedBuiltinTermArgumentMachineError) term' applyEvaluate _ val _ = - throwErrorWithCause (StructuralError NonFunctionalApplicationMachineError) $ ckValueToTerm val - -runCk - :: BuiltinsRuntime fun (CkValue uni fun) - -> CaserBuiltin uni - -> Bool - -> Term TyName Name uni fun () - -> (Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()), [Text]) + throwErrorWithCause (StructuralError NonFunctionalApplicationMachineError) $ ckValueToTerm val + +runCk :: + BuiltinsRuntime fun (CkValue uni fun) -> + CaserBuiltin uni -> + Bool -> + Term TyName Name uni fun () -> + (Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()), [Text]) runCk runtime caser emitting term = runCkM runtime caser emitting $ [] |> term -- | Evaluate a term using the CK machine with logging enabled. -evaluateCk - :: BuiltinsRuntime fun (CkValue uni fun) - -> CaserBuiltin uni - -> Term TyName Name uni fun () - -> (Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()), [Text]) +evaluateCk :: + BuiltinsRuntime fun (CkValue uni fun) -> + CaserBuiltin uni -> + Term TyName Name uni fun () -> + (Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()), [Text]) evaluateCk runtime caser = runCk runtime caser True -- | Evaluate a term using the CK machine with logging disabled. -evaluateCkNoEmit - :: BuiltinsRuntime fun (CkValue uni fun) - -> CaserBuiltin uni - -> Term TyName Name uni fun () - -> Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()) +evaluateCkNoEmit :: + BuiltinsRuntime fun (CkValue uni fun) -> + CaserBuiltin uni -> + Term TyName Name uni fun () -> + Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()) evaluateCkNoEmit runtime caser = fst . runCk runtime caser False -- | Unlift a value using the CK machine. -readKnownCk - :: ReadKnown (Term TyName Name uni fun ()) a - => BuiltinsRuntime fun (CkValue uni fun) - -> CaserBuiltin uni - -> Term TyName Name uni fun () - -> Either (CkEvaluationException uni fun) a +readKnownCk :: + ReadKnown (Term TyName Name uni fun ()) a => + BuiltinsRuntime fun (CkValue uni fun) -> + CaserBuiltin uni -> + Term TyName Name uni fun () -> + Either (CkEvaluationException uni fun) a readKnownCk runtime caser = evaluateCkNoEmit runtime caser >=> readKnownSelf diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostModelInterface.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostModelInterface.hs index 134db5c7c54..f09923205e4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostModelInterface.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostModelInterface.hs @@ -1,23 +1,25 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module PlutusCore.Evaluation.Machine.CostModelInterface - ( CostModelParams - , CekMachineCosts - , extractCostModelParams - , applyCostModelParams - , CostModelApplyError (..) - , CostModelApplyWarn (..) - ) +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module PlutusCore.Evaluation.Machine.CostModelInterface ( + CostModelParams, + CekMachineCosts, + extractCostModelParams, + applyCostModelParams, + CostModelApplyError (..), + CostModelApplyWarn (..), +) where import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..)) -import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts, - cekMachineCostsPrefix) +import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts ( + CekMachineCosts, + cekMachineCostsPrefix, + ) import Control.DeepSeq (NFData) import Control.Exception @@ -217,113 +219,119 @@ The table then looks like this: [10] this is the same case as `old_node / before_HF / longer_list`, just in the context of a different hardfork -} -{-| A raw representation of the ledger's cost model parameters. - -The associated keys/names to the parameter values are arbitrarily set by the plutus team; the ledger does not hold any such names. - -See Note [Cost model parameters] --} +-- | A raw representation of the ledger's cost model parameters. +-- +-- The associated keys/names to the parameter values are arbitrarily set by the plutus team; the ledger does not hold any such names. +-- +-- See Note [Cost model parameters] type CostModelParams = Map.Map Text.Text Int64 -- See Note [Cost model parameters] + -- | Extract the model parameters from a model. extractParams :: ToJSON a => a -> Maybe CostModelParams extractParams cm = case toJSON cm of - Object o -> - let - flattened = objToHm $ flattenObject "-" o - usingCostingIntegers = HM.mapMaybe (\case { Number n -> Just $ ceiling n; _ -> Nothing }) flattened - -- ^ Only (the contents of) the "Just" values are retained in the output map. - mapified = Map.fromList $ HM.toList usingCostingIntegers - in Just mapified - _ -> Nothing - + Object o -> + let + flattened = objToHm $ flattenObject "-" o + usingCostingIntegers = HM.mapMaybe (\case Number n -> Just $ ceiling n; _ -> Nothing) flattened + -- \^ Only (the contents of) the "Just" values are retained in the output map. + mapified = Map.fromList $ HM.toList usingCostingIntegers + in + Just mapified + _ -> Nothing -- | A fatal error when trying to create a cost given some plain costmodel parameters. -data CostModelApplyError = - CMUnknownParamError !Text.Text - -- ^ a costmodel parameter with the give name does not exist in the costmodel to be applied upon - | CMInternalReadError - -- ^ internal error when we are transforming the applyParams' input to json (should not happen) - | CMInternalWriteError !String - -- ^ internal error when we are transforming the applied params from json with given jsonstring error (should not happen) - deriving stock (Eq, Show, Generic, Data) - deriving anyclass (Exception, NFData, NoThunks) +data CostModelApplyError + = -- | a costmodel parameter with the give name does not exist in the costmodel to be applied upon + CMUnknownParamError !Text.Text + | -- | internal error when we are transforming the applyParams' input to json (should not happen) + CMInternalReadError + | -- | internal error when we are transforming the applied params from json with given jsonstring error (should not happen) + CMInternalWriteError !String + deriving stock (Eq, Show, Generic, Data) + deriving anyclass (Exception, NFData, NoThunks) -- | A non-fatal warning when trying to create a cost given some plain costmodel parameters. -data CostModelApplyWarn = - CMTooManyParamsWarn { cmExpected :: !Int, cmActual :: !Int } - -- ^ See Note [Cost model parameters from the ledger's point of view] - | CMTooFewParamsWarn { cmExpected :: !Int, cmActual :: !Int } - -- ^ See Note [Cost model parameters from the ledger's point of view] +data CostModelApplyWarn + = -- | See Note [Cost model parameters from the ledger's point of view] + CMTooManyParamsWarn {cmExpected :: !Int, cmActual :: !Int} + | -- | See Note [Cost model parameters from the ledger's point of view] + CMTooFewParamsWarn {cmExpected :: !Int, cmActual :: !Int} instance Pretty CostModelApplyError where - pretty = (preamble <+>) . \case - CMUnknownParamError k -> "No such parameter in target cost model:" <+> pretty k - CMInternalReadError -> "Internal problem occurred upon reading the given cost model parameters" - CMInternalWriteError str -> "Internal problem occurred upon generating the applied cost model parameters with JSON error:" <+> pretty str - where - preamble = "applyParams error:" + pretty = + (preamble <+>) . \case + CMUnknownParamError k -> "No such parameter in target cost model:" <+> pretty k + CMInternalReadError -> "Internal problem occurred upon reading the given cost model parameters" + CMInternalWriteError str -> "Internal problem occurred upon generating the applied cost model parameters with JSON error:" <+> pretty str + where + preamble = "applyParams error:" instance Pretty CostModelApplyWarn where - pretty = (preamble <+>) . \case - CMTooManyParamsWarn{..} -> "Too many cost model parameters passed, expected" <+> pretty cmExpected <+> "but got" <+> pretty cmActual - CMTooFewParamsWarn{..} -> "Too few cost model parameters passed, expected" <+> pretty cmExpected <+> "but got" <+> pretty cmActual - where - preamble = "applyParams warn:" + pretty = + (preamble <+>) . \case + CMTooManyParamsWarn {..} -> "Too many cost model parameters passed, expected" <+> pretty cmExpected <+> "but got" <+> pretty cmActual + CMTooFewParamsWarn {..} -> "Too few cost model parameters passed, expected" <+> pretty cmExpected <+> "but got" <+> pretty cmActual + where + preamble = "applyParams warn:" -- See Note [Cost model parameters] + -- | Update a model by overwriting the parameters with the given ones. -applyParams :: (FromJSON a, ToJSON a, MonadError CostModelApplyError m) - => a - -> CostModelParams - -> m a +applyParams :: + (FromJSON a, ToJSON a, MonadError CostModelApplyError m) => + a -> + CostModelParams -> + m a applyParams cm params = case toJSON cm of - Object o -> - let - usingScientific = fmap (Number . fromIntegral) params - flattened = fromHash $ objToHm $ flattenObject "-" o - in do - -- this is where the overwriting happens - -- fail when key is in params (left) but not in the model (right) - merged <- Map.mergeA failMissing Map.preserveMissing (Map.zipWithMatched leftBiased) usingScientific flattened - let unflattened = unflattenObject "-" $ hmToObj $ toHash merged - case fromJSON (Object unflattened) of - Success a -> pure a - Error str -> throwError $ CMInternalWriteError str - _ -> throwError CMInternalReadError + Object o -> + let + usingScientific = fmap (Number . fromIntegral) params + flattened = fromHash $ objToHm $ flattenObject "-" o + in + do + -- this is where the overwriting happens + -- fail when key is in params (left) but not in the model (right) + merged <- Map.mergeA failMissing Map.preserveMissing (Map.zipWithMatched leftBiased) usingScientific flattened + let unflattened = unflattenObject "-" $ hmToObj $ toHash merged + case fromJSON (Object unflattened) of + Success a -> pure a + Error str -> throwError $ CMInternalWriteError str + _ -> throwError CMInternalReadError where toHash = HM.fromList . Map.toList fromHash = Map.fromList . HM.toList -- fail when field missing - failMissing = Map.traverseMissing $ \ k _v -> throwError $ CMUnknownParamError k + failMissing = Map.traverseMissing $ \k _v -> throwError $ CMUnknownParamError k -- left-biased merging when key found in both maps leftBiased _k l _r = l - -- | Parameters for a machine step model and a builtin evaluation model bundled together. -data SplitCostModelParams = - SplitCostModelParams { - _machineParams :: CostModelParams - , _builtinParams :: CostModelParams - } +data SplitCostModelParams + = SplitCostModelParams + { _machineParams :: CostModelParams + , _builtinParams :: CostModelParams + } -- | Split a CostModelParams object into two subobjects according to some prefix: -- see item 5 of Note [Cost model parameters]. splitParams :: Text.Text -> CostModelParams -> SplitCostModelParams splitParams prefix params = - let (machineparams, builtinparams) = Map.partitionWithKey (\k _ -> Text.isPrefixOf prefix k) params - in SplitCostModelParams machineparams builtinparams + let (machineparams, builtinparams) = Map.partitionWithKey (\k _ -> Text.isPrefixOf prefix k) params + in SplitCostModelParams machineparams builtinparams -- | Given a CostModel, produce a single map containing the parameters from both components -extractCostModelParams - :: (ToJSON machinecosts, ToJSON builtincosts) - => CostModel machinecosts builtincosts -> Maybe CostModelParams -extractCostModelParams model = -- this is using the applicative instance of Maybe - Map.union <$> extractParams (_machineCostModel model) <*> extractParams (_builtinCostModel model) +extractCostModelParams :: + (ToJSON machinecosts, ToJSON builtincosts) => + CostModel machinecosts builtincosts -> Maybe CostModelParams +extractCostModelParams model = + -- this is using the applicative instance of Maybe + Map.union <$> extractParams (_machineCostModel model) <*> extractParams (_builtinCostModel model) -- | Given a set of cost model parameters, split it into two parts according to -- some prefix and use those parts to update the components of a cost model. + {- Strictly we don't need to do the splitting: when we call fromJSON in applyParams any superfluous objects in the map being decoded will be discarded, so we could update both components of the cost model with the @@ -332,23 +340,24 @@ extractCostModelParams model = -- this is using the applicative instance of Mayb undocumented implementation choice in Aeson though (other JSON decoders (for other languages) seem to vary in how unknown fields are handled), so let's be explicit. -} -applySplitCostModelParams - :: (FromJSON evaluatorcosts, FromJSON builtincosts, ToJSON evaluatorcosts, ToJSON builtincosts, MonadError CostModelApplyError m) - => Text.Text - -> CostModel evaluatorcosts builtincosts - -> CostModelParams - -> m (CostModel evaluatorcosts builtincosts) +applySplitCostModelParams :: + (FromJSON evaluatorcosts, FromJSON builtincosts, ToJSON evaluatorcosts, ToJSON builtincosts, MonadError CostModelApplyError m) => + Text.Text -> + CostModel evaluatorcosts builtincosts -> + CostModelParams -> + m (CostModel evaluatorcosts builtincosts) applySplitCostModelParams prefix model params = - let SplitCostModelParams machineparams builtinparams = splitParams prefix params - in CostModel <$> applyParams (_machineCostModel model) machineparams - <*> applyParams (_builtinCostModel model) builtinparams + let SplitCostModelParams machineparams builtinparams = splitParams prefix params + in CostModel + <$> applyParams (_machineCostModel model) machineparams + <*> applyParams (_builtinCostModel model) builtinparams -- | Update a CostModel for the CEK machine with a given set of parameters. -- Note that this is costly. See [here](https://github.com/IntersectMBO/plutus/issues/4962). -- Callers are recommended to call this once and cache the results. -applyCostModelParams - :: (FromJSON evaluatorcosts, FromJSON builtincosts, ToJSON evaluatorcosts, ToJSON builtincosts, MonadError CostModelApplyError m) - => CostModel evaluatorcosts builtincosts - -> CostModelParams - -> m (CostModel evaluatorcosts builtincosts) +applyCostModelParams :: + (FromJSON evaluatorcosts, FromJSON builtincosts, ToJSON evaluatorcosts, ToJSON builtincosts, MonadError CostModelApplyError m) => + CostModel evaluatorcosts builtincosts -> + CostModelParams -> + m (CostModel evaluatorcosts builtincosts) applyCostModelParams = applySplitCostModelParams cekMachineCostsPrefix diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostStream.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostStream.hs index 8365dede6c4..f75a5d63944 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostStream.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostStream.hs @@ -1,18 +1,17 @@ {-# LANGUAGE BangPatterns #-} -module PlutusCore.Evaluation.Machine.CostStream - ( CostStream(..) - , unconsCost - , reconsCost - , sumCostStream - , mapCostStream - , addCostStream - , minCostStream - ) where +module PlutusCore.Evaluation.Machine.CostStream ( + CostStream (..), + unconsCost, + reconsCost, + sumCostStream, + mapCostStream, + addCostStream, + minCostStream, +) where import PlutusCore.Evaluation.Machine.ExMemory - {- Note [Single-element streams] Both 'CostStream' and 'ExBudgetStream' are semantically equivalent to 'NonEmpty' (modulo strictness) except instead of making the first element of each of these stream types a special one, we make @@ -28,6 +27,7 @@ inlineable allowing for optimized handling of single-element streams. -} -- See Note [Single-element streams] + -- | A lazy stream of 'CostingInteger's. Basically @NonEmpty CostingInteger@, except the elements -- are stored strictly. -- @@ -38,14 +38,15 @@ inlineable allowing for optimized handling of single-element streams. -- assumption. Negative costs (a.k.a. allowing the user to forge execution units at runtime) -- wouldn't make sense. data CostStream - = CostLast {-# UNPACK #-} !CostingInteger - | CostCons {-# UNPACK #-} !CostingInteger CostStream - deriving stock (Show) + = CostLast {-# UNPACK #-} !CostingInteger + | CostCons {-# UNPACK #-} !CostingInteger CostStream + deriving stock (Show) -- TODO: (# CostingInteger, (# (# #) | CostStream #) #)? + -- | Uncons an element from a 'CostStream' and return the rest of the stream, if not empty. unconsCost :: CostStream -> (CostingInteger, Maybe CostStream) -unconsCost (CostLast cost) = (cost, Nothing) +unconsCost (CostLast cost) = (cost, Nothing) unconsCost (CostCons cost costs) = (cost, Just costs) {-# INLINE unconsCost #-} @@ -70,29 +71,31 @@ duplicated in the generated Core. -- See Note [Global local functions]. sumCostStreamGo :: CostingInteger -> CostStream -> CostingInteger -sumCostStreamGo !acc (CostLast cost) = acc + cost +sumCostStreamGo !acc (CostLast cost) = acc + cost sumCostStreamGo !acc (CostCons cost costs) = sumCostStreamGo (acc + cost) costs -- | Add up all the costs in a 'CostStream'. sumCostStream :: CostStream -> CostingInteger -sumCostStream (CostLast cost0) = cost0 +sumCostStream (CostLast cost0) = cost0 sumCostStream (CostCons cost0 costs0) = sumCostStreamGo cost0 costs0 {-# INLINE sumCostStream #-} -- See Note [Global local functions]. + -- | Map a function over a 'CostStream'. mapCostStream :: (CostingInteger -> CostingInteger) -> CostStream -> CostStream -- See Note [Single-element streams] -mapCostStream f (CostLast cost0) = CostLast (f cost0) -mapCostStream f (CostCons cost0 costs0) = CostCons (f cost0) $ go costs0 where +mapCostStream f (CostLast cost0) = CostLast (f cost0) +mapCostStream f (CostCons cost0 costs0) = CostCons (f cost0) $ go costs0 + where go :: CostStream -> CostStream - go (CostLast cost) = CostLast (f cost) + go (CostLast cost) = CostLast (f cost) go (CostCons cost costs) = CostCons (f cost) $ go costs {-# INLINE mapCostStream #-} -- See Note [Global local functions]. addCostStreamGo :: CostStream -> CostStream -> CostStream -addCostStreamGo (CostLast costL) costsR = CostCons costL costsR +addCostStreamGo (CostLast costL) costsR = CostCons costL costsR addCostStreamGo (CostCons costL costsL) costsR = CostCons costL $ addCostStreamGo costsR costsL -- | Add two streams by interleaving their elements (as opposed to draining out one of the streams @@ -100,33 +103,33 @@ addCostStreamGo (CostCons costL costsL) costsR = CostCons costL $ addCostStreamG -- interleaving over draining out one of the streams first. addCostStream :: CostStream -> CostStream -> CostStream addCostStream costsL0 costsR0 = case (costsL0, costsR0) of - -- See Note [Single-element streams]. - (CostLast costL, CostLast costR) -> CostLast $ costL + costR - _ -> addCostStreamGo costsL0 costsR0 + -- See Note [Single-element streams]. + (CostLast costL, CostLast costR) -> CostLast $ costL + costR + _ -> addCostStreamGo costsL0 costsR0 {-# INLINE addCostStream #-} -- See Note [Global local functions]. -- Didn't attempt to optimize it. minCostStreamGo :: CostStream -> CostStream -> CostStream minCostStreamGo costsL costsR = - -- Peel off a cost from each of the streams, if there's any, compare the two costs, emit - -- the minimum cost to the outside and recurse. If the two elements aren't equal, then we put - -- the difference between them back to the stream that had the greatest cost (thus subtracting - -- the minimum cost from the stream -- since we just accounted for it by lazily emitting it to - -- the outside). Proceed until one of the streams is drained out. - let (!costL, !mayCostsL') = unconsCost costsL - (!costR, !mayCostsR') = unconsCost costsR - (!costMin, !mayCostsL'', !mayCostsR'') = case costL `compare` costR of - LT -> (costL, mayCostsL', pure $ reconsCost (costR - costL) mayCostsR') - EQ -> (costL, mayCostsL', mayCostsR') - GT -> (costR, pure $ reconsCost (costL - costR) mayCostsL', mayCostsR') - in reconsCost costMin $ minCostStreamGo <$> mayCostsL'' <*> mayCostsR'' + -- Peel off a cost from each of the streams, if there's any, compare the two costs, emit + -- the minimum cost to the outside and recurse. If the two elements aren't equal, then we put + -- the difference between them back to the stream that had the greatest cost (thus subtracting + -- the minimum cost from the stream -- since we just accounted for it by lazily emitting it to + -- the outside). Proceed until one of the streams is drained out. + let (!costL, !mayCostsL') = unconsCost costsL + (!costR, !mayCostsR') = unconsCost costsR + (!costMin, !mayCostsL'', !mayCostsR'') = case costL `compare` costR of + LT -> (costL, mayCostsL', pure $ reconsCost (costR - costL) mayCostsR') + EQ -> (costL, mayCostsL', mayCostsR') + GT -> (costR, pure $ reconsCost (costL - costR) mayCostsL', mayCostsR') + in reconsCost costMin $ minCostStreamGo <$> mayCostsL'' <*> mayCostsR'' -- | Calculate the minimum of two 'CostStream's. May return a stream that is longer than either of -- the two (but not more than twice). minCostStream :: CostStream -> CostStream -> CostStream minCostStream costsL0 costsR0 = case (costsL0, costsR0) of - -- See Note [Single-element streams]. - (CostLast costL, CostLast costR) -> CostLast $ min costL costR - _ -> minCostStreamGo costsL0 costsR0 + -- See Note [Single-element streams]. + (CostLast costL, CostLast costR) -> CostLast $ min costL costR + _ -> minCostStreamGo costsL0 costsR0 {-# INLINE minCostStream #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs index 0b9ede4c10a..a59df83e201 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs @@ -1,52 +1,52 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE StrictData #-} -module PlutusCore.Evaluation.Machine.CostingFun.Core - ( CostingFun(..) - , UnimplementedCostingFun(..) - , Intercept(..) - , Slope(..) - , Coefficient0(..) - , Coefficient1(..) - , Coefficient2(..) - , Coefficient00(..) - , Coefficient10(..) - , Coefficient01(..) - , Coefficient20(..) - , Coefficient11(..) - , Coefficient02(..) - , Coefficient12(..) - , OneVariableLinearFunction(..) - , OneVariableQuadraticFunction(..) - , TwoVariableLinearFunction(..) - , TwoVariableQuadraticFunction(..) - , ExpModCostingFunction(..) - , ModelSubtractedSizes(..) - , ModelConstantOrLinear(..) -- Deprecated: see below. - , ModelConstantOrOneArgument(..) - , ModelConstantOrTwoArguments(..) - , ModelOneArgument(..) - , ModelTwoArguments(..) - , ModelThreeArguments(..) - , ModelFourArguments(..) - , ModelFiveArguments(..) - , ModelSixArguments(..) - , runCostingFunOneArgument - , runCostingFunTwoArguments - , runCostingFunThreeArguments - , runCostingFunFourArguments - , runCostingFunFiveArguments - , runCostingFunSixArguments - , Hashable - ) +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module PlutusCore.Evaluation.Machine.CostingFun.Core ( + CostingFun (..), + UnimplementedCostingFun (..), + Intercept (..), + Slope (..), + Coefficient0 (..), + Coefficient1 (..), + Coefficient2 (..), + Coefficient00 (..), + Coefficient10 (..), + Coefficient01 (..), + Coefficient20 (..), + Coefficient11 (..), + Coefficient02 (..), + Coefficient12 (..), + OneVariableLinearFunction (..), + OneVariableQuadraticFunction (..), + TwoVariableLinearFunction (..), + TwoVariableQuadraticFunction (..), + ExpModCostingFunction (..), + ModelSubtractedSizes (..), + ModelConstantOrLinear (..), -- Deprecated: see below. + ModelConstantOrOneArgument (..), + ModelConstantOrTwoArguments (..), + ModelOneArgument (..), + ModelTwoArguments (..), + ModelThreeArguments (..), + ModelFourArguments (..), + ModelFiveArguments (..), + ModelSixArguments (..), + runCostingFunOneArgument, + runCostingFunTwoArguments, + runCostingFunThreeArguments, + runCostingFunFourArguments, + runCostingFunFiveArguments, + runCostingFunSixArguments, + Hashable, +) where import PlutusCore.Evaluation.Machine.CostStream @@ -63,161 +63,175 @@ import Language.Haskell.TH.Syntax hiding (Name, newName) -- | A class used for convenience in this module, don't export it. class OnMemoryUsages c a where - -- | Turn - -- - -- > \mem1 ... memN -> f mem1 ... memN - -- - -- into - -- - -- > \arg1 ... argN -> f (memoryUsage arg1) ... (memoryUsage argN) - -- - -- so that we don't need to repeat those 'memoryUsage' calls at every use site, which would also - -- require binding @arg*@ explicitly, i.e. require even more boilerplate. - onMemoryUsages :: c -> a - -instance (ab ~ (a -> b), ExMemoryUsage a, OnMemoryUsages c b) => - OnMemoryUsages (CostStream -> c) ab where - -- 'inline' is for making sure that 'memoryUsage' does get inlined. - onMemoryUsages f = onMemoryUsages . f . flattenCostRose . inline memoryUsage - {-# INLINE onMemoryUsages #-} + -- | Turn + -- + -- > \mem1 ... memN -> f mem1 ... memN + -- + -- into + -- + -- > \arg1 ... argN -> f (memoryUsage arg1) ... (memoryUsage argN) + -- + -- so that we don't need to repeat those 'memoryUsage' calls at every use site, which would also + -- require binding @arg*@ explicitly, i.e. require even more boilerplate. + onMemoryUsages :: c -> a + +instance + (ab ~ (a -> b), ExMemoryUsage a, OnMemoryUsages c b) => + OnMemoryUsages (CostStream -> c) ab + where + -- 'inline' is for making sure that 'memoryUsage' does get inlined. + onMemoryUsages f = onMemoryUsages . f . flattenCostRose . inline memoryUsage + {-# INLINE onMemoryUsages #-} instance ab ~ ExBudgetStream => OnMemoryUsages ExBudgetStream ab where - onMemoryUsages = id - {-# INLINE onMemoryUsages #-} - -{- | A type of costing functions parametric over a model type. In practice the we -have one model type `ModelArguments` for every N, where N is the arity of the -builtin whose costs we want to model. Each model type has a number of -constructors defining different "shapes" of N-parameter functions which -calculate a cost given the sizes of the builtin's arguments. -} + onMemoryUsages = id + {-# INLINE onMemoryUsages #-} + +-- | A type of costing functions parametric over a model type. In practice the we +-- have one model type `ModelArguments` for every N, where N is the arity of the +-- builtin whose costs we want to model. Each model type has a number of +-- constructors defining different "shapes" of N-parameter functions which +-- calculate a cost given the sizes of the builtin's arguments. data CostingFun model = CostingFun - { costingFunCpu :: model - , costingFunMemory :: model - } - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (Default, NFData) - -{- | In the initial stages of implementing a new builtin it is necessary to - provide a temporary costing function which is used until the builtin has been - properly costed: `see CostModelGeneration.md`. Each `ModelArguments` type - defines an instance of this class where `unimplementedCostingFun` is a - constant costing function which returns a very high cost for all inputs. - This prevents new functions from being used in situations where costs are - important until a sensible costing function has been implemented. -} + { costingFunCpu :: model + , costingFunMemory :: model + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (Default, NFData) + +-- | In the initial stages of implementing a new builtin it is necessary to +-- provide a temporary costing function which is used until the builtin has been +-- properly costed: `see CostModelGeneration.md`. Each `ModelArguments` type +-- defines an instance of this class where `unimplementedCostingFun` is a +-- constant costing function which returns a very high cost for all inputs. +-- This prevents new functions from being used in situations where costs are +-- important until a sensible costing function has been implemented. class UnimplementedCostingFun a where unimplementedCostingFun :: b -> CostingFun a -{- | Make a very expensive pair of CPU and memory costing functions. The name is - slightly misleading because it actually makes a function which returns such a - pair, which is what is required at the use site in `PlutusCore.Default.Builtins`, - where properly implemented costing functions are constructed from a - BuiltinCostModel object. We can't use maxBound :: CostingInteger because then the - evaluator always fails; instead we assign a cost of 100,000,000,000, which is well - beyond the current on-chain CPU and memory limits (10,000,000,000 and 14,000,000 - respectively) but still allows over 92,000,000 evaluations before the maximum - CostingInteger is reached. This allows us to use an "uncosted" builtin for - testing and for running costing benchmarks, but will prevent it from being used - when the Plutus Core evaluator is invoked by the ledger. --} +-- | Make a very expensive pair of CPU and memory costing functions. The name is +-- slightly misleading because it actually makes a function which returns such a +-- pair, which is what is required at the use site in `PlutusCore.Default.Builtins`, +-- where properly implemented costing functions are constructed from a +-- BuiltinCostModel object. We can't use maxBound :: CostingInteger because then the +-- evaluator always fails; instead we assign a cost of 100,000,000,000, which is well +-- beyond the current on-chain CPU and memory limits (10,000,000,000 and 14,000,000 +-- respectively) but still allows over 92,000,000 evaluations before the maximum +-- CostingInteger is reached. This allows us to use an "uncosted" builtin for +-- testing and for running costing benchmarks, but will prevent it from being used +-- when the Plutus Core evaluator is invoked by the ledger. makeUnimplementedCostingFun :: (CostingInteger -> model) -> b -> CostingFun model makeUnimplementedCostingFun c = const $ CostingFun (c k) (c k) - where k = 100_000_000_000 + where + k = 100_000_000_000 ---------------- Types for use within costing functions ---------------- -- | A wrapped 'CostingInteger' that is supposed to be used as an intercept. newtype Intercept = Intercept - { unIntercept :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unIntercept :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as a slope. newtype Slope = Slope - { unSlope :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unSlope :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree 0 -- coefficient of a polynomial. newtype Coefficient0 = Coefficient0 - { unCoefficient0 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient0 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree 1 -- coefficient of a polynomial. newtype Coefficient1 = Coefficient1 - { unCoefficient1 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient1 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree 2 -- coefficient of a polynomial. newtype Coefficient2 = Coefficient2 - { unCoefficient2 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient2 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree (0,0) -- coefficient of a two-variable polynomial. newtype Coefficient00 = Coefficient00 - { unCoefficient00 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient00 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree (1,0) -- coefficient of a two-variable polynomial. newtype Coefficient10 = Coefficient10 - { unCoefficient10 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient10 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree (0,1) -- coefficient of a two-variable polynomial. newtype Coefficient01 = Coefficient01 - { unCoefficient01 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient01 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree (2,0) -- coefficient of a two-variable polynomial. newtype Coefficient20 = Coefficient20 - { unCoefficient20 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient20 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree (1,1) -- coefficient of a two-variable polynomial. newtype Coefficient11 = Coefficient11 - { unCoefficient11 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient11 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree (0,2) -- coefficient of a two-variable polynomial. newtype Coefficient02 = Coefficient02 - { unCoefficient02 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient02 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) -- | A wrapped 'CostingInteger' that is supposed to be used as the degree (1,2) -- coefficient of a two-variable polynomial. newtype Coefficient12 = Coefficient12 - { unCoefficient12 :: CostingInteger - } deriving stock (Generic, Lift) - deriving newtype (Show, Eq, Num, NFData) + { unCoefficient12 :: CostingInteger + } + deriving stock (Generic, Lift) + deriving newtype (Show, Eq, Num, NFData) ---------------- One-argument costing functions ---------------- -data ModelOneArgument = - ModelOneArgumentConstantCost CostingInteger - | ModelOneArgumentLinearInX OneVariableLinearFunction - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) +data ModelOneArgument + = ModelOneArgumentConstantCost CostingInteger + | ModelOneArgumentLinearInX OneVariableLinearFunction + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) instance Default ModelOneArgument where - def = ModelOneArgumentConstantCost maxBound + def = ModelOneArgumentConstantCost maxBound instance UnimplementedCostingFun ModelOneArgument where unimplementedCostingFun = makeUnimplementedCostingFun ModelOneArgumentConstantCost @@ -280,34 +294,34 @@ These optimizations gave us a ~3.2% speedup at the time this Note was written. -} -- See Note [runCostingFun* API]. -runCostingFunOneArgument - :: ExMemoryUsage a1 - => CostingFun ModelOneArgument - -> a1 - -> ExBudgetStream +runCostingFunOneArgument :: + ExMemoryUsage a1 => + CostingFun ModelOneArgument -> + a1 -> + ExBudgetStream runCostingFunOneArgument (CostingFun cpu mem) = - case (runOneArgumentModel cpu, runOneArgumentModel mem) of - (!runCpu, !runMem) -> onMemoryUsages $ \mem1 -> - zipCostStream - (runCpu mem1) - (runMem mem1) + case (runOneArgumentModel cpu, runOneArgumentModel mem) of + (!runCpu, !runMem) -> onMemoryUsages $ \mem1 -> + zipCostStream + (runCpu mem1) + (runMem mem1) {-# INLINE runCostingFunOneArgument #-} -- | Take an intercept, a slope and a stream and scale each element of the stream by the slope and -- cons the intercept to the stream afterwards. scaleLinearly :: Intercept -> Slope -> CostStream -> CostStream scaleLinearly (Intercept intercept) (Slope slope) = - addCostStream (CostLast intercept) . mapCostStream (slope *) + addCostStream (CostLast intercept) . mapCostStream (slope *) {-# INLINE scaleLinearly #-} -runOneArgumentModel - :: ModelOneArgument - -> CostStream - -> CostStream +runOneArgumentModel :: + ModelOneArgument -> + CostStream -> + CostStream runOneArgumentModel (ModelOneArgumentConstantCost c) = - lazy $ \_ -> CostLast c + lazy $ \_ -> CostLast c runOneArgumentModel (ModelOneArgumentLinearInX (OneVariableLinearFunction intercept slope)) = - lazy $ \costs1 -> scaleLinearly intercept slope costs1 + lazy $ \costs1 -> scaleLinearly intercept slope costs1 {-# OPAQUE runOneArgumentModel #-} ---------------- Two-argument costing functions ---------------- @@ -328,34 +342,38 @@ would complicate the JSON encoding and might also impact efficiency. -- | s * x + I data OneVariableLinearFunction = OneVariableLinearFunction - { oneVariableLinearFunctionIntercept :: Intercept - , oneVariableLinearFunctionSlope :: Slope - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + { oneVariableLinearFunctionIntercept :: Intercept + , oneVariableLinearFunctionSlope :: Slope + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) -- | s1 * x + s2 * y + I data TwoVariableLinearFunction = TwoVariableLinearFunction - { twoVariableLinearFunctionIntercept :: Intercept - , twoVariableLinearFunctionSlope1 :: Slope - , twoVariableLinearFunctionSlope2 :: Slope - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + { twoVariableLinearFunctionIntercept :: Intercept + , twoVariableLinearFunctionSlope1 :: Slope + , twoVariableLinearFunctionSlope2 :: Slope + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) -- | c0 + c1*x + c2*x^2 data OneVariableQuadraticFunction = OneVariableQuadraticFunction - { oneVariableQuadraticFunctionC0 :: Coefficient0 - , oneVariableQuadraticFunctionC1 :: Coefficient1 - , oneVariableQuadraticFunctionC2 :: Coefficient2 - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + { oneVariableQuadraticFunctionC0 :: Coefficient0 + , oneVariableQuadraticFunctionC1 :: Coefficient1 + , oneVariableQuadraticFunctionC2 :: Coefficient2 + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) +evaluateOneVariableQuadraticFunction :: + OneVariableQuadraticFunction -> + CostingInteger -> + CostingInteger evaluateOneVariableQuadraticFunction - :: OneVariableQuadraticFunction - -> CostingInteger - -> CostingInteger -evaluateOneVariableQuadraticFunction - (OneVariableQuadraticFunction (Coefficient0 c0) (Coefficient1 c1) (Coefficient2 c2)) x = - c0 + c1*x + c2*x*x + (OneVariableQuadraticFunction (Coefficient0 c0) (Coefficient1 c1) (Coefficient2 c2)) + x = + c0 + c1 * x + c2 * x * x {-# INLINE evaluateOneVariableQuadraticFunction #-} {- Note [Minimum values for two-variable quadratic costing functions] Unlike most @@ -366,30 +384,39 @@ evaluateOneVariableQuadraticFunction than a minimum value that is stored along with the coefficients of the function. -} + -- | c00 + c10*x + c01*y + c20*x^2 + c11*c*y + c02*y^2 data TwoVariableQuadraticFunction = TwoVariableQuadraticFunction { twoVariableQuadraticFunctionMinimum :: CostingInteger - , twoVariableQuadraticFunctionC00 :: Coefficient00 - , twoVariableQuadraticFunctionC10 :: Coefficient10 - , twoVariableQuadraticFunctionC01 :: Coefficient01 - , twoVariableQuadraticFunctionC20 :: Coefficient20 - , twoVariableQuadraticFunctionC11 :: Coefficient11 - , twoVariableQuadraticFunctionC02 :: Coefficient02 - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + , twoVariableQuadraticFunctionC00 :: Coefficient00 + , twoVariableQuadraticFunctionC10 :: Coefficient10 + , twoVariableQuadraticFunctionC01 :: Coefficient01 + , twoVariableQuadraticFunctionC20 :: Coefficient20 + , twoVariableQuadraticFunctionC11 :: Coefficient11 + , twoVariableQuadraticFunctionC02 :: Coefficient02 + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) +evaluateTwoVariableQuadraticFunction :: + TwoVariableQuadraticFunction -> + CostingInteger -> + CostingInteger -> + CostingInteger evaluateTwoVariableQuadraticFunction - :: TwoVariableQuadraticFunction - -> CostingInteger - -> CostingInteger - -> CostingInteger -evaluateTwoVariableQuadraticFunction - (TwoVariableQuadraticFunction minVal - (Coefficient00 c00) (Coefficient10 c10) (Coefficient01 c01) - (Coefficient20 c20) (Coefficient11 c11) (Coefficient02 c02) - ) x y = max minVal (c00 + c10*x + c01*y + c20*x*x + c11*x*y + c02*y*y) - -- We want to be absolutely sure that we don't get back a negative number - -- here: see Note [Minimum values for two-variable quadratic costing functions] + ( TwoVariableQuadraticFunction + minVal + (Coefficient00 c00) + (Coefficient10 c10) + (Coefficient01 c01) + (Coefficient20 c20) + (Coefficient11 c11) + (Coefficient02 c02) + ) + x + y = max minVal (c00 + c10 * x + c01 * y + c20 * x * x + c11 * x * y + c02 * y * y) +-- We want to be absolutely sure that we don't get back a negative number +-- here: see Note [Minimum values for two-variable quadratic costing functions] {-# INLINE evaluateTwoVariableQuadraticFunction #-} -- | c00 + c01x*y + c12x*y^2 @@ -398,31 +425,39 @@ data ExpModCostingFunction = ExpModCostingFunction { coefficient00 :: Coefficient00 , coefficient11 :: Coefficient11 , coefficient12 :: Coefficient12 - } deriving stock (Show, Eq, Generic, Lift) + } + deriving stock (Show, Eq, Generic, Lift) deriving anyclass (NFData) -{- | Calculate the cost of calling `expModInteger a e m` where a is of size aa, e -is of size ee, and m is of size mm. If aa>mm then the cost is increased by -50% to impose a penalty for the extra cost of initially reducing `a` modulo `m`. -If large values of `a` really are required then the penalty can be avoided by -calling `modInteger` before `expModInteger`. --} +-- | Calculate the cost of calling `expModInteger a e m` where a is of size aa, e +-- is of size ee, and m is of size mm. If aa>mm then the cost is increased by +-- 50% to impose a penalty for the extra cost of initially reducing `a` modulo `m`. +-- If large values of `a` really are required then the penalty can be avoided by +-- calling `modInteger` before `expModInteger`. +evaluateExpModCostingFunction :: + ExpModCostingFunction -> + CostingInteger -> + CostingInteger -> + CostingInteger -> + CostingInteger evaluateExpModCostingFunction - :: ExpModCostingFunction - -> CostingInteger - -> CostingInteger - -> CostingInteger - -> CostingInteger -evaluateExpModCostingFunction - (ExpModCostingFunction - (Coefficient00 c00) (Coefficient11 c11) (Coefficient12 c12)) - aa ee mm = if aa <= mm - then cost0 - else cost0 + (cost0 `dividedBy` 2) - where cost0 = c00 + c11*ee*mm + c12*ee*mm*mm + ( ExpModCostingFunction + (Coefficient00 c00) + (Coefficient11 c11) + (Coefficient12 c12) + ) + aa + ee + mm = + if aa <= mm + then cost0 + else cost0 + (cost0 `dividedBy` 2) + where + cost0 = c00 + c11 * ee * mm + c12 * ee * mm * mm {-# INLINE evaluateExpModCostingFunction #-} -- | s * (x - y) + I + {- In principle we could use ModelConstantOrOneArgument here, but that would change the order of the cost model parameters since the minimum value would come first instead of last, so for the time being we use a special type. We may be @@ -430,35 +465,40 @@ able to change this later if we move to a self-describing cost model format where the cost model parameters include the type of the costing function. See Note [Backward compatibility for costing functions]. -} data ModelSubtractedSizes = ModelSubtractedSizes - { modelSubtractedSizesIntercept :: Intercept - , modelSubtractedSizesSlope :: Slope - , modelSubtractedSizesMinimum :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + { modelSubtractedSizesIntercept :: Intercept + , modelSubtractedSizesSlope :: Slope + , modelSubtractedSizesMinimum :: CostingInteger + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) -- | if p then s*x else c; p depends on usage + {- NB: this is subsumed by ModelConstantOrOneArgument, but we have to keep it -- for the time being. See Note [Backward compatibility for costing functions]. -} data ModelConstantOrLinear = ModelConstantOrLinear - { modelConstantOrLinearConstant :: CostingInteger - , modelConstantOrLinearIntercept :: Intercept - , modelConstantOrLinearSlope :: Slope - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + { modelConstantOrLinearConstant :: CostingInteger + , modelConstantOrLinearIntercept :: Intercept + , modelConstantOrLinearSlope :: Slope + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) -- | if p then f(x) else c; p depends on usage data ModelConstantOrOneArgument = ModelConstantOrOneArgument - { modelConstantOrOneArgumentConstant :: CostingInteger - , modelConstantOrOneArgumentModel :: ModelOneArgument - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + { modelConstantOrOneArgumentConstant :: CostingInteger + , modelConstantOrOneArgumentModel :: ModelOneArgument + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) -- | if p then f(x,y) else c; p depends on usage data ModelConstantOrTwoArguments = ModelConstantOrTwoArguments - { modelConstantOrTwoArgumentsConstant :: CostingInteger - , modelConstantOrTwoArgumentsModel :: ModelTwoArguments - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) + { modelConstantOrTwoArgumentsConstant :: CostingInteger + , modelConstantOrTwoArgumentsModel :: ModelTwoArguments + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) {- Note [Backward compatibility for costing functions]. The PR at https://github.com/IntersectMBO/plutus/pull/5857 generalised the costing @@ -476,46 +516,46 @@ data ModelConstantOrTwoArguments = ModelConstantOrTwoArguments models may mean that we don't need to do that). -} -data ModelTwoArguments = - ModelTwoArgumentsConstantCost CostingInteger - | ModelTwoArgumentsLinearInX OneVariableLinearFunction - | ModelTwoArgumentsLinearInY OneVariableLinearFunction - | ModelTwoArgumentsLinearInXAndY TwoVariableLinearFunction - | ModelTwoArgumentsAddedSizes OneVariableLinearFunction - | ModelTwoArgumentsSubtractedSizes ModelSubtractedSizes - | ModelTwoArgumentsMultipliedSizes OneVariableLinearFunction - | ModelTwoArgumentsMinSize OneVariableLinearFunction - | ModelTwoArgumentsMaxSize OneVariableLinearFunction - | ModelTwoArgumentsLinearOnDiagonal ModelConstantOrLinear - | ModelTwoArgumentsConstOffDiagonal ModelConstantOrOneArgument - | ModelTwoArgumentsConstAboveDiagonal ModelConstantOrTwoArguments - | ModelTwoArgumentsConstBelowDiagonal ModelConstantOrTwoArguments - | ModelTwoArgumentsQuadraticInY OneVariableQuadraticFunction - | ModelTwoArgumentsQuadraticInXAndY TwoVariableQuadraticFunction - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) +data ModelTwoArguments + = ModelTwoArgumentsConstantCost CostingInteger + | ModelTwoArgumentsLinearInX OneVariableLinearFunction + | ModelTwoArgumentsLinearInY OneVariableLinearFunction + | ModelTwoArgumentsLinearInXAndY TwoVariableLinearFunction + | ModelTwoArgumentsAddedSizes OneVariableLinearFunction + | ModelTwoArgumentsSubtractedSizes ModelSubtractedSizes + | ModelTwoArgumentsMultipliedSizes OneVariableLinearFunction + | ModelTwoArgumentsMinSize OneVariableLinearFunction + | ModelTwoArgumentsMaxSize OneVariableLinearFunction + | ModelTwoArgumentsLinearOnDiagonal ModelConstantOrLinear + | ModelTwoArgumentsConstOffDiagonal ModelConstantOrOneArgument + | ModelTwoArgumentsConstAboveDiagonal ModelConstantOrTwoArguments + | ModelTwoArgumentsConstBelowDiagonal ModelConstantOrTwoArguments + | ModelTwoArgumentsQuadraticInY OneVariableQuadraticFunction + | ModelTwoArgumentsQuadraticInXAndY TwoVariableQuadraticFunction + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) instance Default ModelTwoArguments where - def = ModelTwoArgumentsConstantCost maxBound + def = ModelTwoArgumentsConstantCost maxBound instance UnimplementedCostingFun ModelTwoArguments where unimplementedCostingFun = makeUnimplementedCostingFun ModelTwoArgumentsConstantCost -- See Note [runCostingFun* API]. -runCostingFunTwoArguments - :: ( ExMemoryUsage a1 - , ExMemoryUsage a2 - ) - => CostingFun ModelTwoArguments - -> a1 - -> a2 - -> ExBudgetStream +runCostingFunTwoArguments :: + ( ExMemoryUsage a1 + , ExMemoryUsage a2 + ) => + CostingFun ModelTwoArguments -> + a1 -> + a2 -> + ExBudgetStream runCostingFunTwoArguments (CostingFun cpu mem) = - case (runTwoArgumentModel cpu, runTwoArgumentModel mem) of - (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 -> - zipCostStream - (runCpu mem1 mem2) - (runMem mem1 mem2) + case (runTwoArgumentModel cpu, runTwoArgumentModel mem) of + (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 -> + zipCostStream + (runCpu mem1 mem2) + (runMem mem1 mem2) {-# INLINE runCostingFunTwoArguments #-} -- | Take an intercept, two slopes and two streams, and scale each element of @@ -524,156 +564,155 @@ runCostingFunTwoArguments (CostingFun cpu mem) = -- the stream afterwards. scaleLinearlyTwoVariables :: Intercept -> Slope -> CostStream -> Slope -> CostStream -> CostStream scaleLinearlyTwoVariables (Intercept intercept) (Slope slope1) stream1 (Slope slope2) stream2 = - addCostStream + addCostStream (CostLast intercept) - (addCostStream - (mapCostStream (slope1 *) stream1) - (mapCostStream (slope2 *) stream2) + ( addCostStream + (mapCostStream (slope1 *) stream1) + (mapCostStream (slope2 *) stream2) ) {-# INLINE scaleLinearlyTwoVariables #-} +runTwoArgumentModel :: + ModelTwoArguments -> + CostStream -> + CostStream -> + CostStream runTwoArgumentModel - :: ModelTwoArguments - -> CostStream - -> CostStream - -> CostStream -runTwoArgumentModel - (ModelTwoArgumentsConstantCost c) = lazy $ \_ _ -> CostLast c + (ModelTwoArgumentsConstantCost c) = lazy $ \_ _ -> CostLast c runTwoArgumentModel - (ModelTwoArgumentsAddedSizes (OneVariableLinearFunction intercept slope)) = - lazy $ \costs1 costs2 -> - scaleLinearly intercept slope $ addCostStream costs1 costs2 + (ModelTwoArgumentsAddedSizes (OneVariableLinearFunction intercept slope)) = + lazy $ \costs1 costs2 -> + scaleLinearly intercept slope $ addCostStream costs1 costs2 runTwoArgumentModel - (ModelTwoArgumentsSubtractedSizes (ModelSubtractedSizes intercept slope minSize)) = - lazy $ \costs1 costs2 -> do - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - scaleLinearly intercept slope $ CostLast (max minSize $ size1 - size2) + (ModelTwoArgumentsSubtractedSizes (ModelSubtractedSizes intercept slope minSize)) = + lazy $ \costs1 costs2 -> do + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + scaleLinearly intercept slope $ CostLast (max minSize $ size1 - size2) runTwoArgumentModel - (ModelTwoArgumentsMultipliedSizes (OneVariableLinearFunction intercept slope)) = - lazy $ \costs1 costs2 -> do - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - scaleLinearly intercept slope $ CostLast (size1 * size2) + (ModelTwoArgumentsMultipliedSizes (OneVariableLinearFunction intercept slope)) = + lazy $ \costs1 costs2 -> do + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + scaleLinearly intercept slope $ CostLast (size1 * size2) runTwoArgumentModel - (ModelTwoArgumentsMinSize (OneVariableLinearFunction intercept slope)) = - lazy $ \costs1 costs2 -> do - scaleLinearly intercept slope $ minCostStream costs1 costs2 + (ModelTwoArgumentsMinSize (OneVariableLinearFunction intercept slope)) = + lazy $ \costs1 costs2 -> do + scaleLinearly intercept slope $ minCostStream costs1 costs2 runTwoArgumentModel - (ModelTwoArgumentsMaxSize (OneVariableLinearFunction intercept slope)) = - lazy $ \costs1 costs2 -> do - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - scaleLinearly intercept slope $ CostLast (max size1 size2) + (ModelTwoArgumentsMaxSize (OneVariableLinearFunction intercept slope)) = + lazy $ \costs1 costs2 -> do + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + scaleLinearly intercept slope $ CostLast (max size1 size2) runTwoArgumentModel - (ModelTwoArgumentsLinearInX (OneVariableLinearFunction intercept slope)) = - lazy $ \costs1 _ -> - scaleLinearly intercept slope costs1 + (ModelTwoArgumentsLinearInX (OneVariableLinearFunction intercept slope)) = + lazy $ \costs1 _ -> + scaleLinearly intercept slope costs1 runTwoArgumentModel - (ModelTwoArgumentsLinearInY (OneVariableLinearFunction intercept slope)) = - lazy $ \_ costs2 -> - scaleLinearly intercept slope costs2 + (ModelTwoArgumentsLinearInY (OneVariableLinearFunction intercept slope)) = + lazy $ \_ costs2 -> + scaleLinearly intercept slope costs2 runTwoArgumentModel - (ModelTwoArgumentsLinearInXAndY (TwoVariableLinearFunction intercept slope1 slope2)) = - lazy $ \costs1 costs2 -> - scaleLinearlyTwoVariables intercept slope1 costs1 slope2 costs2 + (ModelTwoArgumentsLinearInXAndY (TwoVariableLinearFunction intercept slope1 slope2)) = + lazy $ \costs1 costs2 -> + scaleLinearlyTwoVariables intercept slope1 costs1 slope2 costs2 runTwoArgumentModel - -- See Note [Backward compatibility for costing functions] - -- Off the diagonal, return the constant. On the diagonal, run the one-variable linear model. - (ModelTwoArgumentsLinearOnDiagonal (ModelConstantOrLinear c intercept slope)) = - lazy $ \costs1 costs2 -> do - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - if size1 == size2 - then scaleLinearly intercept slope $ CostLast size1 - else CostLast c + -- See Note [Backward compatibility for costing functions] + -- Off the diagonal, return the constant. On the diagonal, run the one-variable linear model. + (ModelTwoArgumentsLinearOnDiagonal (ModelConstantOrLinear c intercept slope)) = + lazy $ \costs1 costs2 -> do + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + if size1 == size2 + then scaleLinearly intercept slope $ CostLast size1 + else CostLast c runTwoArgumentModel - -- Off the diagonal, return the constant. On the diagonal, run the other model. - (ModelTwoArgumentsConstOffDiagonal (ModelConstantOrOneArgument c m)) = - case runOneArgumentModel m of - !run -> lazy $ \costs1 costs2 -> do - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - if size1 /= size2 - then CostLast c - else run (CostLast size1) + -- Off the diagonal, return the constant. On the diagonal, run the other model. + (ModelTwoArgumentsConstOffDiagonal (ModelConstantOrOneArgument c m)) = + case runOneArgumentModel m of + !run -> lazy $ \costs1 costs2 -> do + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + if size1 /= size2 + then CostLast c + else run (CostLast size1) runTwoArgumentModel - -- Below the diagonal, return the constant. Above the diagonal, run the other model. - (ModelTwoArgumentsConstBelowDiagonal (ModelConstantOrTwoArguments c m)) = - case runTwoArgumentModel m of - !run -> lazy $ \costs1 costs2 -> do - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - if size1 > size2 - then CostLast c - else run (CostLast size1) (CostLast size2) + -- Below the diagonal, return the constant. Above the diagonal, run the other model. + (ModelTwoArgumentsConstBelowDiagonal (ModelConstantOrTwoArguments c m)) = + case runTwoArgumentModel m of + !run -> lazy $ \costs1 costs2 -> do + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + if size1 > size2 + then CostLast c + else run (CostLast size1) (CostLast size2) runTwoArgumentModel - -- Above the diagonal, return the constant. Below the diagonal, run the other model. - (ModelTwoArgumentsConstAboveDiagonal (ModelConstantOrTwoArguments c m)) = - case runTwoArgumentModel m of - !run -> lazy $ \costs1 costs2 -> do - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - if size1 < size2 - then CostLast c - else run (CostLast size1) (CostLast size2) + -- Above the diagonal, return the constant. Below the diagonal, run the other model. + (ModelTwoArgumentsConstAboveDiagonal (ModelConstantOrTwoArguments c m)) = + case runTwoArgumentModel m of + !run -> lazy $ \costs1 costs2 -> do + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + if size1 < size2 + then CostLast c + else run (CostLast size1) (CostLast size2) runTwoArgumentModel - (ModelTwoArgumentsQuadraticInY f) = - lazy $ \_ costs2 -> - CostLast $ evaluateOneVariableQuadraticFunction f $ sumCostStream costs2 + (ModelTwoArgumentsQuadraticInY f) = + lazy $ \_ costs2 -> + CostLast $ evaluateOneVariableQuadraticFunction f $ sumCostStream costs2 runTwoArgumentModel - (ModelTwoArgumentsQuadraticInXAndY f) = - lazy $ \costs1 costs2 -> - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - in CostLast $ evaluateTwoVariableQuadraticFunction f size1 size2 + (ModelTwoArgumentsQuadraticInXAndY f) = + lazy $ \costs1 costs2 -> + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + in CostLast $ evaluateTwoVariableQuadraticFunction f size1 size2 {-# OPAQUE runTwoArgumentModel #-} - ---------------- Three-argument costing functions ---------------- -data ModelThreeArguments = - ModelThreeArgumentsConstantCost CostingInteger - | ModelThreeArgumentsLinearInX OneVariableLinearFunction - | ModelThreeArgumentsLinearInY OneVariableLinearFunction - | ModelThreeArgumentsLinearInZ OneVariableLinearFunction - | ModelThreeArgumentsQuadraticInZ OneVariableQuadraticFunction - | ModelThreeArgumentsLiteralInYOrLinearInZ OneVariableLinearFunction - | ModelThreeArgumentsLinearInMaxYZ OneVariableLinearFunction - | ModelThreeArgumentsLinearInYAndZ TwoVariableLinearFunction - | ModelThreeArgumentsQuadraticInYAndZ TwoVariableQuadraticFunction - | ModelThreeArgumentsExpModCost ExpModCostingFunction - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) +data ModelThreeArguments + = ModelThreeArgumentsConstantCost CostingInteger + | ModelThreeArgumentsLinearInX OneVariableLinearFunction + | ModelThreeArgumentsLinearInY OneVariableLinearFunction + | ModelThreeArgumentsLinearInZ OneVariableLinearFunction + | ModelThreeArgumentsQuadraticInZ OneVariableQuadraticFunction + | ModelThreeArgumentsLiteralInYOrLinearInZ OneVariableLinearFunction + | ModelThreeArgumentsLinearInMaxYZ OneVariableLinearFunction + | ModelThreeArgumentsLinearInYAndZ TwoVariableLinearFunction + | ModelThreeArgumentsQuadraticInYAndZ TwoVariableQuadraticFunction + | ModelThreeArgumentsExpModCost ExpModCostingFunction + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) instance Default ModelThreeArguments where - def = ModelThreeArgumentsConstantCost maxBound + def = ModelThreeArgumentsConstantCost maxBound instance UnimplementedCostingFun ModelThreeArguments where unimplementedCostingFun = makeUnimplementedCostingFun ModelThreeArgumentsConstantCost -runThreeArgumentModel - :: ModelThreeArguments - -> CostStream - -> CostStream - -> CostStream - -> CostStream +runThreeArgumentModel :: + ModelThreeArguments -> + CostStream -> + CostStream -> + CostStream -> + CostStream runThreeArgumentModel (ModelThreeArgumentsConstantCost c) = lazy $ \_ _ _ -> CostLast c runThreeArgumentModel - (ModelThreeArgumentsLinearInX (OneVariableLinearFunction intercept slope)) = - lazy $ \costs1 _ _ -> - scaleLinearly intercept slope costs1 + (ModelThreeArgumentsLinearInX (OneVariableLinearFunction intercept slope)) = + lazy $ \costs1 _ _ -> + scaleLinearly intercept slope costs1 runThreeArgumentModel - (ModelThreeArgumentsLinearInY (OneVariableLinearFunction intercept slope)) = - lazy $ \_ costs2 _ -> - scaleLinearly intercept slope costs2 + (ModelThreeArgumentsLinearInY (OneVariableLinearFunction intercept slope)) = + lazy $ \_ costs2 _ -> + scaleLinearly intercept slope costs2 runThreeArgumentModel - (ModelThreeArgumentsLinearInZ (OneVariableLinearFunction intercept slope)) = - lazy $ \_ _ costs3 -> - scaleLinearly intercept slope costs3 + (ModelThreeArgumentsLinearInZ (OneVariableLinearFunction intercept slope)) = + lazy $ \_ _ costs3 -> + scaleLinearly intercept slope costs3 runThreeArgumentModel - (ModelThreeArgumentsQuadraticInZ f) = - lazy $ \_ _ costs3 -> CostLast $ evaluateOneVariableQuadraticFunction f $ sumCostStream costs3 + (ModelThreeArgumentsQuadraticInZ f) = + lazy $ \_ _ costs3 -> CostLast $ evaluateOneVariableQuadraticFunction f $ sumCostStream costs3 {- Either a literal number of bytes or a linear function. This is for `integerToByteString`, where if the second argument is zero, the output bytestring has the minimum length required to contain the converted integer, @@ -684,196 +723,192 @@ runThreeArgumentModel gets a number from `onMemoryUsages`). -} runThreeArgumentModel - (ModelThreeArgumentsLiteralInYOrLinearInZ (OneVariableLinearFunction intercept slope)) = - lazy $ \_ costs2 costs3 -> - let !width = sumCostStream costs2 - in if width == 0 + (ModelThreeArgumentsLiteralInYOrLinearInZ (OneVariableLinearFunction intercept slope)) = + lazy $ \_ costs2 costs3 -> + let !width = sumCostStream costs2 + in if width == 0 then scaleLinearly intercept slope costs3 else costs2 runThreeArgumentModel - (ModelThreeArgumentsLinearInMaxYZ (OneVariableLinearFunction intercept slope)) = - lazy $ \_ costs2 costs3 -> - let !size2 = sumCostStream costs2 - !size3 = sumCostStream costs3 - in scaleLinearly intercept slope $ CostLast (max size2 size3) + (ModelThreeArgumentsLinearInMaxYZ (OneVariableLinearFunction intercept slope)) = + lazy $ \_ costs2 costs3 -> + let !size2 = sumCostStream costs2 + !size3 = sumCostStream costs3 + in scaleLinearly intercept slope $ CostLast (max size2 size3) runThreeArgumentModel - (ModelThreeArgumentsLinearInYAndZ (TwoVariableLinearFunction intercept slope2 slope3)) = - lazy $ \_costs1 costs2 costs3 -> - scaleLinearlyTwoVariables intercept slope2 costs2 slope3 costs3 - + (ModelThreeArgumentsLinearInYAndZ (TwoVariableLinearFunction intercept slope2 slope3)) = + lazy $ \_costs1 costs2 costs3 -> + scaleLinearlyTwoVariables intercept slope2 costs2 slope3 costs3 runThreeArgumentModel (ModelThreeArgumentsQuadraticInYAndZ f) = - lazy $ \_ costs2 costs3 -> - let !size2 = sumCostStream costs2 - !size3 = sumCostStream costs3 - in CostLast $ evaluateTwoVariableQuadraticFunction f size2 size3 - + lazy $ \_ costs2 costs3 -> + let !size2 = sumCostStream costs2 + !size3 = sumCostStream costs3 + in CostLast $ evaluateTwoVariableQuadraticFunction f size2 size3 runThreeArgumentModel (ModelThreeArgumentsExpModCost f) = lazy $ \costs1 costs2 costs3 -> - let !size1 = sumCostStream costs1 - !size2 = sumCostStream costs2 - !size3 = sumCostStream costs3 - in CostLast $ evaluateExpModCostingFunction f size1 size2 size3 + let !size1 = sumCostStream costs1 + !size2 = sumCostStream costs2 + !size3 = sumCostStream costs3 + in CostLast $ evaluateExpModCostingFunction f size1 size2 size3 {-# OPAQUE runThreeArgumentModel #-} -- See Note [runCostingFun* API]. -runCostingFunThreeArguments - :: ( ExMemoryUsage a1 - , ExMemoryUsage a2 - , ExMemoryUsage a3 - ) - => CostingFun ModelThreeArguments - -> a1 - -> a2 - -> a3 - -> ExBudgetStream +runCostingFunThreeArguments :: + ( ExMemoryUsage a1 + , ExMemoryUsage a2 + , ExMemoryUsage a3 + ) => + CostingFun ModelThreeArguments -> + a1 -> + a2 -> + a3 -> + ExBudgetStream runCostingFunThreeArguments (CostingFun cpu mem) = - case (runThreeArgumentModel cpu, runThreeArgumentModel mem) of - (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 -> - zipCostStream - (runCpu mem1 mem2 mem3) - (runMem mem1 mem2 mem3) + case (runThreeArgumentModel cpu, runThreeArgumentModel mem) of + (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 -> + zipCostStream + (runCpu mem1 mem2 mem3) + (runMem mem1 mem2 mem3) {-# INLINE runCostingFunThreeArguments #-} - ---------------- Four-argument costing functions ---------------- -data ModelFourArguments = - ModelFourArgumentsConstantCost CostingInteger - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) +data ModelFourArguments + = ModelFourArgumentsConstantCost CostingInteger + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) instance Default ModelFourArguments where - def = ModelFourArgumentsConstantCost maxBound + def = ModelFourArgumentsConstantCost maxBound instance UnimplementedCostingFun ModelFourArguments where unimplementedCostingFun = makeUnimplementedCostingFun ModelFourArgumentsConstantCost -runFourArgumentModel - :: ModelFourArguments - -> CostStream - -> CostStream - -> CostStream - -> CostStream - -> CostStream +runFourArgumentModel :: + ModelFourArguments -> + CostStream -> + CostStream -> + CostStream -> + CostStream -> + CostStream runFourArgumentModel (ModelFourArgumentsConstantCost c) = lazy $ \_ _ _ _ -> CostLast c {-# OPAQUE runFourArgumentModel #-} -- See Note [runCostingFun* API]. -runCostingFunFourArguments - :: ( ExMemoryUsage a1 - , ExMemoryUsage a2 - , ExMemoryUsage a3 - , ExMemoryUsage a4 - ) - => CostingFun ModelFourArguments - -> a1 - -> a2 - -> a3 - -> a4 - -> ExBudgetStream +runCostingFunFourArguments :: + ( ExMemoryUsage a1 + , ExMemoryUsage a2 + , ExMemoryUsage a3 + , ExMemoryUsage a4 + ) => + CostingFun ModelFourArguments -> + a1 -> + a2 -> + a3 -> + a4 -> + ExBudgetStream runCostingFunFourArguments (CostingFun cpu mem) = - case (runFourArgumentModel cpu, runFourArgumentModel mem) of - (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 mem4 -> - zipCostStream - (runCpu mem1 mem2 mem3 mem4) - (runMem mem1 mem2 mem3 mem4) + case (runFourArgumentModel cpu, runFourArgumentModel mem) of + (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 mem4 -> + zipCostStream + (runCpu mem1 mem2 mem3 mem4) + (runMem mem1 mem2 mem3 mem4) {-# INLINE runCostingFunFourArguments #-} - ---------------- Five-argument costing functions ---------------- -data ModelFiveArguments = - ModelFiveArgumentsConstantCost CostingInteger - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) +data ModelFiveArguments + = ModelFiveArgumentsConstantCost CostingInteger + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) instance Default ModelFiveArguments where - def = ModelFiveArgumentsConstantCost maxBound + def = ModelFiveArgumentsConstantCost maxBound instance UnimplementedCostingFun ModelFiveArguments where unimplementedCostingFun = makeUnimplementedCostingFun ModelFiveArgumentsConstantCost -runFiveArgumentModel - :: ModelFiveArguments - -> CostStream - -> CostStream - -> CostStream - -> CostStream - -> CostStream - -> CostStream +runFiveArgumentModel :: + ModelFiveArguments -> + CostStream -> + CostStream -> + CostStream -> + CostStream -> + CostStream -> + CostStream runFiveArgumentModel (ModelFiveArgumentsConstantCost c) = lazy $ \_ _ _ _ _ -> CostLast c {-# OPAQUE runFiveArgumentModel #-} -- See Note [runCostingFun* API]. -runCostingFunFiveArguments - :: ( ExMemoryUsage a1 - , ExMemoryUsage a2 - , ExMemoryUsage a3 - , ExMemoryUsage a4 - , ExMemoryUsage a5 - ) - => CostingFun ModelFiveArguments - -> a1 - -> a2 - -> a3 - -> a4 - -> a5 - -> ExBudgetStream +runCostingFunFiveArguments :: + ( ExMemoryUsage a1 + , ExMemoryUsage a2 + , ExMemoryUsage a3 + , ExMemoryUsage a4 + , ExMemoryUsage a5 + ) => + CostingFun ModelFiveArguments -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + ExBudgetStream runCostingFunFiveArguments (CostingFun cpu mem) = - case (runFiveArgumentModel cpu, runFiveArgumentModel mem) of - (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 mem4 mem5 -> - zipCostStream - (runCpu mem1 mem2 mem3 mem4 mem5) - (runMem mem1 mem2 mem3 mem4 mem5) + case (runFiveArgumentModel cpu, runFiveArgumentModel mem) of + (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 mem4 mem5 -> + zipCostStream + (runCpu mem1 mem2 mem3 mem4 mem5) + (runMem mem1 mem2 mem3 mem4 mem5) {-# INLINE runCostingFunFiveArguments #-} ---------------- Six-argument costing functions ---------------- -data ModelSixArguments = - ModelSixArgumentsConstantCost CostingInteger - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) +data ModelSixArguments + = ModelSixArgumentsConstantCost CostingInteger + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) instance Default ModelSixArguments where - def = ModelSixArgumentsConstantCost maxBound + def = ModelSixArgumentsConstantCost maxBound instance UnimplementedCostingFun ModelSixArguments where unimplementedCostingFun = makeUnimplementedCostingFun ModelSixArgumentsConstantCost -runSixArgumentModel - :: ModelSixArguments - -> CostStream - -> CostStream - -> CostStream - -> CostStream - -> CostStream - -> CostStream - -> CostStream +runSixArgumentModel :: + ModelSixArguments -> + CostStream -> + CostStream -> + CostStream -> + CostStream -> + CostStream -> + CostStream -> + CostStream runSixArgumentModel (ModelSixArgumentsConstantCost c) = lazy $ \_ _ _ _ _ _ -> CostLast c {-# OPAQUE runSixArgumentModel #-} -- See Note [runCostingFun* API]. -runCostingFunSixArguments - :: ( ExMemoryUsage a1 - , ExMemoryUsage a2 - , ExMemoryUsage a3 - , ExMemoryUsage a4 - , ExMemoryUsage a5 - , ExMemoryUsage a6 - ) - => CostingFun ModelSixArguments - -> a1 - -> a2 - -> a3 - -> a4 - -> a5 - -> a6 - -> ExBudgetStream +runCostingFunSixArguments :: + ( ExMemoryUsage a1 + , ExMemoryUsage a2 + , ExMemoryUsage a3 + , ExMemoryUsage a4 + , ExMemoryUsage a5 + , ExMemoryUsage a6 + ) => + CostingFun ModelSixArguments -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + ExBudgetStream runCostingFunSixArguments (CostingFun cpu mem) = - case (runSixArgumentModel cpu, runSixArgumentModel mem) of - (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 mem4 mem5 mem6 -> - zipCostStream - (runCpu mem1 mem2 mem3 mem4 mem5 mem6) - (runMem mem1 mem2 mem3 mem4 mem5 mem6) + case (runSixArgumentModel cpu, runSixArgumentModel mem) of + (!runCpu, !runMem) -> onMemoryUsages $ \mem1 mem2 mem3 mem4 mem5 mem6 -> + zipCostStream + (runCpu mem1 mem2 mem3 mem4 mem5 mem6) + (runMem mem1 mem2 mem3 mem4 mem5 mem6) {-# INLINE runCostingFunSixArguments #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs index abf72d19736..01830a2cf8b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - +{-# OPTIONS_GHC -O0 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -O0 #-} -- | A separate module for JSON instances, so that we can stick @-O0@ on it and avoid spending -- a lot of time optimizing loads of Core whose performance doesn't matter. @@ -20,103 +19,169 @@ import PlutusCore.Evaluation.Machine.CostingFun.Core type ModelJSON prefix = CustomJSON '[FieldLabelModifier (StripPrefix prefix, CamelToSnake)] type ModelArgumentJSON prefix = - CustomJSON - -- Without TagSingleConstructors the format can change unexpectedly if - -- you add/remove constructors because you don't get the tags if there's - -- only one constructor but you do if there's more than one. - '[ TagSingleConstructors - , SumTaggedObject "type" "arguments" - , ConstructorTagModifier (StripPrefix prefix, CamelToSnake)] + CustomJSON + -- Without TagSingleConstructors the format can change unexpectedly if + -- you add/remove constructors because you don't get the tags if there's + -- only one constructor but you do if there's more than one. + '[ TagSingleConstructors + , SumTaggedObject "type" "arguments" + , ConstructorTagModifier (StripPrefix prefix, CamelToSnake) + ] -deriving via ModelJSON "costingFun" (CostingFun model) - instance FromJSON model => FromJSON (CostingFun model) -deriving via ModelJSON "costingFun" (CostingFun model) - instance ToJSON model => ToJSON (CostingFun model) +deriving via + ModelJSON "costingFun" (CostingFun model) + instance + FromJSON model => FromJSON (CostingFun model) +deriving via + ModelJSON "costingFun" (CostingFun model) + instance + ToJSON model => ToJSON (CostingFun model) deriving newtype instance FromJSON Intercept -deriving newtype instance ToJSON Intercept +deriving newtype instance ToJSON Intercept deriving newtype instance FromJSON Slope -deriving newtype instance ToJSON Slope +deriving newtype instance ToJSON Slope deriving newtype instance FromJSON Coefficient0 -deriving newtype instance ToJSON Coefficient0 +deriving newtype instance ToJSON Coefficient0 deriving newtype instance FromJSON Coefficient1 -deriving newtype instance ToJSON Coefficient1 +deriving newtype instance ToJSON Coefficient1 deriving newtype instance FromJSON Coefficient2 -deriving newtype instance ToJSON Coefficient2 +deriving newtype instance ToJSON Coefficient2 deriving newtype instance FromJSON Coefficient00 -deriving newtype instance ToJSON Coefficient00 +deriving newtype instance ToJSON Coefficient00 deriving newtype instance FromJSON Coefficient10 -deriving newtype instance ToJSON Coefficient10 +deriving newtype instance ToJSON Coefficient10 deriving newtype instance FromJSON Coefficient01 -deriving newtype instance ToJSON Coefficient01 +deriving newtype instance ToJSON Coefficient01 deriving newtype instance FromJSON Coefficient20 -deriving newtype instance ToJSON Coefficient20 +deriving newtype instance ToJSON Coefficient20 deriving newtype instance FromJSON Coefficient11 -deriving newtype instance ToJSON Coefficient11 +deriving newtype instance ToJSON Coefficient11 deriving newtype instance FromJSON Coefficient02 -deriving newtype instance ToJSON Coefficient02 +deriving newtype instance ToJSON Coefficient02 deriving newtype instance FromJSON Coefficient12 -deriving newtype instance ToJSON Coefficient12 +deriving newtype instance ToJSON Coefficient12 + +deriving via + ModelArgumentJSON "ModelOneArgument" ModelOneArgument + instance + FromJSON ModelOneArgument +deriving via + ModelArgumentJSON "ModelOneArgument" ModelOneArgument + instance + ToJSON ModelOneArgument +deriving via + ModelArgumentJSON "ModelTwoArguments" ModelTwoArguments + instance + FromJSON ModelTwoArguments +deriving via + ModelArgumentJSON "ModelTwoArguments" ModelTwoArguments + instance + ToJSON ModelTwoArguments +deriving via + ModelArgumentJSON "ModelThreeArguments" ModelThreeArguments + instance + FromJSON ModelThreeArguments +deriving via + ModelArgumentJSON "ModelThreeArguments" ModelThreeArguments + instance + ToJSON ModelThreeArguments +deriving via + ModelArgumentJSON "ModelFourArguments" ModelFourArguments + instance + FromJSON ModelFourArguments +deriving via + ModelArgumentJSON "ModelFourArguments" ModelFourArguments + instance + ToJSON ModelFourArguments +deriving via + ModelArgumentJSON "ModelFiveArguments" ModelFiveArguments + instance + FromJSON ModelFiveArguments +deriving via + ModelArgumentJSON "ModelFiveArguments" ModelFiveArguments + instance + ToJSON ModelFiveArguments +deriving via + ModelArgumentJSON "ModelSixArguments" ModelSixArguments + instance + FromJSON ModelSixArguments +deriving via + ModelArgumentJSON "ModelSixArguments" ModelSixArguments + instance + ToJSON ModelSixArguments -deriving via ModelArgumentJSON "ModelOneArgument" ModelOneArgument - instance FromJSON ModelOneArgument -deriving via ModelArgumentJSON "ModelOneArgument" ModelOneArgument - instance ToJSON ModelOneArgument -deriving via ModelArgumentJSON "ModelTwoArguments" ModelTwoArguments - instance FromJSON ModelTwoArguments -deriving via ModelArgumentJSON "ModelTwoArguments" ModelTwoArguments - instance ToJSON ModelTwoArguments -deriving via ModelArgumentJSON "ModelThreeArguments" ModelThreeArguments - instance FromJSON ModelThreeArguments -deriving via ModelArgumentJSON "ModelThreeArguments" ModelThreeArguments - instance ToJSON ModelThreeArguments -deriving via ModelArgumentJSON "ModelFourArguments" ModelFourArguments - instance FromJSON ModelFourArguments -deriving via ModelArgumentJSON "ModelFourArguments" ModelFourArguments - instance ToJSON ModelFourArguments -deriving via ModelArgumentJSON "ModelFiveArguments" ModelFiveArguments - instance FromJSON ModelFiveArguments -deriving via ModelArgumentJSON "ModelFiveArguments" ModelFiveArguments - instance ToJSON ModelFiveArguments -deriving via ModelArgumentJSON "ModelSixArguments" ModelSixArguments - instance FromJSON ModelSixArguments -deriving via ModelArgumentJSON "ModelSixArguments" ModelSixArguments - instance ToJSON ModelSixArguments +deriving via + ModelJSON "modelSubtractedSizes" ModelSubtractedSizes + instance + FromJSON ModelSubtractedSizes +deriving via + ModelJSON "modelSubtractedSizes" ModelSubtractedSizes + instance + ToJSON ModelSubtractedSizes +deriving via + ModelJSON "oneVariableLinearFunction" OneVariableLinearFunction + instance + FromJSON OneVariableLinearFunction +deriving via + ModelJSON "oneVariableLinearFunction" OneVariableLinearFunction + instance + ToJSON OneVariableLinearFunction +deriving via + ModelJSON "twoVariableLinearFunction" TwoVariableLinearFunction + instance + FromJSON TwoVariableLinearFunction +deriving via + ModelJSON "twoVariableLinearFunction" TwoVariableLinearFunction + instance + ToJSON TwoVariableLinearFunction +deriving via + ModelJSON "oneVariableQuadraticFunction" OneVariableQuadraticFunction + instance + FromJSON OneVariableQuadraticFunction +deriving via + ModelJSON "oneVariableQuadraticFunction" OneVariableQuadraticFunction + instance + ToJSON OneVariableQuadraticFunction +deriving via + ModelJSON "twoVariableQuadraticFunction" TwoVariableQuadraticFunction + instance + FromJSON TwoVariableQuadraticFunction +deriving via + ModelJSON "twoVariableQuadraticFunction" TwoVariableQuadraticFunction + instance + ToJSON TwoVariableQuadraticFunction +deriving via + ModelJSON "expModCostingFunction" ExpModCostingFunction + instance + FromJSON ExpModCostingFunction +deriving via + ModelJSON "expModCostingFunction" ExpModCostingFunction + instance + ToJSON ExpModCostingFunction +deriving via + ModelJSON "modelConstantOrOneArgument" ModelConstantOrOneArgument + instance + FromJSON ModelConstantOrOneArgument +deriving via + ModelJSON "modelConstantOrOneArgument" ModelConstantOrOneArgument + instance + ToJSON ModelConstantOrOneArgument +deriving via + ModelJSON "modelConstantOrTwoArguments" ModelConstantOrTwoArguments + instance + FromJSON ModelConstantOrTwoArguments +deriving via + ModelJSON "modelConstantOrTwoArguments" ModelConstantOrTwoArguments + instance + ToJSON ModelConstantOrTwoArguments -deriving via ModelJSON "modelSubtractedSizes" ModelSubtractedSizes - instance FromJSON ModelSubtractedSizes -deriving via ModelJSON "modelSubtractedSizes" ModelSubtractedSizes - instance ToJSON ModelSubtractedSizes -deriving via ModelJSON "oneVariableLinearFunction" OneVariableLinearFunction - instance FromJSON OneVariableLinearFunction -deriving via ModelJSON "oneVariableLinearFunction" OneVariableLinearFunction - instance ToJSON OneVariableLinearFunction -deriving via ModelJSON "twoVariableLinearFunction" TwoVariableLinearFunction - instance FromJSON TwoVariableLinearFunction -deriving via ModelJSON "twoVariableLinearFunction" TwoVariableLinearFunction - instance ToJSON TwoVariableLinearFunction -deriving via ModelJSON "oneVariableQuadraticFunction" OneVariableQuadraticFunction - instance FromJSON OneVariableQuadraticFunction -deriving via ModelJSON "oneVariableQuadraticFunction" OneVariableQuadraticFunction - instance ToJSON OneVariableQuadraticFunction -deriving via ModelJSON "twoVariableQuadraticFunction" TwoVariableQuadraticFunction - instance FromJSON TwoVariableQuadraticFunction -deriving via ModelJSON "twoVariableQuadraticFunction" TwoVariableQuadraticFunction - instance ToJSON TwoVariableQuadraticFunction -deriving via ModelJSON "expModCostingFunction" ExpModCostingFunction - instance FromJSON ExpModCostingFunction -deriving via ModelJSON "expModCostingFunction" ExpModCostingFunction - instance ToJSON ExpModCostingFunction -deriving via ModelJSON "modelConstantOrOneArgument" ModelConstantOrOneArgument - instance FromJSON ModelConstantOrOneArgument -deriving via ModelJSON "modelConstantOrOneArgument" ModelConstantOrOneArgument - instance ToJSON ModelConstantOrOneArgument -deriving via ModelJSON "modelConstantOrTwoArguments" ModelConstantOrTwoArguments - instance FromJSON ModelConstantOrTwoArguments -deriving via ModelJSON "modelConstantOrTwoArguments" ModelConstantOrTwoArguments - instance ToJSON ModelConstantOrTwoArguments -- See Note [Backward compatibility for costing functions] for ModelConstantOrLinear -deriving via ModelJSON "modelConstantOrLinear" ModelConstantOrLinear - instance FromJSON ModelConstantOrLinear -deriving via ModelJSON "modelConstantOrLinear" ModelConstantOrLinear - instance ToJSON ModelConstantOrLinear +deriving via + ModelJSON "modelConstantOrLinear" ModelConstantOrLinear + instance + FromJSON ModelConstantOrLinear +deriving via + ModelJSON "modelConstantOrLinear" ModelConstantOrLinear + instance + ToJSON ModelConstantOrLinear diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/SimpleJSON.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/SimpleJSON.hs index 2c26e33f4c9..8c594e97861 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/SimpleJSON.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/SimpleJSON.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{- | A JSON representation of costing functions for Plutus Core - builtins which produces a simple cost model which can be used from Agda and other - executables -} +-- | A JSON representation of costing functions for Plutus Core +-- builtins which produces a simple cost model which can be used from Agda and other +-- executables module PlutusCore.Evaluation.Machine.CostingFun.SimpleJSON where import Data.Aeson @@ -12,96 +12,100 @@ import Language.Haskell.TH.Syntax (Lift) -------------- Types representing cost mode entries and functions for JSON parsing ---------------- -data LinearFunction = - LinearFunction {intercept_ :: Integer, slope_ :: Integer} - deriving stock (Show, Lift) +data LinearFunction + = LinearFunction {intercept_ :: Integer, slope_ :: Integer} + deriving stock (Show, Lift) instance FromJSON LinearFunction where - parseJSON = withObject "Linear function" $ \obj -> - LinearFunction <$> obj .: "intercept" <*> obj .: "slope" + parseJSON = withObject "Linear function" $ \obj -> + LinearFunction <$> obj .: "intercept" <*> obj .: "slope" -data TwoVariableLinearFunction = - TwoVariableLinearFunction {intercept'_ :: Integer, slope1_ :: Integer, slope2_ :: Integer} - deriving stock (Show, Lift) +data TwoVariableLinearFunction + = TwoVariableLinearFunction {intercept'_ :: Integer, slope1_ :: Integer, slope2_ :: Integer} + deriving stock (Show, Lift) instance FromJSON TwoVariableLinearFunction where - parseJSON = withObject "Linear function" $ \obj -> - TwoVariableLinearFunction <$> obj .: "intercept" <*> obj .: "slope1" <*> obj .: "slope2" + parseJSON = withObject "Linear function" $ \obj -> + TwoVariableLinearFunction <$> obj .: "intercept" <*> obj .: "slope1" <*> obj .: "slope2" -data OneVariableQuadraticFunction = - OneVariableQuadraticFunction - { coeff0_ :: Integer - , coeff1_ :: Integer - , coeff2_ :: Integer - } - deriving stock (Show, Lift) +data OneVariableQuadraticFunction + = OneVariableQuadraticFunction + { coeff0_ :: Integer + , coeff1_ :: Integer + , coeff2_ :: Integer + } + deriving stock (Show, Lift) instance FromJSON OneVariableQuadraticFunction where - parseJSON = withObject "One-variable quadratic function" $ \obj -> - OneVariableQuadraticFunction <$> obj .: "c0" <*> obj .: "c1" <*> obj .: "c2" - -data TwoVariableQuadraticFunction = - TwoVariableQuadraticFunction - { minimum :: Integer - , coeff00_ :: Integer - , coeff10_ :: Integer - , coeff01_ :: Integer - , coeff20_ :: Integer - , coeff11_ :: Integer - , coeff02_ :: Integer - } - deriving stock (Show, Lift) + parseJSON = withObject "One-variable quadratic function" $ \obj -> + OneVariableQuadraticFunction <$> obj .: "c0" <*> obj .: "c1" <*> obj .: "c2" + +data TwoVariableQuadraticFunction + = TwoVariableQuadraticFunction + { minimum :: Integer + , coeff00_ :: Integer + , coeff10_ :: Integer + , coeff01_ :: Integer + , coeff20_ :: Integer + , coeff11_ :: Integer + , coeff02_ :: Integer + } + deriving stock (Show, Lift) instance FromJSON TwoVariableQuadraticFunction where - parseJSON = withObject "Two-variable quadratic function" $ \obj -> - TwoVariableQuadraticFunction <$> obj .: "minimum" <*> - obj .: "c00" <*> obj .: "c10" <*> obj .: "c01" <*> - obj .: "c20" <*> obj .: "c11" <*> obj .: "c02" - -data ExpModCostingFunction = - ExpModCostingFunction - { emcfcoeff00_ :: Integer - , emcfcoeff11_ :: Integer - , emcfcoeff12_ :: Integer - } - deriving stock (Show, Lift) + parseJSON = withObject "Two-variable quadratic function" $ \obj -> + TwoVariableQuadraticFunction + <$> obj .: "minimum" + <*> obj .: "c00" + <*> obj .: "c10" + <*> obj .: "c01" + <*> obj .: "c20" + <*> obj .: "c11" + <*> obj .: "c02" + +data ExpModCostingFunction + = ExpModCostingFunction + { emcfcoeff00_ :: Integer + , emcfcoeff11_ :: Integer + , emcfcoeff12_ :: Integer + } + deriving stock (Show, Lift) instance FromJSON ExpModCostingFunction where - parseJSON = withObject "ExpMod costing function" $ \obj -> - ExpModCostingFunction <$> - obj .: "coefficient00" <*> - obj .: "coefficient11" <*> - obj .: "coefficient12" - -{- | This type reflects what is actually in the JSON. The stuff in - CostingFun.Core and CostingFun.JSON is much more rigid, allowing parsing only - for the model types applicable to the various ModelNArguments types; it also - requires entries for everything in DefaultFun. Using the type defined here - allows us to be more flexible and parse stuff that's not exactly what's - expected in builtinCostModel.json. --} + parseJSON = withObject "ExpMod costing function" $ \obj -> + ExpModCostingFunction + <$> obj .: "coefficient00" + <*> obj .: "coefficient11" + <*> obj .: "coefficient12" + +-- | This type reflects what is actually in the JSON. The stuff in +-- CostingFun.Core and CostingFun.JSON is much more rigid, allowing parsing only +-- for the model types applicable to the various ModelNArguments types; it also +-- requires entries for everything in DefaultFun. Using the type defined here +-- allows us to be more flexible and parse stuff that's not exactly what's +-- expected in builtinCostModel.json. data Model - = ConstantCost Integer - | AddedSizes LinearFunction - | MultipliedSizes LinearFunction - | MinSize LinearFunction - | MaxSize LinearFunction - | LinearInX LinearFunction - | LinearInY LinearFunction - | LinearInZ LinearFunction - | LiteralInYOrLinearInZ LinearFunction - | LinearInMaxYZ LinearFunction - | LinearInYAndZ TwoVariableLinearFunction - | QuadraticInY OneVariableQuadraticFunction - | QuadraticInZ OneVariableQuadraticFunction - | QuadraticInXAndY TwoVariableQuadraticFunction - | SubtractedSizes LinearFunction Integer - -- ^ Linear model in x-y plus minimum value for the case x-y < 0. - | ConstAboveDiagonal Integer Model - | ConstBelowDiagonal Integer Model - | ConstOffDiagonal Integer Model - | ExpModCost ExpModCostingFunction - deriving stock (Show, Lift) + = ConstantCost Integer + | AddedSizes LinearFunction + | MultipliedSizes LinearFunction + | MinSize LinearFunction + | MaxSize LinearFunction + | LinearInX LinearFunction + | LinearInY LinearFunction + | LinearInZ LinearFunction + | LiteralInYOrLinearInZ LinearFunction + | LinearInMaxYZ LinearFunction + | LinearInYAndZ TwoVariableLinearFunction + | QuadraticInY OneVariableQuadraticFunction + | QuadraticInZ OneVariableQuadraticFunction + | QuadraticInXAndY TwoVariableQuadraticFunction + | -- | Linear model in x-y plus minimum value for the case x-y < 0. + SubtractedSizes LinearFunction Integer + | ConstAboveDiagonal Integer Model + | ConstBelowDiagonal Integer Model + | ConstOffDiagonal Integer Model + | ExpModCost ExpModCostingFunction + deriving stock (Show, Lift) {- The JSON representation consists of a list of pairs of (type, arguments) values. The "type" field corresponds to the possible constructors above, the @@ -115,65 +119,63 @@ data Model -} instance FromJSON Model where - parseJSON = - withObject "Model" $ - \obj -> do - ty :: Text <- obj .: "type" - args :: Value <- obj .: "arguments" - {- We always have an "arguments" field which is a Value. Usually it's - actually an Object (ie, a map) representing a linear function, but - sometimes it contains other data, and in those cases we need to - coerce it to an Object (with objOf) to extract the relevant data. - We could do that once here and rely on laziness to save us in the - cases when we don't have an Object, but that looks a bit misleading. -} - case ty of - "constant_cost" -> ConstantCost <$> parseJSON args - "added_sizes" -> AddedSizes <$> parseJSON args - "min_size" -> MinSize <$> parseJSON args - "max_size" -> MaxSize <$> parseJSON args - "multiplied_sizes" -> MultipliedSizes <$> parseJSON args - "linear_in_x" -> LinearInX <$> parseJSON args - "linear_in_y" -> LinearInY <$> parseJSON args - "linear_in_z" -> LinearInZ <$> parseJSON args - "quadratic_in_y" -> QuadraticInY <$> parseJSON args - "quadratic_in_z" -> QuadraticInZ <$> parseJSON args - "quadratic_in_x_and_y" -> QuadraticInXAndY <$> parseJSON args - "exp_mod_cost" -> ExpModCost <$> parseJSON args - "literal_in_y_or_linear_in_z" -> LiteralInYOrLinearInZ <$> parseJSON args - "linear_in_max_yz" -> LinearInMaxYZ <$> parseJSON args - "linear_in_y_and_z" -> LinearInYAndZ <$> parseJSON args - "subtracted_sizes" -> SubtractedSizes <$> parseJSON args <*> objOf args .: "minimum" - "const_above_diagonal" -> modelWithConstant ConstAboveDiagonal args - "const_below_diagonal" -> modelWithConstant ConstBelowDiagonal args - "const_off_diagonal" -> modelWithConstant ConstOffDiagonal args - {- An adaptor to deal with the old "linear_on_diagonal" tag. See Note [Backward - compatibility for costing functions]. We never want to convert back to JSON - here, so it's OK to forget that we originally got something tagged with - "linear_on_diagonal". -} - "linear_on_diagonal" -> - let o = objOf args - in do - constant <- o .: "constant" - intercept <- o .: "intercept" - slope <- o .: "slope" - pure $ ConstOffDiagonal constant (LinearInX $ LinearFunction intercept slope) - - _ -> errorWithoutStackTrace $ "Unknown model type " ++ show ty - - where objOf (Object o) = o - objOf _ = - errorWithoutStackTrace "Failed to get Object while parsing \"arguments\"" - - modelWithConstant constr x = constr <$> o .: "constant" <*> o .: "model" - where o = objOf x - -{- | A CPU usage modelling function and a memory usage modelling function bundled - together -} + parseJSON = + withObject "Model" $ + \obj -> do + ty :: Text <- obj .: "type" + args :: Value <- obj .: "arguments" + {- We always have an "arguments" field which is a Value. Usually it's + actually an Object (ie, a map) representing a linear function, but + sometimes it contains other data, and in those cases we need to + coerce it to an Object (with objOf) to extract the relevant data. + We could do that once here and rely on laziness to save us in the + cases when we don't have an Object, but that looks a bit misleading. -} + case ty of + "constant_cost" -> ConstantCost <$> parseJSON args + "added_sizes" -> AddedSizes <$> parseJSON args + "min_size" -> MinSize <$> parseJSON args + "max_size" -> MaxSize <$> parseJSON args + "multiplied_sizes" -> MultipliedSizes <$> parseJSON args + "linear_in_x" -> LinearInX <$> parseJSON args + "linear_in_y" -> LinearInY <$> parseJSON args + "linear_in_z" -> LinearInZ <$> parseJSON args + "quadratic_in_y" -> QuadraticInY <$> parseJSON args + "quadratic_in_z" -> QuadraticInZ <$> parseJSON args + "quadratic_in_x_and_y" -> QuadraticInXAndY <$> parseJSON args + "exp_mod_cost" -> ExpModCost <$> parseJSON args + "literal_in_y_or_linear_in_z" -> LiteralInYOrLinearInZ <$> parseJSON args + "linear_in_max_yz" -> LinearInMaxYZ <$> parseJSON args + "linear_in_y_and_z" -> LinearInYAndZ <$> parseJSON args + "subtracted_sizes" -> SubtractedSizes <$> parseJSON args <*> objOf args .: "minimum" + "const_above_diagonal" -> modelWithConstant ConstAboveDiagonal args + "const_below_diagonal" -> modelWithConstant ConstBelowDiagonal args + "const_off_diagonal" -> modelWithConstant ConstOffDiagonal args + {- An adaptor to deal with the old "linear_on_diagonal" tag. See Note [Backward + compatibility for costing functions]. We never want to convert back to JSON + here, so it's OK to forget that we originally got something tagged with + "linear_on_diagonal". -} + "linear_on_diagonal" -> + let o = objOf args + in do + constant <- o .: "constant" + intercept <- o .: "intercept" + slope <- o .: "slope" + pure $ ConstOffDiagonal constant (LinearInX $ LinearFunction intercept slope) + _ -> errorWithoutStackTrace $ "Unknown model type " ++ show ty + where + objOf (Object o) = o + objOf _ = + errorWithoutStackTrace "Failed to get Object while parsing \"arguments\"" + + modelWithConstant constr x = constr <$> o .: "constant" <*> o .: "model" + where + o = objOf x + +-- | A CPU usage modelling function and a memory usage modelling function bundled +-- together data CpuAndMemoryModel = CpuAndMemoryModel {cpuModel :: Model, memoryModel :: Model} - deriving stock (Show, Lift) + deriving stock (Show, Lift) instance FromJSON CpuAndMemoryModel where - parseJSON = withObject "CpuAndMemoryModel" $ \obj -> - CpuAndMemoryModel <$> obj .: "cpu" <*> obj .: "memory" - - + parseJSON = withObject "CpuAndMemoryModel" $ \obj -> + CpuAndMemoryModel <$> obj .: "cpu" <*> obj .: "memory" diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs index 42034107348..061563d07a7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs @@ -1,10 +1,10 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} {- Note [Strict Data for budgeting] @@ -134,15 +134,15 @@ possible to adjust them at runtime. is well within the accuracy we require for the cost model. -} -module PlutusCore.Evaluation.Machine.ExBudget - ( ExBudget(..) - , minusExBudget - , ExBudgetBuiltin(..) - , ExRestrictingBudget(..) - , LowerInitialCharacter - , largeBudget - , enormousBudget - ) where +module PlutusCore.Evaluation.Machine.ExBudget ( + ExBudget (..), + minusExBudget, + ExBudgetBuiltin (..), + ExRestrictingBudget (..), + LowerInitialCharacter, + largeBudget, + enormousBudget, +) where import PlutusCore.Evaluation.Machine.ExMemory import PlutusPrelude hiding (toList) @@ -154,10 +154,10 @@ import Language.Haskell.TH.Lift (Lift) import NoThunks.Class import Prettyprinter - -- | This is used elsewhere to convert cost models into JSON objects where the -- names of the fields are exactly the same as the names of the builtins. data LowerInitialCharacter + instance StringModifier LowerInitialCharacter where getStringModifier = lowerInitialChar @@ -166,46 +166,52 @@ instance StringModifier LowerInitialCharacter where -- constant application and we want to be general over @exBudgetCat@ there, but still track the -- built-in functions category, hence the ad hoc polymorphism. class ExBudgetBuiltin fun exBudgetCat where - exBudgetBuiltin :: fun -> exBudgetCat + exBudgetBuiltin :: fun -> exBudgetCat -- | A dummy 'ExBudgetBuiltin' instance to be used in monads where we don't care about costing. instance ExBudgetBuiltin fun () where - exBudgetBuiltin _ = () + exBudgetBuiltin _ = () -data ExBudget = ExBudget { exBudgetCPU :: ExCPU, exBudgetMemory :: ExMemory} - deriving stock (Eq, Show, Generic, Lift) - deriving anyclass (PrettyBy config, NFData, NoThunks, Serialise) - deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier LowerInitialCharacter] ExBudget - -- LowerInitialCharacter won't actually do anything here, but let's have it in case we change the field names. +data ExBudget = ExBudget {exBudgetCPU :: ExCPU, exBudgetMemory :: ExMemory} + deriving stock (Eq, Show, Generic, Lift) + deriving anyclass (PrettyBy config, NFData, NoThunks, Serialise) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier LowerInitialCharacter] ExBudget + +-- LowerInitialCharacter won't actually do anything here, but let's have it in case we change the field names. -- | Subtract one 'ExBudget' from another. Does not guarantee that the result is positive. minusExBudget :: ExBudget -> ExBudget -> ExBudget -minusExBudget (ExBudget c1 m1) (ExBudget c2 m2) = ExBudget (c1-c2) (m1-m2) +minusExBudget (ExBudget c1 m1) (ExBudget c2 m2) = ExBudget (c1 - c2) (m1 - m2) {-# INLINE minusExBudget #-} -- These functions are performance critical, so we can't use GenericSemigroupMonoid, and we insist that they be inlined. instance Semigroup ExBudget where - {-# INLINE (<>) #-} - (ExBudget cpu1 mem1) <> (ExBudget cpu2 mem2) = ExBudget (cpu1 <> cpu2) (mem1 <> mem2) - -- This absolutely must be inlined so that the 'fromIntegral' calls can get optimized away, or it destroys performance - {-# INLINE stimes #-} - stimes r (ExBudget (ExCPU cpu) (ExMemory mem)) = ExBudget (ExCPU (fromIntegral r * cpu)) (ExMemory (fromIntegral r * mem)) + {-# INLINE (<>) #-} + (ExBudget cpu1 mem1) <> (ExBudget cpu2 mem2) = ExBudget (cpu1 <> cpu2) (mem1 <> mem2) + + -- This absolutely must be inlined so that the 'fromIntegral' calls can get optimized away, or it destroys performance + {-# INLINE stimes #-} + stimes r (ExBudget (ExCPU cpu) (ExMemory mem)) = ExBudget (ExCPU (fromIntegral r * cpu)) (ExMemory (fromIntegral r * mem)) instance Monoid ExBudget where - mempty = ExBudget mempty mempty - {-# INLINE mempty #-} + mempty = ExBudget mempty mempty + {-# INLINE mempty #-} instance Pretty ExBudget where - pretty (ExBudget cpu memory) = parens $ braces $ vsep - [ "cpu:" <+> pretty cpu - , "| mem:" <+> pretty memory - ] + pretty (ExBudget cpu memory) = + parens $ + braces $ + vsep + [ "cpu:" <+> pretty cpu + , "| mem:" <+> pretty memory + ] newtype ExRestrictingBudget = ExRestrictingBudget - { unExRestrictingBudget :: ExBudget - } deriving stock (Show, Eq) - deriving newtype (Semigroup, Monoid) - deriving newtype (Pretty, PrettyBy config, NFData) + { unExRestrictingBudget :: ExBudget + } + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid) + deriving newtype (Pretty, PrettyBy config, NFData) -- | When we want to just evaluate the program that is intended to run out of budget we use the -- 'Restricting' mode with this big budget designed to make the CEK machine terminate in a diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetStream.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetStream.hs index 321f9174f00..1965f5ec214 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetStream.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetStream.hs @@ -1,10 +1,10 @@ {-# LANGUAGE BangPatterns #-} -module PlutusCore.Evaluation.Machine.ExBudgetStream - ( ExBudgetStream(..) - , sumExBudgetStream - , zipCostStream - ) where +module PlutusCore.Evaluation.Machine.ExBudgetStream ( + ExBudgetStream (..), + sumExBudgetStream, + zipCostStream, +) where import PlutusCore.Evaluation.Machine.CostStream import PlutusCore.Evaluation.Machine.ExBudget @@ -25,25 +25,26 @@ import Data.Coerce -- in the CEK machine to get inlined and so unboxing 'ExBudget' here would only result in boxing it -- back once it's about to be spent. data ExBudgetStream - = ExBudgetLast !ExBudget - | ExBudgetCons !ExBudget ExBudgetStream - deriving stock (Show) + = ExBudgetLast !ExBudget + | ExBudgetCons !ExBudget ExBudgetStream + deriving stock (Show) -- See Note [Global local functions]. sumExBudgetStreamGo :: ExBudget -> ExBudgetStream -> ExBudget -sumExBudgetStreamGo !acc (ExBudgetLast budget) = acc <> budget +sumExBudgetStreamGo !acc (ExBudgetLast budget) = acc <> budget sumExBudgetStreamGo !acc (ExBudgetCons budget budgets) = sumExBudgetStreamGo (acc <> budget) budgets -- | Add up all the budgets in a 'ExBudgetStream'. sumExBudgetStream :: ExBudgetStream -> ExBudget -sumExBudgetStream (ExBudgetLast budget0) = budget0 +sumExBudgetStream (ExBudgetLast budget0) = budget0 sumExBudgetStream (ExBudgetCons budget0 budgets0) = sumExBudgetStreamGo budget0 budgets0 {-# INLINE sumExBudgetStream #-} -- | Convert a 'CostStream' to an 'ExBudgetStream' by applying a function to each element. costToExBudgetStream :: (CostingInteger -> ExBudget) -> CostStream -> ExBudgetStream -costToExBudgetStream f = go where - go (CostLast cost) = ExBudgetLast (f cost) +costToExBudgetStream f = go + where + go (CostLast cost) = ExBudgetLast (f cost) go (CostCons cost costs) = ExBudgetCons (f cost) $ go costs {-# INLINE costToExBudgetStream #-} @@ -56,13 +57,13 @@ toExBudget = coerce ExBudget -- See Note [Global local functions]. zipCostStreamGo :: CostStream -> CostStream -> ExBudgetStream zipCostStreamGo (CostLast cpu) (CostLast mem) = - ExBudgetLast $ toExBudget cpu mem + ExBudgetLast $ toExBudget cpu mem zipCostStreamGo (CostLast cpu) (CostCons mem mems) = - ExBudgetCons (toExBudget cpu mem) $ costToExBudgetStream (\mem' -> toExBudget 0 mem') mems + ExBudgetCons (toExBudget cpu mem) $ costToExBudgetStream (\mem' -> toExBudget 0 mem') mems zipCostStreamGo (CostCons cpu cpus) (CostLast mem) = - ExBudgetCons (toExBudget cpu mem) $ costToExBudgetStream (\cpu' -> toExBudget cpu' 0) cpus + ExBudgetCons (toExBudget cpu mem) $ costToExBudgetStream (\cpu' -> toExBudget cpu' 0) cpus zipCostStreamGo (CostCons cpu cpus) (CostCons mem mems) = - ExBudgetCons (toExBudget cpu mem) $ zipCostStreamGo cpus mems + ExBudgetCons (toExBudget cpu mem) $ zipCostStreamGo cpus mems -- | Zip two 'CostStream' together (one with CPU costs and the other one with memory costs, -- respectively) to get an 'ExBudgetStream'. If one is longer than the other, then it's assumed to @@ -70,7 +71,7 @@ zipCostStreamGo (CostCons cpu cpus) (CostCons mem mems) = -- \"appear\" in the tail of the stream). zipCostStream :: CostStream -> CostStream -> ExBudgetStream zipCostStream cpus0 mems0 = case (cpus0, mems0) of - -- See Note [Single-element streams]. - (CostLast cpu, CostLast mem) -> ExBudgetLast $ toExBudget cpu mem - _ -> zipCostStreamGo cpus0 mems0 + -- See Note [Single-element streams]. + (CostLast cpu, CostLast mem) -> ExBudgetLast $ toExBudget cpu mem + _ -> zipCostStreamGo cpus0 mems0 {-# INLINE zipCostStream #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index b70266cb250..c5d44f9ac04 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -1,25 +1,24 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module PlutusCore.Evaluation.Machine.ExBudgetingDefaults - ( defaultBuiltinsRuntimeForSemanticsVariant - , defaultCekParametersForVariant - , defaultCostModelParamsForVariant - , cekCostModelForVariant - , defaultBuiltinsRuntimeForTesting - , defaultCekParametersForTesting - , defaultCekMachineCostsForTesting - , defaultCostModelParamsForTesting - , defaultBuiltinCostModelForTesting - , defaultCekCostModelForTesting - , defaultCekCostModelForTestingB - , unitCekMachineCosts - , unitCekParameters - ) - +{-# LANGUAGE TypeFamilies #-} + +module PlutusCore.Evaluation.Machine.ExBudgetingDefaults ( + defaultBuiltinsRuntimeForSemanticsVariant, + defaultCekParametersForVariant, + defaultCostModelParamsForVariant, + cekCostModelForVariant, + defaultBuiltinsRuntimeForTesting, + defaultCekParametersForTesting, + defaultCekMachineCostsForTesting, + defaultCostModelParamsForTesting, + defaultBuiltinCostModelForTesting, + defaultCekCostModelForTesting, + defaultCekCostModelForTestingB, + unitCekMachineCosts, + unitCekParameters, +) where import PlutusCore.Builtin @@ -34,6 +33,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts import UntypedPlutusCore.Evaluation.Machine.Cek.Internal import Data.Aeson.THReader + -- Not using 'noinline' from "GHC.Exts", because our CI was unable to find it there, somehow. import GHC.Magic (noinline) import PlutusPrelude @@ -65,7 +65,7 @@ import PlutusPrelude -- | The default cost model for built-in functions (variant A) builtinCostModelVariantA :: BuiltinCostModel builtinCostModelVariantA = - $$(readJSONFromFile DFP.builtinCostModelFileA) + $$(readJSONFromFile DFP.builtinCostModelFileA) -- This is a huge record, inlining it is wasteful. {-# OPAQUE builtinCostModelVariantA #-} @@ -73,27 +73,27 @@ builtinCostModelVariantA = We don't want this to get inlined, as otherwise the default 'CekMachineCosts' appears faster than 'CekMachineCosts' that we get in production after applying the costing parameters provided by the ledger. -} + -- | Default costs for CEK machine instructions (variant A) cekMachineCostsVariantA :: CekMachineCosts cekMachineCostsVariantA = $$(readJSONFromFile DFP.cekMachineCostsFileA) {-# OPAQUE cekMachineCostsVariantA #-} -{-| The default cost model, including both builtin costs and machine step costs. - Note that this is not necessarily the cost model in use on the chain at any - given time. The definitive values used for calculating on-chain costs are - protocol parameters which are part of the state of the chain; in practice - these will usually have been obtained from the contents of the JSON files at - some point in the past, but we do not guarantee this. During on-chain - evaluation the ledger passes a cost model to the Plutus Core evaluator using - the `mkEvaluationContext` functions in PlutusLedgerApi. --} +-- | The default cost model, including both builtin costs and machine step costs. +-- Note that this is not necessarily the cost model in use on the chain at any +-- given time. The definitive values used for calculating on-chain costs are +-- protocol parameters which are part of the state of the chain; in practice +-- these will usually have been obtained from the contents of the JSON files at +-- some point in the past, but we do not guarantee this. During on-chain +-- evaluation the ledger passes a cost model to the Plutus Core evaluator using +-- the `mkEvaluationContext` functions in PlutusLedgerApi. cekCostModelVariantA :: CostModel CekMachineCosts BuiltinCostModel cekCostModelVariantA = CostModel cekMachineCostsVariantA builtinCostModelVariantA builtinCostModelVariantB :: BuiltinCostModel builtinCostModelVariantB = - $$(readJSONFromFile DFP.builtinCostModelFileB) + $$(readJSONFromFile DFP.builtinCostModelFileB) {-# OPAQUE builtinCostModelVariantB #-} -- See Note [No inlining for CekMachineCosts] @@ -107,7 +107,7 @@ cekCostModelVariantB = CostModel cekMachineCostsVariantB builtinCostModelVariant builtinCostModelVariantC :: BuiltinCostModel builtinCostModelVariantC = - $$(readJSONFromFile DFP.builtinCostModelFileC) + $$(readJSONFromFile DFP.builtinCostModelFileC) {-# OPAQUE builtinCostModelVariantC #-} -- See Note [No inlining for CekMachineCosts] @@ -149,49 +149,50 @@ faster than the used in production. Also see Note [noinline for saving on ticks]. -} defaultCekParametersA :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) defaultCekParametersA = - MachineParameters def $ - noinline mkMachineVariantParameters DefaultFunSemanticsVariantA cekCostModelVariantA + MachineParameters def $ + noinline mkMachineVariantParameters DefaultFunSemanticsVariantA cekCostModelVariantA -- See Note [No inlining for MachineParameters] defaultCekParametersB :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) defaultCekParametersB = - MachineParameters def $ - noinline mkMachineVariantParameters DefaultFunSemanticsVariantB cekCostModelVariantB + MachineParameters def $ + noinline mkMachineVariantParameters DefaultFunSemanticsVariantB cekCostModelVariantB -- See Note [No inlining for MachineParameters] defaultCekParametersC :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) defaultCekParametersC = - MachineParameters def $ - noinline mkMachineVariantParameters DefaultFunSemanticsVariantC cekCostModelVariantC + MachineParameters def $ + noinline mkMachineVariantParameters DefaultFunSemanticsVariantC cekCostModelVariantC {- Note [noinline for saving on ticks] We use 'noinline' purely for saving on simplifier ticks for definitions, whose performance doesn't matter. Otherwise compilation for this module is slower and GHC may end up exhausting simplifier ticks leading to a compilation error. -} -defaultBuiltinsRuntimeForSemanticsVariant - :: HasMeaningIn DefaultUni term - => BuiltinSemanticsVariant DefaultFun - -> BuiltinsRuntime DefaultFun term +defaultBuiltinsRuntimeForSemanticsVariant :: + HasMeaningIn DefaultUni term => + BuiltinSemanticsVariant DefaultFun -> + BuiltinsRuntime DefaultFun term -- See Note [noinline for saving on ticks]. defaultBuiltinsRuntimeForSemanticsVariant semvar = noinline toBuiltinsRuntime semvar $ builtinCostModelFor semvar - where builtinCostModelFor = \case - DefaultFunSemanticsVariantA -> builtinCostModelVariantA - DefaultFunSemanticsVariantB -> builtinCostModelVariantB - DefaultFunSemanticsVariantC -> builtinCostModelVariantC - -defaultCekParametersForVariant - :: Typeable ann - => BuiltinSemanticsVariant DefaultFun - -> MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + where + builtinCostModelFor = \case + DefaultFunSemanticsVariantA -> builtinCostModelVariantA + DefaultFunSemanticsVariantB -> builtinCostModelVariantB + DefaultFunSemanticsVariantC -> builtinCostModelVariantC + +defaultCekParametersForVariant :: + Typeable ann => + BuiltinSemanticsVariant DefaultFun -> + MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) defaultCekParametersForVariant = \case DefaultFunSemanticsVariantA -> defaultCekParametersA DefaultFunSemanticsVariantB -> defaultCekParametersB DefaultFunSemanticsVariantC -> defaultCekParametersC - -- *** THE FOLLOWING SHOULD ONLY BE USED FOR TESTING *** + {- We export a number of objects which are used in tests in a number of places in the codebase. For the time being we'll just use the most recent cost model for all of these. In fact we may want tests for each variant in some cases @@ -202,9 +203,9 @@ defaultCekParametersForVariant = \case * Perhaps export functions like `defaultBuiltinCostModelForVariant and then apply those to `def` where they're used. -} -defaultBuiltinsRuntimeForTesting - :: HasMeaningIn DefaultUni term - => BuiltinsRuntime DefaultFun term +defaultBuiltinsRuntimeForTesting :: + HasMeaningIn DefaultUni term => + BuiltinsRuntime DefaultFun term -- See Note [noinline for saving on ticks]. defaultBuiltinsRuntimeForTesting = defaultBuiltinsRuntimeForSemanticsVariant DefaultFunSemanticsVariantC @@ -230,136 +231,136 @@ defaultCekCostModelForTestingB = cekCostModelVariantB This currently works for all semantics variants because to date we have only ever added new builtins and never removed any. -} unitCostOneArgument :: CostingFun ModelOneArgument -unitCostOneArgument = CostingFun (ModelOneArgumentConstantCost 1) (ModelOneArgumentConstantCost 0) +unitCostOneArgument = CostingFun (ModelOneArgumentConstantCost 1) (ModelOneArgumentConstantCost 0) unitCostTwoArguments :: CostingFun ModelTwoArguments -unitCostTwoArguments = CostingFun (ModelTwoArgumentsConstantCost 1) (ModelTwoArgumentsConstantCost 0) +unitCostTwoArguments = CostingFun (ModelTwoArgumentsConstantCost 1) (ModelTwoArgumentsConstantCost 0) unitCostThreeArguments :: CostingFun ModelThreeArguments -unitCostThreeArguments = CostingFun (ModelThreeArgumentsConstantCost 1) (ModelThreeArgumentsConstantCost 0) +unitCostThreeArguments = CostingFun (ModelThreeArgumentsConstantCost 1) (ModelThreeArgumentsConstantCost 0) unitCostSixArguments :: CostingFun ModelSixArguments -unitCostSixArguments = CostingFun (ModelSixArgumentsConstantCost 1) (ModelSixArgumentsConstantCost 0) +unitCostSixArguments = CostingFun (ModelSixArgumentsConstantCost 1) (ModelSixArgumentsConstantCost 0) unitCostBuiltinCostModel :: BuiltinCostModel -unitCostBuiltinCostModel = BuiltinCostModelBase - { - -- Integers - paramAddInteger = unitCostTwoArguments - , paramSubtractInteger = unitCostTwoArguments - , paramMultiplyInteger = unitCostTwoArguments - , paramDivideInteger = unitCostTwoArguments - , paramQuotientInteger = unitCostTwoArguments - , paramRemainderInteger = unitCostTwoArguments - , paramModInteger = unitCostTwoArguments - , paramEqualsInteger = unitCostTwoArguments - , paramLessThanInteger = unitCostTwoArguments - , paramLessThanEqualsInteger = unitCostTwoArguments - -- Bytestrings - , paramAppendByteString = unitCostTwoArguments - , paramConsByteString = unitCostTwoArguments - , paramSliceByteString = unitCostThreeArguments - , paramLengthOfByteString = unitCostOneArgument - , paramIndexByteString = unitCostTwoArguments - , paramEqualsByteString = unitCostTwoArguments - , paramLessThanByteString = unitCostTwoArguments - , paramLessThanEqualsByteString = unitCostTwoArguments - -- Cryptography and hashes - , paramSha2_256 = unitCostOneArgument - , paramSha3_256 = unitCostOneArgument - , paramBlake2b_256 = unitCostOneArgument - , paramVerifyEd25519Signature = unitCostThreeArguments - , paramVerifyEcdsaSecp256k1Signature = unitCostThreeArguments +unitCostBuiltinCostModel = + BuiltinCostModelBase + { -- Integers + paramAddInteger = unitCostTwoArguments + , paramSubtractInteger = unitCostTwoArguments + , paramMultiplyInteger = unitCostTwoArguments + , paramDivideInteger = unitCostTwoArguments + , paramQuotientInteger = unitCostTwoArguments + , paramRemainderInteger = unitCostTwoArguments + , paramModInteger = unitCostTwoArguments + , paramEqualsInteger = unitCostTwoArguments + , paramLessThanInteger = unitCostTwoArguments + , paramLessThanEqualsInteger = unitCostTwoArguments + , -- Bytestrings + paramAppendByteString = unitCostTwoArguments + , paramConsByteString = unitCostTwoArguments + , paramSliceByteString = unitCostThreeArguments + , paramLengthOfByteString = unitCostOneArgument + , paramIndexByteString = unitCostTwoArguments + , paramEqualsByteString = unitCostTwoArguments + , paramLessThanByteString = unitCostTwoArguments + , paramLessThanEqualsByteString = unitCostTwoArguments + , -- Cryptography and hashes + paramSha2_256 = unitCostOneArgument + , paramSha3_256 = unitCostOneArgument + , paramBlake2b_256 = unitCostOneArgument + , paramVerifyEd25519Signature = unitCostThreeArguments + , paramVerifyEcdsaSecp256k1Signature = unitCostThreeArguments , paramVerifySchnorrSecp256k1Signature = unitCostThreeArguments - -- Strings - , paramAppendString = unitCostTwoArguments - , paramEqualsString = unitCostTwoArguments - , paramEncodeUtf8 = unitCostOneArgument - , paramDecodeUtf8 = unitCostOneArgument - -- Bool - , paramIfThenElse = unitCostThreeArguments - -- Unit - , paramChooseUnit = unitCostTwoArguments - -- Tracing - , paramTrace = unitCostTwoArguments - -- Pairs - , paramFstPair = unitCostOneArgument - , paramSndPair = unitCostOneArgument - -- Lists - , paramChooseList = unitCostThreeArguments - , paramMkCons = unitCostTwoArguments - , paramHeadList = unitCostOneArgument - , paramTailList = unitCostOneArgument - , paramNullList = unitCostOneArgument - -- Data - , paramChooseData = unitCostSixArguments - , paramConstrData = unitCostTwoArguments - , paramMapData = unitCostOneArgument - , paramListData = unitCostOneArgument - , paramIData = unitCostOneArgument - , paramBData = unitCostOneArgument - , paramUnConstrData = unitCostOneArgument - , paramUnMapData = unitCostOneArgument - , paramUnListData = unitCostOneArgument - , paramUnIData = unitCostOneArgument - , paramUnBData = unitCostOneArgument - , paramEqualsData = unitCostTwoArguments - -- Misc constructors - , paramMkPairData = unitCostTwoArguments - , paramMkNilData = unitCostOneArgument - , paramMkNilPairData = unitCostOneArgument - , paramSerialiseData = unitCostOneArgument - -- BLS12-381 operations - , paramBls12_381_G1_add = unitCostTwoArguments - , paramBls12_381_G1_neg = unitCostOneArgument - , paramBls12_381_G1_scalarMul = unitCostTwoArguments - , paramBls12_381_G1_multiScalarMul = unitCostTwoArguments - , paramBls12_381_G1_equal = unitCostTwoArguments - , paramBls12_381_G1_compress = unitCostOneArgument - , paramBls12_381_G1_uncompress = unitCostOneArgument - , paramBls12_381_G1_hashToGroup = unitCostTwoArguments - , paramBls12_381_G2_add = unitCostTwoArguments - , paramBls12_381_G2_neg = unitCostOneArgument - , paramBls12_381_G2_scalarMul = unitCostTwoArguments - , paramBls12_381_G2_multiScalarMul = unitCostTwoArguments - , paramBls12_381_G2_equal = unitCostTwoArguments - , paramBls12_381_G2_compress = unitCostOneArgument - , paramBls12_381_G2_uncompress = unitCostOneArgument - , paramBls12_381_G2_hashToGroup = unitCostTwoArguments - , paramBls12_381_millerLoop = unitCostTwoArguments - , paramBls12_381_mulMlResult = unitCostTwoArguments - , paramBls12_381_finalVerify = unitCostTwoArguments - -- Keccak_256, Blake2b_224 - , paramKeccak_256 = unitCostOneArgument - , paramBlake2b_224 = unitCostOneArgument - -- Bitwise operations - , paramIntegerToByteString = unitCostThreeArguments - , paramByteStringToInteger = unitCostTwoArguments - , paramAndByteString = unitCostThreeArguments - , paramOrByteString = unitCostThreeArguments - , paramXorByteString = unitCostThreeArguments - , paramComplementByteString = unitCostOneArgument - , paramReadBit = unitCostTwoArguments - , paramWriteBits = unitCostThreeArguments - , paramReplicateByte = unitCostTwoArguments - , paramShiftByteString = unitCostTwoArguments - , paramRotateByteString = unitCostTwoArguments - , paramCountSetBits = unitCostOneArgument - , paramFindFirstSetBit = unitCostOneArgument - -- Ripemd_160 - , paramRipemd_160 = unitCostOneArgument - -- Batch 6 - , paramExpModInteger = unitCostThreeArguments - , paramDropList = unitCostTwoArguments - -- Arrays - , paramLengthOfArray = unitCostOneArgument - , paramListToArray = unitCostOneArgument - , paramIndexArray = unitCostTwoArguments + , -- Strings + paramAppendString = unitCostTwoArguments + , paramEqualsString = unitCostTwoArguments + , paramEncodeUtf8 = unitCostOneArgument + , paramDecodeUtf8 = unitCostOneArgument + , -- Bool + paramIfThenElse = unitCostThreeArguments + , -- Unit + paramChooseUnit = unitCostTwoArguments + , -- Tracing + paramTrace = unitCostTwoArguments + , -- Pairs + paramFstPair = unitCostOneArgument + , paramSndPair = unitCostOneArgument + , -- Lists + paramChooseList = unitCostThreeArguments + , paramMkCons = unitCostTwoArguments + , paramHeadList = unitCostOneArgument + , paramTailList = unitCostOneArgument + , paramNullList = unitCostOneArgument + , -- Data + paramChooseData = unitCostSixArguments + , paramConstrData = unitCostTwoArguments + , paramMapData = unitCostOneArgument + , paramListData = unitCostOneArgument + , paramIData = unitCostOneArgument + , paramBData = unitCostOneArgument + , paramUnConstrData = unitCostOneArgument + , paramUnMapData = unitCostOneArgument + , paramUnListData = unitCostOneArgument + , paramUnIData = unitCostOneArgument + , paramUnBData = unitCostOneArgument + , paramEqualsData = unitCostTwoArguments + , -- Misc constructors + paramMkPairData = unitCostTwoArguments + , paramMkNilData = unitCostOneArgument + , paramMkNilPairData = unitCostOneArgument + , paramSerialiseData = unitCostOneArgument + , -- BLS12-381 operations + paramBls12_381_G1_add = unitCostTwoArguments + , paramBls12_381_G1_neg = unitCostOneArgument + , paramBls12_381_G1_scalarMul = unitCostTwoArguments + , paramBls12_381_G1_multiScalarMul = unitCostTwoArguments + , paramBls12_381_G1_equal = unitCostTwoArguments + , paramBls12_381_G1_compress = unitCostOneArgument + , paramBls12_381_G1_uncompress = unitCostOneArgument + , paramBls12_381_G1_hashToGroup = unitCostTwoArguments + , paramBls12_381_G2_add = unitCostTwoArguments + , paramBls12_381_G2_neg = unitCostOneArgument + , paramBls12_381_G2_scalarMul = unitCostTwoArguments + , paramBls12_381_G2_multiScalarMul = unitCostTwoArguments + , paramBls12_381_G2_equal = unitCostTwoArguments + , paramBls12_381_G2_compress = unitCostOneArgument + , paramBls12_381_G2_uncompress = unitCostOneArgument + , paramBls12_381_G2_hashToGroup = unitCostTwoArguments + , paramBls12_381_millerLoop = unitCostTwoArguments + , paramBls12_381_mulMlResult = unitCostTwoArguments + , paramBls12_381_finalVerify = unitCostTwoArguments + , -- Keccak_256, Blake2b_224 + paramKeccak_256 = unitCostOneArgument + , paramBlake2b_224 = unitCostOneArgument + , -- Bitwise operations + paramIntegerToByteString = unitCostThreeArguments + , paramByteStringToInteger = unitCostTwoArguments + , paramAndByteString = unitCostThreeArguments + , paramOrByteString = unitCostThreeArguments + , paramXorByteString = unitCostThreeArguments + , paramComplementByteString = unitCostOneArgument + , paramReadBit = unitCostTwoArguments + , paramWriteBits = unitCostThreeArguments + , paramReplicateByte = unitCostTwoArguments + , paramShiftByteString = unitCostTwoArguments + , paramRotateByteString = unitCostTwoArguments + , paramCountSetBits = unitCostOneArgument + , paramFindFirstSetBit = unitCostOneArgument + , -- Ripemd_160 + paramRipemd_160 = unitCostOneArgument + , -- Batch 6 + paramExpModInteger = unitCostThreeArguments + , paramDropList = unitCostTwoArguments + , -- Arrays + paramLengthOfArray = unitCostOneArgument + , paramListToArray = unitCostOneArgument + , paramIndexArray = unitCostTwoArguments } unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) unitCekParameters = - -- See Note [noinline for saving on ticks]. - MachineParameters def $ - noinline mkMachineVariantParameters def $ - CostModel unitCekMachineCosts unitCostBuiltinCostModel + -- See Note [noinline for saving on ticks]. + MachineParameters def $ + noinline mkMachineVariantParameters def $ + CostModel unitCekMachineCosts unitCostBuiltinCostModel diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemory.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemory.hs index 3690db632b9..b483f38ca49 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemory.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemory.hs @@ -1,15 +1,15 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -module PlutusCore.Evaluation.Machine.ExMemory - ( CostingInteger - , ExMemory(..) - , ExCPU(..) - , dividedBy - ) where +module PlutusCore.Evaluation.Machine.ExMemory ( + CostingInteger, + ExMemory (..), + ExCPU (..), + dividedBy, +) where import Codec.Serialise (Serialise) import Control.DeepSeq @@ -76,12 +76,13 @@ newtype ExMemory = ExMemory CostingInteger deriving stock (Eq, Ord, Show, Generic, Lift) deriving newtype (Num, NFData, Read, Bounded) deriving (FromJSON, ToJSON) via CostingInteger - deriving Serialise via CostingInteger - deriving anyclass NoThunks + deriving (Serialise) via CostingInteger + deriving anyclass (NoThunks) + instance Pretty ExMemory where - pretty (ExMemory i) = pretty (unSatInt i) + pretty (ExMemory i) = pretty (unSatInt i) instance PrettyBy config ExMemory where - prettyBy _ m = pretty m + prettyBy _ m = pretty m {- Note [Manual Semigroup and Monoid instances for Sum monoids] We don't do @@ -97,16 +98,16 @@ So instead we implement @Semigroup A@ and @Monoid A@ instances manually for a 'S -- See Note [Manual Semigroup and Monoid instances for Sum monoids]. instance Semigroup ExMemory where - (<>) = (+) - {-# INLINE (<>) #-} + (<>) = (+) + {-# INLINE (<>) #-} - stimes n mem = fromIntegral n * mem - {-# INLINE stimes #-} + stimes n mem = fromIntegral n * mem + {-# INLINE stimes #-} -- See Note [Manual Semigroup and Monoid instances for Sum monoids]. instance Monoid ExMemory where - mempty = ExMemory 0 - {-# INLINE mempty #-} + mempty = ExMemory 0 + {-# INLINE mempty #-} -- | Counts CPU units in picoseconds: maximum value for SatInt is 2^63 ps, or -- appproximately 106 days. @@ -114,22 +115,23 @@ newtype ExCPU = ExCPU CostingInteger deriving stock (Eq, Ord, Show, Generic, Lift) deriving newtype (Num, NFData, Read, Bounded) deriving (FromJSON, ToJSON) via CostingInteger - deriving Serialise via CostingInteger - deriving anyclass NoThunks + deriving (Serialise) via CostingInteger + deriving anyclass (NoThunks) + instance Pretty ExCPU where - pretty (ExCPU i) = pretty (unSatInt i) + pretty (ExCPU i) = pretty (unSatInt i) instance PrettyBy config ExCPU where - prettyBy _ m = pretty m + prettyBy _ m = pretty m -- See Note [Manual Semigroup and Monoid instances for Sum monoids]. instance Semigroup ExCPU where - (<>) = (+) - {-# INLINE (<>) #-} + (<>) = (+) + {-# INLINE (<>) #-} - stimes n mem = fromIntegral n * mem - {-# INLINE stimes #-} + stimes n mem = fromIntegral n * mem + {-# INLINE stimes #-} -- See Note [Manual Semigroup and Monoid instances for Sum monoids]. instance Monoid ExCPU where - mempty = ExCPU 0 - {-# INLINE mempty #-} + mempty = ExCPU 0 + {-# INLINE mempty #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemoryUsage.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemoryUsage.hs index 101082a296f..3b99b060df8 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemoryUsage.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemoryUsage.hs @@ -1,20 +1,20 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module PlutusCore.Evaluation.Machine.ExMemoryUsage - ( CostRose(..) - , singletonRose - , ExMemoryUsage(..) - , flattenCostRose - , NumBytesCostedAsNumWords(..) - , IntegerCostedLiterally(..) - , ValueTotalSize(..) - , ValueOuterOrMaxInner(..) - ) where +module PlutusCore.Evaluation.Machine.ExMemoryUsage ( + CostRose (..), + singletonRose, + ExMemoryUsage (..), + flattenCostRose, + NumBytesCostedAsNumWords (..), + IntegerCostedLiterally (..), + ValueTotalSize (..), + ValueOuterOrMaxInner (..), +) where import PlutusCore.Crypto.BLS12_381.G1 as BLS12_381.G1 import PlutusCore.Crypto.BLS12_381.G2 as BLS12_381.G2 @@ -111,7 +111,7 @@ traversing the list), while we of course want it to be O(1). -- stream the costs to the outside where, say, the CEK machine picks them up one by one and handles -- somehow (in particular, subtracts from the remaining budget). data CostRose = CostRose {-# UNPACK #-} !CostingInteger ![CostRose] - deriving stock (Show) + deriving stock (Show) -- | Create a 'CostRose' containing a single cost. singletonRose :: CostingInteger -> CostRose @@ -130,36 +130,36 @@ singletonRose cost = CostRose cost [] -- point of the lazy costing approach) flattenCostRoseGo :: CostRose -> [CostRose] -> CostStream flattenCostRoseGo (CostRose cost1 forest1) forest2 = - case forest1 of - -- The current subtree doesn't have its own subtrees. - [] -> case forest2 of - -- No more elements in the entire tree, emit the last cost. - [] -> CostLast cost1 - -- There's at least one unhandled subtree encountered earlier, emit the current cost - -- and collapse the unhandled subtree. - rose2' : forest2' -> CostCons cost1 $ flattenCostRoseGo rose2' forest2' - -- The current subtree has at least one its own subtree. - rose1' : forest1' -> - -- Emit the current cost and handle the list of subtrees of the current subtree. - CostCons cost1 $ case forest1' of - -- Same as the case below, except this one avoids creating a chain of - -- @[] ++ ([] ++ ([] ++ <...>))@, which would make retrieving the next element an - -- O(depth_of_the_tree) operation in the worst case. - [] -> flattenCostRoseGo rose1' forest2 - -- Add the remaining subtrees of the current subtree (@forest1'@) to the stack of - -- all other subtrees (@forest2@) and handle the new current subtree (@rose1'@). - _ -> flattenCostRoseGo rose1' $ forest1' ++ forest2 + case forest1 of + -- The current subtree doesn't have its own subtrees. + [] -> case forest2 of + -- No more elements in the entire tree, emit the last cost. + [] -> CostLast cost1 + -- There's at least one unhandled subtree encountered earlier, emit the current cost + -- and collapse the unhandled subtree. + rose2' : forest2' -> CostCons cost1 $ flattenCostRoseGo rose2' forest2' + -- The current subtree has at least one its own subtree. + rose1' : forest1' -> + -- Emit the current cost and handle the list of subtrees of the current subtree. + CostCons cost1 $ case forest1' of + -- Same as the case below, except this one avoids creating a chain of + -- @[] ++ ([] ++ ([] ++ <...>))@, which would make retrieving the next element an + -- O(depth_of_the_tree) operation in the worst case. + [] -> flattenCostRoseGo rose1' forest2 + -- Add the remaining subtrees of the current subtree (@forest1'@) to the stack of + -- all other subtrees (@forest2@) and handle the new current subtree (@rose1'@). + _ -> flattenCostRoseGo rose1' $ forest1' ++ forest2 -- | Collapse a 'CostRose' to a lazy linear stream of costs. Retrieving the next element takes O(1) -- time in the worst case regardless of the recursion pattern of the given 'CostRose'. flattenCostRose :: CostRose -> CostStream -flattenCostRose (CostRose cost []) = CostLast cost +flattenCostRose (CostRose cost []) = CostLast cost flattenCostRose (CostRose cost (rose : forest)) = CostCons cost $ flattenCostRoseGo rose forest {-# INLINE flattenCostRose #-} class ExMemoryUsage a where - -- Inlining the implementations of this method gave us a 1-2% speedup. - memoryUsage :: a -> CostRose + -- Inlining the implementations of this method gave us a 1-2% speedup. + memoryUsage :: a -> CostRose {- Note [Alternative memory usage instances]. The `memoryUsage` function provides a measure of the size of an object for costing purposes, the idea being that @@ -200,8 +200,8 @@ class ExMemoryUsage a where usage is set to maxBound so that we'll notice if this assumption is ever violated -} instance ExMemoryUsage (a, b) where - memoryUsage _ = singletonRose maxBound - {-# INLINE memoryUsage #-} + memoryUsage _ = singletonRose maxBound + {-# INLINE memoryUsage #-} {- Note the the `memoryUsage` of an empty list is zero. This shouldn't cause any problems, but be sure to check that no costing function involving lists can @@ -220,22 +220,22 @@ instance ExMemoryUsage [a] where return zero for an empty array (or any other input). -} instance ExMemoryUsage (Vector a) where - memoryUsage l = singletonRose . fromIntegral $ Vector.length l - {-# INLINE memoryUsage #-} + memoryUsage l = singletonRose . fromIntegral $ Vector.length l + {-# INLINE memoryUsage #-} instance (Closed uni, uni `Everywhere` ExMemoryUsage) => ExMemoryUsage (Some (ValueOf uni)) where - memoryUsage (Some (ValueOf uni x)) = bring (Proxy @ExMemoryUsage) uni (memoryUsage x) - {-# INLINE memoryUsage #-} + memoryUsage (Some (ValueOf uni x)) = bring (Proxy @ExMemoryUsage) uni (memoryUsage x) + {-# INLINE memoryUsage #-} instance ExMemoryUsage () where - memoryUsage () = singletonRose 1 - {-# INLINE memoryUsage #-} + memoryUsage () = singletonRose 1 + {-# INLINE memoryUsage #-} -{- | Calculate a 'CostingInteger' for the size of the given 'Integer', measured in -64-bit words. This is the default size measure for `Integer`s. --} +-- | Calculate a 'CostingInteger' for the size of the given 'Integer', measured in +-- 64-bit words. This is the default size measure for `Integer`s. memoryUsageInteger :: Integer -> CostingInteger -- integerLog2# is unspecified for 0 (but in practice returns -1) + -- ^ This changed with GHC 9.2: it now returns 0. It's probably safest if we -- keep this special case for the time being though. memoryUsageInteger 0 = 1 @@ -246,93 +246,96 @@ memoryUsageInteger i = fromIntegral $ I# (integerLog2# (abs i) `quotInt#` intege {-# OPAQUE memoryUsageInteger #-} instance ExMemoryUsage Integer where - memoryUsage i = singletonRose $ memoryUsageInteger i - {-# INLINE memoryUsage #-} + memoryUsage i = singletonRose $ memoryUsageInteger i + {-# INLINE memoryUsage #-} instance ExMemoryUsage Natural where - -- Same as Integer since we are going via Integer - memoryUsage n = memoryUsage $ toInteger n - {-# INLINE memoryUsage #-} + -- Same as Integer since we are going via Integer + memoryUsage n = memoryUsage $ toInteger n + {-# INLINE memoryUsage #-} instance ExMemoryUsage Word8 where - memoryUsage _ = singletonRose 1 - {-# INLINE memoryUsage #-} - -{- | When invoking a built-in function, a value of type `NumBytesCostedAsNumWords` - can be used transparently as a built-in Integer but with a different size - measure: see Note [Integral types as Integer]. This is required by the - `integerToByteString` builtin, which takes an argument `w` specifying the - width (in bytes) of the output bytestring (zero-padded to the desired size). - The memory consumed by the function is given by `w`, *not* the size of `w`. - The `NumBytesCostedAsNumWords` type wraps an Int `w` in a newtype whose - `ExMemoryUsage` is equal to the number of eight-byte words required to - contain `w` bytes, allowing its costing function to work properly. We also - use this for `replicateByte`. If this is used to wrap an argument in the - denotation of a builtin then it *MUST* also be used to wrap the same argument - in the relevant budgeting benchmark. --} -newtype NumBytesCostedAsNumWords = NumBytesCostedAsNumWords { unNumBytesCostedAsNumWords :: Integer } + memoryUsage _ = singletonRose 1 + {-# INLINE memoryUsage #-} + +-- | When invoking a built-in function, a value of type `NumBytesCostedAsNumWords` +-- can be used transparently as a built-in Integer but with a different size +-- measure: see Note [Integral types as Integer]. This is required by the +-- `integerToByteString` builtin, which takes an argument `w` specifying the +-- width (in bytes) of the output bytestring (zero-padded to the desired size). +-- The memory consumed by the function is given by `w`, *not* the size of `w`. +-- The `NumBytesCostedAsNumWords` type wraps an Int `w` in a newtype whose +-- `ExMemoryUsage` is equal to the number of eight-byte words required to +-- contain `w` bytes, allowing its costing function to work properly. We also +-- use this for `replicateByte`. If this is used to wrap an argument in the +-- denotation of a builtin then it *MUST* also be used to wrap the same argument +-- in the relevant budgeting benchmark. +newtype NumBytesCostedAsNumWords = NumBytesCostedAsNumWords {unNumBytesCostedAsNumWords :: Integer} + instance ExMemoryUsage NumBytesCostedAsNumWords where - memoryUsage (NumBytesCostedAsNumWords n) = singletonRose . fromIntegral $ ((n-1) `div` 8) + 1 - {-# INLINE memoryUsage #-} - -- Note that this uses `fromIntegral`, which will narrow large values to - -- maxBound::SatInt = 2^63-1. This shouldn't be a problem for costing because no - -- realistic input should be that large; however if you're going to use this then be - -- sure to convince yourself that it's safe. - -{- | A wrapper for `Integer`s whose "memory usage" for costing purposes is the - absolute value of the `Integer`. This is used for costing built-in functions - such as `shiftByteString` and `rotateByteString`, where the cost may depend - on the actual value of the shift argument, not its size. If this is used to - wrap an argument in the denotation of a builtin then it *MUST* also be used - to wrap the same argument in the relevant budgeting benchmark. --} -newtype IntegerCostedLiterally = IntegerCostedLiterally { unIntegerCostedLiterally :: Integer } + memoryUsage (NumBytesCostedAsNumWords n) = singletonRose . fromIntegral $ ((n - 1) `div` 8) + 1 + {-# INLINE memoryUsage #-} + +-- Note that this uses `fromIntegral`, which will narrow large values to +-- maxBound::SatInt = 2^63-1. This shouldn't be a problem for costing because no +-- realistic input should be that large; however if you're going to use this then be +-- sure to convince yourself that it's safe. + +-- | A wrapper for `Integer`s whose "memory usage" for costing purposes is the +-- absolute value of the `Integer`. This is used for costing built-in functions +-- such as `shiftByteString` and `rotateByteString`, where the cost may depend +-- on the actual value of the shift argument, not its size. If this is used to +-- wrap an argument in the denotation of a builtin then it *MUST* also be used +-- to wrap the same argument in the relevant budgeting benchmark. +newtype IntegerCostedLiterally = IntegerCostedLiterally {unIntegerCostedLiterally :: Integer} + instance ExMemoryUsage IntegerCostedLiterally where - memoryUsage (IntegerCostedLiterally n) = singletonRose . fromIntegral $ abs n - {-# INLINE memoryUsage #-} - -- Note that this uses `fromIntegral`, which will narrow large values to - -- maxBound::SatInt = 2^63-1. This shouldn't be a problem for costing because no - -- realistic input should be that large; however if you're going to use this then be - -- sure to convince yourself that it's safe. + memoryUsage (IntegerCostedLiterally n) = singletonRose . fromIntegral $ abs n + {-# INLINE memoryUsage #-} + +-- Note that this uses `fromIntegral`, which will narrow large values to +-- maxBound::SatInt = 2^63-1. This shouldn't be a problem for costing because no +-- realistic input should be that large; however if you're going to use this then be +-- sure to convince yourself that it's safe. {- Bytestrings: we want the empty bytestring and bytestrings of length 1-8 to have size 1, bytestrings of length 9-16 to have size 2, etc. Note that (-1) `quot` 8 == 0, so the code below gives the correct answer for the empty bytestring. -} instance ExMemoryUsage BS.ByteString where - -- Don't use `div` here! That gives 0 instead of 1 for the empty bytestring. - memoryUsage bs = singletonRose . unsafeToSatInt $ ((n - 1) `quot` 8) + 1 where - n = BS.length bs - {-# INLINE memoryUsage #-} + -- Don't use `div` here! That gives 0 instead of 1 for the empty bytestring. + memoryUsage bs = singletonRose . unsafeToSatInt $ ((n - 1) `quot` 8) + 1 + where + n = BS.length bs + {-# INLINE memoryUsage #-} instance ExMemoryUsage T.Text where - -- This says that @Text@ allocates 1 'CostingInteger' worth of memory (i.e. 8 bytes) per - -- character, which is a conservative overestimate (i.e. is safe) regardless of whether @Text@ - -- is UTF16-based (like it used to when we implemented this instance) or UTF8-based (like it is - -- now). - -- - -- Note that the @ExMemoryUsage Char@ instance does not affect this one, this is for performance - -- reasons, since @T.length@ is O(1) unlike @sum . map (memoryUsage @Char) . T.unpack@. We used - -- to have the latter, but changed it to the former for easy performance gains. - -- - -- We may want to make this a bit less of an overestimate in future just not to overcharge - -- users. - memoryUsage = singletonRose . fromIntegral . T.length - {-# INLINE memoryUsage #-} + -- This says that @Text@ allocates 1 'CostingInteger' worth of memory (i.e. 8 bytes) per + -- character, which is a conservative overestimate (i.e. is safe) regardless of whether @Text@ + -- is UTF16-based (like it used to when we implemented this instance) or UTF8-based (like it is + -- now). + -- + -- Note that the @ExMemoryUsage Char@ instance does not affect this one, this is for performance + -- reasons, since @T.length@ is O(1) unlike @sum . map (memoryUsage @Char) . T.unpack@. We used + -- to have the latter, but changed it to the former for easy performance gains. + -- + -- We may want to make this a bit less of an overestimate in future just not to overcharge + -- users. + memoryUsage = singletonRose . fromIntegral . T.length + {-# INLINE memoryUsage #-} instance ExMemoryUsage Int where - memoryUsage _ = singletonRose 1 - {-# INLINE memoryUsage #-} + memoryUsage _ = singletonRose 1 + {-# INLINE memoryUsage #-} -- If you ever change this, also change @ExMemoryUsage T.Text@. instance ExMemoryUsage Char where - memoryUsage _ = singletonRose 1 - {-# INLINE memoryUsage #-} + memoryUsage _ = singletonRose 1 + {-# INLINE memoryUsage #-} instance ExMemoryUsage Bool where - memoryUsage _ = singletonRose 1 - {-# INLINE memoryUsage #-} + memoryUsage _ = singletonRose 1 + {-# INLINE memoryUsage #-} -- | Add two 'CostRose's. We don't make this into a 'Semigroup' instance, because there exist -- different ways to add two 'CostRose's (e.g. we could optimize the case when one of the roses @@ -342,7 +345,7 @@ instance ExMemoryUsage Bool where -- below. addConstantRose :: CostRose -> CostRose -> CostRose addConstantRose (CostRose cost1 forest1) (CostRose cost2 forest2) = - CostRose (cost1 + cost2) (forest1 ++ forest2) + CostRose (cost1 + cost2) (forest1 ++ forest2) {-# INLINE addConstantRose #-} {- A naive traversal for size. This accounts for the number of nodes in a Data @@ -361,35 +364,36 @@ addConstantRose (CostRose cost1 forest1) (CostRose cost2 forest2) = units per node, but we may wish to revise this after experimentation. -} instance ExMemoryUsage Data where - memoryUsage = sizeData where - dataNodeRose = singletonRose 4 - {-# INLINE dataNodeRose #-} - - sizeData d = addConstantRose dataNodeRose $ case d of - -- TODO: include the size of the tag, but not just yet. See PLT-1176. - Constr _ l -> CostRose 0 $ l <&> sizeData - Map l -> CostRose 0 $ l >>= \(d1, d2) -> [d1, d2] <&> sizeData - List l -> CostRose 0 $ l <&> sizeData - I n -> memoryUsage n - B b -> memoryUsage b + memoryUsage = sizeData + where + dataNodeRose = singletonRose 4 + {-# INLINE dataNodeRose #-} + + sizeData d = addConstantRose dataNodeRose $ case d of + -- TODO: include the size of the tag, but not just yet. See PLT-1176. + Constr _ l -> CostRose 0 $ l <&> sizeData + Map l -> CostRose 0 $ l >>= \(d1, d2) -> [d1, d2] <&> sizeData + List l -> CostRose 0 $ l <&> sizeData + I n -> memoryUsage n + B b -> memoryUsage b instance ExMemoryUsage Value where - memoryUsage = singletonRose . fromIntegral . Value.totalSize + memoryUsage = singletonRose . fromIntegral . Value.totalSize -- | Measure the size of a `Value` by its `Value.totalSize`. -newtype ValueTotalSize = ValueTotalSize { unValueTotalSize :: Value } +newtype ValueTotalSize = ValueTotalSize {unValueTotalSize :: Value} instance ExMemoryUsage ValueTotalSize where - memoryUsage = singletonRose . fromIntegral . Value.totalSize . unValueTotalSize + memoryUsage = singletonRose . fromIntegral . Value.totalSize . unValueTotalSize -- | Measure the size of a `Value` by taking the max of -- (size of the outer map, size of the largest inner map). -newtype ValueOuterOrMaxInner = ValueOuterOrMaxInner { unValueOuterOrMaxInner :: Value } +newtype ValueOuterOrMaxInner = ValueOuterOrMaxInner {unValueOuterOrMaxInner :: Value} instance ExMemoryUsage ValueOuterOrMaxInner where - memoryUsage (ValueOuterOrMaxInner v) = singletonRose (fromIntegral size) - where - size = Map.size (Value.unpack v) `max` Value.maxInnerSize v + memoryUsage (ValueOuterOrMaxInner v) = singletonRose (fromIntegral size) + where + size = Map.size (Value.unpack v) `max` Value.maxInnerSize v {- Note [Costing constant-size types] The memory usage of each of the BLS12-381 types is constant, so we may be able @@ -404,21 +408,24 @@ g1ElementCost = singletonRose . unsafeToSatInt $ BLS12_381.G1.memSizeBytes `div` {-# OPAQUE g1ElementCost #-} instance ExMemoryUsage BLS12_381.G1.Element where - memoryUsage _ = g1ElementCost - -- Should be 18 + memoryUsage _ = g1ElementCost + +-- Should be 18 g2ElementCost :: CostRose g2ElementCost = singletonRose . unsafeToSatInt $ BLS12_381.G2.memSizeBytes `div` 8 {-# OPAQUE g2ElementCost #-} instance ExMemoryUsage BLS12_381.G2.Element where - memoryUsage _ = g2ElementCost - -- Should be 36 + memoryUsage _ = g2ElementCost + +-- Should be 36 mlResultElementCost :: CostRose mlResultElementCost = singletonRose . unsafeToSatInt $ BLS12_381.Pairing.mlResultMemSizeBytes `div` 8 {-# OPAQUE mlResultElementCost #-} instance ExMemoryUsage BLS12_381.Pairing.MlResult where - memoryUsage _ = mlResultElementCost - -- Should be 72 + memoryUsage _ = mlResultElementCost + +-- Should be 72 diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs index 8ad6133d71b..bbbef75ea2c 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs @@ -1,34 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- editorconfig-checker-disable-file --- | The exceptions that an abstract machine can throw. - -- appears in the generated instances {-# OPTIONS_GHC -Wno-overlapping-patterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Evaluation.Machine.Exception - ( UnliftingError (..) - , BuiltinError (..) - , MachineError (..) - , EvaluationError (..) - , ErrorWithCause (..) - , EvaluationException - , notAConstant - , throwErrorWithCause - , splitStructuralOperational - , unsafeSplitStructuralOperational - , BuiltinErrorToEvaluationError - , builtinErrorToEvaluationError - , throwBuiltinErrorWithCause - ) where +-- | The exceptions that an abstract machine can throw. +module PlutusCore.Evaluation.Machine.Exception ( + UnliftingError (..), + BuiltinError (..), + MachineError (..), + EvaluationError (..), + ErrorWithCause (..), + EvaluationException, + notAConstant, + throwErrorWithCause, + splitStructuralOperational, + unsafeSplitStructuralOperational, + BuiltinErrorToEvaluationError, + builtinErrorToEvaluationError, + throwBuiltinErrorWithCause, +) where import PlutusPrelude @@ -44,31 +42,31 @@ import Prettyprinter -- | Errors which can occur during a run of an abstract machine. data MachineError fun - = NonPolymorphicInstantiationMachineError - -- ^ An attempt to reduce a not immediately reducible type instantiation. - | NonWrapUnwrappedMachineError - -- ^ An attempt to unwrap a not wrapped term. - | NonFunctionalApplicationMachineError - -- ^ An attempt to reduce a not immediately reducible application. - | OpenTermEvaluatedMachineError - -- ^ An attempt to evaluate an open term. - | UnliftingMachineError UnliftingError - -- ^ An attempt to compute a constant application resulted in 'UnliftingError'. - | BuiltinTermArgumentExpectedMachineError - -- ^ A builtin expected a term argument, but something else was received. - | UnexpectedBuiltinTermArgumentMachineError - -- ^ A builtin received a term argument when something else was expected - | NonConstrScrutinizedMachineError - -- ^ An attempt to scrutinize a non-constr. - | MissingCaseBranchMachineError Word64 - -- ^ An attempt to go into a non-existent case branch. - | PanicMachineError String - -- ^ A GHC exception was thrown. - deriving stock (Show, Eq, Functor, Generic) - deriving anyclass (NFData) + = -- | An attempt to reduce a not immediately reducible type instantiation. + NonPolymorphicInstantiationMachineError + | -- | An attempt to unwrap a not wrapped term. + NonWrapUnwrappedMachineError + | -- | An attempt to reduce a not immediately reducible application. + NonFunctionalApplicationMachineError + | -- | An attempt to evaluate an open term. + OpenTermEvaluatedMachineError + | -- | An attempt to compute a constant application resulted in 'UnliftingError'. + UnliftingMachineError UnliftingError + | -- | A builtin expected a term argument, but something else was received. + BuiltinTermArgumentExpectedMachineError + | -- | A builtin received a term argument when something else was expected + UnexpectedBuiltinTermArgumentMachineError + | -- | An attempt to scrutinize a non-constr. + NonConstrScrutinizedMachineError + | -- | An attempt to go into a non-existent case branch. + MissingCaseBranchMachineError Word64 + | -- | A GHC exception was thrown. + PanicMachineError String + deriving stock (Show, Eq, Functor, Generic) + deriving anyclass (NFData) type EvaluationException structural operational = - ErrorWithCause (EvaluationError structural operational) + ErrorWithCause (EvaluationError structural operational) {- Note [Ignoring context in OperationalError] The 'OperationalError' error has a term argument, but 'splitStructuralOperational' just @@ -83,49 +81,53 @@ context if available. -- See the Haddock of 'EvaluationError' for what structural and operational errors are. -- See Note [Ignoring context in OperationalError]. + -- | Preserve the contents of an 'StructuralError' as a 'Left' and turn an -- 'OperationalError' into a @Right EvaluationFailure@ (thus erasing the content of the -- error in the latter case). -splitStructuralOperational - :: Either (EvaluationException structural operational term) a - -> Either (ErrorWithCause structural term) (EvaluationResult a) +splitStructuralOperational :: + Either (EvaluationException structural operational term) a -> + Either (ErrorWithCause structural term) (EvaluationResult a) splitStructuralOperational (Right term) = Right $ EvaluationSuccess term splitStructuralOperational (Left (ErrorWithCause evalErr cause)) = case evalErr of - StructuralError err -> Left $ ErrorWithCause err cause - OperationalError _ -> Right EvaluationFailure + StructuralError err -> Left $ ErrorWithCause err cause + OperationalError _ -> Right EvaluationFailure -- | Throw on a 'StructuralError' and turn an 'OperationalError' into an -- 'EvaluationFailure' (thus erasing the content of the error in the latter case). -unsafeSplitStructuralOperational - :: (PrettyPlc structural, PrettyPlc term, Typeable structural, Typeable term) - => Either (EvaluationException structural operational term) a - -> EvaluationResult a +unsafeSplitStructuralOperational :: + (PrettyPlc structural, PrettyPlc term, Typeable structural, Typeable term) => + Either (EvaluationException structural operational term) a -> + EvaluationResult a unsafeSplitStructuralOperational = unsafeFromEither . splitStructuralOperational -instance (HasPrettyDefaults config ~ 'True, Pretty fun) => - PrettyBy config (MachineError fun) where - prettyBy _ NonPolymorphicInstantiationMachineError = - "Attempted to instantiate a non-polymorphic term." - prettyBy _ NonWrapUnwrappedMachineError = - "Cannot unwrap a not wrapped term." - prettyBy _ NonFunctionalApplicationMachineError = - "Attempted to apply a non-function." - prettyBy _ OpenTermEvaluatedMachineError = - "Cannot evaluate an open term" - prettyBy _ BuiltinTermArgumentExpectedMachineError = - "A builtin expected a term argument, but something else was received" - prettyBy _ UnexpectedBuiltinTermArgumentMachineError = - "A builtin received a term argument when something else was expected" - prettyBy _ (UnliftingMachineError unliftingError) = - pretty unliftingError - prettyBy _ NonConstrScrutinizedMachineError = - "A non-constructor/non-builtin value was scrutinized in a case expression" - prettyBy _ (MissingCaseBranchMachineError i) = - "Case expression missing the branch required by the scrutinee tag:" <+> pretty i - prettyBy _ (PanicMachineError err) = vcat - [ "Panic: a GHC exception was thrown, please report this as a bug." - , "The error: " <+> pretty err - ] +instance + (HasPrettyDefaults config ~ 'True, Pretty fun) => + PrettyBy config (MachineError fun) + where + prettyBy _ NonPolymorphicInstantiationMachineError = + "Attempted to instantiate a non-polymorphic term." + prettyBy _ NonWrapUnwrappedMachineError = + "Cannot unwrap a not wrapped term." + prettyBy _ NonFunctionalApplicationMachineError = + "Attempted to apply a non-function." + prettyBy _ OpenTermEvaluatedMachineError = + "Cannot evaluate an open term" + prettyBy _ BuiltinTermArgumentExpectedMachineError = + "A builtin expected a term argument, but something else was received" + prettyBy _ UnexpectedBuiltinTermArgumentMachineError = + "A builtin received a term argument when something else was expected" + prettyBy _ (UnliftingMachineError unliftingError) = + pretty unliftingError + prettyBy _ NonConstrScrutinizedMachineError = + "A non-constructor/non-builtin value was scrutinized in a case expression" + prettyBy _ (MissingCaseBranchMachineError i) = + "Case expression missing the branch required by the scrutinee tag:" <+> pretty i + prettyBy _ (PanicMachineError err) = + vcat + [ "Panic: a GHC exception was thrown, please report this as a bug." + , "The error: " <+> pretty err + ] class BuiltinErrorToEvaluationError structural operational where builtinErrorToEvaluationError :: BuiltinError -> EvaluationError structural operational @@ -134,10 +136,10 @@ class BuiltinErrorToEvaluationError structural operational where -- Note that an evaluator might require the cause to be computed lazily for best performance on the -- happy path, hence this function must not force its first argument. -- TODO: wrap @cause@ in 'Lazy' once we have it. -throwBuiltinErrorWithCause - :: ( MonadError (EvaluationException structural operational cause) m - , BuiltinErrorToEvaluationError structural operational - ) - => cause -> BuiltinError -> m void +throwBuiltinErrorWithCause :: + ( MonadError (EvaluationException structural operational cause) m + , BuiltinErrorToEvaluationError structural operational + ) => + cause -> BuiltinError -> m void throwBuiltinErrorWithCause cause e = throwErrorWithCause (builtinErrorToEvaluationError e) cause {-# INLINE throwBuiltinErrorWithCause #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index 948196cd786..2b26c09b35d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module PlutusCore.Evaluation.Machine.MachineParameters where @@ -17,20 +17,21 @@ import GHC.Exts (inline) import GHC.Generics import NoThunks.Class -{-| We need to account for the costs of evaluator steps and also built-in function - evaluation. The models for these have different structures and are used in - different parts of the code, so inside the valuator we pass separate objects - about most of the time . It's convenient for clients of the evaluator to - only have to worry about a single object, so the CostModel type bundles the - two together. We could conceivably have different evaluators with different - internal costs, so we keep the machine costs abstract. The model for Cek - machine steps is in UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts. --} -data CostModel machinecosts builtincosts = - CostModel { - _machineCostModel :: machinecosts - , _builtinCostModel :: builtincosts - } deriving stock (Eq, Show) +-- | We need to account for the costs of evaluator steps and also built-in function +-- evaluation. The models for these have different structures and are used in +-- different parts of the code, so inside the valuator we pass separate objects +-- about most of the time . It's convenient for clients of the evaluator to +-- only have to worry about a single object, so the CostModel type bundles the +-- two together. We could conceivably have different evaluators with different +-- internal costs, so we keep the machine costs abstract. The model for Cek +-- machine steps is in UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts. +data CostModel machinecosts builtincosts + = CostModel + { _machineCostModel :: machinecosts + , _builtinCostModel :: builtincosts + } + deriving stock (Eq, Show) + makeLenses ''CostModel -- | The part of 'MachineParameters' that is individual for each semantics variant of 'DefaultFun'. @@ -39,36 +40,35 @@ makeLenses ''CostModel -- the language version (even though there's an implicit dependency on the language version: older -- languages don't support 'Case' in general, but it's safe to ignore that, because support for -- 'Case' is controlled by the AST version, which is a separate check during deserialisation). -data MachineVariantParameters machineCosts fun val = - MachineVariantParameters { - machineCosts :: machineCosts - , builtinsRuntime :: BuiltinsRuntime fun val - } - deriving stock Generic - deriving anyclass (NFData) - -{-| At execution time we need a 'BuiltinsRuntime' object which includes both the cost model for -builtins and their denotations. This bundles one of those together with the cost model for evaluator -steps and a 'CaserBuiltin' specifying how casing on values of built-in types works. -The @val@ type will be 'CekValue' when we're using this with the CEK machine. --} -data MachineParameters machineCosts fun val = - MachineParameters { - machineCaserBuiltin :: CaserBuiltin (UniOf val) - , machineVariantParameters :: MachineVariantParameters machineCosts fun val - } - deriving stock Generic - deriving anyclass (NFData) +data MachineVariantParameters machineCosts fun val + = MachineVariantParameters + { machineCosts :: machineCosts + , builtinsRuntime :: BuiltinsRuntime fun val + } + deriving stock (Generic) + deriving anyclass (NFData) + +-- | At execution time we need a 'BuiltinsRuntime' object which includes both the cost model for +-- builtins and their denotations. This bundles one of those together with the cost model for evaluator +-- steps and a 'CaserBuiltin' specifying how casing on values of built-in types works. +-- The @val@ type will be 'CekValue' when we're using this with the CEK machine. +data MachineParameters machineCosts fun val + = MachineParameters + { machineCaserBuiltin :: CaserBuiltin (UniOf val) + , machineVariantParameters :: MachineVariantParameters machineCosts fun val + } + deriving stock (Generic) + deriving anyclass (NFData) -- For some reason the generic instance gives incorrect nothunk errors, -- see https://github.com/input-output-hk/nothunks/issues/24 instance (NoThunks machinecosts, Bounded fun, Enum fun) => NoThunks (MachineVariantParameters machinecosts fun val) where wNoThunks ctx (MachineVariantParameters costs runtime) = - allNoThunks [ noThunks ctx costs, noThunks ctx runtime ] + allNoThunks [noThunks ctx costs, noThunks ctx runtime] instance (NoThunks machinecosts, Bounded fun, Enum fun) => NoThunks (MachineParameters machinecosts fun val) where wNoThunks ctx (MachineParameters caser varPars) = - allNoThunks [ noThunks ctx caser, noThunks ctx varPars ] + allNoThunks [noThunks ctx caser, noThunks ctx varPars] {- Note [The CostingPart constraint in mkMachineVariantParameters] Discharging the @CostingPart uni fun ~ builtincosts@ constraint in 'mkMachineParameters' causes GHC @@ -96,17 +96,18 @@ which makes sense: if @f@ receives all its type and term args then there's less -} -- See Note [Inlining meanings of builtins]. -{-| This just uses 'toBuiltinsRuntime' function to convert a BuiltinCostModel to a BuiltinsRuntime. -} + +-- | This just uses 'toBuiltinsRuntime' function to convert a BuiltinCostModel to a BuiltinsRuntime. mkMachineVariantParameters :: - ( -- WARNING: do not discharge the equality constraint as that causes GHC to fail to inline the - -- function at its call site, see Note [The CostingPart constraint in mkMachineParameters]. - CostingPart uni fun ~ builtincosts - , HasMeaningIn uni val - , ToBuiltinMeaning uni fun - ) - => BuiltinSemanticsVariant fun - -> CostModel machineCosts builtincosts - -> MachineVariantParameters machineCosts fun val + ( -- WARNING: do not discharge the equality constraint as that causes GHC to fail to inline the + -- function at its call site, see Note [The CostingPart constraint in mkMachineParameters]. + CostingPart uni fun ~ builtincosts + , HasMeaningIn uni val + , ToBuiltinMeaning uni fun + ) => + BuiltinSemanticsVariant fun -> + CostModel machineCosts builtincosts -> + MachineVariantParameters machineCosts fun val mkMachineVariantParameters semvar (CostModel mchnCosts builtinCosts) = - MachineVariantParameters mchnCosts $ inline toBuiltinsRuntime semvar builtinCosts + MachineVariantParameters mchnCosts $ inline toBuiltinsRuntime semvar builtinCosts {-# INLINE mkMachineVariantParameters #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 82304a21698..3e327247595 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -18,13 +18,13 @@ import GHC.Exts (inline) -- | The semantics-variant-dependent part of 'MachineParameters'. type DefaultMachineVariantParameters = - MachineVariantParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) + MachineVariantParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) -- | 'MachineParameters' instantiated at CEK-machine-specific types and default builtins. -- Encompasses everything we need for evaluating a UPLC program with default builtins using the CEK -- machine. type DefaultMachineParameters = - MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) + MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) {- Note [Inlining meanings of builtins] It's vitally important to inline the 'toBuiltinMeaning' method of a set of built-in functions as @@ -63,19 +63,20 @@ inlining). -- -- This function is very expensive, so its result needs to be cached if it's going to be used -- multiple times. -mkMachineVariantParametersFor - :: MonadError CostModelApplyError m - => [BuiltinSemanticsVariant DefaultFun] - -> CostModelParams - -> m [(BuiltinSemanticsVariant DefaultFun, DefaultMachineVariantParameters)] +mkMachineVariantParametersFor :: + MonadError CostModelApplyError m => + [BuiltinSemanticsVariant DefaultFun] -> + CostModelParams -> + m [(BuiltinSemanticsVariant DefaultFun, DefaultMachineVariantParameters)] mkMachineVariantParametersFor semVars newCMP = do - res <- for semVars $ \semVar -> - -- See Note [Inlining meanings of builtins]. - (,) semVar . inline mkMachineVariantParameters semVar <$> - applyCostModelParams (cekCostModelForVariant semVar) newCMP - -- Force all thunks to pay the cost of creating machine parameters upfront. Doing it here saves - -- us from doing that in every single benchmark runner. - pure $! force res + res <- for semVars $ \semVar -> + -- See Note [Inlining meanings of builtins]. + (,) semVar . inline mkMachineVariantParameters semVar + <$> applyCostModelParams (cekCostModelForVariant semVar) newCMP + -- Force all thunks to pay the cost of creating machine parameters upfront. Doing it here saves + -- us from doing that in every single benchmark runner. + pure $! force res + -- Not marking this function with @INLINE@, since at this point everything we wanted to be inlined -- is inlined and there's zero reason to duplicate thousands and thousands of lines of Core down -- the line. diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/SimpleBuiltinCostModel.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/SimpleBuiltinCostModel.hs index 71f566827f3..6ada1096bb4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/SimpleBuiltinCostModel.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/SimpleBuiltinCostModel.hs @@ -1,16 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} -- TODO: Extend this to handle the different variants of the cost model -{- | A program to parse a JSON representation of costing functions for Plutus Core - builtins and and produce a simple cost model which can be used from Agda and other - executables -} -module PlutusCore.Evaluation.Machine.SimpleBuiltinCostModel - ( BuiltinCostMap - , BuiltinCostKeyMap - , toSimpleBuiltinCostModel - , defaultSimpleBuiltinCostModel - ) where + +-- | A program to parse a JSON representation of costing functions for Plutus Core +-- builtins and and produce a simple cost model which can be used from Agda and other +-- executables +module PlutusCore.Evaluation.Machine.SimpleBuiltinCostModel ( + BuiltinCostMap, + BuiltinCostKeyMap, + toSimpleBuiltinCostModel, + defaultSimpleBuiltinCostModel, +) where import Data.Aeson.Key as Key (toText) import Data.Aeson.KeyMap qualified as KeyMap @@ -24,10 +25,10 @@ type BuiltinCostMap = [(Text, CpuAndMemoryModel)] type BuiltinCostKeyMap = KeyMap.KeyMap CpuAndMemoryModel -- | The default builtin cost map. - -- TODO: maybe we should take account of the semantic variant here. +-- TODO: maybe we should take account of the semantic variant here. defaultBuiltinCostKeyMap :: BuiltinCostKeyMap defaultBuiltinCostKeyMap = - $$(readJSONFromFile DFP.latestBuiltinCostModelFile) + $$(readJSONFromFile DFP.latestBuiltinCostModelFile) -- replace underscores _ by dashes - builtinName :: Text -> Text diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs index 872bb6fd840..e2e64c39525 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs @@ -1,18 +1,17 @@ --- | This module defines a common type various evaluation machine use to return their results. - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} -module PlutusCore.Evaluation.Result - ( EvaluationResult (..) - , isEvaluationSuccess - , isEvaluationFailure - ) where +-- | This module defines a common type various evaluation machine use to return their results. +module PlutusCore.Evaluation.Result ( + EvaluationResult (..), + isEvaluationSuccess, + isEvaluationFailure, +) where import PlutusPrelude @@ -22,57 +21,57 @@ import Control.Monad.Except (MonadError, catchError, throwError) -- | The parameterized type of results various evaluation engines return. data EvaluationResult a - = EvaluationSuccess !a - | EvaluationFailure - deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) - deriving anyclass (NFData) + = EvaluationSuccess !a + | EvaluationFailure + deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) + deriving anyclass (NFData) instance MonadError () EvaluationResult where - throwError () = EvaluationFailure - {-# INLINE throwError #-} + throwError () = EvaluationFailure + {-# INLINE throwError #-} - catchError EvaluationFailure f = f () - catchError x _ = x - {-# INLINE catchError #-} + catchError EvaluationFailure f = f () + catchError x _ = x + {-# INLINE catchError #-} instance Applicative EvaluationResult where - pure = EvaluationSuccess - {-# INLINE pure #-} + pure = EvaluationSuccess + {-# INLINE pure #-} - EvaluationSuccess f <*> a = fmap f a - EvaluationFailure <*> _ = EvaluationFailure - {-# INLINE (<*>) #-} + EvaluationSuccess f <*> a = fmap f a + EvaluationFailure <*> _ = EvaluationFailure + {-# INLINE (<*>) #-} - EvaluationSuccess _ *> b = b - EvaluationFailure *> _ = EvaluationFailure - {-# INLINE (*>) #-} + EvaluationSuccess _ *> b = b + EvaluationFailure *> _ = EvaluationFailure + {-# INLINE (*>) #-} instance Monad EvaluationResult where - EvaluationSuccess x >>= f = f x - EvaluationFailure >>= _ = EvaluationFailure - {-# INLINE (>>=) #-} + EvaluationSuccess x >>= f = f x + EvaluationFailure >>= _ = EvaluationFailure + {-# INLINE (>>=) #-} - (>>) = (*>) - {-# INLINE (>>) #-} + (>>) = (*>) + {-# INLINE (>>) #-} instance Alternative EvaluationResult where - empty = EvaluationFailure - {-# INLINE empty #-} + empty = EvaluationFailure + {-# INLINE empty #-} - a@EvaluationSuccess{} <|> _ = a - EvaluationFailure <|> b = b - {-# INLINE (<|>) #-} + a@EvaluationSuccess {} <|> _ = a + EvaluationFailure <|> b = b + {-# INLINE (<|>) #-} instance MonadFail EvaluationResult where - fail _ = EvaluationFailure - {-# INLINE fail #-} + fail _ = EvaluationFailure + {-# INLINE fail #-} instance PrettyBy config a => PrettyBy config (EvaluationResult a) where - prettyBy config (EvaluationSuccess x) = prettyBy config x - prettyBy _ EvaluationFailure = "Failure" + prettyBy config (EvaluationSuccess x) = prettyBy config x + prettyBy _ EvaluationFailure = "Failure" instance PrettyClassic a => Pretty (EvaluationResult a) where - pretty = prettyClassic + pretty = prettyClassic -- | Check whether an 'EvaluationResult' is an 'EvaluationSuccess'. isEvaluationSuccess :: EvaluationResult a -> Bool diff --git a/plutus-core/plutus-core/src/PlutusCore/FlatInstances.hs b/plutus-core/plutus-core/src/PlutusCore/FlatInstances.hs index c9afd9a119e..3d1fc1ad3c4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/FlatInstances.hs +++ b/plutus-core/plutus-core/src/PlutusCore/FlatInstances.hs @@ -1,19 +1,18 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Flat instances for Plutus Core types. Make sure to read Note [Stable -- encoding of TPLC] and Note [Stable encoding of UPLC] before touching anything -- in this file. -module PlutusCore.FlatInstances - ( safeEncodeBits - ) where +module PlutusCore.FlatInstances ( + safeEncodeBits, +) where import Codec.Extras.FlatViaSerialise import PlutusCore.Core @@ -57,14 +56,14 @@ This requires specialised encode/decode functions for each constructor that encodes a different number of possibilities. Here is a list of the tags and their used/available encoding possibilities. -** The BELOW table is about Typed-PLC and not UPLC. See `UntypedPlutusCore.Core.Instance.Flat`** +\** The BELOW table is about Typed-PLC and not UPLC. See `UntypedPlutusCore.Core.Instance.Flat`** -| Data type | Function | Bit Width | Total | Used | Remaining | -|------------------|-------------------|-----------|-------|------|-----------| -| default builtins | encodeBuiltin | 7 | 128 | 54 | 74 | -| Kinds | encodeKind | 1 | 2 | 2 | 0 | -| Types | encodeType | 3 | 8 | 7 | 1 | -| Terms | encodeTerm | 4 | 16 | 12 | 4 | +\| Data type | Function | Bit Width | Total | Used | Remaining | +\|------------------|-------------------|-----------|-------|------|-----------| +\| default builtins | encodeBuiltin | 7 | 128 | 54 | 74 | +\| Kinds | encodeKind | 1 | 2 | 2 | 0 | +\| Types | encodeType | 3 | 8 | 7 | 1 | +\| Terms | encodeTerm | 4 | 16 | 12 | 4 | For format stability we are manually assigning the tag values to the constructors (and we do not use a generic algorithm that may change this order). @@ -106,9 +105,14 @@ so the nodes' behavior does not change. safeEncodeBits :: NumBits -> Word8 -> Encoding safeEncodeBits maxBits v = if 2 ^ maxBits <= v - then error $ "Overflow detected, cannot fit " - <> show v <> " in " <> show maxBits <> " bits." - else eBits maxBits v + then + error $ + "Overflow detected, cannot fit " + <> show v + <> " in " + <> show maxBits + <> " bits." + else eBits maxBits v constantWidth :: NumBits constantWidth = 4 @@ -123,52 +127,55 @@ deriving via FlatViaSerialise Data instance Flat Data decodeKindedUniFlat :: Closed uni => Get (SomeTypeIn (Kinded uni)) decodeKindedUniFlat = - go . decodeKindedUni . map (fromIntegral :: Word8 -> Int) - =<< decodeListWith decodeConstant - where - go Nothing = fail "Failed to decode a universe" - go (Just uni) = pure uni + go . decodeKindedUni . map (fromIntegral :: Word8 -> Int) + =<< decodeListWith decodeConstant + where + go Nothing = fail "Failed to decode a universe" + go (Just uni) = pure uni -- See Note [The G, the Tag and the Auto]. instance Closed uni => Flat (SomeTypeIn uni) where - encode (SomeTypeIn uni) = - encodeListWith encodeConstant . - map (fromIntegral :: Int -> Word8) $ encodeUni uni + encode (SomeTypeIn uni) = + encodeListWith encodeConstant + . map (fromIntegral :: Int -> Word8) + $ encodeUni uni - decode = decodeKindedUniFlat <&> \(SomeTypeIn (Kinded uni)) -> SomeTypeIn uni + decode = decodeKindedUniFlat <&> \(SomeTypeIn (Kinded uni)) -> SomeTypeIn uni - -- Encode a view of the universe, not the universe itself. - size (SomeTypeIn uni) acc = - acc + - length (encodeUni uni) * (1 + constantWidth) + -- List Cons (1 bit) + constant - 1 -- List Nil (1 bit) + -- Encode a view of the universe, not the universe itself. + size (SomeTypeIn uni) acc = + acc + + length (encodeUni uni) * (1 + constantWidth) + + 1 -- List Cons (1 bit) + constant + -- List Nil (1 bit) -- See Note [The G, the Tag and the Auto]. instance (Closed uni, uni `Everywhere` Flat) => Flat (Some (ValueOf uni)) where - encode (Some (ValueOf uni x)) = encode (SomeTypeIn uni) <> bring (Proxy @Flat) uni (encode x) + encode (Some (ValueOf uni x)) = encode (SomeTypeIn uni) <> bring (Proxy @Flat) uni (encode x) - decode = - decodeKindedUniFlat @uni >>= \(SomeTypeIn (Kinded uni)) -> - -- See Note [Decoding universes]. - case checkStar uni of - Nothing -> fail "A non-star type can't have a value to decode" - Just Refl -> Some . ValueOf uni <$> bring (Proxy @Flat) uni decode + decode = + decodeKindedUniFlat @uni >>= \(SomeTypeIn (Kinded uni)) -> + -- See Note [Decoding universes]. + case checkStar uni of + Nothing -> fail "A non-star type can't have a value to decode" + Just Refl -> Some . ValueOf uni <$> bring (Proxy @Flat) uni decode - -- We need to get the flat instance in scope. - size (Some (ValueOf uni x)) acc = size (SomeTypeIn uni) acc - + bring (Proxy @Flat) uni (size x 0) + -- We need to get the flat instance in scope. + size (Some (ValueOf uni x)) acc = + size (SomeTypeIn uni) acc + + bring (Proxy @Flat) uni (size x 0) deriving newtype instance Flat Unique -- via int instance Flat Name where - encode (Name txt u) = encode txt <> encode u - decode = Name <$> decode <*> decode + encode (Name txt u) = encode txt <> encode u + decode = Name <$> decode <*> decode deriving newtype instance Flat TyName -- via Name instance Flat Version where - encode (Version n n' n'') = encode n <> encode n' <> encode n'' - decode = Version <$> decode <*> decode <*> decode + encode (Version n n' n'') = encode n <> encode n' <> encode n'' + decode = Version <$> decode <*> decode <*> decode -- | Use 1 bit to encode kind tags. kindTagWidth :: NumBits @@ -181,20 +188,22 @@ decodeKind :: Get Word8 decodeKind = dBEBits8 kindTagWidth instance Flat ann => Flat (Kind ann) where - encode = \case - Type ann -> encodeKind 0 <> encode ann - KindArrow ann k k' -> encodeKind 1 <> encode ann <> encode k <> encode k' - - decode = go =<< decodeKind - where go 0 = Type <$> decode - go 1 = KindArrow <$> decode <*> decode <*> decode - go _ = fail "Failed to decode Kind ()" - - size tm sz = - let - sz' = sz + kindTagWidth - in case tm of - Type ann -> size ann sz' + encode = \case + Type ann -> encodeKind 0 <> encode ann + KindArrow ann k k' -> encodeKind 1 <> encode ann <> encode k <> encode k' + + decode = go =<< decodeKind + where + go 0 = Type <$> decode + go 1 = KindArrow <$> decode <*> decode <*> decode + go _ = fail "Failed to decode Kind ()" + + size tm sz = + let + sz' = sz + kindTagWidth + in + case tm of + Type ann -> size ann sz' KindArrow ann k k' -> size ann $ size k $ size k' sz' -- | Use 3 bits to encode type tags. @@ -208,41 +217,43 @@ decodeType :: Get Word8 decodeType = dBEBits8 typeTagWidth instance (Closed uni, Flat ann, Flat tyname) => Flat (Type tyname uni ann) where - encode = \case - TyVar ann tn -> encodeType 0 <> encode ann <> encode tn - TyFun ann t t' -> encodeType 1 <> encode ann <> encode t <> encode t' - TyIFix ann pat arg -> encodeType 2 <> encode ann <> encode pat <> encode arg - TyForall ann tn k t -> encodeType 3 <> encode ann <> encode tn <> encode k <> encode t - TyBuiltin ann con -> encodeType 4 <> encode ann <> encode con - TyLam ann n k t -> encodeType 5 <> encode ann <> encode n <> encode k <> encode t - TyApp ann t t' -> encodeType 6 <> encode ann <> encode t <> encode t' - -- Note that this relies on the instance for lists. We shouldn't use this in the - -- serious on-chain version but it's okay here. - TySOP ann tyls -> encodeType 7 <> encode ann <> encode tyls - - decode = go =<< decodeType - where go 0 = TyVar <$> decode <*> decode - go 1 = TyFun <$> decode <*> decode <*> decode - go 2 = TyIFix <$> decode <*> decode <*> decode - go 3 = TyForall <$> decode <*> decode <*> decode <*> decode - go 4 = TyBuiltin <$> decode <*> decode - go 5 = TyLam <$> decode <*> decode <*> decode <*> decode - go 6 = TyApp <$> decode <*> decode <*> decode - go 7 = TySOP <$> decode <*> decode - go _ = fail "Failed to decode Type TyName ()" - - size tm sz = - let - sz' = sz + typeTagWidth - in case tm of - TyVar ann tn -> size ann $ size tn sz' - TyFun ann t t' -> size ann $ size t $ size t' sz' - TyIFix ann pat arg -> size ann $ size pat $ size arg sz' - TyForall ann tn k t -> size ann $ size tn $ size k $ size t sz' - TyBuiltin ann con -> size ann $ size con sz' - TyLam ann n k t -> size ann $ size n $ size k $ size t sz' - TyApp ann t t' -> size ann $ size t $ size t' sz' - TySOP ann tyls -> size ann $ size tyls sz' + encode = \case + TyVar ann tn -> encodeType 0 <> encode ann <> encode tn + TyFun ann t t' -> encodeType 1 <> encode ann <> encode t <> encode t' + TyIFix ann pat arg -> encodeType 2 <> encode ann <> encode pat <> encode arg + TyForall ann tn k t -> encodeType 3 <> encode ann <> encode tn <> encode k <> encode t + TyBuiltin ann con -> encodeType 4 <> encode ann <> encode con + TyLam ann n k t -> encodeType 5 <> encode ann <> encode n <> encode k <> encode t + TyApp ann t t' -> encodeType 6 <> encode ann <> encode t <> encode t' + -- Note that this relies on the instance for lists. We shouldn't use this in the + -- serious on-chain version but it's okay here. + TySOP ann tyls -> encodeType 7 <> encode ann <> encode tyls + + decode = go =<< decodeType + where + go 0 = TyVar <$> decode <*> decode + go 1 = TyFun <$> decode <*> decode <*> decode + go 2 = TyIFix <$> decode <*> decode <*> decode + go 3 = TyForall <$> decode <*> decode <*> decode <*> decode + go 4 = TyBuiltin <$> decode <*> decode + go 5 = TyLam <$> decode <*> decode <*> decode <*> decode + go 6 = TyApp <$> decode <*> decode <*> decode + go 7 = TySOP <$> decode <*> decode + go _ = fail "Failed to decode Type TyName ()" + + size tm sz = + let + sz' = sz + typeTagWidth + in + case tm of + TyVar ann tn -> size ann $ size tn sz' + TyFun ann t t' -> size ann $ size t $ size t' sz' + TyIFix ann pat arg -> size ann $ size pat $ size arg sz' + TyForall ann tn k t -> size ann $ size tn $ size k $ size t sz' + TyBuiltin ann con -> size ann $ size con sz' + TyLam ann n k t -> size ann $ size n $ size k $ size t sz' + TyApp ann t t' -> size ann $ size t $ size t' sz' + TySOP ann tyls -> size ann $ size tyls sz' termTagWidth :: NumBits termTagWidth = 4 @@ -253,88 +264,99 @@ encodeTerm = safeEncodeBits termTagWidth decodeTerm :: Get Word8 decodeTerm = dBEBits8 termTagWidth -instance ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat tyname - , Flat name - ) => Flat (Term tyname name uni fun ann) where - encode = \case - Var ann n -> encodeTerm 0 <> encode ann <> encode n - TyAbs ann tn k t -> encodeTerm 1 <> encode ann <> encode tn <> encode k <> encode t - LamAbs ann n ty t -> encodeTerm 2 <> encode ann <> encode n <> encode ty <> encode t - Apply ann t t' -> encodeTerm 3 <> encode ann <> encode t <> encode t' - Constant ann c -> encodeTerm 4 <> encode ann <> encode c - TyInst ann t ty -> encodeTerm 5 <> encode ann <> encode t <> encode ty - Unwrap ann t -> encodeTerm 6 <> encode ann <> encode t - IWrap ann pat arg t -> encodeTerm 7 <> encode ann <> encode pat <> encode arg <> encode t - Error ann ty -> encodeTerm 8 <> encode ann <> encode ty - Builtin ann bn -> encodeTerm 9 <> encode ann <> encode bn - Constr ann ty i es -> - encodeTerm 10 - <> encode ann - <> encode ty - <> encode i - <> encode es - Case ann ty arg cs -> - encodeTerm 11 - <> encode ann - <> encode ty - <> encode arg - <> encode cs - - decode = go =<< decodeTerm - where go 0 = Var <$> decode <*> decode - go 1 = TyAbs <$> decode <*> decode <*> decode <*> decode - go 2 = LamAbs <$> decode <*> decode <*> decode <*> decode - go 3 = Apply <$> decode <*> decode <*> decode - go 4 = Constant <$> decode <*> decode - go 5 = TyInst <$> decode <*> decode <*> decode - go 6 = Unwrap <$> decode <*> decode - go 7 = IWrap <$> decode <*> decode <*> decode <*> decode - go 8 = Error <$> decode <*> decode - go 9 = Builtin <$> decode <*> decode - go 10 = Constr <$> decode <*> decode <*> decode <*> decode - go 11 = Case <$> decode <*> decode <*> decode <*> decode - go _ = fail "Failed to decode Term TyName Name ()" - - size tm sz = - let - sz' = termTagWidth + sz - in case tm of - Var ann n -> size ann $ size n sz' - TyAbs ann tn k t -> size ann $ size tn $ size k $ size t sz' - LamAbs ann n ty t -> size ann $ size n $ size ty $ size t sz' - Apply ann t t' -> size ann $ size t $ size t' sz' - Constant ann c -> size ann $ size c sz' - TyInst ann t ty -> size ann $ size t $ size ty sz' - Unwrap ann t -> size ann $ size t sz' - IWrap ann pat arg t -> size ann $ size pat $ size arg $ size t sz' - Error ann ty -> size ann $ size ty sz' - Builtin ann bn -> size ann $ size bn sz' - Constr ann ty i es -> size ann $ size ty $ size i $ size es sz' - Case ann ty arg cs -> size ann $ size ty $ size arg $ size cs sz' - -instance ( Closed uni - , Flat ann - , Flat tyname - , Flat name - ) => Flat (VarDecl tyname name uni ann) where - encode (VarDecl t name tyname ) = encode t <> encode name <> encode tyname - decode = VarDecl <$> decode <*> decode <*> decode - -instance (Flat ann, Flat tyname) => Flat (TyVarDecl tyname ann) where - encode (TyVarDecl t tyname kind) = encode t <> encode tyname <> encode kind - decode = TyVarDecl <$> decode <*> decode <*> decode - -instance ( Flat ann - , Flat (Term tyname name uni fun ann) - ) => Flat (Program tyname name uni fun ann) where - encode (Program ann v t) = encode ann <> encode v <> encode t - decode = Program <$> decode <*> decode <*> decode - -deriving newtype instance (Flat a) => Flat (Normalized a) +instance + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat tyname + , Flat name + ) => + Flat (Term tyname name uni fun ann) + where + encode = \case + Var ann n -> encodeTerm 0 <> encode ann <> encode n + TyAbs ann tn k t -> encodeTerm 1 <> encode ann <> encode tn <> encode k <> encode t + LamAbs ann n ty t -> encodeTerm 2 <> encode ann <> encode n <> encode ty <> encode t + Apply ann t t' -> encodeTerm 3 <> encode ann <> encode t <> encode t' + Constant ann c -> encodeTerm 4 <> encode ann <> encode c + TyInst ann t ty -> encodeTerm 5 <> encode ann <> encode t <> encode ty + Unwrap ann t -> encodeTerm 6 <> encode ann <> encode t + IWrap ann pat arg t -> encodeTerm 7 <> encode ann <> encode pat <> encode arg <> encode t + Error ann ty -> encodeTerm 8 <> encode ann <> encode ty + Builtin ann bn -> encodeTerm 9 <> encode ann <> encode bn + Constr ann ty i es -> + encodeTerm 10 + <> encode ann + <> encode ty + <> encode i + <> encode es + Case ann ty arg cs -> + encodeTerm 11 + <> encode ann + <> encode ty + <> encode arg + <> encode cs + + decode = go =<< decodeTerm + where + go 0 = Var <$> decode <*> decode + go 1 = TyAbs <$> decode <*> decode <*> decode <*> decode + go 2 = LamAbs <$> decode <*> decode <*> decode <*> decode + go 3 = Apply <$> decode <*> decode <*> decode + go 4 = Constant <$> decode <*> decode + go 5 = TyInst <$> decode <*> decode <*> decode + go 6 = Unwrap <$> decode <*> decode + go 7 = IWrap <$> decode <*> decode <*> decode <*> decode + go 8 = Error <$> decode <*> decode + go 9 = Builtin <$> decode <*> decode + go 10 = Constr <$> decode <*> decode <*> decode <*> decode + go 11 = Case <$> decode <*> decode <*> decode <*> decode + go _ = fail "Failed to decode Term TyName Name ()" + + size tm sz = + let + sz' = termTagWidth + sz + in + case tm of + Var ann n -> size ann $ size n sz' + TyAbs ann tn k t -> size ann $ size tn $ size k $ size t sz' + LamAbs ann n ty t -> size ann $ size n $ size ty $ size t sz' + Apply ann t t' -> size ann $ size t $ size t' sz' + Constant ann c -> size ann $ size c sz' + TyInst ann t ty -> size ann $ size t $ size ty sz' + Unwrap ann t -> size ann $ size t sz' + IWrap ann pat arg t -> size ann $ size pat $ size arg $ size t sz' + Error ann ty -> size ann $ size ty sz' + Builtin ann bn -> size ann $ size bn sz' + Constr ann ty i es -> size ann $ size ty $ size i $ size es sz' + Case ann ty arg cs -> size ann $ size ty $ size arg $ size cs sz' + +instance + ( Closed uni + , Flat ann + , Flat tyname + , Flat name + ) => + Flat (VarDecl tyname name uni ann) + where + encode (VarDecl t name tyname) = encode t <> encode name <> encode tyname + decode = VarDecl <$> decode <*> decode <*> decode + +instance (Flat ann, Flat tyname) => Flat (TyVarDecl tyname ann) where + encode (TyVarDecl t tyname kind) = encode t <> encode tyname <> encode kind + decode = TyVarDecl <$> decode <*> decode <*> decode + +instance + ( Flat ann + , Flat (Term tyname name uni fun ann) + ) => + Flat (Program tyname name uni fun ann) + where + encode (Program ann v t) = encode ann <> encode v <> encode t + decode = Program <$> decode <*> decode <*> decode + +deriving newtype instance Flat a => Flat (Normalized a) -- See Note [DeBruijn Index serialization] deriving newtype instance Flat Index -- via word64 @@ -343,21 +365,22 @@ deriving newtype instance Flat DeBruijn -- via index deriving newtype instance Flat TyDeBruijn -- via debruijn instance Flat NamedDeBruijn where - encode (NamedDeBruijn txt ix) = encode txt <> encode ix - decode = NamedDeBruijn <$> decode <*> decode + encode (NamedDeBruijn txt ix) = encode txt <> encode ix + decode = NamedDeBruijn <$> decode <*> decode deriving newtype instance Flat NamedTyDeBruijn -- via nameddebruijn -- NOTE: the serialization roundtrip holds iff the invariant binder.index==0 holds instance Flat (Binder DeBruijn) where - size _ = id -- zero cost - encode _ = mempty - decode = pure $ Binder $ DeBruijn deBruijnInitIndex + size _ = id -- zero cost + encode _ = mempty + decode = pure $ Binder $ DeBruijn deBruijnInitIndex -- (Binder TyDeBruijn) could similarly have a flat instance, but we don't need it. deriving newtype instance Flat (Binder Name) deriving newtype instance Flat (Binder TyName) + -- We could use an alternative, manual Flat-serialization of Named(Ty)DeBruijn -- where we store the name only at the binder and the index only at the use-site (Var/TyVar). -- That would be more compact, but we don't need it at the moment. @@ -370,9 +393,9 @@ but we do not need any other isomorphic Flat deriving for the moment. See Note [Why newtype FakeNamedDeBruijn] -} instance Flat FakeNamedDeBruijn where - size = size . fromFake - encode = encode . fromFake - decode = toFake <$> decode + size = size . fromFake + encode = encode . fromFake + decode = toFake <$> decode {- This instance is going via Flat (Binder DeBruijn) instance. Binder FakeNamedDeBruijn <-> Binder DeBruijn are isomorphic because @@ -383,6 +406,6 @@ See Note [Why newtype FakeNamedDeBruijn] NOTE: the serialization roundtrip holds iff the invariant binder.index==0 holds -} instance Flat (Binder FakeNamedDeBruijn) where - size = size . fmap fromFake - encode = encode . fmap fromFake - decode = fmap toFake <$> decode + size = size . fmap fromFake + encode = encode . fmap fromFake + decode = fmap toFake <$> decode diff --git a/plutus-core/plutus-core/src/PlutusCore/FsTree.hs b/plutus-core/plutus-core/src/PlutusCore/FsTree.hs index 88a469aebb7..db631883875 100644 --- a/plutus-core/plutus-core/src/PlutusCore/FsTree.hs +++ b/plutus-core/plutus-core/src/PlutusCore/FsTree.hs @@ -3,29 +3,29 @@ -- (pretty-printing, type checking, etc): each time a function / data type is added to that value, -- none of the tests is required to be adapted, instead all the tests see the new definition -- automatically. - -module PlutusCore.FsTree - ( FsTree (..) - , FolderContents (..) - , PlcEntity (..) - , PlcFsTree - , PlcFolderContents - , treeFolderContents - , plcTypeFile - , plcTermFile - , foldFsTree - , foldPlcFsTree - , foldPlcFolderContents - ) where +module PlutusCore.FsTree ( + FsTree (..), + FolderContents (..), + PlcEntity (..), + PlcFsTree, + PlcFolderContents, + treeFolderContents, + plcTypeFile, + plcTermFile, + foldFsTree, + foldPlcFsTree, + foldPlcFolderContents, +) where import PlutusCore.Core import PlutusCore.Name.Unique -- We use 'String's for names, because 'FilePath's are 'String's. + -- | An 'FsTree' is either a file or a folder with a list of 'FsTree's inside. data FsTree a - = FsFolder String (FolderContents a) - | FsFile String a + = FsFolder String (FolderContents a) + | FsFile String a -- | The contents of a folder. A wrapper around @[FsTree a]@. -- Exists because of its 'Semigroup' instance which allows to concatenate two 'FolderContents's @@ -33,15 +33,16 @@ data FsTree a -- (@stdlib@, @examples@, etc), define compound modules (e.g. @stdlib <> examples@) and run various -- tests (pretty-printing, type synthesis, etc) against simple and compound modules uniformly. newtype FolderContents a = FolderContents - { unFolderContents :: [FsTree a] - } deriving newtype (Semigroup, Monoid) + { unFolderContents :: [FsTree a] + } + deriving newtype (Semigroup, Monoid) -- | A 'PlcEntity' is either a 'Type' or a 'Term'. data PlcEntity uni fun - = PlcType (Type TyName uni ()) - | PlcTerm (Term TyName Name uni fun ()) + = PlcType (Type TyName uni ()) + | PlcTerm (Term TyName Name uni fun ()) -type PlcFsTree uni fun = FsTree (PlcEntity uni fun) +type PlcFsTree uni fun = FsTree (PlcEntity uni fun) type PlcFolderContents uni fun = FolderContents (PlcEntity uni fun) -- | Construct an 'FsTree' out of the name of a folder and a list of 'FsTree's. @@ -57,32 +58,42 @@ plcTermFile :: String -> Term TyName Name uni fun () -> PlcFsTree uni fun plcTermFile name = FsFile name . PlcTerm -- | Fold a 'FsTree'. -foldFsTree - :: (String -> [b] -> b) -- ^ What to do on a folder. - -> (String -> a -> b) -- ^ What to do on a single file in a folder. - -> FsTree a - -> b -foldFsTree onFolder onFile = go where +foldFsTree :: + -- | What to do on a folder. + (String -> [b] -> b) -> + -- | What to do on a single file in a folder. + (String -> a -> b) -> + FsTree a -> + b +foldFsTree onFolder onFile = go + where go (FsFolder name (FolderContents trees)) = onFolder name $ map go trees - go (FsFile name x) = onFile name x + go (FsFile name x) = onFile name x -- | Fold a 'PlcFsTree'. -foldPlcFsTree - :: (String -> [b] -> b) -- ^ What to do on a folder. - -> (String -> Type TyName uni () -> b) -- ^ What to do on a type. - -> (String -> Term TyName Name uni fun () -> b) -- ^ What to do on a term. - -> PlcFsTree uni fun - -> b -foldPlcFsTree onFolder onType onTerm = foldFsTree onFolder onFile where - onFile name (PlcType getTy) = onType name getTy +foldPlcFsTree :: + -- | What to do on a folder. + (String -> [b] -> b) -> + -- | What to do on a type. + (String -> Type TyName uni () -> b) -> + -- | What to do on a term. + (String -> Term TyName Name uni fun () -> b) -> + PlcFsTree uni fun -> + b +foldPlcFsTree onFolder onType onTerm = foldFsTree onFolder onFile + where + onFile name (PlcType getTy) = onType name getTy onFile name (PlcTerm getTerm) = onTerm name getTerm -- | Fold the contents of a PLC folder. -foldPlcFolderContents - :: (String -> [b] -> b) -- ^ What to do on a folder. - -> (String -> Type TyName uni () -> b) -- ^ What to do on a type. - -> (String -> Term TyName Name uni fun () -> b) -- ^ What to do on a term. - -> PlcFolderContents uni fun - -> [b] +foldPlcFolderContents :: + -- | What to do on a folder. + (String -> [b] -> b) -> + -- | What to do on a type. + (String -> Type TyName uni () -> b) -> + -- | What to do on a term. + (String -> Term TyName Name uni fun () -> b) -> + PlcFolderContents uni fun -> + [b] foldPlcFolderContents onFolder onType onTerm (FolderContents trees) = - map (foldPlcFsTree onFolder onType onTerm) trees + map (foldPlcFsTree onFolder onType onTerm) trees diff --git a/plutus-core/plutus-core/src/PlutusCore/Mark.hs b/plutus-core/plutus-core/src/PlutusCore/Mark.hs index eeee75c2f33..efd55782d68 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Mark.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Mark.hs @@ -1,8 +1,8 @@ -module PlutusCore.Mark - ( markNonFreshTerm - , markNonFreshType - , markNonFreshProgram - ) where +module PlutusCore.Mark ( + markNonFreshTerm, + markNonFreshType, + markNonFreshProgram, +) where import Data.Set.Lens (setOf) import PlutusCore.Core @@ -11,22 +11,22 @@ import PlutusCore.Quote -- | Marks all the 'Unique's in a type as used, so they will not be generated in future. Useful if -- you have a type which was not generated in 'Quote'. -markNonFreshType - :: (HasUniques (Type tyname uni ann), MonadQuote m) - => Type tyname uni ann -> m () +markNonFreshType :: + (HasUniques (Type tyname uni ann), MonadQuote m) => + Type tyname uni ann -> m () markNonFreshType = markNonFreshMax . setOf typeUniquesDeep -- | Marks all the 'Unique's in a term as used, so they will not be generated in future. Useful if -- you have a term which was not generated in 'Quote'. -markNonFreshTerm - :: (HasUniques (Term tyname name uni fun ann), MonadQuote m) - => Term tyname name uni fun ann -> m () +markNonFreshTerm :: + (HasUniques (Term tyname name uni fun ann), MonadQuote m) => + Term tyname name uni fun ann -> m () markNonFreshTerm = markNonFreshMax . setOf termUniquesDeep -- | Marks all the 'Unique's in a program as used, so they will not be generated in future. Useful -- if you have a program which was not generated in 'Quote'. -markNonFreshProgram - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadQuote m) - => Program tyname name uni fun ann - -> m () +markNonFreshProgram :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadQuote m) => + Program tyname name uni fun ann -> + m () markNonFreshProgram (Program _ _ body) = markNonFreshTerm body diff --git a/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs b/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs index 0b6aa62779b..a274087fb3b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs +++ b/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs @@ -1,62 +1,62 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.MkPlc - ( TermLike (..) - , UniOf - , HasTypeLevel - , HasTermLevel - , HasTypeAndTermLevel - , mkTyBuiltinOf - , mkTyBuiltin - , mkConstantOf - , mkConstant - , VarDecl (..) - , TyVarDecl (..) - , TyDecl (..) - , mkVar - , mkTyVar - , tyDeclVar - , Def (..) - , embedTerm - , TermDef - , TypeDef - , FunctionType (..) - , FunctionDef (..) - , functionTypeToType - , functionDefToType - , functionDefVarDecl - , mkFunctionDef - , mkImmediateLamAbs - , mkImmediateTyAbs - , mkIterTyForall - , mkIterTyLam - , mkIterApp - , mkIterAppNoAnn - , (@@) - , mkIterTyFun - , mkIterLamAbs - , mkIterInst - , mkIterInstNoAnn - , mkIterTyAbs - , mkIterTyApp - , mkIterTyAppNoAnn - , mkIterKindArrow - , mkFreshTermLet - , headSpineToTerm - , headSpineToTermNoAnn - ) where +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module PlutusCore.MkPlc ( + TermLike (..), + UniOf, + HasTypeLevel, + HasTermLevel, + HasTypeAndTermLevel, + mkTyBuiltinOf, + mkTyBuiltin, + mkConstantOf, + mkConstant, + VarDecl (..), + TyVarDecl (..), + TyDecl (..), + mkVar, + mkTyVar, + tyDeclVar, + Def (..), + embedTerm, + TermDef, + TypeDef, + FunctionType (..), + FunctionDef (..), + functionTypeToType, + functionDefToType, + functionDefVarDecl, + mkFunctionDef, + mkImmediateLamAbs, + mkImmediateTyAbs, + mkIterTyForall, + mkIterTyLam, + mkIterApp, + mkIterAppNoAnn, + (@@), + mkIterTyFun, + mkIterLamAbs, + mkIterInst, + mkIterInstNoAnn, + mkIterTyAbs, + mkIterTyApp, + mkIterTyAppNoAnn, + mkIterKindArrow, + mkFreshTermLet, + headSpineToTerm, + headSpineToTermNoAnn, +) where import PlutusPrelude import Prelude hiding (error) @@ -71,72 +71,74 @@ import Universe -- | A final encoding for Term, to allow PLC terms to be used transparently as PIR terms. class TermLike term tyname name uni fun | term -> tyname name uni fun where - var :: ann -> name -> term ann - tyAbs :: ann -> tyname -> Kind ann -> term ann -> term ann - lamAbs :: ann -> name -> Type tyname uni ann -> term ann -> term ann - apply :: ann -> term ann -> term ann -> term ann - constant :: ann -> Some (ValueOf uni) -> term ann - builtin :: ann -> fun -> term ann - tyInst :: ann -> term ann -> Type tyname uni ann -> term ann - unwrap :: ann -> term ann -> term ann - iWrap :: ann -> Type tyname uni ann -> Type tyname uni ann -> term ann -> term ann - error :: ann -> Type tyname uni ann -> term ann - constr :: ann -> Type tyname uni ann -> Word64 -> [term ann] -> term ann - kase :: ann -> Type tyname uni ann -> term ann -> [term ann] -> term ann - - termLet :: ann -> TermDef term tyname name uni ann -> term ann -> term ann - typeLet :: ann -> TypeDef tyname uni ann -> term ann -> term ann - - termLet = mkImmediateLamAbs - typeLet = mkImmediateTyAbs + var :: ann -> name -> term ann + tyAbs :: ann -> tyname -> Kind ann -> term ann -> term ann + lamAbs :: ann -> name -> Type tyname uni ann -> term ann -> term ann + apply :: ann -> term ann -> term ann -> term ann + constant :: ann -> Some (ValueOf uni) -> term ann + builtin :: ann -> fun -> term ann + tyInst :: ann -> term ann -> Type tyname uni ann -> term ann + unwrap :: ann -> term ann -> term ann + iWrap :: ann -> Type tyname uni ann -> Type tyname uni ann -> term ann -> term ann + error :: ann -> Type tyname uni ann -> term ann + constr :: ann -> Type tyname uni ann -> Word64 -> [term ann] -> term ann + kase :: ann -> Type tyname uni ann -> term ann -> [term ann] -> term ann + + termLet :: ann -> TermDef term tyname name uni ann -> term ann -> term ann + typeLet :: ann -> TypeDef tyname uni ann -> term ann -> term ann + + termLet = mkImmediateLamAbs + typeLet = mkImmediateTyAbs -- TODO: make it @forall {k}@ once we have that. -- (see https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0099-explicit-specificity.rst) + -- | Embed a type (given its explicit type tag) into a PLC type. mkTyBuiltinOf :: forall k (a :: k) uni tyname ann. ann -> uni (Esc a) -> Type tyname uni ann mkTyBuiltinOf ann = TyBuiltin ann . SomeTypeIn -- | Embed a Haskell value (given its explicit type tag) into a PLC term. -mkConstantOf - :: forall a uni fun term tyname name ann. TermLike term tyname name uni fun - => ann -> uni (Esc a) -> a -> term ann +mkConstantOf :: + forall a uni fun term tyname name ann. + TermLike term tyname name uni fun => + ann -> uni (Esc a) -> a -> term ann mkConstantOf ann uni = constant ann . someValueOf uni -- | Embed a Haskell value (provided its type is in the universe) into a PLC term. -mkConstant - :: forall a uni fun term tyname name ann. - (TermLike term tyname name uni fun, uni `HasTermLevel` a) - => ann -> a -> term ann +mkConstant :: + forall a uni fun term tyname name ann. + (TermLike term tyname name uni fun, uni `HasTermLevel` a) => + ann -> a -> term ann mkConstant ann = constant ann . someValue instance TermLike (Term tyname name uni fun) tyname name uni fun where - var = Var - tyAbs = TyAbs - lamAbs = LamAbs - apply = Apply - constant = Constant - builtin = Builtin - tyInst = TyInst - unwrap = Unwrap - iWrap = IWrap - error = Error - constr = Constr - kase = Case + var = Var + tyAbs = TyAbs + lamAbs = LamAbs + apply = Apply + constant = Constant + builtin = Builtin + tyInst = TyInst + unwrap = Unwrap + iWrap = IWrap + error = Error + constr = Constr + kase = Case embedTerm :: TermLike term tyname name uni fun => Term tyname name uni fun ann -> term ann embedTerm = \case - Var a n -> var a n - TyAbs a tn k t -> tyAbs a tn k (embedTerm t) - LamAbs a n ty t -> lamAbs a n ty (embedTerm t) - Apply a t1 t2 -> apply a (embedTerm t1) (embedTerm t2) - Constant a c -> constant a c - Builtin a bi -> builtin a bi - TyInst a t ty -> tyInst a (embedTerm t) ty - Error a ty -> error a ty - Unwrap a t -> unwrap a (embedTerm t) - IWrap a ty1 ty2 t -> iWrap a ty1 ty2 (embedTerm t) - Constr a ty i es -> constr a ty i (fmap embedTerm es) - Case a ty arg cs -> kase a ty (embedTerm arg) (fmap embedTerm cs) + Var a n -> var a n + TyAbs a tn k t -> tyAbs a tn k (embedTerm t) + LamAbs a n ty t -> lamAbs a n ty (embedTerm t) + Apply a t1 t2 -> apply a (embedTerm t1) (embedTerm t2) + Constant a c -> constant a c + Builtin a bi -> builtin a bi + TyInst a t ty -> tyInst a (embedTerm t) ty + Error a ty -> error a ty + Unwrap a t -> unwrap a (embedTerm t) + IWrap a ty1 ty2 t -> iWrap a ty1 ty2 (embedTerm t) + Constr a ty i es -> constr a ty i (fmap embedTerm es) + Case a ty arg cs -> kase a ty (embedTerm arg) (fmap embedTerm cs) -- | Make a 'Var' referencing the given 'VarDecl'. -- The @ann@ is propagated from the 'VarDecl' to the 'Var'. @@ -151,32 +153,42 @@ mkTyVar ann = TyVar ann . _tyVarDeclName -- | A definition. Pretty much just a pair with more descriptive names. data Def var val = Def - { defVar :: var - , defVal :: val - } deriving stock (Show, Eq, Ord, Generic) + { defVar :: var + , defVal :: val + } + deriving stock (Show, Eq, Ord, Generic) -- | A term definition as a variable. type TermDef term tyname name uni ann = Def (VarDecl tyname name uni ann) (term ann) + -- | A type definition as a type variable. type TypeDef tyname uni ann = Def (TyVarDecl tyname ann) (Type tyname uni ann) -- | The type of a PLC function. data FunctionType tyname uni ann = FunctionType - { _functionTypeAnn :: ann -- ^ An annotation. - , _functionTypeDom :: Type tyname uni ann -- ^ The domain of a function. - , _functionTypeCod :: Type tyname uni ann -- ^ The codomain of the function. - } + { _functionTypeAnn :: ann + -- ^ An annotation. + , _functionTypeDom :: Type tyname uni ann + -- ^ The domain of a function. + , _functionTypeCod :: Type tyname uni ann + -- ^ The codomain of the function. + } -- Should we parameterize 'VarDecl' by @ty@ rather than @tyname@, so that we can define -- 'FunctionDef' as 'TermDef FunctionType tyname name uni fun ann'? -- Perhaps we even should define general 'Decl' and 'Def' that cover all of the cases? + -- | A PLC function. data FunctionDef term tyname name uni fun ann = FunctionDef - { _functionDefAnn :: ann -- ^ An annotation. - , _functionDefName :: name -- ^ The name of a function. - , _functionDefType :: FunctionType tyname uni ann -- ^ The type of the function. - , _functionDefTerm :: term ann -- ^ The definition of the function. - } + { _functionDefAnn :: ann + -- ^ An annotation. + , _functionDefName :: name + -- ^ The name of a function. + , _functionDefType :: FunctionType tyname uni ann + -- ^ The type of the function. + , _functionDefTerm :: term ann + -- ^ The definition of the function. + } -- | Convert a 'FunctionType' to the corresponding 'Type'. functionTypeToType :: FunctionType tyname uni ann -> Type tyname uni ann @@ -191,160 +203,184 @@ functionDefVarDecl :: FunctionDef term tyname name uni fun ann -> VarDecl tyname functionDefVarDecl (FunctionDef ann name funTy _) = VarDecl ann name $ functionTypeToType funTy -- | Make a 'FunctionDef'. Return 'Nothing' if the provided type is not functional. -mkFunctionDef - :: ann - -> name - -> Type tyname uni ann - -> term ann - -> Maybe (FunctionDef term tyname name uni fun ann) +mkFunctionDef :: + ann -> + name -> + Type tyname uni ann -> + term ann -> + Maybe (FunctionDef term tyname name uni fun ann) mkFunctionDef annName name (TyFun annTy dom cod) term = - Just $ FunctionDef annName name (FunctionType annTy dom cod) term -mkFunctionDef _ _ _ _ = Nothing + Just $ FunctionDef annName name (FunctionType annTy dom cod) term +mkFunctionDef _ _ _ _ = Nothing -- | Make a "let-binding" for a term as an immediately applied lambda abstraction. -mkImmediateLamAbs - :: TermLike term tyname name uni fun - => ann - -> TermDef term tyname name uni ann - -> term ann -- ^ The body of the let, possibly referencing the name. - -> term ann +mkImmediateLamAbs :: + TermLike term tyname name uni fun => + ann -> + TermDef term tyname name uni ann -> + -- | The body of the let, possibly referencing the name. + term ann -> + term ann mkImmediateLamAbs ann1 (Def (VarDecl ann2 name ty) bind) body = - apply ann1 (lamAbs ann2 name ty body) bind + apply ann1 (lamAbs ann2 name ty body) bind -- | Make a "let-binding" for a type as an immediately instantiated type abstraction. Note: the body must be a value. -mkImmediateTyAbs - :: TermLike term tyname name uni fun - => ann - -> TypeDef tyname uni ann - -> term ann -- ^ The body of the let, possibly referencing the name. - -> term ann +mkImmediateTyAbs :: + TermLike term tyname name uni fun => + ann -> + TypeDef tyname uni ann -> + -- | The body of the let, possibly referencing the name. + term ann -> + term ann mkImmediateTyAbs ann1 (Def (TyVarDecl ann2 name k) bind) body = - tyInst ann1 (tyAbs ann2 name k body) bind + tyInst ann1 (tyAbs ann2 name k body) bind -- | Make an iterated application. Each `apply` node uses the annotation associated with -- the corresponding argument. -mkIterApp - :: TermLike term tyname name uni fun - => term ann - -> [(ann, term ann)] - -> term ann +mkIterApp :: + TermLike term tyname name uni fun => + term ann -> + [(ann, term ann)] -> + term ann mkIterApp = foldl' $ \acc (ann, arg) -> apply ann acc arg -- | Make an iterated application with no annotation. -mkIterAppNoAnn - :: TermLike term tyname name uni fun - => term () -- ^ @f@ - -> [term ()] -- ^ @[ x0 ... xn ]@ - -> term () -- ^ @[f x0 ... xn ]@ +mkIterAppNoAnn :: + TermLike term tyname name uni fun => + -- | @f@ + term () -> + -- | @[ x0 ... xn ]@ + [term ()] -> + -- | @[f x0 ... xn ]@ + term () mkIterAppNoAnn term = mkIterApp term . fmap ((),) -- | An infix synonym for `mkIterAppNoAnn` -(@@) :: TermLike term tyname name uni fun - => term () -- ^ @f@ - -> [term ()] -- ^ @[ x0 ... xn ]@ - -> term () -- ^ @[f x0 ... xn ]@ +(@@) :: + TermLike term tyname name uni fun => + -- | @f@ + term () -> + -- | @[ x0 ... xn ]@ + [term ()] -> + -- | @[f x0 ... xn ]@ + term () (@@) = mkIterAppNoAnn -- | Make an iterated instantiation. Each `tyInst` node uses the annotation associated with -- the corresponding argument. -mkIterInst - :: TermLike term tyname name uni fun - => term ann -- ^ @a@ - -> [(ann, Type tyname uni ann)] -- ^ @ [ x0 ... xn ] @ - -> term ann -- ^ @{ a x0 ... xn }@ +mkIterInst :: + TermLike term tyname name uni fun => + -- | @a@ + term ann -> + -- | @ [ x0 ... xn ] @ + [(ann, Type tyname uni ann)] -> + -- | @{ a x0 ... xn }@ + term ann mkIterInst = foldl' $ \acc (ann, arg) -> tyInst ann acc arg -- | Make an iterated instantiation with no annotation. -mkIterInstNoAnn - :: TermLike term tyname name uni fun - => term () -- ^ @a@ - -> [Type tyname uni ()] -- ^ @ [ x0 ... xn ] @ - -> term () -- ^ @{ a x0 ... xn }@ +mkIterInstNoAnn :: + TermLike term tyname name uni fun => + -- | @a@ + term () -> + -- | @ [ x0 ... xn ] @ + [Type tyname uni ()] -> + -- | @{ a x0 ... xn }@ + term () mkIterInstNoAnn term = mkIterInst term . fmap ((),) -- | Lambda abstract a list of names. -mkIterLamAbs - :: TermLike term tyname name uni fun - => [VarDecl tyname name uni ann] - -> term ann - -> term ann +mkIterLamAbs :: + TermLike term tyname name uni fun => + [VarDecl tyname name uni ann] -> + term ann -> + term ann mkIterLamAbs args body = - foldr (\(VarDecl ann name ty) acc -> lamAbs ann name ty acc) body args + foldr (\(VarDecl ann name ty) acc -> lamAbs ann name ty acc) body args -- | Type abstract a list of names. -mkIterTyAbs - :: TermLike term tyname name uni fun - => [TyVarDecl tyname ann] - -> term ann - -> term ann +mkIterTyAbs :: + TermLike term tyname name uni fun => + [TyVarDecl tyname ann] -> + term ann -> + term ann mkIterTyAbs args body = - foldr (\(TyVarDecl ann name kind) acc -> tyAbs ann name kind acc) body args + foldr (\(TyVarDecl ann name kind) acc -> tyAbs ann name kind acc) body args -- | Make an iterated type application. Each `TyApp` node uses the annotation associated with -- the corresponding argument. -mkIterTyApp - :: Type tyname uni ann -- ^ @f@ - -> [(ann, Type tyname uni ann)] -- ^ @[ x0 ... xn ]@ - -> Type tyname uni ann -- ^ @[ f x0 ... xn ]@ +mkIterTyApp :: + -- | @f@ + Type tyname uni ann -> + -- | @[ x0 ... xn ]@ + [(ann, Type tyname uni ann)] -> + -- | @[ f x0 ... xn ]@ + Type tyname uni ann mkIterTyApp = foldl' $ \acc (ann, arg) -> TyApp ann acc arg -- | Make an iterated type application with no annotation. -mkIterTyAppNoAnn - :: Type tyname uni () -- ^ @f@ - -> [Type tyname uni ()] -- ^ @[ x0 ... xn ]@ - -> Type tyname uni () -- ^ @[ f x0 ... xn ]@ +mkIterTyAppNoAnn :: + -- | @f@ + Type tyname uni () -> + -- | @[ x0 ... xn ]@ + [Type tyname uni ()] -> + -- | @[ f x0 ... xn ]@ + Type tyname uni () mkIterTyAppNoAnn ty = mkIterTyApp ty . fmap ((),) -- | Make an iterated function type. -mkIterTyFun - :: ann - -> [Type tyname uni ann] - -> Type tyname uni ann - -> Type tyname uni ann +mkIterTyFun :: + ann -> + [Type tyname uni ann] -> + Type tyname uni ann -> + Type tyname uni ann mkIterTyFun ann tys target = foldr (\ty acc -> TyFun ann ty acc) target tys -- | Universally quantify a list of names. -mkIterTyForall - :: [TyVarDecl tyname ann] - -> Type tyname uni ann - -> Type tyname uni ann +mkIterTyForall :: + [TyVarDecl tyname ann] -> + Type tyname uni ann -> + Type tyname uni ann mkIterTyForall args body = - foldr (\(TyVarDecl ann name kind) acc -> TyForall ann name kind acc) body args + foldr (\(TyVarDecl ann name kind) acc -> TyForall ann name kind acc) body args -- | Lambda abstract a list of names. -mkIterTyLam - :: [TyVarDecl tyname ann] - -> Type tyname uni ann - -> Type tyname uni ann +mkIterTyLam :: + [TyVarDecl tyname ann] -> + Type tyname uni ann -> + Type tyname uni ann mkIterTyLam args body = - foldr (\(TyVarDecl ann name kind) acc -> TyLam ann name kind acc) body args + foldr (\(TyVarDecl ann name kind) acc -> TyLam ann name kind acc) body args -- | Make an iterated function kind. -mkIterKindArrow - :: ann - -> [Kind ann] - -> Kind ann - -> Kind ann +mkIterKindArrow :: + ann -> + [Kind ann] -> + Kind ann -> + Kind ann mkIterKindArrow ann kinds target = foldr (KindArrow ann) target kinds -{- | A helper to create a single, fresh strict binding; It returns the fresh bound `Var`iable and -a function `Term -> Term`, expecting an "in-Term" to form a let-expression. --} -mkFreshTermLet :: (MonadQuote m, TermLike t tyname Name uni fun, Monoid a) - => Type tyname uni a -- ^ the type of binding - -> t a -- ^ the term bound to the fresh variable - -> m (t a, t a -> t a) -- ^ the fresh Var and a function that takes an "in" term to construct the Let +-- | A helper to create a single, fresh strict binding; It returns the fresh bound `Var`iable and +-- a function `Term -> Term`, expecting an "in-Term" to form a let-expression. +mkFreshTermLet :: + (MonadQuote m, TermLike t tyname Name uni fun, Monoid a) => + -- | the type of binding + Type tyname uni a -> + -- | the term bound to the fresh variable + t a -> + -- | the fresh Var and a function that takes an "in" term to construct the Let + m (t a, t a -> t a) mkFreshTermLet aT a = do - -- I wish this was less constrained to Name - genName <- freshName "generated" - pure (var mempty genName, termLet mempty (Def (VarDecl mempty genName aT) a)) + -- I wish this was less constrained to Name + genName <- freshName "generated" + pure (var mempty genName, termLet mempty (Def (VarDecl mempty genName aT) a)) -- | 'apply' the head of the application to the arguments iteratively. headSpineToTerm :: TermLike term tyname name uni fun => ann -> MonoHeadSpine (term ann) -> term ann -headSpineToTerm _ (HeadOnly t) = t +headSpineToTerm _ (HeadOnly t) = t headSpineToTerm ann (HeadSpine t ts) = foldl (apply ann) t ts -- | @headSpineToTerm@ but without annotation. headSpineToTermNoAnn :: TermLike term tyname name uni fun => MonoHeadSpine (term ()) -> term () -headSpineToTermNoAnn (HeadOnly t) = t +headSpineToTermNoAnn (HeadOnly t) = t headSpineToTermNoAnn (HeadSpine t ts) = foldl (apply ()) t ts diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs index 8eac09b1e8d..98c636e9fb7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs @@ -1,25 +1,23 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -{- | A 'Name' is a datatype used to identify a variable inside the Plutus Core languages. - Name comparisons are a fundamental part of the domain logic, and comparing 'Text' directly - is inefficient. As a solution to this problem, we provide the 'Unique' type which is an - integer associated to the 'Name', unique to each instantiation of the type. We can, - therefore, compare the integers instead, which is obviously much more cost-effective. - - We distinguish between the names of term variables and type variables by defining the - 'TyName' wrapper over 'Name'. Since the code we usually write is polymorphic in the - name type, we want to be able to define a class of names which have an associated 'Unique'. - This class is 'HasUnique', see the definition below. --} - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- | A 'Name' is a datatype used to identify a variable inside the Plutus Core languages. +-- Name comparisons are a fundamental part of the domain logic, and comparing 'Text' directly +-- is inefficient. As a solution to this problem, we provide the 'Unique' type which is an +-- integer associated to the 'Name', unique to each instantiation of the type. We can, +-- therefore, compare the integers instead, which is obviously much more cost-effective. +-- +-- We distinguish between the names of term variables and type variables by defining the +-- 'TyName' wrapper over 'Name'. Since the code we usually write is polymorphic in the +-- name type, we want to be able to define a class of names which have an associated 'Unique'. +-- This class is 'HasUnique', see the definition below. module PlutusCore.Name.Unique ( --- * Types + -- * Types Name (..), isIdentifierStartingChar, isIdentifierChar, @@ -40,8 +38,18 @@ module PlutusCore.Name.Unique ( mapTyNameString, ) where -import PlutusPrelude (Coercible, Generic, Lens', NFData, Pretty (pretty), PrettyBy (prettyBy), - Render (render), coerce, on, over) +import PlutusPrelude ( + Coercible, + Generic, + Lens', + NFData, + Pretty (pretty), + PrettyBy (prettyBy), + Render (render), + coerce, + on, + over, + ) import PlutusCore.Pretty.ConfigName (HasPrettyConfigName (..), PrettyConfigName (PrettyConfigName)) @@ -55,7 +63,7 @@ import Language.Haskell.TH.Syntax (Lift) -- | A 'Name' represents variables/names in Plutus Core. data Name = Name - { _nameText :: T.Text + { _nameText :: T.Text -- ^ The identifier name, for use in error messages. , _nameUnique :: Unique -- ^ A 'Unique' assigned to the name, allowing for cheap comparisons in the compiler. @@ -81,17 +89,15 @@ isQuotedIdentifierChar c = isValidUnquotedName :: Text -> Bool isValidUnquotedName n = case T.uncons n of Just (hd, tl) -> isIdentifierStartingChar hd && T.all isIdentifierChar tl - Nothing -> False + Nothing -> False -{- | Quote the name with backticks if it is not a valid unquoted name. -It does not check whether the given name is a valid quoted name. --} +-- | Quote the name with backticks if it is not a valid unquoted name. +-- It does not check whether the given name is a valid quoted name. toPrintedName :: Text -> Text toPrintedName txt = if isValidUnquotedName txt then txt else "`" <> txt <> "`" -{- | We use a @newtype@ to enforce separation between names used for types and -those used for terms. --} +-- | We use a @newtype@ to enforce separation between names used for types and +-- those used for terms. newtype TyName = TyName {unTyName :: Name} deriving stock (Show, Generic, Lift) deriving newtype (Eq, Ord, NFData, Hashable, PrettyBy config) @@ -100,11 +106,11 @@ instance Wrapped TyName data Named a = Named { _namedString :: Text - , _namedValue :: a + , _namedValue :: a } deriving stock (Functor, Foldable, Traversable) -instance (HasPrettyConfigName config) => PrettyBy config Name where +instance HasPrettyConfigName config => PrettyBy config Name where prettyBy config (Name txt (Unique uniq)) | showsUnique = pretty $ toPrintedName txt <> "-" <> render (pretty uniq) | otherwise = pretty $ toPrintedName txt @@ -121,10 +127,9 @@ instance Ord Name where instance Hashable Name where hashWithSalt s = hashWithSalt s . _nameUnique -{-| A unique identifier -This is normally a positive integral number, except -in `LetFloatOut.topUnique` where we make use of a negative unique to signify top-level. --} +-- | A unique identifier +-- This is normally a positive integral number, except +-- in `LetFloatOut.topUnique` where we make use of a negative unique to signify top-level. newtype Unique = Unique {unUnique :: Int} deriving stock (Eq, Show, Ord, Lift) deriving newtype (Enum, NFData, Pretty, Hashable) @@ -164,7 +169,7 @@ instance HasText TyName where theText = coerced . theText @Name -- | Types which have a 'Unique' attached to them, mostly names. -class (Coercible unique Unique) => HasUnique a unique | a -> unique where +class Coercible unique Unique => HasUnique a unique | a -> unique where unique :: Lens' a unique -- | The default implementation of 'HasUnique' for newtypes. @@ -182,5 +187,5 @@ instance HasUnique Name TermUnique where instance HasUnique TyName TypeUnique -- | A lens focused on the 'Unique' of a name. -theUnique :: (HasUnique name unique) => Lens' name Unique +theUnique :: HasUnique name unique => Lens' name Unique theUnique = unique . coerced diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs index 98a76b2036e..36c2fee0e7e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs @@ -1,9 +1,7 @@ -{- | A type for maps (key-value associations), where the key type can be - identified by 'Unique's. In practice, these types are usually names. - This approach is preferred when it is more efficient to compare the associated - 'Unique's instead of the underlying type. --} - +-- | A type for maps (key-value associations), where the key type can be +-- identified by 'Unique's. In practice, these types are usually names. +-- This approach is preferred when it is more efficient to compare the associated +-- 'Unique's instead of the underlying type. module PlutusCore.Name.UniqueMap ( UniqueMap (..), insertByUnique, @@ -29,10 +27,9 @@ import PlutusCore.Name.Unique (HasText (..), HasUnique (..), Named (Named), Uniq import PlutusCore.Name.UniqueSet (UniqueSet (UniqueSet)) import Prelude hiding (foldr) -{- | A mapping from 'Unique's to arbitrary values of type @a@. - Since 'Unique' is equivalent to 'Int' (see "PlutusCore.Name.Unique"), - we can use an 'IntMap' representation for this type. --} +-- | A mapping from 'Unique's to arbitrary values of type @a@. +-- Since 'Unique' is equivalent to 'Int' (see "PlutusCore.Name.Unique"), +-- we can use an 'IntMap' representation for this type. newtype UniqueMap unique a = UniqueMap { unUniqueMap :: IM.IntMap a } @@ -41,7 +38,7 @@ newtype UniqueMap unique a = UniqueMap -- | Insert a value @a@ by a @unique@. insertByUnique :: - (Coercible unique Unique) => + Coercible unique Unique => unique -> a -> UniqueMap unique a -> @@ -49,11 +46,11 @@ insertByUnique :: insertByUnique uniq = coerce . IM.insert (coerce uniq) -- | Insert a value @a@ by the @unique@ of a @name@. -insertByName :: (HasUnique name unique) => name -> a -> UniqueMap unique a -> UniqueMap unique a +insertByName :: HasUnique name unique => name -> a -> UniqueMap unique a -> UniqueMap unique a insertByName = insertByUnique . view unique -- | Create the singleton map of the @unique@ of a @name@ and a value @a@. -singletonByName :: (HasUnique name unique) => name -> a -> UniqueMap unique a +singletonByName :: HasUnique name unique => name -> a -> UniqueMap unique a singletonByName n a = insertByName n a mempty -- | Insert a named value @a@ by the index of the @unique@ of the @name@. @@ -65,10 +62,9 @@ insertNamed :: UniqueMap unique (Named a) insertNamed name = insertByName name . Named (name ^. theText) -{- | Insert a value by the index of the unique of a name. -Unlike 'insertByUnique' and 'insertByName', this function does not provide any static guarantees, -so you can for example insert by a type-level name in a map from term-level uniques. --} +-- | Insert a value by the index of the unique of a name. +-- Unlike 'insertByUnique' and 'insertByName', this function does not provide any static guarantees, +-- so you can for example insert by a type-level name in a map from term-level uniques. insertByNameIndex :: (HasUnique name unique1, Coercible unique2 Unique) => name -> @@ -79,36 +75,35 @@ insertByNameIndex = insertByUnique . coerce . view unique -- | Convert a 'Foldable' into a 'UniqueMap' using the given insertion function. fromFoldable :: - (Foldable f) => + Foldable f => (i -> a -> UniqueMap unique a -> UniqueMap unique a) -> f (i, a) -> UniqueMap unique a fromFoldable ins = List.foldl' (flip $ uncurry ins) mempty -- | Convert a 'Foldable' with uniques into a 'UniqueMap'. -fromUniques :: (Foldable f) => (Coercible Unique unique) => f (unique, a) -> UniqueMap unique a +fromUniques :: Foldable f => Coercible Unique unique => f (unique, a) -> UniqueMap unique a fromUniques = fromFoldable insertByUnique -- | Convert a 'Foldable' with names into a 'UniqueMap'. -fromNames :: (Foldable f) => (HasUnique name unique) => f (name, a) -> UniqueMap unique a +fromNames :: Foldable f => HasUnique name unique => f (name, a) -> UniqueMap unique a fromNames = fromFoldable insertByName -- | Look up a value by a unique. -lookupUnique :: (Coercible unique Unique) => unique -> UniqueMap unique a -> Maybe a +lookupUnique :: Coercible unique Unique => unique -> UniqueMap unique a -> Maybe a lookupUnique uniq = IM.lookup (coerce uniq) . unUniqueMap -- | Look up a value by the unique of a name. -lookupName :: (HasUnique name unique) => name -> UniqueMap unique a -> Maybe a +lookupName :: HasUnique name unique => name -> UniqueMap unique a -> Maybe a lookupName = lookupUnique . view unique restrictKeys :: UniqueMap unique v -> UniqueSet unique -> UniqueMap unique v restrictKeys (UniqueMap m) (UniqueSet s) = UniqueMap $ IM.restrictKeys m s -{- | Look up a value by the index of the unique of a name. -Unlike 'lookupUnique' and 'lookupName', this function does not provide any static guarantees, -so you can for example look up a type-level name in a map from term-level uniques. --} +-- | Look up a value by the index of the unique of a name. +-- Unlike 'lookupUnique' and 'lookupName', this function does not provide any static guarantees, +-- so you can for example look up a type-level name in a map from term-level uniques. lookupNameIndex :: (HasUnique name unique1, Coercible unique2 Unique) => name -> diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs index 5e3de70180d..5ff814e0354 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs @@ -1,8 +1,6 @@ -{- | A type for sets of things identified by 'Unique's, usually names. - This approach is preferred when it is more efficient to compare the associated - 'Unique's instead of the underlying type. --} - +-- | A type for sets of things identified by 'Unique's, usually names. +-- This approach is preferred when it is more efficient to compare the associated +-- 'Unique's instead of the underlying type. module PlutusCore.Name.UniqueSet ( UniqueSet (..), insertByUnique, @@ -28,9 +26,8 @@ import Data.IntSet.Lens qualified as IS import Data.List as List (foldl') import PlutusCore.Name.Unique (HasUnique (..), Unique (Unique)) -{- | A set containing 'Unique's. Since 'Unique' is equivalent to 'Int' - (see "PlutusCore.Name.Unique"), we can use an 'IntSet' representation for this type. --} +-- | A set containing 'Unique's. Since 'Unique' is equivalent to 'Int' +-- (see "PlutusCore.Name.Unique"), we can use an 'IntSet' representation for this type. newtype UniqueSet unique = UniqueSet { unUniqueSet :: IS.IntSet } @@ -39,48 +36,47 @@ newtype UniqueSet unique = UniqueSet -- | Insert a @unique@. insertByUnique :: - (Coercible unique Unique) => + Coercible unique Unique => unique -> UniqueSet unique -> UniqueSet unique insertByUnique = coerce . IS.insert . coerce -- | Insert the @unique@ associated to the @name@. -insertByName :: (HasUnique name unique) => name -> UniqueSet unique -> UniqueSet unique +insertByName :: HasUnique name unique => name -> UniqueSet unique -> UniqueSet unique insertByName = insertByUnique . view unique -- | Create the singleton set of the @unique@ associated to the @name@. -singletonName :: (HasUnique name unique) => name -> UniqueSet unique +singletonName :: HasUnique name unique => name -> UniqueSet unique singletonName n = insertByName n mempty -- | Convert a 'Foldable' into a 'UniqueSet' using the given insertion function. fromFoldable :: - (Foldable f) => + Foldable f => (i -> UniqueSet unique -> UniqueSet unique) -> f i -> UniqueSet unique fromFoldable ins = List.foldl' (flip ins) mempty -- | Convert a 'Foldable' with uniques into a 'UniqueSet'. -fromUniques :: (Foldable f) => (Coercible Unique unique) => f unique -> UniqueSet unique +fromUniques :: Foldable f => Coercible Unique unique => f unique -> UniqueSet unique fromUniques = fromFoldable insertByUnique -- | Convert a 'Foldable' with names into a 'UniqueSet'. -fromNames :: (Foldable f) => (HasUnique name unique) => f name -> UniqueSet unique +fromNames :: Foldable f => HasUnique name unique => f name -> UniqueSet unique fromNames = fromFoldable insertByName -- | Is the @unique@ a member of the set? -memberByUnique :: (Coercible unique Unique) => unique -> UniqueSet unique -> Bool +memberByUnique :: Coercible unique Unique => unique -> UniqueSet unique -> Bool memberByUnique uniq = IS.member (coerce uniq) . unUniqueSet -- | Is the @name@ associated to the @unique@ a member of the set? -memberByName :: (HasUnique name unique) => name -> UniqueSet unique -> Bool +memberByName :: HasUnique name unique => name -> UniqueSet unique -> Bool memberByName = memberByUnique . view unique -{- | The negation of 'memberByName', useful for converting to operator form, - e.g. @name `notMemberByName` set@. --} -notMemberByName :: (HasUnique name unique) => name -> UniqueSet unique -> Bool +-- | The negation of 'memberByName', useful for converting to operator form, +-- e.g. @name `notMemberByName` set@. +notMemberByName :: HasUnique name unique => name -> UniqueSet unique -> Bool notMemberByName n = not . memberByName n -- | The difference of two 'UniqueSet's. @@ -93,7 +89,7 @@ union (UniqueSet s1) (UniqueSet s2) = UniqueSet $ s1 `IS.union` s2 -- | Build a set of @unique@s from the 'Getting'. setOfByUnique :: - (Coercible unique Unique) => + Coercible unique Unique => Getting (UniqueSet unique) s unique -> s -> UniqueSet unique @@ -101,7 +97,7 @@ setOfByUnique g = UniqueSet <$> IS.setOf (coerce g) -- | Build a set of @unique@s associated to the names in the 'Getting'. setOfByName :: - (HasUnique name unique) => + HasUnique name unique => Getting (UniqueSet unique) s name -> s -> UniqueSet unique diff --git a/plutus-core/plutus-core/src/PlutusCore/Normalize.hs b/plutus-core/plutus-core/src/PlutusCore/Normalize.hs index 959fca918de..703cced0d06 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Normalize.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Normalize.hs @@ -1,10 +1,9 @@ -- | The user-facing API of the normalizer. - -module PlutusCore.Normalize - ( normalizeType - , normalizeTypesIn - , normalizeTypesInProgram - ) where +module PlutusCore.Normalize ( + normalizeType, + normalizeTypesIn, + normalizeTypesInProgram, +) where import PlutusCore.Core import PlutusCore.Name.Unique @@ -14,20 +13,21 @@ import PlutusCore.Rename import Control.Monad ((>=>)) -- See Note [Normalization]. + -- | Normalize a 'Type'. -normalizeType - :: (HasUnique tyname TypeUnique, MonadNormalizeType uni m) - => Type tyname uni ann -> m (Normalized (Type tyname uni ann)) +normalizeType :: + (HasUnique tyname TypeUnique, MonadNormalizeType uni m) => + Type tyname uni ann -> m (Normalized (Type tyname uni ann)) normalizeType = rename >=> runNormalizeTypeT . normalizeTypeM -- | Normalize every 'Type' in a 'Term'. -normalizeTypesIn - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadNormalizeType uni m) - => Term tyname name uni fun ann -> m (Term tyname name uni fun ann) +normalizeTypesIn :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadNormalizeType uni m) => + Term tyname name uni fun ann -> m (Term tyname name uni fun ann) normalizeTypesIn = rename >=> runNormalizeTypeT . normalizeTypesInM -- | Normalize every 'Type' in a 'Program'. -normalizeTypesInProgram - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadNormalizeType uni m) - => Program tyname name uni fun ann -> m (Program tyname name uni fun ann) +normalizeTypesInProgram :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadNormalizeType uni m) => + Program tyname name uni fun ann -> m (Program tyname name uni fun ann) normalizeTypesInProgram (Program x v t) = Program x v <$> normalizeTypesIn t diff --git a/plutus-core/plutus-core/src/PlutusCore/Normalize/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/Normalize/Internal.hs index 7e390791ce4..d0ce4289620 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Normalize/Internal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Normalize/Internal.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} -- | The internals of the normalizer. @@ -36,9 +36,8 @@ that the global uniqueness condition is satisfied before calling ANY function fr The invariant is preserved. In future we will enforce the invariant. -} -{- | Mapping from variables to what they stand for (each row represents a substitution). -Needed for efficiency reasons, otherwise we could just use substitutions. --} +-- | Mapping from variables to what they stand for (each row represents a substitution). +-- Needed for efficiency reasons, otherwise we could just use substitutions. type TypeVarEnv tyname uni ann = UniqueMap TypeUnique (Dupable (Normalized (Type tyname uni ann))) -- | The environments that type normalization runs in. @@ -84,6 +83,7 @@ to deal with gas, and could maybe be changed now.) -} -- See Note [NormalizeTypeT]. + -- | The monad transformer that type normalization runs in. newtype NormalizeTypeT m tyname uni ann a = NormalizeTypeT { unNormalizeTypeT :: ReaderT (NormalizeTypeEnv tyname uni ann) m a @@ -172,9 +172,8 @@ Hence we do the opposite, which is straightforward. -- See Note [Normalization of built-in types]. -{- | Normalize a built-in type by replacing each application inside the universe with regular -type application. --} +-- | Normalize a built-in type by replacing each application inside the universe with regular +-- type application. normalizeUni :: forall k (a :: k) uni tyname. HasUniApply uni => uni (Esc a) -> Type tyname uni () normalizeUni uni = matchUniApply @@ -205,7 +204,7 @@ normalizeTypeM (TyApp ann fun arg) = do vArg <- normalizeTypeM arg case unNormalized vFun of TyLam _ nArg _ body -> substNormalizeTypeM vArg nArg body - _ -> pure $ TyApp ann <$> vFun <*> vArg + _ -> pure $ TyApp ann <$> vFun <*> vArg normalizeTypeM var@(TyVar _ name) = do mayTy <- lookupTyNameM name case mayTy of @@ -226,6 +225,7 @@ normalized types. However we do not enforce this in the type signature, because -} -- See Note [Normalizing substitution]. + -- | Substitute a type for a variable in a type and normalize in the 'NormalizeTypeT' monad. substNormalizeTypeM :: (HasUnique tyname TypeUnique, MonadNormalizeType uni m) => diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser.hs b/plutus-core/plutus-core/src/PlutusCore/Parser.hs index d06b42c90f0..039d96aefe1 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser.hs @@ -1,17 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} -- | Parsers for PLC terms in DefaultUni. - -module PlutusCore.Parser - ( module Export - , program - , parseProgram - , parseTerm - , parseType - , SourcePos - , ParserError(..) - ) where +module PlutusCore.Parser ( + module Export, + program, + parseProgram, + parseTerm, + parseType, + SourcePos, + ParserError (..), +) where import PlutusCore.Annotation import PlutusCore.Core (Program (..), Term (..), Type) @@ -38,92 +37,94 @@ type PTerm = Term TyName Name DefaultUni DefaultFun SrcSpan varTerm :: Parser PTerm varTerm = withSpan $ \sp -> - Var sp <$> name + Var sp <$> name tyAbsTerm :: Parser PTerm tyAbsTerm = withSpan $ \sp -> - inParens $ TyAbs sp <$> (symbol "abs" *> trailingWhitespace tyName) <*> kind <*> term + inParens $ TyAbs sp <$> (symbol "abs" *> trailingWhitespace tyName) <*> kind <*> term lamTerm :: Parser PTerm lamTerm = withSpan $ \sp -> - inParens $ LamAbs sp <$> (symbol "lam" *> trailingWhitespace name) <*> pType <*> term + inParens $ LamAbs sp <$> (symbol "lam" *> trailingWhitespace name) <*> pType <*> term appTerm :: Parser PTerm appTerm = withSpan $ \sp -> - -- TODO: should not use the same `sp` for all arguments. - inBrackets $ mkIterApp <$> term <*> (fmap (sp,) <$> some term) + -- TODO: should not use the same `sp` for all arguments. + inBrackets $ mkIterApp <$> term <*> (fmap (sp,) <$> some term) conTerm :: Parser PTerm conTerm = withSpan $ \sp -> - inParens $ Constant sp <$> (symbol "con" *> constant) + inParens $ Constant sp <$> (symbol "con" *> constant) builtinTerm :: Parser PTerm builtinTerm = withSpan $ \sp -> - inParens $ Builtin sp <$> (symbol "builtin" *> builtinFunction) + inParens $ Builtin sp <$> (symbol "builtin" *> builtinFunction) tyInstTerm :: Parser PTerm tyInstTerm = withSpan $ \sp -> - -- TODO: should not use the same `sp` for all arguments. - inBraces $ mkIterInst <$> term <*> (fmap (sp,) <$> many pType) + -- TODO: should not use the same `sp` for all arguments. + inBraces $ mkIterInst <$> term <*> (fmap (sp,) <$> many pType) unwrapTerm :: Parser PTerm unwrapTerm = withSpan $ \sp -> - inParens $ Unwrap sp <$> (symbol "unwrap" *> term) + inParens $ Unwrap sp <$> (symbol "unwrap" *> term) iwrapTerm :: Parser PTerm iwrapTerm = withSpan $ \sp -> - inParens $ IWrap sp <$> (symbol "iwrap" *> pType) <*> pType <*> term + inParens $ IWrap sp <$> (symbol "iwrap" *> pType) <*> pType <*> term errorTerm :: Parser PTerm errorTerm = withSpan $ \sp -> - inParens $ Error sp <$> (symbol "error" *> pType) + inParens $ Error sp <$> (symbol "error" *> pType) constrTerm :: Parser PTerm constrTerm = withSpan $ \sp -> - inParens $ do - let maxTag = fromIntegral (maxBound :: Word64) - ty <- symbol "constr" *> pType - tag :: Integer <- lexeme Lex.decimal - args <- many term - whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0" - when (tag > maxTag) $ fail "constr tag too large: must be a legal Word64 value" - pure $ Constr sp ty (fromIntegral tag) args + inParens $ do + let maxTag = fromIntegral (maxBound :: Word64) + ty <- symbol "constr" *> pType + tag :: Integer <- lexeme Lex.decimal + args <- many term + whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0" + when (tag > maxTag) $ fail "constr tag too large: must be a legal Word64 value" + pure $ Constr sp ty (fromIntegral tag) args caseTerm :: Parser PTerm caseTerm = withSpan $ \sp -> - inParens $ do - res <- Case sp <$> (symbol "case" *> pType) <*> term <*> many term - whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" - pure res + inParens $ do + res <- Case sp <$> (symbol "case" *> pType) <*> term <*> many term + whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" + pure res -- | Parser for all PLC terms. term :: Parser PTerm term = leadingWhitespace go where go = - choice $ map try - [ tyAbsTerm - , lamTerm - , appTerm - , conTerm - , builtinTerm - , tyInstTerm - , unwrapTerm - , iwrapTerm - , errorTerm - , varTerm - , constrTerm - , caseTerm - ] + choice $ + map + try + [ tyAbsTerm + , lamTerm + , appTerm + , conTerm + , builtinTerm + , tyInstTerm + , unwrapTerm + , iwrapTerm + , errorTerm + , varTerm + , constrTerm + , caseTerm + ] -- | Parse a PLC program. The resulting program will have fresh names. The -- underlying monad must be capable of handling any parse errors. This passes -- "test" to the parser as the name of the input stream; to supply a name -- explicity, use `parse program `. parseProgram :: - (MonadError ParserErrorBundle m, MonadQuote m) - => Text - -> m (Program TyName Name DefaultUni DefaultFun SrcSpan) + (MonadError ParserErrorBundle m, MonadQuote m) => + Text -> + m (Program TyName Name DefaultUni DefaultFun SrcSpan) parseProgram = parseGen program -- | Parser for PLC programs. @@ -131,20 +132,22 @@ program :: Parser (Program TyName Name DefaultUni DefaultFun SrcSpan) program = leadingWhitespace go where go = do - prog <- withSpan $ \sp -> inParens $ do - v <- symbol "program" *> version - withVersion v $ Program sp v <$> term - notFollowedBy anySingle - pure prog + prog <- withSpan $ \sp -> inParens $ do + v <- symbol "program" *> version + withVersion v $ Program sp v <$> term + notFollowedBy anySingle + pure prog -- | Parse a PLC term. The resulting program will have fresh names. The underlying monad -- must be capable of handling any parse errors. -parseTerm :: (MonadError ParserErrorBundle m, MonadQuote m) => - Text -> m (Term TyName Name DefaultUni DefaultFun SrcSpan) +parseTerm :: + (MonadError ParserErrorBundle m, MonadQuote m) => + Text -> m (Term TyName Name DefaultUni DefaultFun SrcSpan) parseTerm = parseGen term -- | Parse a PLC type. The resulting program will have fresh names. The underlying monad -- must be capable of handling any parse errors. -parseType :: (MonadError ParserErrorBundle m, MonadQuote m) => - Text -> m (Type TyName DefaultUni SrcSpan) +parseType :: + (MonadError ParserErrorBundle m, MonadQuote m) => + Text -> m (Type TyName DefaultUni SrcSpan) parseType = parseGen pType diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs index 0cffcc5864e..6a243a5742b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module PlutusCore.Parser.Builtin where @@ -58,13 +58,12 @@ hexByte = do conBS :: Parser ByteString conBS = lexeme . fmap pack $ char '#' *> many hexByte -{- | Parser for string constants (wrapped in double quotes). Note that - Data.Text.pack "performs replacement on invalid scalar values", which means - that Unicode surrogate code points (corresponding to integers in the range - 0xD800-0xDFFF) are converted to the Unicode replacement character U+FFFD - (decimal 65533). Thus `(con string "X\xD800Z")` parses to a `Text` object - whose second character is U+FFFD. --} +-- | Parser for string constants (wrapped in double quotes). Note that +-- Data.Text.pack "performs replacement on invalid scalar values", which means +-- that Unicode surrogate code points (corresponding to integers in the range +-- 0xD800-0xDFFF) are converted to the Unicode replacement character U+FFFD +-- (decimal 65533). Thus `(con string "X\xD800Z")` parses to a `Text` object +-- whose second character is U+FFFD. conText :: Parser T.Text conText = lexeme . fmap T.pack $ char '\"' *> manyTill Lex.charLiteral (char '\"') @@ -82,8 +81,9 @@ conBool = -- | Parser for lists. conList :: DefaultUni (Esc a) -> Parser [a] -conList uniA = trailingWhitespace . inBrackets $ - constantOf ExpectParensNo uniA `sepBy` symbol "," +conList uniA = + trailingWhitespace . inBrackets $ + constantOf ExpectParensNo uniA `sepBy` symbol "," -- | Parser for arrays. conArray :: DefaultUni (Esc a) -> Parser (Vector a) @@ -98,18 +98,27 @@ conValue = do PlutusCore.Builtin.Result.BuiltinSuccessWithLogs _logs v -> pure v PlutusCore.Builtin.Result.BuiltinFailure logs _trace -> fail $ "Failed to construct Value: " <> show logs - where - validateToken (token, amt) = do - tk <- maybe (fail $ "Token name exceeds maximum length of 32 bytes: " <> show (unpack token)) - pure (Value.k token) - qty <- maybe (fail $ "Token quantity out of signed 128-bit integer bounds: " <> show amt) - pure (Value.quantity amt) - pure (tk, qty) - validateKeys (currency, tokens) = do - ck <- maybe (fail $ "Currency symbol exceeds maximum length of 32 bytes: " <> show (unpack currency)) - pure (Value.k currency) - tks <- traverse validateToken tokens - pure (ck, tks) + where + validateToken (token, amt) = do + tk <- + maybe + (fail $ "Token name exceeds maximum length of 32 bytes: " <> show (unpack token)) + pure + (Value.k token) + qty <- + maybe + (fail $ "Token quantity out of signed 128-bit integer bounds: " <> show amt) + pure + (Value.quantity amt) + pure (tk, qty) + validateKeys (currency, tokens) = do + ck <- + maybe + (fail $ "Currency symbol exceeds maximum length of 32 bytes: " <> show (unpack currency)) + pure + (Value.k currency) + tks <- traverse validateToken tokens + pure (ck, tks) -- | Parser for pairs. conPair :: DefaultUni (Esc a) -> DefaultUni (Esc b) -> Parser (a, b) @@ -121,17 +130,17 @@ conPair uniA uniB = trailingWhitespace . inParens $ do conDataNoParens :: Parser Data conDataNoParens = - choice - [ symbol "Constr" *> (Constr <$> conInteger <*> conList knownUni) - , symbol "Map" *> (Map <$> conList knownUni) - , symbol "List" *> (List <$> conList knownUni) - , symbol "I" *> (I <$> conInteger) - , symbol "B" *> (B <$> conBS) - ] + choice + [ symbol "Constr" *> (Constr <$> conInteger <*> conList knownUni) + , symbol "Map" *> (Map <$> conList knownUni) + , symbol "List" *> (List <$> conList knownUni) + , symbol "I" *> (I <$> conInteger) + , symbol "B" *> (B <$> conBS) + ] conData :: ExpectParens -> Parser Data conData ExpectParensYes = trailingWhitespace $ inParens conDataNoParens -conData ExpectParensNo = conDataNoParens +conData ExpectParensNo = conDataNoParens -- Serialised BLS12_381 elements are "0x" followed by a hex string of even -- length. Maybe we should just use the usual bytestring syntax. @@ -140,37 +149,37 @@ con0xBS = lexeme . fmap pack $ string "0x" *> many hexByte conBLS12_381_G1_Element :: Parser BLS12_381.G1.Element conBLS12_381_G1_Element = do - s <- con0xBS - case BLS12_381.G1.uncompress s of - Left err -> fail $ "Failed to decode value of type bls12_381_G1_element: " ++ show err - Right e -> pure e + s <- con0xBS + case BLS12_381.G1.uncompress s of + Left err -> fail $ "Failed to decode value of type bls12_381_G1_element: " ++ show err + Right e -> pure e conBLS12_381_G2_Element :: Parser BLS12_381.G2.Element conBLS12_381_G2_Element = do - s <- con0xBS - case BLS12_381.G2.uncompress s of - Left err -> fail $ "Failed to decode value of type bls12_381_G2_element: " ++ show err - Right e -> pure e + s <- con0xBS + case BLS12_381.G2.uncompress s of + Left err -> fail $ "Failed to decode value of type bls12_381_G2_element: " ++ show err + Right e -> pure e -- | Parser for constants of the given type. constantOf :: ExpectParens -> DefaultUni (Esc a) -> Parser a constantOf expectParens uni = case uni of - DefaultUniInteger -> conInteger - DefaultUniByteString -> conBS - DefaultUniString -> conText - DefaultUniUnit -> conUnit - DefaultUniBool -> conBool - DefaultUniValue -> conValue - DefaultUniProtoList `DefaultUniApply` uniA -> conList uniA - DefaultUniProtoArray `DefaultUniApply` uniA -> conArray uniA + DefaultUniInteger -> conInteger + DefaultUniByteString -> conBS + DefaultUniString -> conText + DefaultUniUnit -> conUnit + DefaultUniBool -> conBool + DefaultUniValue -> conValue + DefaultUniProtoList `DefaultUniApply` uniA -> conList uniA + DefaultUniProtoArray `DefaultUniApply` uniA -> conArray uniA DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB -> conPair uniA uniB - f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _ -> noMoreTypeFunctions f - DefaultUniData -> conData expectParens - DefaultUniBLS12_381_G1_Element -> conBLS12_381_G1_Element - DefaultUniBLS12_381_G2_Element -> conBLS12_381_G2_Element - DefaultUniBLS12_381_MlResult - -> fail "Constants of type bls12_381_mlresult are not supported" + f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _ -> noMoreTypeFunctions f + DefaultUniData -> conData expectParens + DefaultUniBLS12_381_G1_Element -> conBLS12_381_G1_Element + DefaultUniBLS12_381_G2_Element -> conBLS12_381_G2_Element + DefaultUniBLS12_381_MlResult -> + fail "Constants of type bls12_381_mlresult are not supported" -- | Parser of constants whose type is in 'DefaultUni'. constant :: Parser (Some (ValueOf DefaultUni)) diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs index e94d1a0f6ed..7af5f2a810d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Common functions for parsers of UPLC, PLC, and PIR. @@ -23,8 +23,13 @@ import Control.Monad.State.Class (MonadState, get, put) import PlutusCore.Annotation import PlutusCore.Core.Type import PlutusCore.Error -import PlutusCore.Name.Unique (Name (..), Unique (..), isIdentifierChar, isIdentifierStartingChar, - isQuotedIdentifierChar) +import PlutusCore.Name.Unique ( + Name (..), + Unique (..), + isIdentifierChar, + isIdentifierStartingChar, + isQuotedIdentifierChar, + ) import PlutusCore.Quote {- Note [Whitespace invariant] @@ -52,30 +57,29 @@ getVersion = ask withVersion :: Version -> Parser a -> Parser a withVersion v = local (const $ Just v) -{- | Run an action conditionally based on a predicate on the version. -If we don't know the version then the predicate is assumed to be -false, i.e. we act if we _know_ the predicate is satisfied. --} +-- | Run an action conditionally based on a predicate on the version. +-- If we don't know the version then the predicate is assumed to be +-- false, i.e. we act if we _know_ the predicate is satisfied. whenVersion :: (Version -> Bool) -> Parser () -> Parser () whenVersion p act = do mv <- getVersion case mv of Nothing -> pure () - Just v -> when (p v) act - -parse - :: (MonadError ParserErrorBundle m, MonadQuote m) - => Parser a - -> String - -> Text - -> m a + Just v -> when (p v) act + +parse :: + (MonadError ParserErrorBundle m, MonadQuote m) => + Parser a -> + String -> + Text -> + m a parse p file str = do let res = fmap toErrorB (runReaderT (evalStateT (runParserT p file str) initial) Nothing) liftEither =<< liftQuote res toErrorB :: Either (ParseErrorBundle Text ParserError) a -> Either ParserErrorBundle a toErrorB (Left err) = Left $ ParseErrorB err -toErrorB (Right a) = Right a +toErrorB (Right a) = Right a -- | Generic parser function in which the file path is just "test". parseGen :: (MonadError ParserErrorBundle m, MonadQuote m) => Parser a -> Text -> m a @@ -94,7 +98,7 @@ trailingWhitespace = (<* whitespace) -- This is samething from @Text.Megaparsec.Stream@. reachOffsetNoLine' :: forall s. - (Stream s) => + Stream s => -- | How to split input stream at given offset (Int -> s -> (Tokens s, s)) -> -- | How to fold over input stream @@ -117,11 +121,11 @@ reachOffsetNoLine' o PosState {..} = ( PosState - { pstateInput = post, - pstateOffset = max pstateOffset o, - pstateSourcePos = spos, - pstateTabWidth = pstateTabWidth, - pstateLinePrefix = pstateLinePrefix + { pstateInput = post + , pstateOffset = max pstateOffset o + , pstateSourcePos = spos + , pstateTabWidth = pstateTabWidth + , pstateLinePrefix = pstateLinePrefix } ) where @@ -154,13 +158,12 @@ getSourcePos' = do 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@. - -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. --} +-- | 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' @@ -169,10 +172,9 @@ withSpan' f = mdo let sp = toSrcSpan start end pure res -{- | Like `withSpan'`, but the result parser consumes whitespaces. - -@withSpan = (<* whitespace) . withSpan'@ --} +-- | Like `withSpan'`, but the result parser consumes whitespaces. +-- +-- @withSpan = (<* whitespace) . withSpan'@ withSpan :: (SrcSpan -> Parser a) -> Parser a withSpan = (<* whitespace) . withSpan' diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/Type.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/Type.hs index 340aad56468..9ef325a73fe 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/Type.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/Type.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module PlutusCore.Parser.Type where @@ -32,28 +32,28 @@ type PType = Type TyName DefaultUni SrcSpan varType :: Parser PType varType = withSpan $ \sp -> - TyVar sp <$> tyName + TyVar sp <$> tyName funType :: Parser PType funType = withSpan $ \sp -> - inParens $ TyFun sp <$> (symbol "fun" *> pType) <*> pType + inParens $ TyFun sp <$> (symbol "fun" *> pType) <*> pType allType :: Parser PType allType = withSpan $ \sp -> - inParens $ TyForall sp <$> (symbol "all" *> trailingWhitespace tyName) <*> kind <*> pType + inParens $ TyForall sp <$> (symbol "all" *> trailingWhitespace tyName) <*> kind <*> pType lamType :: Parser PType lamType = withSpan $ \sp -> - inParens $ TyLam sp <$> (symbol "lam" *> trailingWhitespace tyName) <*> kind <*> pType + inParens $ TyLam sp <$> (symbol "lam" *> trailingWhitespace tyName) <*> kind <*> pType ifixType :: Parser PType ifixType = withSpan $ \sp -> - inParens $ TyIFix sp <$> (symbol "ifix" *> pType) <*> pType + inParens $ TyIFix sp <$> (symbol "ifix" *> pType) <*> pType builtinType :: Parser PType builtinType = withSpan $ \sp -> inParens $ do - SomeTypeIn (Kinded uni) <- symbol "con" *> defaultUni - pure $ TyBuiltin sp (SomeTypeIn uni) + SomeTypeIn (Kinded uni) <- symbol "con" *> defaultUni + pure $ TyBuiltin sp (SomeTypeIn uni) sopType :: Parser PType sopType = withSpan $ \sp -> inParens $ TySOP sp <$> (symbol "sop" *> many tyList) @@ -63,41 +63,44 @@ sopType = withSpan $ \sp -> inParens $ TySOP sp <$> (symbol "sop" *> many tyList appType :: Parser PType appType = withSpan $ \sp -> inBrackets $ do - fn <- pType - args <- some pType - -- TODO: should not use the same `sp` for all arguments. - pure $ mkIterTyApp fn ((sp,) <$> args) + fn <- pType + args <- some pType + -- TODO: should not use the same `sp` for all arguments. + pure $ mkIterTyApp fn ((sp,) <$> args) kind :: Parser (Kind SrcSpan) kind = withSpan $ \sp -> - let typeKind = Type sp <$ symbol "type" - funKind = KindArrow sp <$> (symbol "fun" *> kind) <*> kind - in inParens (typeKind <|> funKind) + let typeKind = Type sp <$ symbol "type" + funKind = KindArrow sp <$> (symbol "fun" *> kind) <*> kind + in inParens (typeKind <|> funKind) -- | Parser for @PType@. pType :: Parser PType -pType = choice $ map try - [ funType - , ifixType - , allType - , builtinType - , lamType - , appType - , varType - , sopType - ] +pType = + choice $ + map + try + [ funType + , ifixType + , allType + , builtinType + , lamType + , appType + , varType + , sopType + ] -- | Parser for built-in type applications. The textual names here should match -- the ones in the PrettyBy instance for DefaultUni in PlutusCore.Default.Universe. defaultUniApplication :: Parser (SomeTypeIn (Kinded DefaultUni)) defaultUniApplication = do - -- Parse the head of the application. - f <- defaultUni - -- Parse the arguments. - as <- many defaultUni - -- Iteratively apply the head to the arguments checking that the kinds match and - -- failing otherwise. - foldM tryUniApply f as + -- Parse the head of the application. + f <- defaultUni + -- Parse the arguments. + as <- many defaultUni + -- Iteratively apply the head to the arguments checking that the kinds match and + -- failing otherwise. + foldM tryUniApply f as -- | Parser for built-in types (the ones from 'DefaultUni' specifically). -- @@ -132,22 +135,25 @@ defaultUniApplication = do -- to do the kind checking of builtins regardless (even for UPLC), we don't win much by deferring -- doing it. defaultUni :: Parser (SomeTypeIn (Kinded DefaultUni)) -defaultUni = choice $ map try - [ trailingWhitespace (inParens defaultUniApplication) - , someType @_ @Integer <$ symbol "integer" - , someType @_ @ByteString <$ symbol "bytestring" - , someType @_ @Text <$ symbol "string" - , someType @_ @() <$ symbol "unit" - , someType @_ @Bool <$ symbol "bool" - , someType @_ @[] <$ symbol "list" - , someType @_ @Strict.Vector <$ symbol "array" - , someType @_ @(,) <$ symbol "pair" - , someType @_ @Data <$ symbol "data" - , someType @_ @BLS12_381.G1.Element <$ symbol "bls12_381_G1_element" - , someType @_ @BLS12_381.G2.Element <$ symbol "bls12_381_G2_element" - , someType @_ @BLS12_381.Pairing.MlResult <$ symbol "bls12_381_mlresult" - , someType @_ @Value <$ symbol "value" - ] +defaultUni = + choice $ + map + try + [ trailingWhitespace (inParens defaultUniApplication) + , someType @_ @Integer <$ symbol "integer" + , someType @_ @ByteString <$ symbol "bytestring" + , someType @_ @Text <$ symbol "string" + , someType @_ @() <$ symbol "unit" + , someType @_ @Bool <$ symbol "bool" + , someType @_ @[] <$ symbol "list" + , someType @_ @Strict.Vector <$ symbol "array" + , someType @_ @(,) <$ symbol "pair" + , someType @_ @Data <$ symbol "data" + , someType @_ @BLS12_381.G1.Element <$ symbol "bls12_381_G1_element" + , someType @_ @BLS12_381.G2.Element <$ symbol "bls12_381_G2_element" + , someType @_ @BLS12_381.Pairing.MlResult <$ symbol "bls12_381_mlresult" + , someType @_ @Value <$ symbol "value" + ] tyName :: Parser TyName tyName = TyName <$> name diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty.hs index f0bab62379a..e2e2669d4b4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty.hs @@ -1,85 +1,91 @@ -module PlutusCore.Pretty - ( - -- * Basic types and functions - Doc - , Pretty (..) - , PrettyBy (..) - , IgnorePrettyConfig (..) - , AttachPrettyConfig (..) - , Render (..) - , PrettyParens - , display - , displayBy - , juxtRenderContext - -- * Defaults - , prettyPlc - , displayPlc - , prettyPlcSimple - , displayPlcSimple - -- * Global configuration - , CondensedErrors (..) - , DefaultPrettyPlcStrategy - , PrettyConfigPlcOptions (..) - , PrettyConfigPlcStrategy (..) - , PrettyConfigPlc (..) - , PrettyPlc - , prettyConfigPlcOptions - , prettyConfigPlcClassic - , prettyConfigPlcClassicSimple - , prettyConfigPlcReadable - , prettyConfigPlcReadableSimple - -- * Custom functions for PLC types. - , prettyPlcClassic - , prettyPlcClassicSimple - , prettyPlcReadable - , prettyPlcReadableSimple - , prettyPlcCondensedErrorBy - , displayPlcCondensedErrorClassic - -- * Names - , PrettyConfigName (..) - , HasPrettyConfigName (..) - , prettyConfigName - , prettyConfigNameSimple - -- * Classic view - , PrettyConfigClassic (..) - , PrettyClassicBy - , PrettyClassic - , consAnnIf - , prettyClassic - , prettyClassicSimple - -- * Readable view - , ShowKinds (..) - , PrettyConfigReadable (..) - , prettyReadable - , prettyReadableSimple - , pcrConfigName - , pcrRenderContext - , pcrShowKinds - , PrettyReadableBy - , PrettyReadable - , AsReadable (..) - , Parened (..) - , inBraces - , topPrettyConfigReadable - , botPrettyConfigReadable - , binderFixity - , arrowFixity - , iterTyForallPrettyM - , iterLamAbsPrettyM - , iterTyAbsPrettyM - , iterArrowPrettyM - , iterAppDocM - , iterInterAppPrettyM - , iterAppPrettyM - -- * Utils - , prettyBytes - , ConstConfig (..) - , PrettyConst - , PrettyUni - , ThrowableBuiltins - , prettyConst - , module Export - ) where +module PlutusCore.Pretty ( + -- * Basic types and functions + Doc, + Pretty (..), + PrettyBy (..), + IgnorePrettyConfig (..), + AttachPrettyConfig (..), + Render (..), + PrettyParens, + display, + displayBy, + juxtRenderContext, + + -- * Defaults + prettyPlc, + displayPlc, + prettyPlcSimple, + displayPlcSimple, + + -- * Global configuration + CondensedErrors (..), + DefaultPrettyPlcStrategy, + PrettyConfigPlcOptions (..), + PrettyConfigPlcStrategy (..), + PrettyConfigPlc (..), + PrettyPlc, + prettyConfigPlcOptions, + prettyConfigPlcClassic, + prettyConfigPlcClassicSimple, + prettyConfigPlcReadable, + prettyConfigPlcReadableSimple, + + -- * Custom functions for PLC types. + prettyPlcClassic, + prettyPlcClassicSimple, + prettyPlcReadable, + prettyPlcReadableSimple, + prettyPlcCondensedErrorBy, + displayPlcCondensedErrorClassic, + + -- * Names + PrettyConfigName (..), + HasPrettyConfigName (..), + prettyConfigName, + prettyConfigNameSimple, + + -- * Classic view + PrettyConfigClassic (..), + PrettyClassicBy, + PrettyClassic, + consAnnIf, + prettyClassic, + prettyClassicSimple, + + -- * Readable view + ShowKinds (..), + PrettyConfigReadable (..), + prettyReadable, + prettyReadableSimple, + pcrConfigName, + pcrRenderContext, + pcrShowKinds, + PrettyReadableBy, + PrettyReadable, + AsReadable (..), + Parened (..), + inBraces, + topPrettyConfigReadable, + botPrettyConfigReadable, + binderFixity, + arrowFixity, + iterTyForallPrettyM, + iterLamAbsPrettyM, + iterTyAbsPrettyM, + iterArrowPrettyM, + iterAppDocM, + iterInterAppPrettyM, + iterAppPrettyM, + + -- * Utils + prettyBytes, + ConstConfig (..), + PrettyConst, + PrettyUni, + ThrowableBuiltins, + prettyConst, + module Export, +) where import PlutusCore.Pretty.Classic import PlutusCore.Pretty.ConfigName diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs index 98f97a24df7..81da1204850 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs @@ -1,22 +1,21 @@ --- | A "classic" (i.e. as seen in the specification) way to pretty-print PLC entities. - {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.Pretty.Classic - ( PrettyConfigClassic (..) - , PrettyClassicBy - , PrettyClassic - , PrettyParens - , juxtRenderContext - , consAnnIf - , prettyConfigClassic - , prettyConfigClassicSimple - , prettyClassic - , prettyClassicSimple - ) where +-- | A "classic" (i.e. as seen in the specification) way to pretty-print PLC entities. +module PlutusCore.Pretty.Classic ( + PrettyConfigClassic (..), + PrettyClassicBy, + PrettyClassic, + PrettyParens, + juxtRenderContext, + consAnnIf, + prettyConfigClassic, + prettyConfigClassicSimple, + prettyClassic, + prettyClassicSimple, +) where import PlutusPrelude @@ -27,10 +26,12 @@ import Prettyprinter.Internal (Doc (Empty)) -- | Configuration for the classic pretty-printing. data PrettyConfigClassic configName = PrettyConfigClassic - { _pccConfigName :: configName -- ^ How to pretty-print names. - , _pccDisplayAnn :: Bool -- ^ Whether to display annotations. - } - deriving stock (Show) + { _pccConfigName :: configName + -- ^ How to pretty-print names. + , _pccDisplayAnn :: Bool + -- ^ Whether to display annotations. + } + deriving stock (Show) type instance HasPrettyDefaults (PrettyConfigClassic _) = 'True @@ -40,11 +41,11 @@ type PrettyClassicBy configName = PrettyBy (PrettyConfigClassic configName) type PrettyClassic = PrettyClassicBy PrettyConfigName instance configName ~ PrettyConfigName => HasPrettyConfigName (PrettyConfigClassic configName) where - toPrettyConfigName = _pccConfigName + toPrettyConfigName = _pccConfigName isEmptyDoc :: Doc ann -> Bool isEmptyDoc Empty = True -isEmptyDoc _ = False +isEmptyDoc _ = False -- | Add a pretty-printed annotation to a list of 'Doc's if the given config enables pretty-printing -- of annotations. diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs index 7d248459d18..d585f1c551d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} -module PlutusCore.Pretty.ConfigName - ( PrettyConfigName (..) - , HasPrettyConfigName (..) - , prettyConfigName - , prettyConfigNameSimple - ) where +module PlutusCore.Pretty.ConfigName ( + PrettyConfigName (..), + HasPrettyConfigName (..), + prettyConfigName, + prettyConfigNameSimple, +) where import Data.Coerce (coerce) import Text.PrettyBy (HasPrettyDefaults) @@ -31,9 +31,8 @@ instance HasPrettyConfigName (Sole PrettyConfigName) where -- | The 'PrettyConfigName' used by default: print 'Unique' indexes after nams. prettyConfigName :: PrettyConfigName -prettyConfigName = PrettyConfigName{_pcnShowsUnique = True} +prettyConfigName = PrettyConfigName {_pcnShowsUnique = True} -- | The 'PrettyConfigName' to be used when 'Unique' indices don't matter. Easier to read. prettyConfigNameSimple :: PrettyConfigName -prettyConfigNameSimple = PrettyConfigName{_pcnShowsUnique = False} - +prettyConfigNameSimple = PrettyConfigName {_pcnShowsUnique = False} diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs index f4fc8eee15c..7d772e9f33b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs @@ -1,10 +1,10 @@ -module PlutusCore.Pretty.Default - ( prettyPlc - , displayPlc - , prettyPlcSimple - , displayPlcSimple - , displayPlcCondensedErrorClassic - ) where +module PlutusCore.Pretty.Default ( + prettyPlc, + displayPlc, + prettyPlcSimple, + displayPlcSimple, + displayPlcCondensedErrorClassic, +) where import PlutusPrelude @@ -29,4 +29,4 @@ displayPlcSimple = render . prettyPlcClassicSimple -- | Render an error to 'String' in the condensed manner using the classic view. displayPlcCondensedErrorClassic :: (PrettyPlc a, Render str) => a -> str displayPlcCondensedErrorClassic = - render . prettyPlcCondensedErrorBy prettyConfigPlcClassic + render . prettyPlcCondensedErrorBy prettyConfigPlcClassic diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Extra.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Extra.hs index cb502923aa9..e4641dceceb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Extra.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Extra.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Pretty-printing stuff, some of which should probably go into the main library. -module PlutusCore.Pretty.Extra - ( PrettyParens - , juxtRenderContext - ) where +module PlutusCore.Pretty.Extra ( + PrettyParens, + juxtRenderContext, +) where import PlutusPrelude @@ -28,21 +27,21 @@ import Text.PrettyBy.Internal type instance HasPrettyDefaults (Sole config) = HasPrettyDefaults config instance Profunctor InContextM where - lmap - :: forall config' config a. - (config' -> config) - -> InContextM config a - -> InContextM config' a - lmap = coerce (withReader :: (config' -> config) -> Reader config a -> Reader config' a) - {-# INLINE lmap #-} + lmap :: + forall config' config a. + (config' -> config) -> + InContextM config a -> + InContextM config' a + lmap = coerce (withReader :: (config' -> config) -> Reader config a -> Reader config' a) + {-# INLINE lmap #-} - rmap - :: forall config a b. - (a -> b) - -> InContextM config a - -> InContextM config b - rmap = coerce (mapReader :: (a -> b) -> Reader config a -> Reader config b) - {-# INLINE rmap #-} + rmap :: + forall config a b. + (a -> b) -> + InContextM config a -> + InContextM config b + rmap = coerce (mapReader :: (a -> b) -> Reader config a -> Reader config b) + {-# INLINE rmap #-} -- | For pretty-printing a value with a minimum amount of parens. type PrettyParens = PrettyBy RenderContext @@ -54,16 +53,22 @@ juxtRenderContext :: RenderContext juxtRenderContext = RenderContext ToTheRight juxtFixity instance PrettyDefaultBy config [(k, v)] => DefaultPrettyBy config (Map k v) where - defaultPrettyBy config = prettyBy config . Map.toList -deriving via PrettyCommon (Map k v) - instance PrettyDefaultBy config (Map k v) => PrettyBy config (Map k v) + defaultPrettyBy config = prettyBy config . Map.toList +deriving via + PrettyCommon (Map k v) + instance + PrettyDefaultBy config (Map k v) => PrettyBy config (Map k v) instance PrettyDefaultBy config [a] => DefaultPrettyBy config (Set a) where - defaultPrettyBy config = prettyBy config . Set.toList -deriving via PrettyCommon (Set a) - instance PrettyDefaultBy config (Set a) => PrettyBy config (Set a) + defaultPrettyBy config = prettyBy config . Set.toList +deriving via + PrettyCommon (Set a) + instance + PrettyDefaultBy config (Set a) => PrettyBy config (Set a) instance PrettyDefaultBy config [a] => DefaultPrettyBy config (Vector a) where - defaultPrettyBy config = prettyBy config . toList -deriving via PrettyCommon (Vector a) - instance PrettyDefaultBy config (Vector a) => PrettyBy config (Vector a) + defaultPrettyBy config = prettyBy config . toList +deriving via + PrettyCommon (Vector a) + instance + PrettyDefaultBy config (Vector a) => PrettyBy config (Vector a) diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs index dfbe4545b8d..f277046ee24 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs @@ -1,34 +1,33 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- | The global pretty-printing config used to pretty-print everything in the PLC world. -- This module also defines custom pretty-printing functions for PLC types as a convenience. - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Pretty.Plc - ( - -- * Global configuration - CondensedErrors (..) - , PrettyConfigPlcOptions (..) - , PrettyConfigPlcStrategy (..) - , PrettyConfigPlc (..) - , PrettyPlc - , DefaultPrettyPlcStrategy - , prettyConfigPlcOptions - , prettyConfigPlcClassic - , prettyConfigPlcClassicSimple - , prettyConfigPlcReadable - , prettyConfigPlcReadableSimple - -- * Custom functions for PLC types. - , prettyPlcClassic - , prettyPlcClassicSimple - , prettyPlcReadable - , prettyPlcReadableSimple - , prettyPlcCondensedErrorBy - ) where +module PlutusCore.Pretty.Plc ( + -- * Global configuration + CondensedErrors (..), + PrettyConfigPlcOptions (..), + PrettyConfigPlcStrategy (..), + PrettyConfigPlc (..), + PrettyPlc, + DefaultPrettyPlcStrategy, + prettyConfigPlcOptions, + prettyConfigPlcClassic, + prettyConfigPlcClassicSimple, + prettyConfigPlcReadable, + prettyConfigPlcReadableSimple, + + -- * Custom functions for PLC types. + prettyPlcClassic, + prettyPlcClassicSimple, + prettyPlcReadable, + prettyPlcReadableSimple, + prettyPlcCondensedErrorBy, +) where import PlutusPrelude @@ -38,28 +37,28 @@ import PlutusCore.Pretty.Readable -- | Whether to pretty-print PLC errors in full or with some information omitted. data CondensedErrors - = CondensedErrorsYes - | CondensedErrorsNo - deriving stock (Show, Eq) + = CondensedErrorsYes + | CondensedErrorsNo + deriving stock (Show, Eq) -- | Options for pretty-printing PLC entities. newtype PrettyConfigPlcOptions = PrettyConfigPlcOptions - { _pcpoCondensedErrors :: CondensedErrors - } - deriving stock (Show) + { _pcpoCondensedErrors :: CondensedErrors + } + deriving stock (Show) -- | Strategy for pretty-printing PLC entities. data PrettyConfigPlcStrategy - = PrettyConfigPlcClassic (PrettyConfigClassic PrettyConfigName) - | PrettyConfigPlcReadable (PrettyConfigReadable PrettyConfigName) - deriving stock (Show) + = PrettyConfigPlcClassic (PrettyConfigClassic PrettyConfigName) + | PrettyConfigPlcReadable (PrettyConfigReadable PrettyConfigName) + deriving stock (Show) -- | Global configuration used for pretty-printing PLC entities. data PrettyConfigPlc = PrettyConfigPlc - { _pcpOptions :: PrettyConfigPlcOptions - , _pcpStrategy :: PrettyConfigPlcStrategy - } - deriving stock (Show) + { _pcpOptions :: PrettyConfigPlcOptions + , _pcpStrategy :: PrettyConfigPlcStrategy + } + deriving stock (Show) type instance HasPrettyDefaults PrettyConfigPlc = 'True @@ -68,23 +67,23 @@ type PrettyPlc = PrettyBy PrettyConfigPlc -- | A constraint that allows to derive @PrettyBy PrettyConfigPlc@ instances, see below. type DefaultPrettyPlcStrategy a = - ( PrettyClassic a - , PrettyReadable a - ) + ( PrettyClassic a + , PrettyReadable a + ) instance HasPrettyConfigName PrettyConfigPlcStrategy where - toPrettyConfigName (PrettyConfigPlcClassic configClassic) = toPrettyConfigName configClassic - toPrettyConfigName (PrettyConfigPlcReadable configReadable) = toPrettyConfigName configReadable + toPrettyConfigName (PrettyConfigPlcClassic configClassic) = toPrettyConfigName configClassic + toPrettyConfigName (PrettyConfigPlcReadable configReadable) = toPrettyConfigName configReadable instance HasPrettyConfigName PrettyConfigPlc where - toPrettyConfigName = toPrettyConfigName . _pcpStrategy + toPrettyConfigName = toPrettyConfigName . _pcpStrategy instance DefaultPrettyPlcStrategy a => PrettyBy PrettyConfigPlcStrategy (PrettyAny a) where - prettyBy (PrettyConfigPlcClassic configClassic ) = prettyBy configClassic . unPrettyAny - prettyBy (PrettyConfigPlcReadable configReadable) = prettyBy configReadable . unPrettyAny + prettyBy (PrettyConfigPlcClassic configClassic) = prettyBy configClassic . unPrettyAny + prettyBy (PrettyConfigPlcReadable configReadable) = prettyBy configReadable . unPrettyAny instance DefaultPrettyPlcStrategy a => PrettyBy PrettyConfigPlc (PrettyAny a) where - prettyBy = prettyBy . _pcpStrategy + prettyBy = prettyBy . _pcpStrategy -- | The 'PrettyConfigPlcOptions' used by default: -- print errors in full. @@ -95,27 +94,27 @@ prettyConfigPlcOptions = PrettyConfigPlcOptions CondensedErrorsNo -- use the classic view and print neither 'Unique's, nor name attachments. prettyConfigPlcClassic :: PrettyConfigPlcOptions -> PrettyConfigPlc prettyConfigPlcClassic opts = - PrettyConfigPlc opts $ PrettyConfigPlcClassic prettyConfigClassic + PrettyConfigPlc opts $ PrettyConfigPlcClassic prettyConfigClassic -- | The 'PrettyConfigPlc' used for debugging: -- use the classic view and print 'Unique's, but not name attachments. prettyConfigPlcClassicSimple :: PrettyConfigPlcOptions -> PrettyConfigPlc prettyConfigPlcClassicSimple opts = - PrettyConfigPlc opts $ PrettyConfigPlcClassic prettyConfigClassicSimple + PrettyConfigPlc opts $ PrettyConfigPlcClassic prettyConfigClassicSimple -- | The 'PrettyConfigPlc' used by default and for readability: -- use the refined view and print 'Unique's but not name attachments. prettyConfigPlcReadable :: PrettyConfigPlcOptions -> PrettyConfigPlc prettyConfigPlcReadable opts = - PrettyConfigPlc opts . PrettyConfigPlcReadable $ - botPrettyConfigReadable prettyConfigName def + PrettyConfigPlc opts . PrettyConfigPlcReadable $ + botPrettyConfigReadable prettyConfigName def -- | The 'PrettyConfigPlc' used for debugging and readability: -- use the refined view and print neither 'Unique's nor name attachments. prettyConfigPlcReadableSimple :: PrettyConfigPlcOptions -> PrettyConfigPlc prettyConfigPlcReadableSimple opts = - PrettyConfigPlc opts . PrettyConfigPlcReadable $ - botPrettyConfigReadable prettyConfigNameSimple def + PrettyConfigPlc opts . PrettyConfigPlcReadable $ + botPrettyConfigReadable prettyConfigNameSimple def -- | Pretty-print a PLC value in the default mode using the classic view. prettyPlcClassic :: PrettyPlc a => a -> Doc ann @@ -135,6 +134,6 @@ prettyPlcReadableSimple = prettyBy $ prettyConfigPlcReadableSimple prettyConfigP -- | Pretty-print a PLC value using the condensed way (see 'CondensedErrors') -- of pretty-printing PLC errors (in case there are any). -prettyPlcCondensedErrorBy - :: PrettyPlc a => (PrettyConfigPlcOptions -> PrettyConfigPlc) -> a -> Doc ann +prettyPlcCondensedErrorBy :: + PrettyPlc a => (PrettyConfigPlcOptions -> PrettyConfigPlc) -> a -> Doc ann prettyPlcCondensedErrorBy toConfig = prettyBy . toConfig $ PrettyConfigPlcOptions CondensedErrorsYes diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/PrettyConst.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/PrettyConst.hs index a7001386add..4f1a52e9bfa 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/PrettyConst.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/PrettyConst.hs @@ -1,16 +1,15 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- editorconfig-checker-disable-file {-# 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 @@ -72,15 +71,17 @@ Not a big deal, since our parser isn't whitespace-sensitive. -} -- See Note [Prettyprinting built-in constants]. + -- | The type of configs used for pretty-printing constants. Has a 'RenderContext' inside, so that -- we don't add redundant parens to the output. newtype ConstConfig = ConstConfig - { unConstConfig :: RenderContext - } + { unConstConfig :: RenderContext + } + type instance HasPrettyDefaults ConstConfig = 'False instance HasRenderContext ConstConfig where - renderContext = coerced + renderContext = coerced type PrettyConst = PrettyBy ConstConfig @@ -97,12 +98,12 @@ type ThrowableBuiltins uni fun = (PrettyUni uni, Pretty fun, Typeable uni, Typea -- For that we'll also need to ensure that it's alright when @HasPrettyDefaults config ~ 'True@. instance DefaultPrettyBy ConstConfig (PrettyAny a) => NonDefaultPrettyBy ConstConfig (PrettyAny a) instance DefaultPrettyBy ConstConfig (PrettyAny a) => PrettyBy ConstConfig (PrettyAny a) where - prettyBy = defaultPrettyBy - prettyListBy = defaultPrettyListBy + prettyBy = defaultPrettyBy + prettyListBy = defaultPrettyListBy instance Show a => DefaultPrettyBy ConstConfig (PrettyAny a) where - defaultPrettyBy _ = pretty . show @a . coerce - defaultPrettyListBy _ = pretty . show @[a] . coerce + defaultPrettyBy _ = pretty . show @a . coerce + defaultPrettyListBy _ = pretty . show @[a] . coerce prettyConst :: PrettyConst a => RenderContext -> a -> Doc ann prettyConst = prettyBy . ConstConfig @@ -110,83 +111,86 @@ prettyConst = prettyBy . ConstConfig -- 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.foldr' prettyChar "" - 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 + nonDefaultPrettyListBy conf = Prettyprinter.list . Prelude.map (nonDefaultPrettyBy conf) + nonDefaultPrettyBy = inContextM $ \t -> pure $ pretty $ "\"" <> escape t <> "\"" + where + escape = T.foldr' prettyChar "" + 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 -- | For rendering values without parens, i.e. in 'botRenderContext'. newtype NoParens a = NoParens - { unNoParens :: a - } + { unNoParens :: a + } instance PrettyConst a => PrettyBy ConstConfig (NoParens a) where - prettyBy config = prettyBy @_ @a (config & renderContext .~ botRenderContext) . coerce - prettyListBy config = prettyListBy @_ @a (config & renderContext .~ botRenderContext) . coerce + prettyBy config = prettyBy @_ @a (config & renderContext .~ botRenderContext) . coerce + prettyListBy config = prettyListBy @_ @a (config & renderContext .~ botRenderContext) . coerce instance PrettyConst a => NonDefaultPrettyBy ConstConfig [a] where - nonDefaultPrettyBy config = defaultPrettyBy @_ @[NoParens a] config . coerce + nonDefaultPrettyBy config = defaultPrettyBy @_ @[NoParens a] config . coerce instance PrettyConst a => NonDefaultPrettyBy ConstConfig (Vector a) where - nonDefaultPrettyBy config = defaultPrettyBy @_ @(Vector (NoParens a)) config . coerce + nonDefaultPrettyBy config = defaultPrettyBy @_ @(Vector (NoParens a)) config . coerce instance (PrettyConst a, PrettyConst b) => NonDefaultPrettyBy ConstConfig (a, b) where - nonDefaultPrettyBy config = defaultPrettyBy @_ @(NoParens a, NoParens b) config . coerce + nonDefaultPrettyBy config = defaultPrettyBy @_ @(NoParens a, NoParens b) config . coerce -- Special instance for bytestrings asBytes :: Word8 -> Doc ann asBytes x = Text 2 $ T.pack $ addLeadingZero $ showHex x mempty - where addLeadingZero :: String -> String - addLeadingZero - | x < 16 = ('0' :) - | otherwise = id + where + addLeadingZero :: String -> String + addLeadingZero + | x < 16 = ('0' :) + | otherwise = id toBytes :: BS.ByteString -> Doc ann -toBytes = foldMap asBytes . BS.unpack +toBytes = foldMap asBytes . BS.unpack instance PrettyBy ConstConfig Data where - prettyBy = inContextM $ \d0 -> iterAppDocM $ \_ prettyArg -> case d0 of - Constr i ds -> ("Constr" <+> prettyArg i) :| [prettyArg ds] - Map ps -> "Map" :| [prettyArg ps] - List ds -> "List" :| [prettyArg ds] - I i -> ("I" <+> prettyArg i) :| [] - B b -> ("B" <+> prettyArg b) :| [] + prettyBy = inContextM $ \d0 -> iterAppDocM $ \_ prettyArg -> case d0 of + Constr i ds -> ("Constr" <+> prettyArg i) :| [prettyArg ds] + Map ps -> "Map" :| [prettyArg ps] + List ds -> "List" :| [prettyArg ds] + I i -> ("I" <+> prettyArg i) :| [] + B b -> ("B" <+> prettyArg b) :| [] instance PrettyBy ConstConfig Value.K where - prettyBy config = prettyBy config . Value.unK + prettyBy config = prettyBy config . Value.unK instance PrettyBy ConstConfig Value.Quantity where - prettyBy config = prettyBy config . Value.unQuantity + prettyBy config = prettyBy config . Value.unQuantity instance PrettyBy ConstConfig Value where - prettyBy config = prettyBy config . Value.toList + prettyBy config = prettyBy config . Value.toList instance PrettyBy ConstConfig BS.ByteString where - prettyBy _ b = "#" <> toBytes b + prettyBy _ b = "#" <> toBytes b instance Pretty (SomeTypeIn uni) => Pretty (SomeTypeIn (Kinded uni)) where - pretty (SomeTypeIn (Kinded uni)) = pretty (SomeTypeIn uni) + pretty (SomeTypeIn (Kinded uni)) = pretty (SomeTypeIn uni) -- See Note [Prettyprinting built-in constants]. instance (Closed uni, uni `Everywhere` PrettyConst) => PrettyBy ConstConfig (ValueOf uni a) where - prettyBy config (ValueOf uni x) = bring (Proxy @PrettyConst) uni $ prettyBy config x + prettyBy config (ValueOf uni x) = bring (Proxy @PrettyConst) uni $ prettyBy config x -- See Note [Prettyprinting built-in constants]. -instance (Closed uni, uni `Everywhere` PrettyConst) => - PrettyBy ConstConfig (Some (ValueOf uni)) where - prettyBy config (Some s) = prettyBy config s +instance + (Closed uni, uni `Everywhere` PrettyConst) => + PrettyBy ConstConfig (Some (ValueOf uni)) + where + prettyBy config (Some s) = prettyBy config s -- See Note [Prettyprinting built-in constants]. instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (ValueOf uni a) where - pretty = prettyConst juxtRenderContext + pretty = prettyConst juxtRenderContext -- See Note [Prettyprinting built-in constants]. instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (Some (ValueOf uni)) where - pretty = prettyConst juxtRenderContext + pretty = prettyConst juxtRenderContext diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs index b35b03858f8..dc93992eacb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | A "readable" Agda-like way to pretty-print PLC entities. module PlutusCore.Pretty.Readable ( @@ -39,9 +39,9 @@ instance Default ShowKinds where -- | Configuration for the readable pretty-printing. data PrettyConfigReadable configName = PrettyConfigReadable - { _pcrConfigName :: configName + { _pcrConfigName :: configName , _pcrRenderContext :: RenderContext - , _pcrShowKinds :: ShowKinds + , _pcrShowKinds :: ShowKinds } deriving stock (Show) @@ -62,7 +62,7 @@ type HasPrettyConfigReadable env configName = makeLenses ''PrettyConfigReadable instance - (configName ~ PrettyConfigName) => + configName ~ PrettyConfigName => HasPrettyConfigName (PrettyConfigReadable configName) where toPrettyConfigName = _pcrConfigName @@ -70,15 +70,14 @@ instance instance HasRenderContext (PrettyConfigReadable configName) where renderContext = pcrRenderContext -{- | For rendering things in a readable manner regardless of the pretty-printing function chosen. -I.e. all of 'show', 'pretty', 'prettyClassic' will use 'PrettyReadable' instead of doing what -they normally do. @prettyBy config (AsReadable x)@ requires @config@ to have a 'PrettyConfigName' -and respects it. - -This wrapper can be particularly useful if you want to apply a function having a 'Show' or -'Pretty' or 'PrettyClassic' or 'PrettyPlc' or whatever constraint, but want to get the argument -rendered in a readable manner instead. --} +-- | For rendering things in a readable manner regardless of the pretty-printing function chosen. +-- I.e. all of 'show', 'pretty', 'prettyClassic' will use 'PrettyReadable' instead of doing what +-- they normally do. @prettyBy config (AsReadable x)@ requires @config@ to have a 'PrettyConfigName' +-- and respects it. +-- +-- This wrapper can be particularly useful if you want to apply a function having a 'Show' or +-- 'Pretty' or 'PrettyClassic' or 'PrettyPlc' or whatever constraint, but want to get the argument +-- rendered in a readable manner instead. newtype AsReadable a = AsReadable { unAsReadable :: a } @@ -90,31 +89,34 @@ instance defaultPrettyBy config (AsReadable x) = prettyBy (botPrettyConfigReadable (toPrettyConfigName config) def) x -instance (PrettyReadable a) => Show (AsReadable a) where +instance PrettyReadable a => Show (AsReadable a) where show = displayBy $ Sole prettyConfigName -instance (PrettyReadable a) => Pretty (AsReadable a) where +instance PrettyReadable a => Pretty (AsReadable a) where pretty = viaShow deriving via PrettyCommon (AsReadable a) instance - (PrettyDefaultBy config (AsReadable a)) => PrettyBy config (AsReadable a) + PrettyDefaultBy config (AsReadable a) => PrettyBy config (AsReadable a) -- | A value of type @a@ to render in parens using the readable pretty-printer. data Parened a = Parened - { parenOpening :: String - , parenClosing :: String - , parenedValue :: a - } - -instance PrettyReadableBy configName a => - PrettyBy (PrettyConfigReadable configName) (Parened a) where - prettyBy config (Parened opening closing x) = fold - [ pretty opening - , prettyBy (config & renderContext .~ botRenderContext) x - , pretty closing - ] + { parenOpening :: String + , parenClosing :: String + , parenedValue :: a + } + +instance + PrettyReadableBy configName a => + PrettyBy (PrettyConfigReadable configName) (Parened a) + where + prettyBy config (Parened opening closing x) = + fold + [ pretty opening + , prettyBy (config & renderContext .~ botRenderContext) x + , pretty closing + ] -- | Enclose the given value, so that it's rendered inside of braces with no additional parens -- regardless of the 'RenderContext'. @@ -137,17 +139,16 @@ binderFixity = Fixity RightAssociative 1 arrowFixity :: Fixity arrowFixity = Fixity RightAssociative 2 -{- | Lay out an iterated binder. For example, this function lays out iterated lambdas either as - -> \(x : a) (y : b) (z : c) -> body - -or as - -> \(x : a) -> (y : b) -> (z : c) -> -> body --} +-- | Lay out an iterated binder. For example, this function lays out iterated lambdas either as +-- +-- > \(x : a) (y : b) (z : c) -> body +-- +-- or as +-- +-- > \(x : a) +-- > (y : b) +-- > (z : c) -> +-- > body iterBinderPrettyM :: ( MonadPrettyReadable configName env m , PrettyReadableBy configName arg @@ -160,7 +161,7 @@ iterBinderPrettyM :: iterBinderPrettyM enframe args body = infixDocM binderFixity $ \prettyBind prettyBody -> let prettyBinds = align . sep $ map prettyBind args - in enframe prettyBinds prettyBody body + in enframe prettyBinds prettyBody body -- | Lay out an iterated 'TyForall' via 'iterBinderPrettyM'. iterTyForallPrettyM :: @@ -211,30 +212,30 @@ type ReadableToDoc configName ann = forall a. PrettyReadableBy configName a => a -- | Lay out an iteration application, providing to the caller a function to render the head of the -- application and a function to render each of the arguments. iterAppDocM :: - MonadPrettyContext config env m => - (AnyToDoc config ann -> AnyToDoc config ann -> NonEmpty (Doc ann)) -> - m (Doc ann) + MonadPrettyContext config env m => + (AnyToDoc config ann -> AnyToDoc config ann -> NonEmpty (Doc ann)) -> + m (Doc ann) iterAppDocM k = infixDocM juxtFixity $ \prettyFun prettyArg -> let fun :| args = k prettyFun prettyArg - in if null args - then fun - else fun vsep args - -{- | Lay out iterated function applications either as - -> foo x y z - -or as - -> foo -> x -> y -> z --} + in if null args + then fun + else fun vsep args + +-- | Lay out iterated function applications either as +-- +-- > foo x y z +-- +-- or as +-- +-- > foo +-- > x +-- > y +-- > z iterAppPrettyM :: ( MonadPrettyContext config env m - , PrettyBy config fun, PrettyBy config term + , PrettyBy config fun + , PrettyBy config term ) => fun -> [term] -> @@ -243,21 +244,20 @@ iterAppPrettyM fun args = iterAppDocM $ \prettyFun prettyArg -> prettyFun fun :| map prettyArg args -{- | Lay out interleaved function applications either as - -> foo {a} x {b} y z - -or as - -> foo -> {a} -> x -> {b} -> y -> z - -'Left's are laid out in braces, 'Right's are laid out without braces. --} +-- | Lay out interleaved function applications either as +-- +-- > foo {a} x {b} y z +-- +-- or as +-- +-- > foo +-- > {a} +-- > x +-- > {b} +-- > y +-- > z +-- +-- 'Left's are laid out in braces, 'Right's are laid out without braces. iterInterAppPrettyM :: ( MonadPrettyReadable configName env m , PrettyReadableBy configName fun @@ -269,14 +269,14 @@ iterInterAppPrettyM :: m (Doc ann) iterInterAppPrettyM fun args = iterAppDocM $ \prettyFun prettyArg -> - let ppArg (Left ty) = prettyArg $ inBraces ty + let ppArg (Left ty) = prettyArg $ inBraces ty ppArg (Right term) = prettyArg term - in prettyFun fun :| map ppArg args + in prettyFun fun :| map ppArg args -- | Pretty-print something with the @PrettyConfigReadable@ config. -prettyReadable :: (PrettyReadable a) => a -> Doc ann +prettyReadable :: PrettyReadable a => a -> Doc ann prettyReadable = prettyBy (botPrettyConfigReadable prettyConfigName def) -- | Pretty-print something with the @PrettyConfigReadableSimple@ config. -prettyReadableSimple :: (PrettyReadable a) => a -> Doc ann +prettyReadableSimple :: PrettyReadable a => a -> Doc ann prettyReadableSimple = prettyBy (botPrettyConfigReadable prettyConfigNameSimple def) diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs index e8eef31ea35..ee9de60708a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.Pretty.Utils - ( prettyBytes - ) where +module PlutusCore.Pretty.Utils ( + prettyBytes, +) where import PlutusPrelude @@ -13,10 +13,11 @@ import Prettyprinter.Internal asBytes :: Word8 -> Doc ann asBytes x = Text 2 $ T.pack $ addLeadingZero $ showHex x mempty - where addLeadingZero :: String -> String - addLeadingZero - | x < 16 = ('0' :) - | otherwise = id + where + addLeadingZero :: String -> String + addLeadingZero + | x < 16 = ('0' :) + | otherwise = id prettyBytes :: BS.ByteString -> Doc ann prettyBytes b = "#" <> foldMap asBytes (BS.unpack b) diff --git a/plutus-core/plutus-core/src/PlutusCore/Quote.hs b/plutus-core/plutus-core/src/PlutusCore/Quote.hs index 5dd680a06fd..875dc06e327 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Quote.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Quote.hs @@ -1,32 +1,31 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} -- just for the type equality constraint -{-# LANGUAGE GADTs #-} - +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- 9.6 thinks that a constraint generated by the deriving machinery is -- redundant: https://gitlab.haskell.org/ghc/ghc/-/issues/23143 {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module PlutusCore.Quote - ( runQuoteT - , runQuote - , freshUnique - , freshName - , freshTyName - , freshenName - , freshenTyName - , QuoteT (..) - , Quote - , MonadQuote - , FreshState - , liftQuote - , markNonFreshBelow - , markNonFresh - , markNonFreshMax - ) where +module PlutusCore.Quote ( + runQuoteT, + runQuote, + freshUnique, + freshName, + freshTyName, + freshenName, + freshenTyName, + QuoteT (..), + Quote, + MonadQuote, + FreshState, + liftQuote, + markNonFreshBelow, + markNonFresh, + markNonFreshMax, +) where import PlutusPrelude (fromMaybe) @@ -55,36 +54,36 @@ 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 - , MonadFix - , MM.MFunctor - , MonadError e - , MonadReader r - , MonadIO - , MonadWriter w - ) + 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 - get = lift get - put = lift . put - state = lift . state + get = lift get + put = lift . put + state = lift . state -- | 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. - default liftQuote :: (MonadQuote n, MonadTrans t, t n ~ m) => Quote a -> m a - liftQuote = lift . liftQuote + 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. + default liftQuote :: (MonadQuote n, MonadTrans t, t n ~ m) => Quote a -> m a + liftQuote = lift . liftQuote -instance (Monad m) => MonadQuote (QuoteT m) where - liftQuote = MM.hoist (pure . runIdentity) +instance Monad m => MonadQuote (QuoteT m) where + liftQuote = MM.hoist (pure . runIdentity) instance MonadQuote m => MonadQuote (StateT s m) instance MonadQuote m => MonadQuote (MaybeT m) @@ -95,7 +94,7 @@ instance MonadQuote m => MonadQuote (PropertyT m) -- | Run a quote from an empty identifier state. Note that the resulting term cannot necessarily -- be safely combined with other terms - that should happen inside 'QuoteT'. -runQuoteT :: Monad m => QuoteT m a -> m a +runQuoteT :: Monad m => QuoteT m a -> m a runQuoteT q = evalStateT (unQuoteT q) emptyFreshState -- | A non-transformer version of 'QuoteT'. @@ -108,9 +107,9 @@ runQuote = runIdentity . runQuoteT -- | Get a fresh 'Unique'. freshUnique :: MonadQuote m => m Unique freshUnique = liftQuote $ do - nextU <- QuoteT get - QuoteT $ put $ Unique (unUnique nextU + 1) - pure nextU + nextU <- QuoteT get + QuoteT $ put $ Unique (unUnique nextU + 1) + pure nextU -- | Get a fresh 'Name', given the annotation and the 'Text.Text' name. freshName :: MonadQuote m => Text.Text -> m Name diff --git a/plutus-core/plutus-core/src/PlutusCore/Rename.hs b/plutus-core/plutus-core/src/PlutusCore/Rename.hs index 79681bad84b..d8b90bf9c51 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Rename.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Rename.hs @@ -1,18 +1,17 @@ --- | The user-facing API of the renamer. - -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -module PlutusCore.Rename - ( Renamed (unRenamed) - , Rename (..) - , getRenamed - , Dupable - , dupable - , liftDupable - ) where +-- | The user-facing API of the renamer. +module PlutusCore.Rename ( + Renamed (unRenamed), + Rename (..), + getRenamed, + Dupable, + dupable, + liftDupable, +) where import PlutusPrelude @@ -32,12 +31,12 @@ programming trick in order to perform renaming in a single pass. -- | The class of things that can be renamed. -- I.e. things that are capable of satisfying the global uniqueness condition. class Rename a where - -- | Rename 'Unique's so that they're globally unique. - -- In case there are any free variables, they must be left untouched and bound variables - -- must not get renamed to free ones. - -- Must always assign new names to bound variables, - -- so that @rename@ can be used for alpha-renaming as well. - rename :: MonadQuote m => a -> m a + -- | Rename 'Unique's so that they're globally unique. + -- In case there are any free variables, they must be left untouched and bound variables + -- must not get renamed to free ones. + -- Must always assign new names to bound variables, + -- so that @rename@ can be used for alpha-renaming as well. + rename :: MonadQuote m => a -> m a -- | 'rename' a value and wrap the result in 'Renamed', so that it can be passed around and it's -- visible in the types that the thing inside satisfies global uniqueness. @@ -53,17 +52,19 @@ liftDupable :: (MonadQuote m, Rename a) => Dupable a -> m a liftDupable = liftQuote . rename . unDupable instance HasUniques (Type tyname uni ann) => Rename (Type tyname uni ann) where - -- See Note [Marking]. - rename = through markNonFreshType >=> runRenameT @TypeRenaming . renameTypeM + -- See Note [Marking]. + rename = through markNonFreshType >=> runRenameT @TypeRenaming . renameTypeM instance HasUniques (Term tyname name uni fun ann) => Rename (Term tyname name uni fun ann) where - -- See Note [Marking]. - rename = through markNonFreshTerm >=> runRenameT . renameTermM + -- See Note [Marking]. + rename = through markNonFreshTerm >=> runRenameT . renameTermM -instance HasUniques (Program tyname name uni fun ann) => - Rename (Program tyname name uni fun ann) where - -- See Note [Marking]. - rename = through markNonFreshProgram >=> runRenameT . renameProgramM +instance + HasUniques (Program tyname name uni fun ann) => + Rename (Program tyname name uni fun ann) + where + -- See Note [Marking]. + rename = through markNonFreshProgram >=> runRenameT . renameProgramM instance Rename a => Rename (Normalized a) where - rename = traverse rename + rename = traverse rename diff --git a/plutus-core/plutus-core/src/PlutusCore/Rename/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/Rename/Internal.hs index 6292114149f..8603ec379b3 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Rename/Internal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Rename/Internal.hs @@ -1,17 +1,17 @@ -- editorconfig-checker-disable-file + -- | The internal module of the renamer that defines the actual algorithms, -- but not the user-facing API. - -module PlutusCore.Rename.Internal - ( module Export - , Renamed (..) - , Dupable (..) - , withFreshenedTyVarDecl - , withFreshenedVarDecl - , renameTypeM - , renameTermM - , renameProgramM - ) where +module PlutusCore.Rename.Internal ( + module Export, + Renamed (..), + Dupable (..), + withFreshenedTyVarDecl, + withFreshenedVarDecl, + renameTypeM, + renameTermM, + renameProgramM, +) where import PlutusCore.Core import PlutusCore.Name.Unique @@ -28,8 +28,9 @@ import Control.Monad.Reader -- Don't provide any instances allowing the user to create a 'Renamed' (even out of an existing one -- like with 'Functor'). newtype Renamed a = Renamed - { unRenamed :: a - } deriving stock (Show, Eq) + { unRenamed :: a + } + deriving stock (Show, Eq) -- | @Dupable a@ is isomorphic to @a@, but the only way to extract the @a@ is via 'liftDupable' -- (defined in the main API module because of a constraint requirement) which renames the stored @@ -44,18 +45,19 @@ newtype Renamed a = Renamed -- 'unDupable' is not supposed to be exported. Don't provide any instances allowing the user to -- access the underlying value. newtype Dupable a = Dupable - { unDupable :: a - } deriving stock (Show, Eq) + { unDupable :: a + } + deriving stock (Show, Eq) -- | Replace the unique in the name stored in a 'TyVarDecl' by a new unique, save the mapping -- from the old unique to the new one and supply the updated 'TyVarDecl' to a continuation. -withFreshenedTyVarDecl - :: (HasRenaming ren TypeUnique, HasUniques (Type tyname uni ann), MonadQuote m, MonadReader ren m) - => TyVarDecl tyname ann - -> (TyVarDecl tyname ann -> m c) - -> m c +withFreshenedTyVarDecl :: + (HasRenaming ren TypeUnique, HasUniques (Type tyname uni ann), MonadQuote m, MonadReader ren m) => + TyVarDecl tyname ann -> + (TyVarDecl tyname ann -> m c) -> + m c withFreshenedTyVarDecl (TyVarDecl ann name kind) cont = - withFreshenedName name $ \nameFr -> cont $ TyVarDecl ann nameFr kind + withFreshenedName name $ \nameFr -> cont $ TyVarDecl ann nameFr kind -- | Replace the unique in the name stored in a 'VarDecl' by a new unique, save the mapping -- from the old unique to the new one and supply to a continuation the computation that @@ -63,51 +65,51 @@ withFreshenedTyVarDecl (TyVarDecl ann name kind) cont = -- The reason the continuation receives a computation rather than a pure term is that we may want -- to bring several term and type variables in scope before renaming the types of term variables. -- This situation arises when we want to rename a bunch of mutually recursive bindings. -withFreshenedVarDecl - :: (HasUniques (Term tyname name uni fun ann), MonadQuote m, MonadReader ScopedRenaming m) - => VarDecl tyname name uni ann - -> (m (VarDecl tyname name uni ann) -> m c) - -> m c +withFreshenedVarDecl :: + (HasUniques (Term tyname name uni fun ann), MonadQuote m, MonadReader ScopedRenaming m) => + VarDecl tyname name uni ann -> + (m (VarDecl tyname name uni ann) -> m c) -> + m c withFreshenedVarDecl (VarDecl ann name ty) cont = - withFreshenedName name $ \nameFr -> cont $ VarDecl ann nameFr <$> renameTypeM ty + withFreshenedName name $ \nameFr -> cont $ VarDecl ann nameFr <$> renameTypeM ty -- | Rename a 'Type' in the 'RenameM' monad. -renameTypeM - :: (HasRenaming ren TypeUnique, HasUniques (Type tyname uni ann), MonadQuote m, MonadReader ren m) - => Type tyname uni ann -> m (Type tyname uni ann) -renameTypeM (TyLam ann name kind ty) = - withFreshenedName name $ \nameFr -> TyLam ann nameFr kind <$> renameTypeM ty +renameTypeM :: + (HasRenaming ren TypeUnique, HasUniques (Type tyname uni ann), MonadQuote m, MonadReader ren m) => + Type tyname uni ann -> m (Type tyname uni ann) +renameTypeM (TyLam ann name kind ty) = + withFreshenedName name $ \nameFr -> TyLam ann nameFr kind <$> renameTypeM ty renameTypeM (TyForall ann name kind ty) = - withFreshenedName name $ \nameFr -> TyForall ann nameFr kind <$> renameTypeM ty -renameTypeM (TyIFix ann pat arg) = TyIFix ann <$> renameTypeM pat <*> renameTypeM arg -renameTypeM (TyApp ann fun arg) = TyApp ann <$> renameTypeM fun <*> renameTypeM arg -renameTypeM (TyFun ann dom cod) = TyFun ann <$> renameTypeM dom <*> renameTypeM cod -renameTypeM (TyVar ann name) = TyVar ann <$> renameNameM name -renameTypeM (TySOP ann tyls) = TySOP ann <$> (traverse . traverse) renameTypeM tyls -renameTypeM ty@TyBuiltin{} = pure ty + withFreshenedName name $ \nameFr -> TyForall ann nameFr kind <$> renameTypeM ty +renameTypeM (TyIFix ann pat arg) = TyIFix ann <$> renameTypeM pat <*> renameTypeM arg +renameTypeM (TyApp ann fun arg) = TyApp ann <$> renameTypeM fun <*> renameTypeM arg +renameTypeM (TyFun ann dom cod) = TyFun ann <$> renameTypeM dom <*> renameTypeM cod +renameTypeM (TyVar ann name) = TyVar ann <$> renameNameM name +renameTypeM (TySOP ann tyls) = TySOP ann <$> (traverse . traverse) renameTypeM tyls +renameTypeM ty@TyBuiltin {} = pure ty -- | Rename a 'Term' in the 'RenameM' monad. -renameTermM - :: (HasUniques (Term tyname name uni fun ann), MonadQuote m, MonadReader ScopedRenaming m) - => Term tyname name uni fun ann -> m (Term tyname name uni fun ann) -renameTermM (LamAbs ann name ty body) = - withFreshenedName name $ \nameFr -> LamAbs ann nameFr <$> renameTypeM ty <*> renameTermM body +renameTermM :: + (HasUniques (Term tyname name uni fun ann), MonadQuote m, MonadReader ScopedRenaming m) => + Term tyname name uni fun ann -> m (Term tyname name uni fun ann) +renameTermM (LamAbs ann name ty body) = + withFreshenedName name $ \nameFr -> LamAbs ann nameFr <$> renameTypeM ty <*> renameTermM body renameTermM (TyAbs ann name kind body) = - withFreshenedName name $ \nameFr -> TyAbs ann nameFr kind <$> renameTermM body -renameTermM (IWrap ann pat arg term) = - IWrap ann <$> renameTypeM pat <*> renameTypeM arg <*> renameTermM term -renameTermM (Apply ann fun arg) = Apply ann <$> renameTermM fun <*> renameTermM arg -renameTermM (Unwrap ann term) = Unwrap ann <$> renameTermM term -renameTermM (Error ann ty) = Error ann <$> renameTypeM ty -renameTermM (TyInst ann term ty) = TyInst ann <$> renameTermM term <*> renameTypeM ty -renameTermM (Var ann name) = Var ann <$> renameNameM name -renameTermM (Constr ann ty i es) = Constr ann <$> renameTypeM ty <*> pure i <*> traverse renameTermM es -renameTermM (Case ann ty arg cs) = Case ann <$> renameTypeM ty <*> renameTermM arg <*> traverse renameTermM cs -renameTermM con@Constant{} = pure con -renameTermM bi@Builtin{} = pure bi + withFreshenedName name $ \nameFr -> TyAbs ann nameFr kind <$> renameTermM body +renameTermM (IWrap ann pat arg term) = + IWrap ann <$> renameTypeM pat <*> renameTypeM arg <*> renameTermM term +renameTermM (Apply ann fun arg) = Apply ann <$> renameTermM fun <*> renameTermM arg +renameTermM (Unwrap ann term) = Unwrap ann <$> renameTermM term +renameTermM (Error ann ty) = Error ann <$> renameTypeM ty +renameTermM (TyInst ann term ty) = TyInst ann <$> renameTermM term <*> renameTypeM ty +renameTermM (Var ann name) = Var ann <$> renameNameM name +renameTermM (Constr ann ty i es) = Constr ann <$> renameTypeM ty <*> pure i <*> traverse renameTermM es +renameTermM (Case ann ty arg cs) = Case ann <$> renameTypeM ty <*> renameTermM arg <*> traverse renameTermM cs +renameTermM con@Constant {} = pure con +renameTermM bi@Builtin {} = pure bi -- | Rename a 'Program' in the 'RenameM' monad. -renameProgramM - :: (HasUniques (Program tyname name uni fun ann), MonadQuote m, MonadReader ScopedRenaming m) - => Program tyname name uni fun ann -> m (Program tyname name uni fun ann) +renameProgramM :: + (HasUniques (Program tyname name uni fun ann), MonadQuote m, MonadReader ScopedRenaming m) => + Program tyname name uni fun ann -> m (Program tyname name uni fun ann) renameProgramM (Program ann ver term) = Program ann ver <$> renameTermM term diff --git a/plutus-core/plutus-core/src/PlutusCore/Rename/Monad.hs b/plutus-core/plutus-core/src/PlutusCore/Rename/Monad.hs index f81b4c627e8..c315724ff43 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Rename/Monad.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Rename/Monad.hs @@ -1,31 +1,34 @@ --- | The monad that the renamer runs in and related infrastructure. - -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module PlutusCore.Rename.Monad - ( RenameT (..) - , ScopedRenameT - , Renaming (..) - , TypeRenaming - , ScopedRenaming (..) - , HasRenaming (..) - , scopedRenamingTypes - , scopedRenamingTerms - , runRenameT - , lookupNameM - , renameNameM - , withFreshenedName - , withRenamedName - ) where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | The monad that the renamer runs in and related infrastructure. +module PlutusCore.Rename.Monad ( + RenameT (..), + ScopedRenameT, + Renaming (..), + TypeRenaming, + ScopedRenaming (..), + HasRenaming (..), + scopedRenamingTypes, + scopedRenamingTerms, + runRenameT, + lookupNameM, + renameNameM, + withFreshenedName, + withRenamedName, +) where import PlutusPrelude (Alternative, Coercible, Lens', coerce, over, view, (&), (.~), (^.)) -import PlutusCore.Name.Unique (HasUnique (..), TermUnique (TermUnique), TypeUnique (TypeUnique), - Unique (Unique)) +import PlutusCore.Name.Unique ( + HasUnique (..), + TermUnique (TermUnique), + TypeUnique (TypeUnique), + Unique (Unique), + ) import PlutusCore.Name.UniqueMap (UniqueMap (UniqueMap), insertByName, lookupName) import PlutusCore.Quote (MonadQuote, freshUnique) @@ -34,17 +37,22 @@ import Control.Monad.Reader (MonadReader (local), ReaderT (..), asks) -- | The monad the renamer runs in. newtype RenameT ren m a = RenameT - { unRenameT :: ReaderT ren m a - } deriving newtype - ( Functor, Applicative, Alternative, Monad - , MonadReader ren - , MonadQuote - ) + { unRenameT :: ReaderT ren m a + } + deriving newtype + ( Functor + , Applicative + , Alternative + , Monad + , MonadReader ren + , MonadQuote + ) -- | A renaming is a mapping from old uniques to new ones. newtype Renaming unique = Renaming - { unRenaming :: UniqueMap unique unique - } deriving newtype (Semigroup, Monoid) + { unRenaming :: UniqueMap unique unique + } + deriving newtype (Semigroup, Monoid) -- | A type-level renaming. -- Needed for instantiating functions running over types in generic @RenameT ren m@ to @@ -54,80 +62,82 @@ type TypeRenaming = Renaming TypeUnique -- | A class that specifies which 'Renaming' a @ren@ has inside. -- A @ren@ can contain several 'Renaming's (like 'Scoped', for example). class Coercible unique Unique => HasRenaming ren unique where - renaming :: Lens' ren (Renaming unique) + renaming :: Lens' ren (Renaming unique) -- | Scoping-aware mapping from locally unique uniques to globally unique uniques. data ScopedRenaming = ScopedRenaming - { _scopedRenamingTypes :: Renaming TypeUnique - , _scopedRenamingTerms :: Renaming TermUnique - } + { _scopedRenamingTypes :: Renaming TypeUnique + , _scopedRenamingTerms :: Renaming TermUnique + } makeLenses ''ScopedRenaming type ScopedRenameT = RenameT ScopedRenaming instance Semigroup ScopedRenaming where - ScopedRenaming types1 terms1 <> ScopedRenaming types2 terms2 = - ScopedRenaming (types1 <> types2) (terms1 <> terms2) + ScopedRenaming types1 terms1 <> ScopedRenaming types2 terms2 = + ScopedRenaming (types1 <> types2) (terms1 <> terms2) instance Monoid ScopedRenaming where - mempty = ScopedRenaming mempty mempty + mempty = ScopedRenaming mempty mempty -instance (Coercible unique1 Unique, unique1 ~ unique2) => - HasRenaming (Renaming unique1) unique2 where - renaming = id +instance + (Coercible unique1 Unique, unique1 ~ unique2) => + HasRenaming (Renaming unique1) unique2 + where + renaming = id instance HasRenaming ScopedRenaming TypeUnique where - renaming = scopedRenamingTypes . renaming + renaming = scopedRenamingTypes . renaming instance HasRenaming ScopedRenaming TermUnique where - renaming = scopedRenamingTerms . renaming + renaming = scopedRenamingTerms . renaming -- | Run a 'RenameT' computation with an empty renaming. runRenameT :: Monoid ren => RenameT ren m a -> m a runRenameT (RenameT a) = runReaderT a mempty -- | Map the underlying representation of 'Renaming'. -mapRenaming - :: (UniqueMap unique unique -> UniqueMap unique unique) - -> Renaming unique - -> Renaming unique +mapRenaming :: + (UniqueMap unique unique -> UniqueMap unique unique) -> + Renaming unique -> + Renaming unique mapRenaming = coerce -- | Save the mapping from the @unique@ of a name to a new @unique@. -insertByNameM - :: (HasUnique name unique, HasRenaming ren unique) - => name -> unique -> ren -> ren +insertByNameM :: + (HasUnique name unique, HasRenaming ren unique) => + name -> unique -> ren -> ren insertByNameM name = over renaming . mapRenaming . insertByName name -- | Look up the new unique a name got mapped to. -lookupNameM - :: (HasUnique name unique, HasRenaming ren unique, MonadReader ren m) - => name -> m (Maybe unique) +lookupNameM :: + (HasUnique name unique, HasRenaming ren unique, MonadReader ren m) => + name -> m (Maybe unique) lookupNameM name = asks $ lookupName name . unRenaming . view renaming -- | Rename a name that has a unique inside. -renameNameM - :: (HasRenaming ren unique, HasUnique name unique, MonadReader ren m) - => name -> m name +renameNameM :: + (HasRenaming ren unique, HasUnique name unique, MonadReader ren m) => + name -> m name renameNameM name = do - mayUniqNew <- lookupNameM name - pure $ case mayUniqNew of - Nothing -> name - Just uniqNew -> name & unique .~ uniqNew + mayUniqNew <- lookupNameM name + pure $ case mayUniqNew of + Nothing -> name + Just uniqNew -> name & unique .~ uniqNew -- | Replace the unique in a name by a new unique, save the mapping -- from the old unique to the new one and supply the updated value to a continuation. -withFreshenedName - :: (HasRenaming ren unique, HasUnique name unique, MonadQuote m, MonadReader ren m) - => name -> (name -> m c) -> m c +withFreshenedName :: + (HasRenaming ren unique, HasUnique name unique, MonadQuote m, MonadReader ren m) => + name -> (name -> m c) -> m c withFreshenedName nameOld k = do - uniqNew <- coerce <$> freshUnique - local (insertByNameM nameOld uniqNew) $ k (nameOld & unique .~ uniqNew) + uniqNew <- coerce <$> freshUnique + local (insertByNameM nameOld uniqNew) $ k (nameOld & unique .~ uniqNew) -- | Run a 'RenameT' computation in the environment extended by the mapping from an old name -- to a new one. -withRenamedName - :: (HasRenaming ren unique, HasUnique name unique, MonadReader ren m) - => name -> name -> m c -> m c +withRenamedName :: + (HasRenaming ren unique, HasUnique name unique, MonadReader ren m) => + name -> name -> m c -> m c withRenamedName old new = local $ insertByNameM old (new ^. unique) diff --git a/plutus-core/plutus-core/src/PlutusCore/Subst.hs b/plutus-core/plutus-core/src/PlutusCore/Subst.hs index a013b3a0e54..03170c28401 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Subst.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Subst.hs @@ -1,34 +1,35 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -module PlutusCore.Subst - ( substTyVarA - , substVarA - , substTyVar - , substVar - , termSubstNamesM - , termSubstTyNamesM - , typeSubstTyNamesM - , termSubstNames - , termSubstTyNames - , typeSubstTyNames - , typeSubstClosedType - , termSubstClosedType - , termSubstClosedTerm - , typeMapNames - , termMapNames - , programMapNames - , fvTerm - , ftvTerm - , ftvTy - , ftvTyCtx - , vTerm - , tvTerm - , tvTy - , substConstantA - , substConstant - , termSubstConstantsM - , termSubstConstants - ) where + +module PlutusCore.Subst ( + substTyVarA, + substVarA, + substTyVar, + substVar, + termSubstNamesM, + termSubstTyNamesM, + typeSubstTyNamesM, + termSubstNames, + termSubstTyNames, + typeSubstTyNames, + typeSubstClosedType, + termSubstClosedType, + termSubstClosedTerm, + typeMapNames, + termMapNames, + programMapNames, + fvTerm, + ftvTerm, + ftvTy, + ftvTyCtx, + vTerm, + tvTerm, + tvTy, + substConstantA, + substConstant, + termSubstConstantsM, + termSubstConstants, +) where import PlutusPrelude @@ -43,112 +44,114 @@ import PlutusCore.Name.UniqueSet qualified as USet import Universe -- | Applicatively replace a type variable using the given function. -substTyVarA - :: Applicative f - => (tyname -> f (Maybe (Type tyname uni ann))) - -> Type tyname uni ann - -> f (Type tyname uni ann) +substTyVarA :: + Applicative f => + (tyname -> f (Maybe (Type tyname uni ann))) -> + Type tyname uni ann -> + f (Type tyname uni ann) substTyVarA tynameF ty@(TyVar _ tyname) = fromMaybe ty <$> tynameF tyname -substTyVarA _ ty = pure ty +substTyVarA _ ty = pure ty {-# INLINE substTyVarA #-} -- | Applicatively replace a variable using the given function. -substVarA - :: Applicative f - => (name -> f (Maybe (Term tyname name uni fun ann))) - -> Term tyname name uni fun ann - -> f (Term tyname name uni fun ann) +substVarA :: + Applicative f => + (name -> f (Maybe (Term tyname name uni fun ann))) -> + Term tyname name uni fun ann -> + f (Term tyname name uni fun ann) substVarA nameF t@(Var _ name) = fromMaybe t <$> nameF name -substVarA _ t = pure t +substVarA _ t = pure t -- | Replace a type variable using the given function. -substTyVar - :: (tyname -> Maybe (Type tyname uni ann)) - -> Type tyname uni ann - -> Type tyname uni ann +substTyVar :: + (tyname -> Maybe (Type tyname uni ann)) -> + Type tyname uni ann -> + Type tyname uni ann substTyVar = purely substTyVarA -- | Replace a variable using the given function. -substVar - :: (name -> Maybe (Term tyname name uni fun ann)) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann +substVar :: + (name -> Maybe (Term tyname name uni fun ann)) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann substVar = purely substVarA -- | Naively monadically substitute type names (i.e. do not substitute binders). -- INLINE is important here because the function is too polymorphic (determined from profiling) -typeSubstTyNamesM - :: Monad m - => (tyname -> m (Maybe (Type tyname uni ann))) - -> Type tyname uni ann - -> m (Type tyname uni ann) +typeSubstTyNamesM :: + Monad m => + (tyname -> m (Maybe (Type tyname uni ann))) -> + Type tyname uni ann -> + m (Type tyname uni ann) typeSubstTyNamesM = transformMOf typeSubtypes . substTyVarA {-# INLINE typeSubstTyNamesM #-} -- | Naively monadically substitute names using the given function (i.e. do not substitute binders). -termSubstNamesM - :: Monad m - => (name -> m (Maybe (Term tyname name uni fun ann))) - -> Term tyname name uni fun ann - -> m (Term tyname name uni fun ann) +termSubstNamesM :: + Monad m => + (name -> m (Maybe (Term tyname name uni fun ann))) -> + Term tyname name uni fun ann -> + m (Term tyname name uni fun ann) termSubstNamesM = transformMOf termSubterms . substVarA -- | Naively monadically substitute type names using the given function -- (i.e. do not substitute binders). -termSubstTyNamesM - :: Monad m - => (tyname -> m (Maybe (Type tyname uni ann))) - -> Term tyname name uni fun ann - -> m (Term tyname name uni fun ann) +termSubstTyNamesM :: + Monad m => + (tyname -> m (Maybe (Type tyname uni ann))) -> + Term tyname name uni fun ann -> + m (Term tyname name uni fun ann) termSubstTyNamesM = - transformMOf termSubterms . traverseOf termSubtypes . transformMOf typeSubtypes . substTyVarA + transformMOf termSubterms . traverseOf termSubtypes . transformMOf typeSubtypes . substTyVarA -- | Naively substitute type names (i.e. do not substitute binders). -typeSubstTyNames - :: (tyname -> Maybe (Type tyname uni ann)) - -> Type tyname uni ann - -> Type tyname uni ann +typeSubstTyNames :: + (tyname -> Maybe (Type tyname uni ann)) -> + Type tyname uni ann -> + Type tyname uni ann typeSubstTyNames = purely typeSubstTyNamesM -- | Naively substitute names using the given function (i.e. do not substitute binders). -termSubstNames - :: (name -> Maybe (Term tyname name uni fun ann)) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann +termSubstNames :: + (name -> Maybe (Term tyname name uni fun ann)) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann termSubstNames = purely termSubstNamesM -- | Naively substitute type names using the given function (i.e. do not substitute binders). -termSubstTyNames - :: (tyname -> Maybe (Type tyname uni ann)) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann +termSubstTyNames :: + (tyname -> Maybe (Type tyname uni ann)) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann termSubstTyNames = purely termSubstTyNamesM -- | Substitute the given closed 'Type' for the given type variable in the given 'Type'. Does not -- descend under binders that bind the same variable as the one we're substituting for (since from -- there that variable is no longer free). The resulting 'Term' may and likely will not satisfy -- global uniqueness. -typeSubstClosedType - :: Eq tyname => tyname -> Type tyname uni a -> Type tyname uni a -> Type tyname uni a -typeSubstClosedType tn0 ty0 = go where +typeSubstClosedType :: + Eq tyname => tyname -> Type tyname uni a -> Type tyname uni a -> Type tyname uni a +typeSubstClosedType tn0 ty0 = go + where go = \case - TyVar a tn -> if tn == tn0 then ty0 else TyVar a tn - TyForall a tn k ty -> TyForall a tn k (goUnder tn ty) - TyLam a tn k ty -> TyLam a tn k (goUnder tn ty) - ty -> ty & over typeSubtypes go + TyVar a tn -> if tn == tn0 then ty0 else TyVar a tn + TyForall a tn k ty -> TyForall a tn k (goUnder tn ty) + TyLam a tn k ty -> TyLam a tn k (goUnder tn ty) + ty -> ty & over typeSubtypes go goUnder tn ty = if tn == tn0 then ty else go ty -- | Substitute the given closed 'Type' for the given type variable in the given 'Term'. Does not -- descend under binders that bind the same variable as the one we're substituting for (since from -- there that variable is no longer free). The resulting 'Term' may and likely will not satisfy -- global uniqueness. -termSubstClosedType - :: Eq tyname - => tyname -> Type tyname uni a -> Term tyname name uni fun a -> Term tyname name uni fun a -termSubstClosedType tn0 ty0 = go where +termSubstClosedType :: + Eq tyname => + tyname -> Type tyname uni a -> Term tyname name uni fun a -> Term tyname name uni fun a +termSubstClosedType tn0 ty0 = go + where go = \case - TyAbs a tn k body -> TyAbs a tn k (goUnder tn body) - t -> t & over termSubtypes goTy & over termSubterms go + TyAbs a tn k body -> TyAbs a tn k (goUnder tn body) + t -> t & over termSubtypes goTy & over termSubterms go goUnder tn term = if tn == tn0 then term else go term goTy = typeSubstClosedType tn0 ty0 @@ -156,70 +159,71 @@ termSubstClosedType tn0 ty0 = go where -- descend under binders that bind the same variable as the one we're substituting for (since from -- there that variable is no longer free). The resulting 'Term' may and likely will not satisfy -- global uniqueness. -termSubstClosedTerm - :: Eq name - => name - -> Term tyname name uni fun a - -> Term tyname name uni fun a - -> Term tyname name uni fun a -termSubstClosedTerm varFor new = go where +termSubstClosedTerm :: + Eq name => + name -> + Term tyname name uni fun a -> + Term tyname name uni fun a -> + Term tyname name uni fun a +termSubstClosedTerm varFor new = go + where go = \case - Var a var -> if var == varFor then new else Var a var - LamAbs a var ty body -> LamAbs a var ty (goUnder var body) - t -> t & over termSubterms go + Var a var -> if var == varFor then new else Var a var + LamAbs a var ty body -> LamAbs a var ty (goUnder var body) + t -> t & over termSubterms go goUnder var term = if var == varFor then term else go term -- Mapping name-modification functions over types and terms. -typeMapNames - :: forall tyname tyname' uni ann - . (tyname -> tyname') - -> Type tyname uni ann - -> Type tyname' uni ann +typeMapNames :: + forall tyname tyname' uni ann. + (tyname -> tyname') -> + Type tyname uni ann -> + Type tyname' uni ann typeMapNames f = go - where - go :: Type tyname uni ann -> Type tyname' uni ann - go = \case - TyVar ann tn -> TyVar ann (f tn) - TyFun ann ty1 ty2 -> TyFun ann (go ty1) (go ty2) - TyIFix ann ty1 ty2 -> TyIFix ann (go ty1) (go ty2) - TyForall ann tn k ty -> TyForall ann (f tn) k (go ty) - TyBuiltin ann s -> TyBuiltin ann s - TyLam ann tn k ty -> TyLam ann (f tn) k (go ty) - TyApp ann ty1 ty2 -> TyApp ann (go ty1) (go ty2) - TySOP ann tyls -> TySOP ann ((fmap . fmap) go tyls) + where + go :: Type tyname uni ann -> Type tyname' uni ann + go = \case + TyVar ann tn -> TyVar ann (f tn) + TyFun ann ty1 ty2 -> TyFun ann (go ty1) (go ty2) + TyIFix ann ty1 ty2 -> TyIFix ann (go ty1) (go ty2) + TyForall ann tn k ty -> TyForall ann (f tn) k (go ty) + TyBuiltin ann s -> TyBuiltin ann s + TyLam ann tn k ty -> TyLam ann (f tn) k (go ty) + TyApp ann ty1 ty2 -> TyApp ann (go ty1) (go ty2) + TySOP ann tyls -> TySOP ann ((fmap . fmap) go tyls) -- termMapNames requires two function arguments: one (called f) to modify type names -- and another (called g) to modify variable names. -termMapNames - :: forall tyname tyname' name name' uni fun ann - . (tyname -> tyname') - -> (name -> name') - -> Term tyname name uni fun ann - -> Term tyname' name' uni fun ann +termMapNames :: + forall tyname tyname' name name' uni fun ann. + (tyname -> tyname') -> + (name -> name') -> + Term tyname name uni fun ann -> + Term tyname' name' uni fun ann termMapNames f g = go - where - go :: Term tyname name uni fun ann -> Term tyname' name' uni fun ann - go = \case - LamAbs ann name ty body -> LamAbs ann (g name) (typeMapNames f ty) (go body) - TyAbs ann tyname k body -> TyAbs ann (f tyname) k (go body) - Var ann name -> Var ann (g name) - Apply ann t1 t2 -> Apply ann (go t1) (go t2) - Constant ann c -> Constant ann c - Builtin ann b -> Builtin ann b - TyInst ann body ty -> TyInst ann (go body) (typeMapNames f ty) - Unwrap ann body -> Unwrap ann (go body) - IWrap ann ty1 ty2 body -> IWrap ann (typeMapNames f ty1) (typeMapNames f ty2) (go body) - Constr ann ty i es -> Constr ann (typeMapNames f ty) i (fmap go es) - Case ann ty arg cs -> Case ann (typeMapNames f ty) (go arg) (fmap go cs) - Error ann ty -> Error ann (typeMapNames f ty) - -programMapNames - :: forall tyname tyname' name name' uni fun ann - . (tyname -> tyname') - -> (name -> name') - -> Program tyname name uni fun ann - -> Program tyname' name' uni fun ann + where + go :: Term tyname name uni fun ann -> Term tyname' name' uni fun ann + go = \case + LamAbs ann name ty body -> LamAbs ann (g name) (typeMapNames f ty) (go body) + TyAbs ann tyname k body -> TyAbs ann (f tyname) k (go body) + Var ann name -> Var ann (g name) + Apply ann t1 t2 -> Apply ann (go t1) (go t2) + Constant ann c -> Constant ann c + Builtin ann b -> Builtin ann b + TyInst ann body ty -> TyInst ann (go body) (typeMapNames f ty) + Unwrap ann body -> Unwrap ann (go body) + IWrap ann ty1 ty2 body -> IWrap ann (typeMapNames f ty1) (typeMapNames f ty2) (go body) + Constr ann ty i es -> Constr ann (typeMapNames f ty) i (fmap go es) + Case ann ty arg cs -> Case ann (typeMapNames f ty) (go arg) (fmap go cs) + Error ann ty -> Error ann (typeMapNames f ty) + +programMapNames :: + forall tyname tyname' name name' uni fun ann. + (tyname -> tyname') -> + (name -> name') -> + Program tyname name uni fun ann -> + Program tyname' name' uni fun ann programMapNames f g (Program a v term) = Program a v (termMapNames f g term) -- Free variables @@ -228,46 +232,46 @@ programMapNames f g (Program a v term) = Program a v (termMapNames f g term) fvTerm :: HasUnique name unique => Traversal' (Term tyname name uni fun ann) name fvTerm = fvTermCtx mempty -fvTermCtx - :: HasUnique name unique - => UniqueSet unique -> Traversal' (Term tyname name uni fun ann) name +fvTermCtx :: + HasUnique name unique => + UniqueSet unique -> Traversal' (Term tyname name uni fun ann) name fvTermCtx bound f = \case - Var a n -> Var a <$> (if USet.memberByName n bound then pure n else f n) - LamAbs a n ty t -> LamAbs a n ty <$> fvTermCtx (USet.insertByName n bound) f t - t -> (termSubterms . fvTermCtx bound) f t + Var a n -> Var a <$> (if USet.memberByName n bound then pure n else f n) + LamAbs a n ty t -> LamAbs a n ty <$> fvTermCtx (USet.insertByName n bound) f t + t -> (termSubterms . fvTermCtx bound) f t -- | Get all the free type variables in a term. ftvTerm :: HasUnique tyname unique => Traversal' (Term tyname name uni fun ann) tyname ftvTerm = ftvTermCtx mempty -ftvTermCtx - :: HasUnique tyname unique - => UniqueSet unique - -> Traversal' (Term tyname name uni fun ann) tyname +ftvTermCtx :: + HasUnique tyname unique => + UniqueSet unique -> + Traversal' (Term tyname name uni fun ann) tyname ftvTermCtx bound f = \case - TyAbs a ty k t -> TyAbs a ty k <$> ftvTermCtx (USet.insertByName ty bound) f t - -- sound because the subterms and subtypes are disjoint - t -> - ((termSubterms . ftvTermCtx bound) `Unsound.adjoin` (termSubtypes . ftvTyCtx bound)) f t + TyAbs a ty k t -> TyAbs a ty k <$> ftvTermCtx (USet.insertByName ty bound) f t + -- sound because the subterms and subtypes are disjoint + t -> + ((termSubterms . ftvTermCtx bound) `Unsound.adjoin` (termSubtypes . ftvTyCtx bound)) f t -- | Get all the free type variables in a type. -ftvTy - :: HasUnique tyname unique => - Traversal' (Type tyname uni ann) tyname +ftvTy :: + HasUnique tyname unique => + Traversal' (Type tyname uni ann) tyname ftvTy = ftvTyCtx mempty -ftvTyCtx - :: HasUnique tyname unique - => UniqueSet unique - -> Traversal' (Type tyname uni ann) tyname +ftvTyCtx :: + HasUnique tyname unique => + UniqueSet unique -> + Traversal' (Type tyname uni ann) tyname ftvTyCtx bound f = \case - TyVar a ty -> TyVar a <$> (if USet.memberByName ty bound then pure ty else f ty) - TyForall a bnd k ty -> TyForall a bnd k <$> ftvTyCtx (USet.insertByName bnd bound) f ty - TyLam a bnd k ty -> TyLam a bnd k <$> ftvTyCtx (USet.insertByName bnd bound) f ty - t -> (typeSubtypes . ftvTyCtx bound) f t - + TyVar a ty -> TyVar a <$> (if USet.memberByName ty bound then pure ty else f ty) + TyForall a bnd k ty -> TyForall a bnd k <$> ftvTyCtx (USet.insertByName bnd bound) f ty + TyLam a bnd k ty -> TyLam a bnd k <$> ftvTyCtx (USet.insertByName bnd bound) f ty + t -> (typeSubtypes . ftvTyCtx bound) f t -- TODO: these could be Traversals + -- | Get all the term variables in a term. vTerm :: Fold (Term tyname name uni fun ann) name vTerm = termSubtermsDeep . termVars @@ -281,32 +285,32 @@ tvTy :: Fold (Type tyname uni ann) tyname tvTy = typeSubtypesDeep . typeTyVars -- | Applicatively replace a constant using the given function. -substConstantA - :: Applicative f - => (ann -> Some (ValueOf uni) -> f (Maybe (Term tyname name uni fun ann))) - -> Term tyname name uni fun ann - -> f (Term tyname name uni fun ann) +substConstantA :: + Applicative f => + (ann -> Some (ValueOf uni) -> f (Maybe (Term tyname name uni fun ann))) -> + Term tyname name uni fun ann -> + f (Term tyname name uni fun ann) substConstantA valF t@(Constant ann val) = fromMaybe t <$> valF ann val -substConstantA _ t = pure t +substConstantA _ t = pure t -- | Replace a constant using the given function. -substConstant - :: (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann +substConstant :: + (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann substConstant = purely (substConstantA . curry) . uncurry -- | Monadically substitute constants using the given function. -termSubstConstantsM - :: Monad m - => (ann -> Some (ValueOf uni) -> m (Maybe (Term tyname name uni fun ann))) - -> Term tyname name uni fun ann - -> m (Term tyname name uni fun ann) +termSubstConstantsM :: + Monad m => + (ann -> Some (ValueOf uni) -> m (Maybe (Term tyname name uni fun ann))) -> + Term tyname name uni fun ann -> + m (Term tyname name uni fun ann) termSubstConstantsM = transformMOf termSubterms . substConstantA -- | Substitute constants using the given function. -termSubstConstants - :: (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann +termSubstConstants :: + (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann termSubstConstants = purely (termSubstConstantsM . curry) . uncurry diff --git a/plutus-core/plutus-core/src/PlutusCore/TypeCheck.hs b/plutus-core/plutus-core/src/PlutusCore/TypeCheck.hs index 5e6f10e8283..6a2428b0cdd 100644 --- a/plutus-core/plutus-core/src/PlutusCore/TypeCheck.hs +++ b/plutus-core/plutus-core/src/PlutusCore/TypeCheck.hs @@ -1,30 +1,31 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + -- | Kind/type inference/checking. +module PlutusCore.TypeCheck ( + ToKind, + MonadKindCheck, + MonadTypeCheck, + TypeErrorPlc, + Typecheckable, -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} + -- * Configuration. + BuiltinTypes (..), + KindCheckConfig (..), + TypeCheckConfig (..), + tccBuiltinTypes, + defKindCheckConfig, + builtinMeaningsToTypes, + getDefTypeCheckConfig, -module PlutusCore.TypeCheck - ( ToKind - , MonadKindCheck - , MonadTypeCheck - , TypeErrorPlc - , Typecheckable - -- * Configuration. - , BuiltinTypes (..) - , KindCheckConfig (..) - , TypeCheckConfig (..) - , tccBuiltinTypes - , defKindCheckConfig - , builtinMeaningsToTypes - , getDefTypeCheckConfig - -- * Kind/type inference/checking. - , inferKind - , checkKind - , inferType - , checkType - , inferTypeOfProgram - , checkTypeOfProgram - ) where + -- * Kind/type inference/checking. + inferKind, + checkKind, + inferType, + checkType, + inferTypeOfProgram, + checkTypeOfProgram, +) where import PlutusPrelude @@ -46,7 +47,7 @@ import PlutusCore.TypeCheck.Internal -- type checking, since it's only needed for computing 'BuiltinTypes', which is passed as a regular -- argument to the worker of the type checker. type Typecheckable uni fun = - (ToKind uni, HasUniApply uni, ToBuiltinMeaning uni fun, AnnotateCaseBuiltin uni) + (ToKind uni, HasUniApply uni, ToBuiltinMeaning uni fun, AnnotateCaseBuiltin uni) -- | The default kind checking config. defKindCheckConfig :: KindCheckConfig @@ -54,76 +55,76 @@ defKindCheckConfig = KindCheckConfig DetectNameMismatches -- | Extract the 'TypeScheme' from a 'BuiltinMeaning' and convert it to the -- corresponding 'Type' for each built-in function. -builtinMeaningsToTypes - :: (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, Typecheckable uni fun) - => BuiltinSemanticsVariant fun - -> ann - -> m (BuiltinTypes uni fun) +builtinMeaningsToTypes :: + (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, Typecheckable uni fun) => + BuiltinSemanticsVariant fun -> + ann -> + m (BuiltinTypes uni fun) builtinMeaningsToTypes semvar ann = - runQuoteT . fmap BuiltinTypes . sequence . tabulateArray $ \fun -> do - let ty = typeOfBuiltinFunction semvar fun - _ <- inferKind defKindCheckConfig $ ann <$ ty - dupable <$> normalizeType ty + runQuoteT . fmap BuiltinTypes . sequence . tabulateArray $ \fun -> do + let ty = typeOfBuiltinFunction semvar fun + _ <- inferKind defKindCheckConfig $ ann <$ ty + dupable <$> normalizeType ty -- | Get the default type checking config. -getDefTypeCheckConfig - :: (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, Typecheckable uni fun) - => ann -> m (TypeCheckConfig uni fun) +getDefTypeCheckConfig :: + (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, Typecheckable uni fun) => + ann -> m (TypeCheckConfig uni fun) getDefTypeCheckConfig ann = - TypeCheckConfig defKindCheckConfig <$> builtinMeaningsToTypes def ann + TypeCheckConfig defKindCheckConfig <$> builtinMeaningsToTypes def ann -- | Infer the kind of a type. -inferKind - :: MonadKindCheck (TypeError term uni fun ann) term uni fun ann m - => KindCheckConfig -> Type TyName uni ann -> m (Kind ()) +inferKind :: + MonadKindCheck (TypeError term uni fun ann) term uni fun ann m => + KindCheckConfig -> Type TyName uni ann -> m (Kind ()) inferKind config = runTypeCheckM config . inferKindM -- | Check a type against a kind. -- Infers the kind of the type and checks that it's equal to the given kind -- throwing a 'TypeError' (annotated with the value of the @ann@ argument) otherwise. -checkKind - :: MonadKindCheck (TypeError term uni fun ann) term uni fun ann m - => KindCheckConfig -> ann -> Type TyName uni ann -> Kind () -> m () +checkKind :: + MonadKindCheck (TypeError term uni fun ann) term uni fun ann m => + KindCheckConfig -> ann -> Type TyName uni ann -> Kind () -> m () checkKind config ann ty = runTypeCheckM config . checkKindM ann ty -- | Infer the type of a term. -inferType - :: MonadTypeCheckPlc uni fun ann m - => TypeCheckConfig uni fun - -> Term TyName Name uni fun ann - -> m (Normalized (Type TyName uni ())) +inferType :: + MonadTypeCheckPlc uni fun ann m => + TypeCheckConfig uni fun -> + Term TyName Name uni fun ann -> + m (Normalized (Type TyName uni ())) inferType config = rename >=> runTypeCheckM config . inferTypeM -- | Check a term against a type. -- Infers the type of the term and checks that it's equal to the given type -- throwing a 'TypeError' (annotated with the value of the @ann@ argument) otherwise. -checkType - :: MonadTypeCheckPlc uni fun ann m - => TypeCheckConfig uni fun - -> ann - -> Term TyName Name uni fun ann - -> Normalized (Type TyName uni ()) - -> m () +checkType :: + MonadTypeCheckPlc uni fun ann m => + TypeCheckConfig uni fun -> + ann -> + Term TyName Name uni fun ann -> + Normalized (Type TyName uni ()) -> + m () checkType config ann term ty = do - termRen <- rename term - runTypeCheckM config $ checkTypeM ann termRen ty + termRen <- rename term + runTypeCheckM config $ checkTypeM ann termRen ty -- | Infer the type of a program. -inferTypeOfProgram - :: MonadTypeCheckPlc uni fun ann m - => TypeCheckConfig uni fun - -> Program TyName Name uni fun ann - -> m (Normalized (Type TyName uni ())) +inferTypeOfProgram :: + MonadTypeCheckPlc uni fun ann m => + TypeCheckConfig uni fun -> + Program TyName Name uni fun ann -> + m (Normalized (Type TyName uni ())) inferTypeOfProgram config (Program _ _ term) = inferType config term -- | Check a program against a type. -- Infers the type of the program and checks that it's equal to the given type -- throwing a 'TypeError' (annotated with the value of the @ann@ argument) otherwise. -checkTypeOfProgram - :: MonadTypeCheckPlc uni fun ann m - => TypeCheckConfig uni fun - -> ann - -> Program TyName Name uni fun ann - -> Normalized (Type TyName uni ()) - -> m () +checkTypeOfProgram :: + MonadTypeCheckPlc uni fun ann m => + TypeCheckConfig uni fun -> + ann -> + Program TyName Name uni fun ann -> + Normalized (Type TyName uni ()) -> + m () checkTypeOfProgram config ann (Program _ _ term) = checkType config ann term diff --git a/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs index 08d36f237ba..22ef6ffe6b7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs @@ -1,29 +1,34 @@ -- editorconfig-checker-disable-file --- | The internal module of the type checker that defines the actual algorithms, --- but not the user-facing API. - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE StrictData #-} - -module PlutusCore.TypeCheck.Internal - ( -- export all because a lot are used by the pir-typechecker - module PlutusCore.TypeCheck.Internal - , MonadNormalizeType - ) where +-- | The internal module of the type checker that defines the actual algorithms, +-- but not the user-facing API. +module PlutusCore.TypeCheck.Internal ( + -- export all because a lot are used by the pir-typechecker + module PlutusCore.TypeCheck.Internal, + MonadNormalizeType, +) where import PlutusCore.Builtin import PlutusCore.Core.Type (Kind (..), Normalized (..), Term (..), Type (..), toPatFuncKind) import PlutusCore.Error (ExpectedShapeOr (ExpectedExact, ExpectedShape), TypeError (..)) import PlutusCore.MkPlc (mkIterTyAppNoAnn, mkIterTyFun, mkTyBuiltinOf) -import PlutusCore.Name.Unique (HasText (theText), Name (Name), Named (Named), TermUnique, - TyName (TyName), TypeUnique, theUnique) +import PlutusCore.Name.Unique ( + HasText (theText), + Name (Name), + Named (Named), + TermUnique, + TyName (TyName), + TypeUnique, + theUnique, + ) import PlutusCore.Name.UniqueMap (UniqueMap, insertNamed, lookupName) import PlutusCore.Normalize.Internal (MonadNormalizeType) import PlutusCore.Normalize.Internal qualified as Norm @@ -34,6 +39,7 @@ import PlutusPrelude (Lens', lens, over, view, void, zipExact, (<<$>>), (<<*>>), import Control.Lens (Ixed (ix), makeClassy, makeLenses, preview, (^?)) import Control.Monad (when) import Control.Monad.Except (MonadError, throwError) + -- Using @transformers@ rather than @mtl@, because the former doesn't impose the 'Monad' constraint -- on 'local'. import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask, local) @@ -92,8 +98,8 @@ functions that cannot fail look like this: -- | Mapping from 'Builtin's to their 'Normalized' 'Type's. newtype BuiltinTypes uni fun = BuiltinTypes - { unBuiltinTypes :: Array fun (Dupable (Normalized (Type TyName uni ()))) - } + { unBuiltinTypes :: Array fun (Dupable (Normalized (Type TyName uni ()))) + } type TyVarKinds = UniqueMap TypeUnique (Named (Kind ())) type VarTypes uni = UniqueMap TermUnique (Named (Dupable (Normalized (Type TyName uni ())))) @@ -110,9 +116,11 @@ type VarTypes uni = UniqueMap TermUnique (Named (Dupable (Normalized (Type TyNam -- -- We perform the same check for term-level variables too. data HandleNameMismatches - = DetectNameMismatches -- ^ Throw upon encountering such a name. - | IgnoreNameMismatches -- ^ Ignore it. - deriving stock (Show, Eq) + = -- | Throw upon encountering such a name. + DetectNameMismatches + | -- | Ignore it. + IgnoreNameMismatches + deriving stock (Show, Eq) {- Note [Alignment of kind and type checker configs] Kind checking is performed as a part of type checking meaning we always need a kind checking config @@ -147,42 +155,44 @@ but it's not much and it doesn't proliferate into user space unlike with the oth -- | Configuration of the kind checker. newtype KindCheckConfig = KindCheckConfig - { _kccHandleNameMismatches :: HandleNameMismatches - } + { _kccHandleNameMismatches :: HandleNameMismatches + } + makeClassy ''KindCheckConfig -- | Configuration of the type checker. data TypeCheckConfig uni fun = TypeCheckConfig - { _tccKindCheckConfig :: KindCheckConfig - , _tccBuiltinTypes :: BuiltinTypes uni fun - } + { _tccKindCheckConfig :: KindCheckConfig + , _tccBuiltinTypes :: BuiltinTypes uni fun + } -- | We want 'HasKindCheckConfig' to be a superclass of 'HasTypeCheckConfig' for being able to -- seamlessly call the kind checker from the type checker, hence we're rolling out our own -- 'makeClassy' here just to add the constraint. class HasKindCheckConfig cfg => HasTypeCheckConfig cfg uni fun | cfg -> uni fun where - typeCheckConfig :: Lens' cfg (TypeCheckConfig uni fun) + typeCheckConfig :: Lens' cfg (TypeCheckConfig uni fun) - tccKindCheckConfig :: Lens' cfg KindCheckConfig - tccKindCheckConfig = - typeCheckConfig . lens _tccKindCheckConfig (\s b -> s { _tccKindCheckConfig = b }) + tccKindCheckConfig :: Lens' cfg KindCheckConfig + tccKindCheckConfig = + typeCheckConfig . lens _tccKindCheckConfig (\s b -> s {_tccKindCheckConfig = b}) - tccBuiltinTypes :: Lens' cfg (BuiltinTypes uni fun) - tccBuiltinTypes = - typeCheckConfig . lens _tccBuiltinTypes (\s b -> s { _tccBuiltinTypes = b }) + tccBuiltinTypes :: Lens' cfg (BuiltinTypes uni fun) + tccBuiltinTypes = + typeCheckConfig . lens _tccBuiltinTypes (\s b -> s {_tccBuiltinTypes = b}) instance HasKindCheckConfig (TypeCheckConfig uni fun) where - kindCheckConfig = tccKindCheckConfig + kindCheckConfig = tccKindCheckConfig instance HasTypeCheckConfig (TypeCheckConfig uni fun) uni fun where - typeCheckConfig = id + typeCheckConfig = id -- | The environment that the type checker runs in. data TypeCheckEnv uni fun cfg = TypeCheckEnv - { _tceTypeCheckConfig :: cfg - , _tceTyVarKinds :: TyVarKinds - , _tceVarTypes :: VarTypes uni - } + { _tceTypeCheckConfig :: cfg + , _tceTyVarKinds :: TyVarKinds + , _tceVarTypes :: VarTypes uni + } + makeLenses ''TypeCheckEnv -- | The type checking monad that the type checker runs in. @@ -191,29 +201,33 @@ type TypeCheckT uni fun cfg m = ReaderT (TypeCheckEnv uni fun cfg) m -- | The constraints that are required for kind checking. type MonadKindCheck err term uni fun ann m = - ( MonadError err m -- Kind/type checking can fail - , ToKind uni -- For getting the kind of a built-in type. - ) + ( MonadError err m -- Kind/type checking can fail + , ToKind uni -- For getting the kind of a built-in type. + ) -- | The general constraints that are required for type checking a Plutus AST. type MonadTypeCheck err term uni fun ann m = - ( MonadKindCheck err term uni fun ann m -- Kind checking is run during type checking (this - -- includes the constraint for throwing errors). - , Norm.MonadNormalizeType uni m -- Type lambdas open up type computation. - , AnnotateCaseBuiltin uni - , GEq uni -- For checking equality of built-in types. - , Ix fun -- For indexing into the precomputed array of - -- types of built-in functions. - ) + ( MonadKindCheck err term uni fun ann m -- Kind checking is run during type checking (this + -- includes the constraint for throwing errors). + , Norm.MonadNormalizeType uni m -- Type lambdas open up type computation. + , AnnotateCaseBuiltin uni + , GEq uni -- For checking equality of built-in types. + , Ix fun -- For indexing into the precomputed array of + -- types of built-in functions. + ) -- | The PLC type error type. type TypeErrorPlc uni fun ann = TypeError (Term TyName Name uni fun ()) uni fun ann -- | The constraints that are required for type checking Plutus Core. type MonadTypeCheckPlc uni fun ann m = - MonadTypeCheck - (TypeErrorPlc uni fun ann) - (Term TyName Name uni fun ()) uni fun ann m + MonadTypeCheck + (TypeErrorPlc uni fun ann) + (Term TyName Name uni fun ()) + uni + fun + ann + m -- ######################### -- ## Auxiliary functions ## @@ -234,74 +248,79 @@ withTyVar :: TyName -> Kind () -> TypeCheckT uni fun cfg m a -> TypeCheckT uni f withTyVar name = local . over tceTyVarKinds . insertNamed name -- | Look up the type of a built-in function. -lookupBuiltinM - :: (MonadTypeCheck (TypeError term uni fun ann) term uni fun ann m, HasTypeCheckConfig cfg uni fun) - => ann -> fun -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) +lookupBuiltinM :: + (MonadTypeCheck (TypeError term uni fun ann) term uni fun ann m, HasTypeCheckConfig cfg uni fun) => + ann -> fun -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) lookupBuiltinM ann fun = do - BuiltinTypes arr <- view $ tceTypeCheckConfig . tccBuiltinTypes - -- Believe it or not, but 'Data.Array' doesn't seem to expose any way of indexing into an array - -- safely. - case preview (ix fun) arr of - Nothing -> throwError $ UnknownBuiltinFunctionE ann fun - Just ty -> liftDupable ty + BuiltinTypes arr <- view $ tceTypeCheckConfig . tccBuiltinTypes + -- Believe it or not, but 'Data.Array' doesn't seem to expose any way of indexing into an array + -- safely. + case preview (ix fun) arr of + Nothing -> throwError $ UnknownBuiltinFunctionE ann fun + Just ty -> liftDupable ty -- | Extend the context of a 'TypeCheckM' computation with a typed variable. -withVar - :: Name - -> Normalized (Type TyName uni ()) - -> TypeCheckT uni fun cfg m a - -> TypeCheckT uni fun cfg m a +withVar :: + Name -> + Normalized (Type TyName uni ()) -> + TypeCheckT uni fun cfg m a -> + TypeCheckT uni fun cfg m a withVar name = local . over tceVarTypes . insertNamed name . dupable -- | Look up a type variable in the current context. -lookupTyVarM - :: (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, HasKindCheckConfig cfg) - => ann -> TyName -> TypeCheckT uni fun cfg m (Kind ()) +lookupTyVarM :: + (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, HasKindCheckConfig cfg) => + ann -> TyName -> TypeCheckT uni fun cfg m (Kind ()) lookupTyVarM ann name = do - env <- ask - let handleNameMismatches = env ^. tceTypeCheckConfig . kccHandleNameMismatches - case lookupName name $ _tceTyVarKinds env of - Nothing -> throwError $ FreeTypeVariableE ann name - Just (Named nameOrig kind) -> - if handleNameMismatches == IgnoreNameMismatches || view theText name == nameOrig - then pure kind - else throwError $ - TyNameMismatch ann (TyName . Name nameOrig $ name ^. theUnique) name + env <- ask + let handleNameMismatches = env ^. tceTypeCheckConfig . kccHandleNameMismatches + case lookupName name $ _tceTyVarKinds env of + Nothing -> throwError $ FreeTypeVariableE ann name + Just (Named nameOrig kind) -> + if handleNameMismatches == IgnoreNameMismatches || view theText name == nameOrig + then pure kind + else + throwError $ + TyNameMismatch ann (TyName . Name nameOrig $ name ^. theUnique) name -- | Look up a term variable in the current context. -lookupVarM - :: (MonadTypeCheck (TypeError term uni fun ann) term uni fun ann m, HasTypeCheckConfig cfg uni fun) - => ann -> Name -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) +lookupVarM :: + (MonadTypeCheck (TypeError term uni fun ann) term uni fun ann m, HasTypeCheckConfig cfg uni fun) => + ann -> Name -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) lookupVarM ann name = do - env <- ask - let handleNameMismatches = - env ^. tceTypeCheckConfig . tccKindCheckConfig . kccHandleNameMismatches - case lookupName name $ _tceVarTypes env of - Nothing -> throwError $ FreeVariableE ann name - Just (Named nameOrig ty) -> - if handleNameMismatches == IgnoreNameMismatches || view theText name == nameOrig - then liftDupable ty - else throwError $ - NameMismatch ann (Name nameOrig $ name ^. theUnique) name + env <- ask + let handleNameMismatches = + env ^. tceTypeCheckConfig . tccKindCheckConfig . kccHandleNameMismatches + case lookupName name $ _tceVarTypes env of + Nothing -> throwError $ FreeVariableE ann name + Just (Named nameOrig ty) -> + if handleNameMismatches == IgnoreNameMismatches || view theText name == nameOrig + then liftDupable ty + else + throwError $ + NameMismatch ann (Name nameOrig $ name ^. theUnique) name -- ######################## -- ## Type normalization ## -- ######################## -- | Normalize a 'Type'. -normalizeTypeM - :: MonadNormalizeType uni m - => Type TyName uni ann - -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ann)) +normalizeTypeM :: + MonadNormalizeType uni m => + Type TyName uni ann -> + TypeCheckT uni fun cfg m (Normalized (Type TyName uni ann)) normalizeTypeM ty = Norm.runNormalizeTypeT $ Norm.normalizeTypeM ty -- | Substitute a type for a variable in a type and normalize the result. -substNormalizeTypeM - :: MonadNormalizeType uni m - => Normalized (Type TyName uni ()) -- ^ @ty@ - -> TyName -- ^ @name@ - -> Type TyName uni () -- ^ @body@ - -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) +substNormalizeTypeM :: + MonadNormalizeType uni m => + -- | @ty@ + Normalized (Type TyName uni ()) -> + -- | @name@ + TyName -> + -- | @body@ + Type TyName uni () -> + TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) substNormalizeTypeM ty name body = Norm.runNormalizeTypeT $ Norm.substNormalizeTypeM ty name body -- ################### @@ -309,250 +328,247 @@ substNormalizeTypeM ty name body = Norm.runNormalizeTypeT $ Norm.substNormalizeT -- ################### -- | Infer the kind of a type. -inferKindM - :: (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, HasKindCheckConfig cfg) - => Type TyName uni ann -> TypeCheckT uni fun cfg m (Kind ()) - +inferKindM :: + (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, HasKindCheckConfig cfg) => + Type TyName uni ann -> TypeCheckT uni fun cfg m (Kind ()) -- b :: k -- ------------------------ -- [infer| G !- con b :: k] inferKindM (TyBuiltin _ (SomeTypeIn uni)) = - pure $ kindOfBuiltinType uni - + pure $ kindOfBuiltinType uni -- [infer| G !- v :: k] -- ------------------------ -- [infer| G !- var v :: k] -inferKindM (TyVar ann v) = - lookupTyVarM ann v - +inferKindM (TyVar ann v) = + lookupTyVarM ann v -- [infer| G , n :: dom !- body :: cod] -- ------------------------------------------------- -- [infer| G !- (\(n :: dom) -> body) :: dom -> cod] -inferKindM (TyLam _ n dom body) = do - let dom_ = void dom - withTyVar n dom_ $ KindArrow () dom_ <$> inferKindM body +inferKindM (TyLam _ n dom body) = do + let dom_ = void dom + withTyVar n dom_ $ KindArrow () dom_ <$> inferKindM body -- [infer| G !- fun :: dom -> cod] [check| G !- arg :: dom] -- ----------------------------------------------------------- -- [infer| G !- fun arg :: cod] -inferKindM (TyApp ann fun arg) = do - funKind <- inferKindM fun - case funKind of - KindArrow _ dom cod -> do - checkKindM ann arg dom - pure cod - _ -> do - let expectedKindArrow = ExpectedShape "fun k l" ["k", "l"] - throwError $ KindMismatch ann (void fun) expectedKindArrow funKind +inferKindM (TyApp ann fun arg) = do + funKind <- inferKindM fun + case funKind of + KindArrow _ dom cod -> do + checkKindM ann arg dom + pure cod + _ -> do + let expectedKindArrow = ExpectedShape "fun k l" ["k", "l"] + throwError $ KindMismatch ann (void fun) expectedKindArrow funKind -- [check| G !- a :: *] [check| G !- b :: *] -- -------------------------------------------- -- [infer| G !- a -> b :: *] -inferKindM (TyFun ann dom cod) = do - checkKindM ann dom $ Type () - checkKindM ann cod $ Type () - pure $ Type () +inferKindM (TyFun ann dom cod) = do + checkKindM ann dom $ Type () + checkKindM ann cod $ Type () + pure $ Type () -- [check| G , n :: k !- body :: *] -- --------------------------------------- -- [infer| G !- (all (n :: k). body) :: *] inferKindM (TyForall ann n k body) = do - withTyVar n (void k) $ checkKindM ann body (Type ()) - pure $ Type () - + withTyVar n (void k) $ checkKindM ann body (Type ()) + pure $ Type () -- [infer| G !- arg :: k] [check| G !- pat :: (k -> *) -> k -> *] -- ----------------------------------------------------------------- -- [infer| G !- ifix pat arg :: *] -inferKindM (TyIFix ann pat arg) = do - k <- inferKindM arg - checkKindM ann pat $ toPatFuncKind k - pure $ Type () +inferKindM (TyIFix ann pat arg) = do + k <- inferKindM arg + checkKindM ann pat $ toPatFuncKind k + pure $ Type () -- s_0 = [p_0_0 ... p_0_m] [check| G !- p_0_0 :: *] ... [check| G !- p_0_m :: *] -- ... -- s_n = [p_n_0 ... p_n_m] [check| G !- p_n_0 :: *] ... [check| G !- p_n_m :: *] -- ------------------------------------------------------------------------------- -- [infer| G !- sop s_0 ... s_n :: *] -inferKindM (TySOP ann tyls) = do - for_ tyls $ \tyl -> for_ tyl $ \ty -> checkKindM ann ty (Type ()) - pure $ Type () +inferKindM (TySOP ann tyls) = do + for_ tyls $ \tyl -> for_ tyl $ \ty -> checkKindM ann ty (Type ()) + pure $ Type () -- | Check a 'Type' against a 'Kind'. -checkKindM - :: (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, HasKindCheckConfig cfg) - => ann -> Type TyName uni ann -> Kind () -> TypeCheckT uni fun cfg m () - +checkKindM :: + (MonadKindCheck (TypeError term uni fun ann) term uni fun ann m, HasKindCheckConfig cfg) => + ann -> Type TyName uni ann -> Kind () -> TypeCheckT uni fun cfg m () -- [infer| G !- ty : tyK] tyK ~ k -- --------------------------------- -- [check| G !- ty : k] checkKindM ann ty k = do - tyK <- inferKindM ty - when (tyK /= k) $ throwError (KindMismatch ann (void ty) (ExpectedExact k) tyK) + tyK <- inferKindM ty + when (tyK /= k) $ throwError (KindMismatch ann (void ty) (ExpectedExact k) tyK) -- ################### -- ## Type checking ## -- ################### -- | @unfoldIFixOf pat arg k = NORM (vPat (\(a :: k) -> ifix vPat a) arg)@ -unfoldIFixOf - :: MonadNormalizeType uni m - => Normalized (Type TyName uni ()) -- ^ @vPat@ - -> Normalized (Type TyName uni ()) -- ^ @vArg@ - -> Kind () -- ^ @k@ - -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) +unfoldIFixOf :: + MonadNormalizeType uni m => + -- | @vPat@ + Normalized (Type TyName uni ()) -> + -- | @vArg@ + Normalized (Type TyName uni ()) -> + -- | @k@ + Kind () -> + TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) unfoldIFixOf pat arg k = do - let vPat = unNormalized pat - vArg = unNormalized arg - a <- liftQuote $ freshTyName "a" - -- We need to rename @vPat@, otherwise it would be used twice below, which would break global - -- uniqueness. Alternatively, we could use 'normalizeType' instead of 'normalizeTypeM' as the - -- former performs renaming before doing normalization, but renaming the entire type implicitly - -- would be less efficient than renaming a subpart of the type explicitly. - -- - -- Note however that breaking global uniqueness here most likely would not result in buggy - -- behavior, see https://github.com/IntersectMBO/plutus/pull/2219#issuecomment-672815272 - -- But breaking global uniqueness is a bad idea regardless. - vPat' <- rename vPat - normalizeTypeM $ - mkIterTyAppNoAnn vPat' - [ TyLam () a k . TyIFix () vPat $ TyVar () a - , vArg - ] + let vPat = unNormalized pat + vArg = unNormalized arg + a <- liftQuote $ freshTyName "a" + -- We need to rename @vPat@, otherwise it would be used twice below, which would break global + -- uniqueness. Alternatively, we could use 'normalizeType' instead of 'normalizeTypeM' as the + -- former performs renaming before doing normalization, but renaming the entire type implicitly + -- would be less efficient than renaming a subpart of the type explicitly. + -- + -- Note however that breaking global uniqueness here most likely would not result in buggy + -- behavior, see https://github.com/IntersectMBO/plutus/pull/2219#issuecomment-672815272 + -- But breaking global uniqueness is a bad idea regardless. + vPat' <- rename vPat + normalizeTypeM $ + mkIterTyAppNoAnn + vPat' + [ TyLam () a k . TyIFix () vPat $ TyVar () a + , vArg + ] -- See Note [Global uniqueness in the type checker]. -- See Note [Typing rules]. --- | Synthesize the type of a term, returning a normalized type. -inferTypeM - :: (MonadTypeCheckPlc uni fun ann m, HasTypeCheckConfig cfg uni fun) - => Term TyName Name uni fun ann -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) +-- | Synthesize the type of a term, returning a normalized type. +inferTypeM :: + (MonadTypeCheckPlc uni fun ann m, HasTypeCheckConfig cfg uni fun) => + Term TyName Name uni fun ann -> TypeCheckT uni fun cfg m (Normalized (Type TyName uni ())) -- c : vTy -- ------------------------- -- [infer| G !- con c : vTy] inferTypeM (Constant _ (Some (ValueOf uni _))) = - -- See Note [Normalization of built-in types]. - normalizeTypeM $ mkTyBuiltinOf () uni - + -- See Note [Normalization of built-in types]. + normalizeTypeM $ mkTyBuiltinOf () uni -- [infer| G !- bi : vTy] -- ------------------------------ -- [infer| G !- builtin bi : vTy] inferTypeM (Builtin ann fun) = - lookupBuiltinM ann fun - + lookupBuiltinM ann fun -- [infer| G !- v : ty] ty ~> vTy -- --------------------------------- -- [infer| G !- var v : vTy] inferTypeM (Var ann name) = - lookupVarM ann name - + lookupVarM ann name -- [check| G !- dom :: *] dom ~> vDom [infer| G , n : dom !- body : vCod] -- ---------------------------------------------------------------------------- -- [infer| G !- lam n dom body : vDom -> vCod] inferTypeM (LamAbs ann n dom body) = do - checkKindM ann dom $ Type () - vDom <- normalizeTypeM $ void dom - TyFun () <<$>> pure vDom <<*>> withVar n vDom (inferTypeM body) + checkKindM ann dom $ Type () + vDom <- normalizeTypeM $ void dom + TyFun () <<$>> pure vDom <<*>> withVar n vDom (inferTypeM body) -- [infer| G , n :: nK !- body : vBodyTy] -- --------------------------------------------------- -- [infer| G !- abs n nK body : all (n :: nK) vBodyTy] inferTypeM (TyAbs _ n nK body) = do - let nK_ = void nK - TyForall () n nK_ <<$>> withTyVar n nK_ (inferTypeM body) + let nK_ = void nK + TyForall () n nK_ <<$>> withTyVar n nK_ (inferTypeM body) -- [infer| G !- fun : vDom -> vCod] [check| G !- arg : vDom] -- ------------------------------------------------------------ -- [infer| G !- fun arg : vCod] inferTypeM (Apply ann fun arg) = do - vFunTy <- inferTypeM fun - case unNormalized vFunTy of - TyFun _ vDom vCod -> do - -- Subparts of a normalized type, so normalized. - checkTypeM ann arg $ Normalized vDom - pure $ Normalized vCod - _ -> do - let expectedTyFun = ExpectedShape "fun k l" ["k", "l"] - throwError (TypeMismatch ann (void fun) expectedTyFun vFunTy) + vFunTy <- inferTypeM fun + case unNormalized vFunTy of + TyFun _ vDom vCod -> do + -- Subparts of a normalized type, so normalized. + checkTypeM ann arg $ Normalized vDom + pure $ Normalized vCod + _ -> do + let expectedTyFun = ExpectedShape "fun k l" ["k", "l"] + throwError (TypeMismatch ann (void fun) expectedTyFun vFunTy) -- [infer| G !- body : all (n :: nK) vCod] [check| G !- ty :: tyK] ty ~> vTy -- ------------------------------------------------------------------------------- -- [infer| G !- body {ty} : NORM ([vTy / n] vCod)] inferTypeM (TyInst ann body ty) = do - vBodyTy <- inferTypeM body - case unNormalized vBodyTy of - TyForall _ n nK vCod -> do - checkKindM ann ty nK - vTy <- normalizeTypeM $ void ty - substNormalizeTypeM vTy n vCod - _ -> do - let expectedTyForall = ExpectedShape "all a kind body" ["a", "kind", "body"] - throwError (TypeMismatch ann (void body) expectedTyForall vBodyTy) + vBodyTy <- inferTypeM body + case unNormalized vBodyTy of + TyForall _ n nK vCod -> do + checkKindM ann ty nK + vTy <- normalizeTypeM $ void ty + substNormalizeTypeM vTy n vCod + _ -> do + let expectedTyForall = ExpectedShape "all a kind body" ["a", "kind", "body"] + throwError (TypeMismatch ann (void body) expectedTyForall vBodyTy) -- [infer| G !- arg :: k] [check| G !- pat :: (k -> *) -> k -> *] pat ~> vPat arg ~> vArg -- [check| G !- term : NORM (vPat (\(a :: k) -> ifix vPat a) vArg)] -- ----------------------------------------------------------------------------------------------- -- [infer| G !- iwrap pat arg term : ifix vPat vArg] inferTypeM (IWrap ann pat arg term) = do - k <- inferKindM arg - checkKindM ann pat $ toPatFuncKind k - vPat <- normalizeTypeM $ void pat - vArg <- normalizeTypeM $ void arg - checkTypeM ann term =<< unfoldIFixOf vPat vArg k - pure $ TyIFix () <$> vPat <*> vArg + k <- inferKindM arg + checkKindM ann pat $ toPatFuncKind k + vPat <- normalizeTypeM $ void pat + vArg <- normalizeTypeM $ void arg + checkTypeM ann term =<< unfoldIFixOf vPat vArg k + pure $ TyIFix () <$> vPat <*> vArg -- [infer| G !- term : ifix vPat vArg] [infer| G !- vArg :: k] -- ----------------------------------------------------------------------- -- [infer| G !- unwrap term : NORM (vPat (\(a :: k) -> ifix vPat a) vArg)] inferTypeM (Unwrap ann term) = do - vTermTy <- inferTypeM term - case unNormalized vTermTy of - TyIFix _ vPat vArg -> do - k <- inferKindM $ ann <$ vArg - -- Subparts of a normalized type, so normalized. - unfoldIFixOf (Normalized vPat) (Normalized vArg) k - _ -> do - let expectedTyIFix = ExpectedShape "ifix pat arg" ["pat", "arg"] - throwError (TypeMismatch ann (void term) expectedTyIFix vTermTy) + vTermTy <- inferTypeM term + case unNormalized vTermTy of + TyIFix _ vPat vArg -> do + k <- inferKindM $ ann <$ vArg + -- Subparts of a normalized type, so normalized. + unfoldIFixOf (Normalized vPat) (Normalized vArg) k + _ -> do + let expectedTyIFix = ExpectedShape "ifix pat arg" ["pat", "arg"] + throwError (TypeMismatch ann (void term) expectedTyIFix vTermTy) -- [check| G !- ty :: *] ty ~> vTy -- ---------------------------------- -- [infer| G !- error ty : vTy] inferTypeM (Error ann ty) = do - checkKindM ann ty $ Type () - normalizeTypeM $ void ty + checkKindM ann ty $ Type () + normalizeTypeM $ void ty -- resTy ~> vResTy vResTy = sop s_0 ... s_i ... s_n -- s_i = [p_i_0 ... p_i_m] [check| G !- t_0 : p_i_0] ... [check| G !- t_m : p_i_m] -- --------------------------------------------------------------------------------- -- [infer| G !- constr resTy i t_0 ... t_m : vResTy] inferTypeM t@(Constr ann resTy i args) = do - vResTy <- normalizeTypeM $ void resTy - - -- We don't know exactly what to expect, we only know what the i-th sum should look like, so we - -- assert that we should have some types in the sum up to there, and then the known product type. - let -- 'toInteger' is necessary, because @i@ is a @Word64@ and therefore @i - 1@ would be - -- @maxBound :: Word64@ for @i = 0@ if we didn't have 'toInteger'. - prodPrefix = map (\j -> "prod_" <> Text.pack (show j)) [0 .. toInteger i - 1] - fields = map (\k -> "field_" <> Text.pack (show k)) [0 .. length args - 1] - prod_i = "[" <> Text.intercalate " " fields <> "]" - shape = "sop " <> foldMap (<> " ") prodPrefix <> prod_i <> " ..." - vars = prodPrefix ++ fields - expectedSop = ExpectedShape shape vars - case unNormalized vResTy of - TySOP _ vSTys -> case vSTys ^? wix i of - Just pTys -> case zipExact args pTys of - -- pTy is a sub-part of a normalized type, so normalized - Just ps -> for_ ps $ \(arg, pTy) -> checkTypeM ann arg (Normalized pTy) - -- the number of args does not match the number of types in the i'th SOP - -- alternative - Nothing -> throwError (TypeMismatch ann (void t) expectedSop vResTy) - -- result type does not contain an i'th sum alternative - Nothing -> throwError (TypeMismatch ann (void t) expectedSop vResTy) - -- result type is not a SOP type - _ -> throwError (TypeMismatch ann (void t) expectedSop vResTy) - - pure vResTy + vResTy <- normalizeTypeM $ void resTy + + -- We don't know exactly what to expect, we only know what the i-th sum should look like, so we + -- assert that we should have some types in the sum up to there, and then the known product type. + let + -- 'toInteger' is necessary, because @i@ is a @Word64@ and therefore @i - 1@ would be + -- @maxBound :: Word64@ for @i = 0@ if we didn't have 'toInteger'. + prodPrefix = map (\j -> "prod_" <> Text.pack (show j)) [0 .. toInteger i - 1] + fields = map (\k -> "field_" <> Text.pack (show k)) [0 .. length args - 1] + prod_i = "[" <> Text.intercalate " " fields <> "]" + shape = "sop " <> foldMap (<> " ") prodPrefix <> prod_i <> " ..." + vars = prodPrefix ++ fields + expectedSop = ExpectedShape shape vars + case unNormalized vResTy of + TySOP _ vSTys -> case vSTys ^? wix i of + Just pTys -> case zipExact args pTys of + -- pTy is a sub-part of a normalized type, so normalized + Just ps -> for_ ps $ \(arg, pTy) -> checkTypeM ann arg (Normalized pTy) + -- the number of args does not match the number of types in the i'th SOP + -- alternative + Nothing -> throwError (TypeMismatch ann (void t) expectedSop vResTy) + -- result type does not contain an i'th sum alternative + Nothing -> throwError (TypeMismatch ann (void t) expectedSop vResTy) + -- result type is not a SOP type + _ -> throwError (TypeMismatch ann (void t) expectedSop vResTy) + + pure vResTy -- resTy ~> vResTy [infer| G !- scrut : sop s_0 ... s_n] -- s_0 = [p_0_0 ... p_0_m] [check| G !- c_0 : p_0_0 -> ... -> p_0_m -> vResTy] @@ -561,48 +577,48 @@ inferTypeM t@(Constr ann resTy i args) = do -- ----------------------------------------------------------------------------- -- [infer| G !- case resTy scrut c_0 ... c_n : vResTy] inferTypeM (Case ann resTy scrut branches) = do - vResTy <- normalizeTypeM $ void resTy - vScrutTy <- inferTypeM scrut - - -- We don't know exactly what to expect, we only know that it should - -- be a SOP with the right number of sum alternatives when type of scrutinee is SOP - let prods = map (\j -> "prod_" <> Text.pack (show j)) [0 .. length branches - 1] - expectedSop = ExpectedShape (Text.intercalate " " $ "sop" : prods) prods - case unNormalized vScrutTy of - TySOP _ sTys -> case zipExact branches sTys of - Just branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> - -- made of sub-parts of a normalized type, so normalized - checkTypeM ann c (Normalized $ mkIterTyFun () argTypes (unNormalized vResTy)) - -- scrutinee does not have a SOP type with the right number of alternatives - -- for the number of branches - Nothing -> throwError (TypeMismatch ann (void scrut) expectedSop vScrutTy) - vTy -> case annotateCaseBuiltin vTy branches of - Right branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> do - vArgTypes <- traverse (fmap unNormalized . normalizeTypeM) argTypes - -- made of sub-parts of a normalized type, so normalized - checkTypeM ann c (Normalized $ mkIterTyFun () vArgTypes (unNormalized vResTy)) - Left err -> throwError $ UnsupportedCaseBuiltin ann err - - -- If we got through all that, then every case type is correct, including that - -- they all result in vResTy, so we can safely conclude that that is the type of the - -- whole expression. - pure vResTy + vResTy <- normalizeTypeM $ void resTy + vScrutTy <- inferTypeM scrut + + -- We don't know exactly what to expect, we only know that it should + -- be a SOP with the right number of sum alternatives when type of scrutinee is SOP + let prods = map (\j -> "prod_" <> Text.pack (show j)) [0 .. length branches - 1] + expectedSop = ExpectedShape (Text.intercalate " " $ "sop" : prods) prods + case unNormalized vScrutTy of + TySOP _ sTys -> case zipExact branches sTys of + Just branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> + -- made of sub-parts of a normalized type, so normalized + checkTypeM ann c (Normalized $ mkIterTyFun () argTypes (unNormalized vResTy)) + -- scrutinee does not have a SOP type with the right number of alternatives + -- for the number of branches + Nothing -> throwError (TypeMismatch ann (void scrut) expectedSop vScrutTy) + vTy -> case annotateCaseBuiltin vTy branches of + Right branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> do + vArgTypes <- traverse (fmap unNormalized . normalizeTypeM) argTypes + -- made of sub-parts of a normalized type, so normalized + checkTypeM ann c (Normalized $ mkIterTyFun () vArgTypes (unNormalized vResTy)) + Left err -> throwError $ UnsupportedCaseBuiltin ann err + + -- If we got through all that, then every case type is correct, including that + -- they all result in vResTy, so we can safely conclude that that is the type of the + -- whole expression. + pure vResTy -- See Note [Global uniqueness in the type checker]. -- See Note [Typing rules]. --- | Check a 'Term' against a 'NormalizedType'. -checkTypeM - :: (MonadTypeCheckPlc uni fun ann m, HasTypeCheckConfig cfg uni fun) - => ann - -> Term TyName Name uni fun ann - -> Normalized (Type TyName uni ()) - -> TypeCheckT uni fun cfg m () +-- | Check a 'Term' against a 'NormalizedType'. +checkTypeM :: + (MonadTypeCheckPlc uni fun ann m, HasTypeCheckConfig cfg uni fun) => + ann -> + Term TyName Name uni fun ann -> + Normalized (Type TyName uni ()) -> + TypeCheckT uni fun cfg m () -- [infer| G !- term : vTermTy] vTermTy ~ vTy -- --------------------------------------------- -- [check| G !- term : vTy] checkTypeM ann term vTy = do - vTermTy <- inferTypeM term - when (vTermTy /= vTy) $ do - let expectedVTy = ExpectedExact $ unNormalized vTy - throwError $ TypeMismatch ann (void term) expectedVTy vTermTy + vTermTy <- inferTypeM term + when (vTermTy /= vTy) $ do + let expectedVTy = ExpectedExact $ unNormalized vTy + throwError $ TypeMismatch ann (void term) expectedVTy vTermTy diff --git a/plutus-core/plutus-core/src/PlutusCore/Value.hs b/plutus-core/plutus-core/src/PlutusCore/Value.hs index 99e1b4cb82c..6f510c73746 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Value.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Value.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module PlutusCore.Value ( Value, -- Do not expose data constructor @@ -109,7 +109,7 @@ instance CBOR.Serialise Quantity where decode = do i <- CBOR.decode case quantity i of - Just q -> pure q + Just q -> pure q Nothing -> fail $ "Quantity out of signed 128-bit integer bounds: " <> show i {-# INLINEABLE decode #-} @@ -119,7 +119,7 @@ instance Flat.Flat Quantity where decode = do i <- Flat.decode case quantity i of - Just q -> pure q + Just q -> pure q Nothing -> fail $ "Quantity out of signed 128-bit integer bounds: " <> show i {-# INLINEABLE decode #-} @@ -162,24 +162,21 @@ type NestedMap = Map K (Map K Quantity) -- | The underlying type of the UPLC built-in type @Value@. data Value = Value + -- | Map from (currency symbol, token name) to quantity. + -- + -- Invariants: no empty inner map, and no zero quantity. !NestedMap - {- ^ Map from (currency symbol, token name) to quantity. - - Invariants: no empty inner map, and no zero quantity. - -} + -- | Map from size to the number of inner maps that have that size. + -- This allows efficient retrieval of the size of the largest inner map, + -- which is useful for costing of operations like `lookupCoin`. + -- + -- Invariant: all values are positive. !(IntMap Int) - {- ^ Map from size to the number of inner maps that have that size. - This allows efficient retrieval of the size of the largest inner map, - which is useful for costing of operations like `lookupCoin`. - - Invariant: all values are positive. - -} + -- | Total size, i.e., sum total of inner map sizes. This avoids recomputing + -- the total size during the costing of operations like `unionValue`. {-# UNPACK #-} !Int - {- ^ Total size, i.e., sum total of inner map sizes. This avoids recomputing - the total size during the costing of operations like `unionValue`. - -} + -- | The number of negative amounts it contains. {-# UNPACK #-} !Int - -- ^ The number of negative amounts it contains. deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -201,18 +198,16 @@ instance Flat.Flat Value where decode = pack <$> Flat.decode {-# INLINE decode #-} -{-| Unpack a `Value` into a map from (currency symbol, token name) to quantity. - -The map is guaranteed to not contain empty inner map or zero quantity. --} +-- | Unpack a `Value` into a map from (currency symbol, token name) to quantity. +-- +-- The map is guaranteed to not contain empty inner map or zero quantity. unpack :: Value -> NestedMap unpack (Value v _ _ _) = v {-# INLINE unpack #-} -{-| Pack a map from (currency symbol, token name) to quantity into a `Value`. - -The map will be filtered so that it does not contain empty inner map or zero quantity. --} +-- | Pack a map from (currency symbol, token name) to quantity into a `Value`. +-- +-- The map will be filtered so that it does not contain empty inner map or zero quantity. pack :: NestedMap -> Value pack = pack' . normalize {-# INLINE pack #-} @@ -220,18 +215,17 @@ pack = pack' . normalize -- | Like `pack` but does not normalize. pack' :: NestedMap -> Value pack' v = Value v sizes size neg - where - (sizes, size, neg) = Map.foldl' alg (mempty, 0, 0) v - alg (ss, s, n) inner = - ( IntMap.alter (maybe (Just 1) (Just . (+ 1))) (Map.size inner) ss - , s + Map.size inner - , n + Map.size (Map.filter (< zeroQuantity) inner) - ) + where + (sizes, size, neg) = Map.foldl' alg (mempty, 0, 0) v + alg (ss, s, n) inner = + ( IntMap.alter (maybe (Just 1) (Just . (+ 1))) (Map.size inner) ss + , s + Map.size inner + , n + Map.size (Map.filter (< zeroQuantity) inner) + ) {-# INLINEABLE pack' #-} -{-| Total size, i.e., the number of distinct `(currency symbol, token name)` pairs -contained in the `Value`. --} +-- | Total size, i.e., the number of distinct `(currency symbol, token name)` pairs +-- contained in the `Value`. totalSize :: Value -> Int totalSize (Value _ _ size _) = size {-# INLINE totalSize #-} @@ -278,14 +272,14 @@ validateQuantities :: HasCallStack => NestedMap -> BuiltinResult NestedMap validateQuantities nestedMap = case find isOutOfBounds allQuantities of Just (UnsafeQuantity i) -> fail $ context <> ": quantity out of bounds: " <> show i - Nothing -> pure nestedMap + Nothing -> pure nestedMap where allQuantities = concatMap Map.elems $ Map.elems nestedMap isOutOfBounds (UnsafeQuantity i) = i < unQuantity minBound || i > unQuantity maxBound context = case getCallStack callStack of - (fnName, _):_ -> fnName - [] -> "" + (fnName, _) : _ -> fnName + [] -> "" {-# INLINEABLE validateQuantities #-} normalize :: NestedMap -> NestedMap @@ -294,12 +288,11 @@ normalize = Map.filter (not . Map.null) . Map.map (Map.filter (/= zeroQuantity)) instance Pretty Value where pretty = pretty . fmap (bimap toText (fmap (first toText))) . toList - where - toText = Text.decodeLatin1 . Base64.encode . unK + where + toText = Text.decodeLatin1 . Base64.encode . unK -{-| \(O(\log \max(m, k))\), where \(m\) is the size of the outer map, and \(k\) is -the size of the largest inner map. --} +-- | \(O(\log \max(m, k))\), where \(m\) is the size of the outer map, and \(k\) is +-- the size of the largest inner map. insertCoin :: ByteString -> ByteString -> Integer -> Value -> BuiltinResult Value insertCoin unsafeCurrency unsafeToken unsafeAmount v@(Value outer sizes size neg) | unsafeAmount == 0 = pure $ deleteCoin unsafeCurrency unsafeToken v @@ -308,13 +301,13 @@ insertCoin unsafeCurrency unsafeToken unsafeAmount v@(Value outer sizes size neg (_, Nothing, _) -> fail $ "insertCoin: invalid token: " <> show (B.unpack unsafeToken) (_, _, Nothing) -> fail $ "insertCoin: quantity out of bounds: " <> show unsafeAmount (Just currency, Just token, Just qty) -> - let f - :: Maybe (Map K Quantity) - -> ( -- Left (old size of inner map) if the total size grows by 1, - -- otherwise, Right (old quantity) - Either Int Quantity - , Maybe (Map K Quantity) - ) + let f :: + Maybe (Map K Quantity) -> + ( -- Left (old size of inner map) if the total size grows by 1, + -- otherwise, Right (old quantity) + Either Int Quantity + , Maybe (Map K Quantity) + ) f = \case Nothing -> (Left 0, Just (Map.singleton token qty)) Just inner -> @@ -345,64 +338,62 @@ insertCoin unsafeCurrency unsafeToken unsafeAmount v@(Value outer sizes size neg deleteCoin :: ByteString -> ByteString -> Value -> Value deleteCoin (UnsafeK -> currency) (UnsafeK -> token) (Value outer sizes size neg) = Value outer' sizes' size' neg' - where - (mold, outer') = Map.alterF f currency outer - (sizes', size', neg') = case mold of - Just (oldSize, oldQuantity) -> - ( updateSizes oldSize (oldSize - 1) sizes - , size - 1 - , if oldQuantity < zeroQuantity then neg - 1 else neg + where + (mold, outer') = Map.alterF f currency outer + (sizes', size', neg') = case mold of + Just (oldSize, oldQuantity) -> + ( updateSizes oldSize (oldSize - 1) sizes + , size - 1 + , if oldQuantity < zeroQuantity then neg - 1 else neg + ) + Nothing -> (sizes, size, neg) + f :: + Maybe (Map K Quantity) -> + ( -- Just (old size of inner map, old quantity) if the total size shrinks by 1, + -- otherwise Nothing + Maybe (Int, Quantity) + , Maybe (Map K Quantity) ) - Nothing -> (sizes, size, neg) - f - :: Maybe (Map K Quantity) - -> ( -- Just (old size of inner map, old quantity) if the total size shrinks by 1, - -- otherwise Nothing - Maybe (Int, Quantity) - , Maybe (Map K Quantity) - ) - f = \case - Nothing -> (Nothing, Nothing) - Just inner -> - let (qty, inner') = Map.updateLookupWithKey (\_ _ -> Nothing) token inner - in ((Map.size inner,) <$> qty, if Map.null inner' then Nothing else Just inner') + f = \case + Nothing -> (Nothing, Nothing) + Just inner -> + let (qty, inner') = Map.updateLookupWithKey (\_ _ -> Nothing) token inner + in ((Map.size inner,) <$> qty, if Map.null inner' then Nothing else Just inner') -- | \(O(\log \max(m, k))\) lookupCoin :: ByteString -> ByteString -> Value -> Integer lookupCoin (UnsafeK -> currency) (UnsafeK -> token) (unpack -> outer) = case Map.lookup currency outer of - Nothing -> 0 + Nothing -> 0 Just inner -> unQuantity $ Map.findWithDefault zeroQuantity token inner -{-| \(O(n_{2}\log \max(m_{1}, k_{1}))\), where \(n_{2}\) is the total size of the second -`Value`, \(m_{1}\) is the size of the outer map in the first `Value` and \(k_{1}\) is -the size of the largest inner map in the first `Value`. - -@a@ contains @b@ if for each @(currency, token, quantity)@ in @b@, -@lookup currency token a >= quantity@. - -Both values must not contain negative amounts. --} +-- | \(O(n_{2}\log \max(m_{1}, k_{1}))\), where \(n_{2}\) is the total size of the second +-- `Value`, \(m_{1}\) is the size of the outer map in the first `Value` and \(k_{1}\) is +-- the size of the largest inner map in the first `Value`. +-- +-- @a@ contains @b@ if for each @(currency, token, quantity)@ in @b@, +-- @lookup currency token a >= quantity@. +-- +-- Both values must not contain negative amounts. valueContains :: Value -> Value -> BuiltinResult Bool valueContains v1 v2 | negativeAmounts v1 > 0 = fail "valueContains: first value contains negative amounts" | negativeAmounts v2 > 0 = fail "valueContains: second value contains negative amounts" | otherwise = BuiltinSuccess . getAll $ Map.foldrWithKey go mempty (unpack v2) - where - go :: K -> Map K Quantity -> All -> All - go c inner = (<>) (Map.foldrWithKey goInner mempty inner) - where - goInner :: K -> Quantity -> All -> All - goInner t a2 = (<>) (All (lookupCoin (unK c) (unK t) v1 >= unQuantity a2)) + where + go :: K -> Map K Quantity -> All -> All + go c inner = (<>) (Map.foldrWithKey goInner mempty inner) + where + goInner :: K -> Quantity -> All -> All + goInner t a2 = (<>) (All (lookupCoin (unK c) (unK t) v1 >= unQuantity a2)) {-# INLINEABLE valueContains #-} -{-| \(O(n_{1}) + O(n_{2})\), where \(n_{1}\) and \(n_{2}\) are the total sizes -(i.e., sum of inner map sizes) of the two maps. --} +-- | \(O(n_{1}) + O(n_{2})\), where \(n_{1}\) and \(n_{2}\) are the total sizes +-- (i.e., sum of inner map sizes) of the two maps. unionValue :: Value -> Value -> BuiltinResult Value unionValue (unpack -> vA) (unpack -> vB) = - pack' <$> - M.mergeA + pack' + <$> M.mergeA M.preserveMissing M.preserveMissing ( M.zipWithMaybeAMatched \_ innerA innerB -> @@ -423,19 +414,17 @@ unionValue (unpack -> vA) (unpack -> vB) = vB {-# INLINEABLE unionValue #-} -{-| \(O(n)\). Encodes `Value` as `Data`, in the same way as non-builtin @Value@. -This is the denotation of @ValueData@ in Plutus V1, V2 and V3. --} +-- | \(O(n)\). Encodes `Value` as `Data`, in the same way as non-builtin @Value@. +-- This is the denotation of @ValueData@ in Plutus V1, V2 and V3. valueData :: Value -> Data valueData = Map . fmap (bimap (B . unK) tokensData) . Map.toList . unpack - where - tokensData :: Map K Quantity -> Data - tokensData = Map . fmap (bimap (B . unK) (I . unQuantity)) . Map.toList + where + tokensData :: Map K Quantity -> Data + tokensData = Map . fmap (bimap (B . unK) (I . unQuantity)) . Map.toList {-# INLINEABLE valueData #-} -{-| \(O(n \log n)\). Decodes `Data` into `Value`, in the same way as non-builtin @Value@. -This is the denotation of @UnValueData@ in Plutus V1, V2 and V3. --} +-- | \(O(n \log n)\). Decodes `Data` into `Value`, in the same way as non-builtin @Value@. +-- This is the denotation of @UnValueData@ in Plutus V1, V2 and V3. unValueData :: Data -> BuiltinResult Value unValueData = fmap pack . \case @@ -446,35 +435,35 @@ unValueData = -- Validate all quantities are within bounds validateQuantities outerMap _ -> fail "unValueData: non-Map constructor" - where - unB :: Data -> BuiltinResult K - unB = \case - B b -> maybe (fail $ "unValueData: invalid key: " <> show (B.unpack b)) pure (k b) - _ -> fail "unValueData: non-B constructor" - - unQ :: Data -> BuiltinResult Quantity - unQ = \case - I i -> pure (UnsafeQuantity i) - _ -> fail "unValueData: non-I constructor" - - unTokens :: Data -> BuiltinResult (Map K Quantity) - unTokens = \case - Map ts -> fmap (Map.fromListWith unsafeAddQuantity) (traverse (bitraverse unB unQ) ts) - _ -> fail "unValueData: non-Map constructor" + where + unB :: Data -> BuiltinResult K + unB = \case + B b -> maybe (fail $ "unValueData: invalid key: " <> show (B.unpack b)) pure (k b) + _ -> fail "unValueData: non-B constructor" + + unQ :: Data -> BuiltinResult Quantity + unQ = \case + I i -> pure (UnsafeQuantity i) + _ -> fail "unValueData: non-I constructor" + + unTokens :: Data -> BuiltinResult (Map K Quantity) + unTokens = \case + Map ts -> fmap (Map.fromListWith unsafeAddQuantity) (traverse (bitraverse unB unQ) ts) + _ -> fail "unValueData: non-Map constructor" {-# INLINEABLE unValueData #-} -- | Decrement bucket @old@, and increment bucket @new@. updateSizes :: Int -> Int -> IntMap Int -> IntMap Int updateSizes old new = dec . inc - where - inc = - if new == 0 - then id - else IntMap.alter (maybe (Just 1) (Just . (+ 1))) new - dec = - if old == 0 - then id - else IntMap.update (\n -> if n <= 1 then Nothing else Just (n - 1)) old + where + inc = + if new == 0 + then id + else IntMap.alter (maybe (Just 1) (Just . (+ 1))) new + dec = + if old == 0 + then id + else IntMap.update (\n -> if n <= 1 then Nothing else Just (n - 1)) old {-# INLINEABLE updateSizes #-} -- | \(O(n)\). Scale each token by the given constant factor. @@ -482,12 +471,12 @@ scaleValue :: Integer -> Value -> BuiltinResult Value scaleValue c (Value outer sizes size neg) -- When scaling by positive factor, no need to change sizes and number of negative amounts. | c > 0 = do - outer' <- go outer - BuiltinSuccess $ Value outer' sizes size neg + outer' <- go outer + BuiltinSuccess $ Value outer' sizes size neg -- When scaling by negative factor, only need to "flip" negative amounts. | c < 0 = do - outer' <- go outer - BuiltinSuccess $ Value outer' sizes size (size - neg) + outer' <- go outer + BuiltinSuccess $ Value outer' sizes size (size - neg) -- Scaling by 0 is always empty value | otherwise = BuiltinSuccess empty where @@ -499,5 +488,7 @@ scaleValue c (Value outer sizes size neg) Nothing -> fail $ "scaleValue: quantity out of bounds: " - <> show c <> " * " <> show (unQuantity x) + <> show c + <> " * " + <> show (unQuantity x) Just q -> pure q diff --git a/plutus-core/plutus-core/src/PlutusCore/Version.hs b/plutus-core/plutus-core/src/PlutusCore/Version.hs index 75f1918d90f..22d64a14927 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Version.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Version.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module PlutusCore.Version ( - Version(..) - , versionMajor - , versionMinor - , versionPatch - , plcVersion100 - , plcVersion110 - , firstVersion - , latestVersion - , knownVersions) where + Version (..), + versionMajor, + versionMinor, + versionPatch, + plcVersion100, + plcVersion110, + firstVersion, + latestVersion, + knownVersions, +) where import PlutusPrelude @@ -20,31 +21,30 @@ import Data.Hashable import Data.Set qualified as Set import Instances.TH.Lift () -{- | -The version of Plutus Core used by this program. - -The intention is to convey different levels of backwards compatibility for existing scripts: -- Major version changes are backwards-incompatible -- Minor version changes are backwards-compatible -- Patch version changes should be entirely invisible (and we will likely not use this level) - -The version used should be changed only when the /language itself/ changes. -For example, adding a new kind of term to the language would require a minor -version bump; removing a kind of term would require a major version bump. - -Similarly, changing the semantics of the language will require a version bump, -typically a major one. This is the main reason why the version is actually -tracked in the AST: we can have two language versions with identical ASTs but -different semantics, so we need to track the version explicitly. - -Compatibility is about compatibility for specific scripts, not about e.g. tools which consume -scripts. 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. --} +-- | +-- The version of Plutus Core used by this program. +-- +-- The intention is to convey different levels of backwards compatibility for existing scripts: +-- - Major version changes are backwards-incompatible +-- - Minor version changes are backwards-compatible +-- - Patch version changes should be entirely invisible (and we will likely not use this level) +-- +-- The version used should be changed only when the /language itself/ changes. +-- For example, adding a new kind of term to the language would require a minor +-- version bump; removing a kind of term would require a major version bump. +-- +-- Similarly, changing the semantics of the language will require a version bump, +-- typically a major one. This is the main reason why the version is actually +-- tracked in the AST: we can have two language versions with identical ASTs but +-- different semantics, so we need to track the version explicitly. +-- +-- Compatibility is about compatibility for specific scripts, not about e.g. tools which consume +-- scripts. 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 - = Version { _versionMajor :: Natural, _versionMinor :: Natural, _versionPatch :: Natural } - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData, Hashable) + = Version {_versionMajor :: Natural, _versionMinor :: Natural, _versionPatch :: Natural} + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, Hashable) makeLenses ''Version @@ -73,7 +73,7 @@ latestVersion = plcVersion110 -- | The set of versions that are "known", i.e. that have been released -- and have actual differences associated with them. knownVersions :: Set.Set Version -knownVersions = Set.fromList [ plcVersion100, plcVersion110 ] +knownVersions = Set.fromList [plcVersion100, plcVersion110] instance Pretty Version where - pretty (Version i j k) = pretty i <> "." <> pretty j <> "." <> pretty k + pretty (Version i j k) = pretty i <> "." <> pretty j <> "." <> pretty k diff --git a/plutus-core/plutus-core/src/Prettyprinter/Custom.hs b/plutus-core/plutus-core/src/Prettyprinter/Custom.hs index 9109a613628..85b8b27ab44 100644 --- a/plutus-core/plutus-core/src/Prettyprinter/Custom.hs +++ b/plutus-core/plutus-core/src/Prettyprinter/Custom.hs @@ -11,9 +11,8 @@ module Prettyprinter.Custom ( import Prettyprinter -{- | An area bracketed by two delimiters. When on multiple lines the delimiters are not -indented but the content is. --} +-- | An area bracketed by two delimiters. When on multiple lines the delimiters are not +-- indented but the content is. section' :: Doc a -> Doc a -> Doc a -> Doc a -- The subtlety here is that the nest call surrounds the first delimiter and the content, but not -- the final one. This is because of how nest behaves, where it doesn't indent until it hits @@ -21,27 +20,23 @@ section' :: Doc a -> Doc a -> Doc a -> Doc a -- indented, but not the final delimiter. section' c1 c2 d = group $ nest 2 (c1 <> d) <> c2 -{- | An area bracketed by two delimiters. When on one line, there are spaces between the delimiters -and the content, when on multiple lines the delimiters are not indented but the content is. --} +-- | An area bracketed by two delimiters. When on one line, there are spaces between the delimiters +-- and the content, when on multiple lines the delimiters are not indented but the content is. section :: Doc a -> Doc a -> Doc a -> Doc a section c1 c2 = section' (c1 <> line) (line <> c2) -{- | This prints a document enclosed by brackets, possibly indenting the output on -a new line if it does not fit. --} +-- | This prints a document enclosed by brackets, possibly indenting the output on +-- a new line if it does not fit. brackets' :: Doc a -> Doc a brackets' = section "[" "]" -{- | This prints a document enclosed by braces, possibly indenting the output on -a new line if it does not fit. --} +-- | This prints a document enclosed by braces, possibly indenting the output on +-- a new line if it does not fit. braces' :: Doc a -> Doc a braces' = section "{" "}" -{- | This prints a document enclosed by parentheses, aligning the opening and -closing parentheses. --} +-- | This prints a document enclosed by parentheses, aligning the opening and +-- closing parentheses. parens' :: Doc a -> Doc a parens' = section "(" ")" @@ -56,15 +51,13 @@ sexp a es = -- case we use line-or-nothing as well. section' ("(" <> a <> if null es then line' else line) (line' <> ")") (sep es) -{- | Lay out a sequence of documents vertically with forced lines between documents. Useful -for prettyprinting layout-sensitive things like let-bindings. --} +-- | Lay out a sequence of documents vertically with forced lines between documents. Useful +-- for prettyprinting layout-sensitive things like let-bindings. vcatHard :: [Doc ann] -> Doc ann vcatHard = concatWith (\x y -> x <> hardline <> y) -{- | Separate two documents `p` and `q` and increase indentation if `q` has to be put on a new -line. Useful to e.g. pretty-print function application like `fun sep arguments`. --} +-- | Separate two documents `p` and `q` and increase indentation if `q` has to be put on a new +-- line. Useful to e.g. pretty-print function application like `fun sep arguments`. () :: Doc ann -> Doc ann -> Doc ann p q = align . nest 2 $ sep [p, q] diff --git a/plutus-core/plutus-core/src/Universe.hs b/plutus-core/plutus-core/src/Universe.hs index 89c90924808..5f6e2e0dbac 100644 --- a/plutus-core/plutus-core/src/Universe.hs +++ b/plutus-core/plutus-core/src/Universe.hs @@ -1,5 +1,5 @@ -module Universe - ( module Export - ) where +module Universe ( + module Export, +) where import Universe.Core as Export diff --git a/plutus-core/plutus-core/src/Universe/Core.hs b/plutus-core/plutus-core/src/Universe/Core.hs index 7f88ce4fa1d..b0cf0ce2b92 100644 --- a/plutus-core/plutus-core/src/Universe/Core.hs +++ b/plutus-core/plutus-core/src/Universe/Core.hs @@ -1,56 +1,56 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- Required only by 'Permits0' for some reason. -{-# LANGUAGE UndecidableSuperClasses #-} - -module Universe.Core - ( Esc - , Some (..) - , SomeTypeIn (..) - , Kinded (..) - , ValueOf (..) - , Contains (..) - , Includes - , knownUniOf - , someType - , someValueOf - , someValue - , someValueType - , DecodeUniM (..) - , Closed (..) - , decodeKindedUni - , peelUniTag - , Permits - , EverywhereAll - , type (<:) - , HasUniApply (..) - , checkStar - , withApplicable - , tryUniApply - , GShow (..) - , gshow - , GEq (..) - , defaultEq - , (:~:)(..) - -- strictly we don't use this, but this is here - -- partially so we have a dependency on dependent-sum - -- directly and so can bound it - , DSum (..) - ) where +{-# LANGUAGE UndecidableSuperClasses #-} + +module Universe.Core ( + Esc, + Some (..), + SomeTypeIn (..), + Kinded (..), + ValueOf (..), + Contains (..), + Includes, + knownUniOf, + someType, + someValueOf, + someValue, + someValueType, + DecodeUniM (..), + Closed (..), + decodeKindedUni, + peelUniTag, + Permits, + EverywhereAll, + type (<:), + HasUniApply (..), + checkStar, + withApplicable, + tryUniApply, + GShow (..), + gshow, + GEq (..), + defaultEq, + (:~:) (..), + -- strictly we don't use this, but this is here + -- partially so we have a dependency on dependent-sum + -- directly and so can bound it + DSum (..), +) where import Control.Applicative import Control.DeepSeq @@ -330,6 +330,7 @@ even though that required reworking all the infrastructure in a backwards-incomp -} -- See Note [Representing polymorphism]. + -- | \"Escapes\" a type of an arbitrary kind to fit into 'Type'. type Esc :: forall k. k -> Type data Esc a @@ -339,53 +340,52 @@ type SomeTypeIn :: (Type -> Type) -> Type data SomeTypeIn uni = forall k (a :: k). SomeTypeIn !(uni (Esc a)) data Kinded uni ta where - Kinded :: Typeable k => !(uni (Esc a)) -> Kinded uni (Esc (a :: k)) + Kinded :: Typeable k => !(uni (Esc a)) -> Kinded uni (Esc (a :: k)) -- | A value of a particular type from a universe. type ValueOf :: (Type -> Type) -> Type -> Type data ValueOf uni a = ValueOf !(uni (Esc a)) !a -{- | A class for enumerating types and fully instantiated type formers that @uni@ contains. -For example, a particular @ExampleUni@ may have monomorphic types in it: - - instance ExampleUni `Contains` Integer where <...> - instance ExampleUni `Contains` Bool where <...> - -as well as polymorphic ones: - - instance ExampleUni `Contains` [] where <...> - instance ExampleUni `Contains` (,) where <...> - -as well as their instantiations: - - instance ExampleUni `Contains` a => ExampleUni `Contains` [a] where <...> - instance (ExampleUni `Contains` a, ExampleUni `Contains` b) => ExampleUni `Contains` (a, b) where <...> - -(a universe can have any subset of the mentioned sorts of types, for example it's fine to have -instantiated polymorphic types and not have uninstantiated ones and vice versa) - -Note that when used as a constraint of a function 'Contains' does not allow you to directly -express things like \"@uni@ has the @Integer@, @Bool@ and @[]@ types and type formers\", -because @[]@ is not fully instantiated. So you can only say \"@uni@ has @Integer@, @Bool@, -@[Integer]@, @[Bool]@, @[[Integer]]@, @[[Bool]]@ etc\" and such manual enumeration is annoying, -so we'd really like to be able to say that @uni@ has lists of arbitrary built-in types -(including lists of lists etc). 'Contains' does not allow that, but 'Includes' does. -For example, in the body of the following definition: - - foo :: (uni `Includes` Integer, uni `Includes` Bool, uni `Includes` []) => <...> - foo = <...> - -you can make use of the fact that @uni@ has lists of arbitrary included types (integers, -booleans and lists). - -Hence most of the time opt for using the more flexible 'Includes'. - -'Includes' is defined in terms of 'Contains', so you only need to provide a 'Contains' instance -per type from the universe and you'll get 'Includes' for free. --} +-- | A class for enumerating types and fully instantiated type formers that @uni@ contains. +-- For example, a particular @ExampleUni@ may have monomorphic types in it: +-- +-- instance ExampleUni `Contains` Integer where <...> +-- instance ExampleUni `Contains` Bool where <...> +-- +-- as well as polymorphic ones: +-- +-- instance ExampleUni `Contains` [] where <...> +-- instance ExampleUni `Contains` (,) where <...> +-- +-- as well as their instantiations: +-- +-- instance ExampleUni `Contains` a => ExampleUni `Contains` [a] where <...> +-- instance (ExampleUni `Contains` a, ExampleUni `Contains` b) => ExampleUni `Contains` (a, b) where <...> +-- +-- (a universe can have any subset of the mentioned sorts of types, for example it's fine to have +-- instantiated polymorphic types and not have uninstantiated ones and vice versa) +-- +-- Note that when used as a constraint of a function 'Contains' does not allow you to directly +-- express things like \"@uni@ has the @Integer@, @Bool@ and @[]@ types and type formers\", +-- because @[]@ is not fully instantiated. So you can only say \"@uni@ has @Integer@, @Bool@, +-- @[Integer]@, @[Bool]@, @[[Integer]]@, @[[Bool]]@ etc\" and such manual enumeration is annoying, +-- so we'd really like to be able to say that @uni@ has lists of arbitrary built-in types +-- (including lists of lists etc). 'Contains' does not allow that, but 'Includes' does. +-- For example, in the body of the following definition: +-- +-- foo :: (uni `Includes` Integer, uni `Includes` Bool, uni `Includes` []) => <...> +-- foo = <...> +-- +-- you can make use of the fact that @uni@ has lists of arbitrary included types (integers, +-- booleans and lists). +-- +-- Hence most of the time opt for using the more flexible 'Includes'. +-- +-- 'Includes' is defined in terms of 'Contains', so you only need to provide a 'Contains' instance +-- per type from the universe and you'll get 'Includes' for free. type Contains :: forall k. (Type -> Type) -> k -> Constraint class uni `Contains` a where - knownUni :: uni (Esc a) + knownUni :: uni (Esc a) {- Note [The definition of Includes] We need to be able to partially apply 'Includes' (required in the definition of '<:' for example), @@ -409,9 +409,10 @@ has to be immediately applied only to a @uni@ at the use site). -- | A @Kinded uni@ contains an @a :: k@ whenever @uni@ contains it and @k@ is 'Typeable'. instance (Typeable k, uni `Contains` a) => Kinded uni `Contains` (a :: k) where - knownUni = Kinded knownUni + knownUni = Kinded knownUni -- See Note [The definition of Includes]. + -- | @uni `Includes` a@ reads as \"@a@ is in the @uni@\". @a@ can be of a higher-kind, -- see the docs of 'Contains' on why you might want that. type Includes :: forall k. (Type -> Type) -> k -> Constraint @@ -441,8 +442,9 @@ someValueType (Some (ValueOf tag _)) = SomeTypeIn tag -- an arbitrary amount of type tags from the input list of tags and so we have state, which is -- convenient to handle with, well, 'StateT'. newtype DecodeUniM a = DecodeUniM - { unDecodeUniM :: StateT [Int] Maybe a - } deriving newtype (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFail) + { unDecodeUniM :: StateT [Int] Maybe a + } + deriving newtype (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFail) runDecodeUniM :: [Int] -> DecodeUniM a -> Maybe (a, [Int]) runDecodeUniM is (DecodeUniM a) = runStateT a is @@ -460,127 +462,131 @@ runDecodeUniM is (DecodeUniM a) = runStateT a is -- @UList (UList UInt)@ can be encoded to @[0,0,1]@ where @0@ and @1@ are the integer tags of the -- @UList@ and @UInt@ constructors, respectively. class Closed uni where - -- | A constrant for \"@constr a@ holds for any @a@ from @uni@\". - type Everywhere uni (constr :: Type -> Constraint) :: Constraint + -- | A constrant for \"@constr a@ holds for any @a@ from @uni@\". + type Everywhere uni (constr :: Type -> Constraint) :: Constraint - -- | Encode a type as a sequence of 'Int' tags. - -- The opposite of 'decodeUni'. - encodeUni :: uni a -> [Int] + -- | Encode a type as a sequence of 'Int' tags. + -- The opposite of 'decodeUni'. + encodeUni :: uni a -> [Int] - -- | Decode a type and feed it to the continuation. - withDecodedUni :: (forall k (a :: k). Typeable k => uni (Esc a) -> DecodeUniM r) -> DecodeUniM r + -- | Decode a type and feed it to the continuation. + withDecodedUni :: (forall k (a :: k). Typeable k => uni (Esc a) -> DecodeUniM r) -> DecodeUniM r - -- | Bring a @constr a@ instance in scope, provided @a@ is a type from the universe and - -- @constr@ holds for any type from the universe. - bring :: uni `Everywhere` constr => proxy constr -> uni (Esc a) -> (constr a => r) -> r + -- | Bring a @constr a@ instance in scope, provided @a@ is a type from the universe and + -- @constr@ holds for any type from the universe. + bring :: uni `Everywhere` constr => proxy constr -> uni (Esc a) -> (constr a => r) -> r -- | Decode a type from a sequence of 'Int' tags. -- The opposite of 'encodeUni' (modulo invalid input). decodeKindedUni :: Closed uni => [Int] -> Maybe (SomeTypeIn (Kinded uni)) decodeKindedUni is = do - (x, []) <- runDecodeUniM is $ withDecodedUni $ pure . SomeTypeIn . Kinded - pure x + (x, []) <- runDecodeUniM is $ withDecodedUni $ pure . SomeTypeIn . Kinded + pure x -- >>> runDecodeUniM [1,2,3] peelUniTag -- Just (1,[2,3]) -- >>> runDecodeUniM [] peelUniTag -- Nothing + -- | Peel off a tag from the input list of type tags. peelUniTag :: DecodeUniM Int peelUniTag = DecodeUniM $ do - i:is <- get - i <$ put is + i : is <- get + i <$ put is -- It's not possible to return a @forall@ from a type family, let alone compute a proper -- quantified context, hence the boilerplate and a finite number of supported cases. type Permits0 :: (Type -> Constraint) -> Type -> Constraint -class constr x => constr `Permits0` x +class constr x => constr `Permits0` x instance constr x => constr `Permits0` x type Permits1 :: (Type -> Constraint) -> (Type -> Type) -> Constraint -class (forall a. constr a => constr (f a)) => constr `Permits1` f +class (forall a. constr a => constr (f a)) => constr `Permits1` f instance (forall a. constr a => constr (f a)) => constr `Permits1` f type Permits2 :: (Type -> Constraint) -> (Type -> Type -> Type) -> Constraint -class (forall a b. (constr a, constr b) => constr (f a b)) => constr `Permits2` f +class (forall a b. (constr a, constr b) => constr (f a b)) => constr `Permits2` f instance (forall a b. (constr a, constr b) => constr (f a b)) => constr `Permits2` f type Permits3 :: (Type -> Constraint) -> (Type -> Type -> Type -> Type) -> Constraint -class (forall a b c. (constr a, constr b, constr c) => constr (f a b c)) => constr `Permits3` f +class (forall a b c. (constr a, constr b, constr c) => constr (f a b c)) => constr `Permits3` f instance (forall a b c. (constr a, constr b, constr c) => constr (f a b c)) => constr `Permits3` f -- I tried defining 'Permits' as a class but that didn't have the right inference properties -- (i.e. I was getting errors in existing code). That probably requires bidirectional instances -- to work, but who cares given that the type family version works alright and can even be -- partially applied (the kind has to be provided immediately though, but that's fine). -{- | @constr `Permits` f@ elaborates to one of -- - constr f - forall a. constr a => constr (f a) - forall a b. (constr a, constr b) => constr (f a b) - forall a b c. (constr a, constr b, constr c) => constr (f a b c) - -depending on the kind of @f@. This allows us to say things like - - ( constr `Permits` Integer - , constr `Permits` [] - , constr `Permits` (,) - ) -and thus constraint every type from the universe (including polymorphic ones) to satisfy -@constr@, which is how we provide an implementation of 'Everywhere' for universes with -polymorphic types. - -'Permits' is an open type family, so you can provide type instances for @f@s expecting -more type arguments than 3 if you need that. - -Note that, say, @constr `Permits` []@ elaborates to - - forall a. constr a => constr [a] - -and for certain type classes that does not make sense (e.g. the 'Generic' instance of @[]@ -does not require the type of elements to be 'Generic'), however it's not a problem because -we use 'Permit' to constrain the whole universe and so we know that arguments of polymorphic -built-in types are builtins themselves are hence do satisfy the constraint and the fact that -these constraints on arguments do not get used in the polymorphic case only means that they -get ignored. --} +-- | @constr `Permits` f@ elaborates to one of +-- - +-- constr f +-- forall a. constr a => constr (f a) +-- forall a b. (constr a, constr b) => constr (f a b) +-- forall a b c. (constr a, constr b, constr c) => constr (f a b c) +-- +-- depending on the kind of @f@. This allows us to say things like +-- +-- ( constr `Permits` Integer +-- , constr `Permits` [] +-- , constr `Permits` (,) +-- ) +-- +-- and thus constraint every type from the universe (including polymorphic ones) to satisfy +-- @constr@, which is how we provide an implementation of 'Everywhere' for universes with +-- polymorphic types. +-- +-- 'Permits' is an open type family, so you can provide type instances for @f@s expecting +-- more type arguments than 3 if you need that. +-- +-- Note that, say, @constr `Permits` []@ elaborates to +-- +-- forall a. constr a => constr [a] +-- +-- and for certain type classes that does not make sense (e.g. the 'Generic' instance of @[]@ +-- does not require the type of elements to be 'Generic'), however it's not a problem because +-- we use 'Permit' to constrain the whole universe and so we know that arguments of polymorphic +-- built-in types are builtins themselves are hence do satisfy the constraint and the fact that +-- these constraints on arguments do not get used in the polymorphic case only means that they +-- get ignored. type Permits :: forall k. (Type -> Constraint) -> k -> Constraint type family Permits constr -type instance Permits @Type constr = Permits0 constr -type instance Permits @(Type -> Type) constr = Permits1 constr -type instance Permits @(Type -> Type -> Type) constr = Permits2 constr +type instance Permits @Type constr = Permits0 constr +type instance Permits @(Type -> Type) constr = Permits1 constr +type instance Permits @(Type -> Type -> Type) constr = Permits2 constr type instance Permits @(Type -> Type -> Type -> Type) constr = Permits3 constr -- We can't use @All (Everywhere uni) constrs@, because 'Everywhere' is an associated type family -- and can't be partially applied, so we have to inline the definition here. type EverywhereAll :: (Type -> Type) -> [Type -> Constraint] -> Constraint type family uni `EverywhereAll` constrs where - uni `EverywhereAll` '[] = () - uni `EverywhereAll` (constr ': constrs) = (uni `Everywhere` constr, uni `EverywhereAll` constrs) + uni `EverywhereAll` '[] = () + uni `EverywhereAll` (constr ': constrs) = (uni `Everywhere` constr, uni `EverywhereAll` constrs) -- | A constraint for \"@uni1@ is a subuniverse of @uni2@\". type uni1 <: uni2 = uni1 `Everywhere` Includes uni2 -- | A class for \"@uni@ has general type application\". class HasUniApply (uni :: Type -> Type) where - -- | Apply a type constructor to an argument. - uniApply :: forall k l (f :: k -> l) a. uni (Esc f) -> uni (Esc a) -> uni (Esc (f a)) - - -- | Deconstruct a type application into the function and the argument and feed them to the - -- continuation. If the type is not an application, then return the default value. - matchUniApply - :: uni tb -- ^ The type. - -> r -- ^ What to return if the type is not an application. - -> (forall k l (f :: k -> l) a. tb ~ Esc (f a) => uni (Esc f) -> uni (Esc a) -> r) - -- ^ The continuation taking a function and an argument. - -> r + -- | Apply a type constructor to an argument. + uniApply :: forall k l (f :: k -> l) a. uni (Esc f) -> uni (Esc a) -> uni (Esc (f a)) + + -- | Deconstruct a type application into the function and the argument and feed them to the + -- continuation. If the type is not an application, then return the default value. + matchUniApply :: + -- | The type. + uni tb -> + -- | What to return if the type is not an application. + r -> + -- | The continuation taking a function and an argument. + (forall k l (f :: k -> l) a. tb ~ Esc (f a) => uni (Esc f) -> uni (Esc a) -> r) -> + r -- See Note [Decoding universes]. -- You might think @uni@ is inferrable from the explicitly given argument. Nope, in most cases it's -- not. It seems, kind equalities mess up inference. + -- | Check if the kind of the given type from the universe is 'Type'. checkStar :: forall uni a (x :: a). Typeable a => uni (Esc x) -> Maybe (a :~: Type) checkStar _ = typeRep @a `testEquality` typeRep @Type @@ -589,37 +595,40 @@ fromJustM :: MonadPlus f => Maybe a -> f a fromJustM = maybe mzero pure -- See Note [Decoding universes]. + -- | Check if one type from the universe can be applied to another (i.e. check that the expected -- kind of the argument matches the actual one) and call the continuation in the refined context. -- Fail with 'mzero' otherwise. -withApplicable - :: forall (a :: Type) (ab :: Type) f x uni m r. (Typeable ab, Typeable a, MonadPlus m) - => uni (Esc (f :: ab)) - -> uni (Esc (x :: a)) - -> (forall (b :: Type). (Typeable b, ab ~ (a -> b)) => m r) - -> m r +withApplicable :: + forall (a :: Type) (ab :: Type) f x uni m r. + (Typeable ab, Typeable a, MonadPlus m) => + uni (Esc (f :: ab)) -> + uni (Esc (x :: a)) -> + (forall (b :: Type). (Typeable b, ab ~ (a -> b)) => m r) -> + m r withApplicable _ _ k = - case typeRep @ab of - Fun repA repB -> do - -- The type of @(->)@ is - -- - -- forall {r1} {r2} (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type - -- - -- so we need to demonstrate that both @a@ and @b@ are of kind @Type@. We get the former - -- from checking that the type representation of 'withApplicable'-bound @a@ equals @a@ - -- from @a -> b@, but for the latter we need an explicit check. - HRefl <- fromJustM $ typeRep @a `eqTypeRep` repA - Refl <- fromJustM $ typeRepKind repB `testEquality` typeRep @Type - withTypeable repB k - _ -> mzero + case typeRep @ab of + Fun repA repB -> do + -- The type of @(->)@ is + -- + -- forall {r1} {r2} (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type + -- + -- so we need to demonstrate that both @a@ and @b@ are of kind @Type@. We get the former + -- from checking that the type representation of 'withApplicable'-bound @a@ equals @a@ + -- from @a -> b@, but for the latter we need an explicit check. + HRefl <- fromJustM $ typeRep @a `eqTypeRep` repA + Refl <- fromJustM $ typeRepKind repB `testEquality` typeRep @Type + withTypeable repB k + _ -> mzero -- | Apply a type constructor to an argument, provided kinds match. -tryUniApply - :: (MonadPlus m, HasUniApply uni) - => SomeTypeIn (Kinded uni) -> SomeTypeIn (Kinded uni) -> m (SomeTypeIn (Kinded uni)) +tryUniApply :: + (MonadPlus m, HasUniApply uni) => + SomeTypeIn (Kinded uni) -> SomeTypeIn (Kinded uni) -> m (SomeTypeIn (Kinded uni)) tryUniApply (SomeTypeIn (Kinded uniF)) (SomeTypeIn (Kinded uniA)) = - withApplicable uniF uniA $ - pure . SomeTypeIn . Kinded $ uniF `uniApply` uniA + withApplicable uniF uniA $ + pure . SomeTypeIn . Kinded $ + uniF `uniApply` uniA {- Note [The G, the Tag and the Auto] Providing instances for @@ -722,86 +731,95 @@ We should be able to use the same strategy for every type class @X@ when a @make -} -- WARNING: DO NOT EXPORT THIS, IT HAS AN UNSOUND 'Lift' INSTANCE USED FOR INTERNAL PURPOSES. + -- | A wrapper that allows to provide an instance for a non-general class (e.g. 'Lift' or 'Show') -- for any @f@ implementing a general class (e.g. 'GLift' or 'GShow'). newtype AG f a = AG (f a) -$(return []) -- Stage restriction, see https://gitlab.haskell.org/ghc/ghc/issues/9813 +$(return []) -- Stage restriction, see https://gitlab.haskell.org/ghc/ghc/issues/9813 -------------------- 'Show' / 'GShow' instance GShow f => Show (AG f a) where - showsPrec pr (AG a) = gshowsPrec pr a + showsPrec pr (AG a) = gshowsPrec pr a instance GShow uni => Show (SomeTypeIn uni) where - showsPrec pr (SomeTypeIn uni) = ($(makeShowsPrec ''SomeTypeIn)) pr (SomeTypeIn (AG uni)) + showsPrec pr (SomeTypeIn uni) = ($(makeShowsPrec ''SomeTypeIn)) pr (SomeTypeIn (AG uni)) instance GShow uni => Show (Kinded uni ta) where - showsPrec pr (Kinded uni) = ($(makeShowsPrec ''Kinded)) pr (Kinded (AG uni)) + showsPrec pr (Kinded uni) = ($(makeShowsPrec ''Kinded)) pr (Kinded (AG uni)) instance GShow uni => GShow (Kinded uni) where gshowsPrec = showsPrec instance (GShow uni, Closed uni, uni `Everywhere` Show) => GShow (ValueOf uni) where - gshowsPrec = showsPrec + gshowsPrec = showsPrec instance (GShow uni, Closed uni, uni `Everywhere` Show) => Show (ValueOf uni a) where - showsPrec pr (ValueOf uni x) = - bring (Proxy @Show) uni $ ($(makeShowsPrec ''ValueOf)) pr (ValueOf (AG uni) x) + showsPrec pr (ValueOf uni x) = + bring (Proxy @Show) uni $ ($(makeShowsPrec ''ValueOf)) pr (ValueOf (AG uni) x) -------------------- 'Eq' / 'GEq' instance (GEq uni, Closed uni, uni `Everywhere` Eq) => GEq (ValueOf uni) where - ValueOf uni1 x1 `geq` ValueOf uni2 x2 = do - Refl <- uni1 `geq` uni2 - guard $ bring (Proxy @Eq) uni1 (x1 == x2) - Just Refl + ValueOf uni1 x1 `geq` ValueOf uni2 x2 = do + Refl <- uni1 `geq` uni2 + guard $ bring (Proxy @Eq) uni1 (x1 == x2) + Just Refl instance GEq uni => Eq (SomeTypeIn uni) where - SomeTypeIn a1 == SomeTypeIn a2 = a1 `defaultEq` a2 + SomeTypeIn a1 == SomeTypeIn a2 = a1 `defaultEq` a2 instance (GEq uni, Closed uni, uni `Everywhere` Eq) => Eq (ValueOf uni a) where - (==) = defaultEq + (==) = defaultEq -------------------- 'Compare' / 'GCompare' -instance (GCompare uni, Closed uni, uni `Everywhere` Ord, uni `Everywhere` Eq) => - GCompare (ValueOf uni) where - ValueOf uni1 x1 `gcompare` ValueOf uni2 x2 = - case uni1 `gcompare` uni2 of - GLT -> GLT - GGT -> GGT - GEQ -> - bring (Proxy @Ord) uni1 $ case x1 `compare` x2 of - EQ -> GEQ - LT -> GLT - GT -> GGT +instance + (GCompare uni, Closed uni, uni `Everywhere` Ord, uni `Everywhere` Eq) => + GCompare (ValueOf uni) + where + ValueOf uni1 x1 `gcompare` ValueOf uni2 x2 = + case uni1 `gcompare` uni2 of + GLT -> GLT + GGT -> GGT + GEQ -> + bring (Proxy @Ord) uni1 $ case x1 `compare` x2 of + EQ -> GEQ + LT -> GLT + GT -> GGT instance GCompare uni => Ord (SomeTypeIn uni) where - SomeTypeIn a1 `compare` SomeTypeIn a2 = a1 `defaultCompare` a2 + SomeTypeIn a1 `compare` SomeTypeIn a2 = a1 `defaultCompare` a2 -- We need the 'Eq' constraint in order for @Ord (ValueOf uni a)@ to imply @Eq (ValueOf uni a)@. -instance (GCompare uni, Closed uni, uni `Everywhere` Ord, uni `Everywhere` Eq) => - Ord (ValueOf uni a) where - compare = defaultCompare +instance + (GCompare uni, Closed uni, uni `Everywhere` Ord, uni `Everywhere` Eq) => + Ord (ValueOf uni a) + where + compare = defaultCompare -------------------- 'NFData' instance (Closed uni, uni `Everywhere` NFData) => GNFData (ValueOf uni) where - grnf (ValueOf uni x) = bring (Proxy @NFData) uni $ rnf x + grnf (ValueOf uni x) = bring (Proxy @NFData) uni $ rnf x instance Closed uni => NFData (SomeTypeIn uni) where - rnf (SomeTypeIn uni) = rnf $ encodeUni uni + rnf (SomeTypeIn uni) = rnf $ encodeUni uni instance (Closed uni, uni `Everywhere` NFData) => NFData (ValueOf uni a) where - rnf = grnf + rnf = grnf instance (Closed uni, GEq uni) => Hashable (SomeTypeIn uni) where - hashWithSalt salt (SomeTypeIn uni) = hashWithSalt salt $ encodeUni uni - -instance (Closed uni, GEq uni, uni `Everywhere` Eq, uni `Everywhere` Hashable) => - Hashable (ValueOf uni a) where - hashWithSalt salt (ValueOf uni x) = - bring (Proxy @Hashable) uni $ hashWithSalt salt (SomeTypeIn uni, x) - -instance (Closed uni, GEq uni, uni `Everywhere` Eq, uni `Everywhere` Hashable) => - Hashable (Some (ValueOf uni)) where - hashWithSalt salt (Some s) = hashWithSalt salt s + hashWithSalt salt (SomeTypeIn uni) = hashWithSalt salt $ encodeUni uni + +instance + (Closed uni, GEq uni, uni `Everywhere` Eq, uni `Everywhere` Hashable) => + Hashable (ValueOf uni a) + where + hashWithSalt salt (ValueOf uni x) = + bring (Proxy @Hashable) uni $ hashWithSalt salt (SomeTypeIn uni, x) + +instance + (Closed uni, GEq uni, uni `Everywhere` Eq, uni `Everywhere` Hashable) => + Hashable (Some (ValueOf uni)) + where + hashWithSalt salt (Some s) = hashWithSalt salt s diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Bool.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Bool.hs index 56b0111482f..72a9be4741f 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Bool.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Bool.hs @@ -1,15 +1,14 @@ --- | @boolean@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.Bool - ( bool - , true - , false - , ifThenElse - ) where +-- | @boolean@ and related functions. +module PlutusCore.StdLib.Data.Bool ( + bool, + true, + false, + ifThenElse, +) where import PlutusCore.Core import PlutusCore.Default.Builtins @@ -34,25 +33,26 @@ false = mkConstant () False -- | @if_then_else_@ as a PLC term. -- -- > /\(A :: *) -> \(b : Bool) (x y : () -> A) -> IfThenElse {() -> A} b x y () -ifThenElse - :: forall term uni. - ( TermLike term TyName Name uni DefaultFun - , uni `HasTypeAndTermLevel` Bool, uni `HasTypeAndTermLevel` () - ) - => term () +ifThenElse :: + forall term uni. + ( TermLike term TyName Name uni DefaultFun + , uni `HasTypeAndTermLevel` Bool + , uni `HasTypeAndTermLevel` () + ) => + term () ifThenElse = runQuote $ do - a <- freshTyName "a" - b <- freshName "b" - x <- freshName "x" - y <- freshName "y" - let unitFunA = TyFun () unit (TyVar () a) - return - . tyAbs () a (Type ()) - $ mkIterLamAbs [ - VarDecl () b bool, - VarDecl () x unitFunA, - VarDecl () y unitFunA - ] - $ mkIterAppNoAnn - (tyInst () (builtin () IfThenElse) unitFunA) - [var () b, var () x, var () y, unitval] + a <- freshTyName "a" + b <- freshName "b" + x <- freshName "x" + y <- freshName "y" + let unitFunA = TyFun () unit (TyVar () a) + return + . tyAbs () a (Type ()) + $ mkIterLamAbs + [ VarDecl () b bool + , VarDecl () x unitFunA + , VarDecl () y unitFunA + ] + $ mkIterAppNoAnn + (tyInst () (builtin () IfThenElse) unitFunA) + [var () b, var () x, var () y, unitval] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ChurchNat.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ChurchNat.hs index 04754a73abb..c781d72c707 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ChurchNat.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ChurchNat.hs @@ -1,12 +1,11 @@ --- | Church-encoded @nat@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.StdLib.Data.ChurchNat - ( churchNat - , churchZero - , churchSucc - ) where +-- | Church-encoded @nat@ and related functions. +module PlutusCore.StdLib.Data.ChurchNat ( + churchNat, + churchZero, + churchSucc, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -18,43 +17,44 @@ import PlutusCore.Quote -- > all (r :: *). r -> (r -> r) -> r churchNat :: Type TyName uni () churchNat = runQuote $ do - r <- freshTyName "r" - return - . TyForall () r (Type ()) - . TyFun () (TyVar () r) - . TyFun () (TyFun () (TyVar () r) $ TyVar () r) - $ TyVar () r + r <- freshTyName "r" + return + . TyForall () r (Type ()) + . TyFun () (TyVar () r) + . TyFun () (TyFun () (TyVar () r) $ TyVar () r) + $ TyVar () r -- | Church-encoded '0' as a PLC term. -- -- > /\(r :: *) -> \(z : r) (f : r -> r) -> z churchZero :: TermLike term TyName Name uni fun => term () churchZero = runQuote $ do - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - return - . tyAbs () r (Type ()) - . lamAbs () z (TyVar () r) - . lamAbs () f (TyFun () (TyVar () r) $ TyVar () r) - $ var () z + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + return + . tyAbs () r (Type ()) + . lamAbs () z (TyVar () r) + . lamAbs () f (TyFun () (TyVar () r) $ TyVar () r) + $ var () z -- | Church-encoded 'succ' as a PLC term. -- -- > \(n : nat) -> /\(r :: *) -> \(z : r) (f : r -> r) -> f (n {r} z f) churchSucc :: TermLike term TyName Name uni fun => term () churchSucc = runQuote $ do - n <- freshName "n" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - return - . lamAbs () n churchNat - . tyAbs () r (Type ()) - . lamAbs () z (TyVar () r) - . lamAbs () f (TyFun () (TyVar () r) $ TyVar () r) - . apply () (var () f) - $ mkIterAppNoAnn (tyInst () (var () n) $ TyVar () r) - [ var () z - , var () f - ] + n <- freshName "n" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + return + . lamAbs () n churchNat + . tyAbs () r (Type ()) + . lamAbs () z (TyVar () r) + . lamAbs () f (TyFun () (TyVar () r) $ TyVar () r) + . apply () (var () f) + $ mkIterAppNoAnn + (tyInst () (var () n) $ TyVar () r) + [ var () z + , var () f + ] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Data.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Data.hs index d768a743be2..943e025d807 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Data.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Data.hs @@ -1,14 +1,13 @@ -- editorconfig-checker-disable-file --- | Built-in @pair@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.Data - ( dataTy - , matchData - ) where +-- | Built-in @pair@ and related functions. +module PlutusCore.StdLib.Data.Data ( + dataTy, + matchData, +) where import Prelude hiding (uncurry) @@ -49,47 +48,49 @@ dataTy = mkTyBuiltin @_ @Data () -- > unitval matchData :: TermLike term TyName Name DefaultUni DefaultFun => term () matchData = runQuote $ do - r <- freshTyName "r" - fConstr <- freshName "fConstr" - fMap <- freshName "fMap" - fList <- freshName "fList" - fI <- freshName "fI" - fB <- freshName "fB" - d <- freshName "d" - u <- freshName "u" - let listData = mkTyBuiltin @_ @[Data] () - listPairData = mkTyBuiltin @_ @[(Data, Data)] () - bytestring = mkTyBuiltin @_ @ByteString () - return - . lamAbs () d dataTy - . tyAbs () r (Type ()) - . lamAbs () fConstr (TyFun () integer . TyFun () listData $ TyVar () r) - . lamAbs () fMap (TyFun () listPairData $ TyVar () r) - . lamAbs () fList (TyFun () listData $ TyVar () r) - . lamAbs () fI (TyFun () integer $ TyVar () r) - . lamAbs () fB (TyFun () bytestring $ TyVar () r) - $ mkIterAppNoAnn (tyInst () (builtin () ChooseData) . TyFun () unit $ TyVar () r) - [ var () d - , lamAbs () u unit - $ mkIterAppNoAnn (mkIterInstNoAnn uncurry [integer, listData, TyVar () r]) - [ var () fConstr - , apply () (builtin () UnConstrData) $ var () d - ] - , lamAbs () u unit - . apply () (var () fMap) - . apply () (builtin () UnMapData) - $ var () d - , lamAbs () u unit - . apply () (var () fList) - . apply () (builtin () UnListData) - $ var () d - , lamAbs () u unit - . apply () (var () fI) - . apply () (builtin () UnIData) - $ var () d - , lamAbs () u unit - . apply () (var () fB) - . apply () (builtin () UnBData) - $ var () d - , unitval + r <- freshTyName "r" + fConstr <- freshName "fConstr" + fMap <- freshName "fMap" + fList <- freshName "fList" + fI <- freshName "fI" + fB <- freshName "fB" + d <- freshName "d" + u <- freshName "u" + let listData = mkTyBuiltin @_ @[Data] () + listPairData = mkTyBuiltin @_ @[(Data, Data)] () + bytestring = mkTyBuiltin @_ @ByteString () + return + . lamAbs () d dataTy + . tyAbs () r (Type ()) + . lamAbs () fConstr (TyFun () integer . TyFun () listData $ TyVar () r) + . lamAbs () fMap (TyFun () listPairData $ TyVar () r) + . lamAbs () fList (TyFun () listData $ TyVar () r) + . lamAbs () fI (TyFun () integer $ TyVar () r) + . lamAbs () fB (TyFun () bytestring $ TyVar () r) + $ mkIterAppNoAnn + (tyInst () (builtin () ChooseData) . TyFun () unit $ TyVar () r) + [ var () d + , lamAbs () u unit $ + mkIterAppNoAnn + (mkIterInstNoAnn uncurry [integer, listData, TyVar () r]) + [ var () fConstr + , apply () (builtin () UnConstrData) $ var () d ] + , lamAbs () u unit + . apply () (var () fMap) + . apply () (builtin () UnMapData) + $ var () d + , lamAbs () u unit + . apply () (var () fList) + . apply () (builtin () UnListData) + $ var () d + , lamAbs () u unit + . apply () (var () fI) + . apply () (builtin () UnIData) + $ var () d + , lamAbs () u unit + . apply () (var () fB) + . apply () (builtin () UnBData) + $ var () d + , unitval + ] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Function.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Function.hs index 0bf630c7ba9..ed14ac3a70c 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Function.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Function.hs @@ -1,25 +1,24 @@ -- editorconfig-checker-disable-file --- | Combinators. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module PlutusCore.StdLib.Data.Function - ( const - , idFun - , applyFun - , selfData - , unroll - , fix - , fixAndType - , fixBy - , fixByAndType - , fixN - , fixNAndType - , FunctionDef (..) - , getMutualFixOf - , getSingleFixOf - ) where +{-# LANGUAGE TupleSections #-} + +-- | Combinators. +module PlutusCore.StdLib.Data.Function ( + const, + idFun, + applyFun, + selfData, + unroll, + fix, + fixAndType, + fixBy, + fixByAndType, + fixN, + fixNAndType, + FunctionDef (..), + getMutualFixOf, + getSingleFixOf, +) where import PlutusPrelude import Prelude hiding (const) @@ -40,44 +39,44 @@ import Control.Monad -- > /\(A :: *) -> \(x : A) -> x idFun :: TermLike term TyName Name uni fun => term () idFun = runQuote $ do - a <- freshTyName "a" - x <- freshName "x" - return - . tyAbs () a (Type ()) - . lamAbs () x (TyVar () a) - $ var () x + a <- freshTyName "a" + x <- freshName "x" + return + . tyAbs () a (Type ()) + . lamAbs () x (TyVar () a) + $ var () x -- | 'const' as a PLC term. -- -- > /\(A B :: *) -> \(x : A) (y : B) -> x const :: TermLike term TyName Name uni fun => term () const = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - x <- freshName "x" - y <- freshName "y" - return - . tyAbs () a (Type ()) - . tyAbs () b (Type ()) - . lamAbs () x (TyVar () a) - . lamAbs () y (TyVar () b) - $ var () x + a <- freshTyName "a" + b <- freshTyName "b" + x <- freshName "x" + y <- freshName "y" + return + . tyAbs () a (Type ()) + . tyAbs () b (Type ()) + . lamAbs () x (TyVar () a) + . lamAbs () y (TyVar () b) + $ var () x -- | '($)' as a PLC term. -- -- > /\(A B :: *) -> \(f : A -> B) (x : A) -> f x applyFun :: TermLike term TyName Name uni fun => term () applyFun = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - f <- freshName "f" - x <- freshName "x" - return - . tyAbs () a (Type ()) - . tyAbs () b (Type ()) - . lamAbs () f (TyFun () (TyVar () a) $ TyVar () b) - . lamAbs () x (TyVar () a) - $ apply () (var () f) (var () x) + a <- freshTyName "a" + b <- freshTyName "b" + f <- freshName "f" + x <- freshName "x" + return + . tyAbs () a (Type ()) + . tyAbs () b (Type ()) + . lamAbs () f (TyFun () (TyVar () a) $ TyVar () b) + . lamAbs () x (TyVar () a) + $ apply () (var () f) (var () x) {- Note [Recursion combinators] We create singly recursive and mutually recursive functions using different combinators. @@ -129,25 +128,25 @@ and fully specified in our "Unraveling recursion: compiling an IR with recursion -- > fix \(self :: * -> *) (a :: *) -> self a -> a selfData :: RecursiveType uni fun () selfData = runQuote $ do - self <- freshTyName "self" - a <- freshTyName "a" - makeRecursiveType () self [TyVarDecl () a $ Type ()] - . TyFun () (TyApp () (TyVar () self) (TyVar () a)) - $ TyVar () a + self <- freshTyName "self" + a <- freshTyName "a" + makeRecursiveType () self [TyVarDecl () a $ Type ()] + . TyFun () (TyApp () (TyVar () self) (TyVar () a)) + $ TyVar () a -- | @unroll@ as a PLC term. -- -- > /\(a :: *) -> \(s : self a) -> unwrap s s unroll :: TermLike term TyName Name uni fun => term () unroll = runQuote $ do - let self = _recursiveType selfData - a <- freshTyName "a" - s <- freshName "s" - return - . tyAbs () a (Type ()) - . lamAbs () s (TyApp () self $ TyVar () a) - . apply () (unwrap () $ var () s) - $ var () s + let self = _recursiveType selfData + a <- freshTyName "a" + s <- freshName "s" + return + . tyAbs () a (Type ()) + . lamAbs () s (TyApp () self $ TyVar () a) + . apply () (unwrap () $ var () s) + $ var () s -- | 'fix' as a PLC term. -- @@ -161,33 +160,34 @@ fix = fst fixAndType fixAndType :: TermLike term TyName Name uni fun => (term (), Type TyName uni ()) fixAndType = runQuote $ do - let RecursiveType self wrapSelf = selfData - a <- freshTyName "a" - b <- freshTyName "b" - f <- freshName "f" - s <- freshName "s" - x <- freshName "x" - let funAB = TyFun () (TyVar () a) $ TyVar () b - unrollFunAB = tyInst () unroll funAB - let selfFunAB = TyApp () self funAB - let fixTerm = - tyAbs () a (Type ()) - . tyAbs () b (Type ()) - . lamAbs () f (TyFun () funAB funAB) - . apply () unrollFunAB - . wrapSelf [funAB] - . lamAbs () s selfFunAB - . apply () (var () f) - . lamAbs () x (TyVar () a) - $ mkIterAppNoAnn unrollFunAB - [ var () s - , var () x - ] - let fixType = - TyForall () a (Type ()) - . TyForall () b (Type ()) - $ TyFun () (TyFun () funAB funAB) funAB - pure (fixTerm, fixType) + let RecursiveType self wrapSelf = selfData + a <- freshTyName "a" + b <- freshTyName "b" + f <- freshName "f" + s <- freshName "s" + x <- freshName "x" + let funAB = TyFun () (TyVar () a) $ TyVar () b + unrollFunAB = tyInst () unroll funAB + let selfFunAB = TyApp () self funAB + let fixTerm = + tyAbs () a (Type ()) + . tyAbs () b (Type ()) + . lamAbs () f (TyFun () funAB funAB) + . apply () unrollFunAB + . wrapSelf [funAB] + . lamAbs () s selfFunAB + . apply () (var () f) + . lamAbs () x (TyVar () a) + $ mkIterAppNoAnn + unrollFunAB + [ var () s + , var () x + ] + let fixType = + TyForall () a (Type ()) + . TyForall () b (Type ()) + $ TyFun () (TyFun () funAB funAB) funAB + pure (fixTerm, fixType) -- | A type that looks like a transformation. -- @@ -206,8 +206,8 @@ natTrans f g = freshTyName "Q" >>= \q -> TyForall () q (Type ()) <$> trans f g ( -- > natTransId F : forall Q :: * . F Q -> Q natTransId :: Type TyName uni () -> Quote (Type TyName uni ()) natTransId f = do - q <- freshTyName "Q" - pure $ TyForall () q (Type ()) (TyFun () (TyApp () f (TyVar () q)) (TyVar () q)) + q <- freshTyName "Q" + pure $ TyForall () q (Type ()) (TyFun () (TyApp () f (TyVar () q)) (TyVar () q)) -- | The 'fixBy' combinator. -- @@ -220,70 +220,69 @@ fixBy = fst fixByAndType fixByAndType :: TermLike term TyName Name uni fun => (term (), Type TyName uni ()) fixByAndType = runQuote $ do - f <- freshTyName "F" - - -- by : (F ~> Id) -> (F ~> Id) - by <- freshName "by" - byTy <- do - nt1 <- natTransId (TyVar () f) - nt2 <- natTransId (TyVar () f) - pure $ TyFun () nt1 nt2 - - resTy <- do - nt1 <- natTrans (TyVar () f) (TyVar () f) - nt2 <- natTransId (TyVar () f) - pure $ TyFun () nt1 nt2 - - -- instantiatedFix = fix {F ~> F} {F ~> Id} - instantiatedFix <- do - nt1 <- natTrans (TyVar () f) (TyVar () f) - nt2 <- natTransId (TyVar () f) - pure $ tyInst () (tyInst () fix nt1) nt2 - - -- rec : (F ~> F) -> (F ~> Id) - recc <- freshName "rec" - reccTy <- do - nt <- natTrans (TyVar () f) (TyVar () f) - nt2 <- natTransId (TyVar () f) - pure $ TyFun () nt nt2 - - -- h : F ~> F - h <- freshName "h" - hty <- natTrans (TyVar () f) (TyVar () f) - - -- R :: * - -- fr : F R - r <- freshTyName "R" - fr <- freshName "fr" - let frTy = TyApp () (TyVar () f) (TyVar () r) - - -- Q :: * - -- fq : F Q - q <- freshTyName "Q" - fq <- freshName "fq" - let fqTy = TyApp () (TyVar () f) (TyVar () q) - - -- inner = (/\ (Q :: *) -> \ q : F Q -> rec h {Q} (h {Q} q)) - let inner = - apply () (var () by) $ - tyAbs () q (Type ()) $ - lamAbs () fq fqTy $ - apply () (tyInst () (apply () (var () recc) (var () h)) (TyVar () q)) $ + f <- freshTyName "F" + + -- by : (F ~> Id) -> (F ~> Id) + by <- freshName "by" + byTy <- do + nt1 <- natTransId (TyVar () f) + nt2 <- natTransId (TyVar () f) + pure $ TyFun () nt1 nt2 + + resTy <- do + nt1 <- natTrans (TyVar () f) (TyVar () f) + nt2 <- natTransId (TyVar () f) + pure $ TyFun () nt1 nt2 + + -- instantiatedFix = fix {F ~> F} {F ~> Id} + instantiatedFix <- do + nt1 <- natTrans (TyVar () f) (TyVar () f) + nt2 <- natTransId (TyVar () f) + pure $ tyInst () (tyInst () fix nt1) nt2 + + -- rec : (F ~> F) -> (F ~> Id) + recc <- freshName "rec" + reccTy <- do + nt <- natTrans (TyVar () f) (TyVar () f) + nt2 <- natTransId (TyVar () f) + pure $ TyFun () nt nt2 + + -- h : F ~> F + h <- freshName "h" + hty <- natTrans (TyVar () f) (TyVar () f) + + -- R :: * + -- fr : F R + r <- freshTyName "R" + fr <- freshName "fr" + let frTy = TyApp () (TyVar () f) (TyVar () r) + + -- Q :: * + -- fq : F Q + q <- freshTyName "Q" + fq <- freshName "fq" + let fqTy = TyApp () (TyVar () f) (TyVar () q) + + -- inner = (/\ (Q :: *) -> \ q : F Q -> rec h {Q} (h {Q} q)) + let inner = + apply () (var () by) $ + tyAbs () q (Type ()) $ + lamAbs () fq fqTy $ + apply () (tyInst () (apply () (var () recc) (var () h)) (TyVar () q)) $ apply () (tyInst () (var () h) (TyVar () q)) (var () fq) - let fixByTerm = - tyAbs () f (KindArrow () (Type ()) (Type ())) $ - lamAbs () by byTy $ + let fixByTerm = + tyAbs () f (KindArrow () (Type ()) (Type ())) $ + lamAbs () by byTy $ apply () instantiatedFix $ - lamAbs () recc reccTy $ - lamAbs () h hty $ - tyAbs () r (Type ()) $ - lamAbs () fr frTy $ - apply () (tyInst () inner (TyVar () r)) (var () fr) - let fixByType = - TyForall () f (KindArrow () (Type ()) (Type ())) $ - TyFun () byTy resTy - pure (fixByTerm, fixByType) - + lamAbs () recc reccTy $ + lamAbs () h hty $ + tyAbs () r (Type ()) $ + lamAbs () fr frTy $ + apply () (tyInst () inner (TyVar () r)) (var () fr) + let fixByType = + TyForall () f (KindArrow () (Type ()) (Type ())) $ + TyFun () byTy resTy + pure (fixByTerm, fixByType) -- | Make a @n@-ary fixpoint combinator. -- @@ -301,97 +300,100 @@ fixN n fixByTerm = fst (fixNAndType n fixByTerm) fixNAndType :: TermLike term TyName Name uni fun => Integer -> term () -> (term (), Type TyName uni ()) fixNAndType n fixByTerm = runQuote $ do - -- the list of pairs of A and B types - asbs <- replicateM (fromIntegral n) $ do - a <- freshTyName "a" - b <- freshTyName "b" - pure (a, b) - - let abFuns = fmap (\(a, b) -> TyFun () (TyVar () a) (TyVar () b)) asbs - let abTyVars = concatMap (\(a, b) -> [ TyVarDecl () a (Type ()), TyVarDecl () b (Type ())]) asbs - - -- funTysTo X = (A1 -> B1) -> ... -> (An -> Bn) -> X - let funTysTo = mkIterTyFun () abFuns - - -- the type of fixN, as in the header comment - fixNType <- do - q <- freshTyName "Q" - let qvar = TyVar () q - let argTy = TyForall () q (Type ()) (TyFun () (funTysTo qvar) (funTysTo qvar)) - r <- freshTyName "R" - let rvar = TyVar () r - let resTy = TyForall () r (Type ()) (TyFun () (funTysTo rvar) rvar) - let fullTy = mkIterTyForall abTyVars $ TyFun () argTy resTy - pure fullTy - - -- instantiatedFix = fixBy { \X :: * -> (A1 -> B1) -> ... -> (An -> Bn) -> X } - instantiatedFix <- do - x <- freshTyName "X" - pure $ tyInst () fixByTerm (TyLam () x (Type ()) (funTysTo (TyVar () x))) - - -- f : forall Q :: * . ((A1 -> B1) -> ... -> (An -> Bn) -> Q) -> (A1 -> B1) -> ... -> (An -> Bn) -> Q) - f <- freshName "f" - fTy <- do - q <- freshTyName "Q" - pure $ TyForall () q (Type ()) $ TyFun () (funTysTo (TyVar () q)) (funTysTo (TyVar () q)) - - -- k : forall Q :: * . ((A1 -> B1) -> ... -> (An -> Bn) -> Q) -> Q) - k <- freshName "k" - kTy <- do - q <- freshTyName "Q" - pure $ TyForall () q (Type ()) $ TyFun () (funTysTo (TyVar () q)) (TyVar () q) - - s <- freshTyName "S" - - -- h : (A1 -> B1) -> ... -> (An -> Bn) -> S - h <- freshName "h" - let hTy = funTysTo (TyVar () s) - - -- branch (ai, bi) i = \x : ai -> k { bi } \(f1 : A1 -> B1) ... (fn : An -> Bn) . fi x - let branch (a, b) i = do - -- names and types for the f arguments - fs <- ifor asbs $ \j (a',b') -> do - f_j <- freshName $ "f_" <> showText j - pure $ VarDecl () f_j (TyFun () (TyVar () a') (TyVar () b')) - - x <- freshName "x" - - pure $ - lamAbs () x (TyVar () a) $ - apply () (tyInst () (var () k) (TyVar () b)) $ - mkIterLamAbs fs $ + -- the list of pairs of A and B types + asbs <- replicateM (fromIntegral n) $ do + a <- freshTyName "a" + b <- freshTyName "b" + pure (a, b) + + let abFuns = fmap (\(a, b) -> TyFun () (TyVar () a) (TyVar () b)) asbs + let abTyVars = concatMap (\(a, b) -> [TyVarDecl () a (Type ()), TyVarDecl () b (Type ())]) asbs + + -- funTysTo X = (A1 -> B1) -> ... -> (An -> Bn) -> X + let funTysTo = mkIterTyFun () abFuns + + -- the type of fixN, as in the header comment + fixNType <- do + q <- freshTyName "Q" + let qvar = TyVar () q + let argTy = TyForall () q (Type ()) (TyFun () (funTysTo qvar) (funTysTo qvar)) + r <- freshTyName "R" + let rvar = TyVar () r + let resTy = TyForall () r (Type ()) (TyFun () (funTysTo rvar) rvar) + let fullTy = mkIterTyForall abTyVars $ TyFun () argTy resTy + pure fullTy + + -- instantiatedFix = fixBy { \X :: * -> (A1 -> B1) -> ... -> (An -> Bn) -> X } + instantiatedFix <- do + x <- freshTyName "X" + pure $ tyInst () fixByTerm (TyLam () x (Type ()) (funTysTo (TyVar () x))) + + -- f : forall Q :: * . ((A1 -> B1) -> ... -> (An -> Bn) -> Q) -> (A1 -> B1) -> ... -> (An -> Bn) -> Q) + f <- freshName "f" + fTy <- do + q <- freshTyName "Q" + pure $ TyForall () q (Type ()) $ TyFun () (funTysTo (TyVar () q)) (funTysTo (TyVar () q)) + + -- k : forall Q :: * . ((A1 -> B1) -> ... -> (An -> Bn) -> Q) -> Q) + k <- freshName "k" + kTy <- do + q <- freshTyName "Q" + pure $ TyForall () q (Type ()) $ TyFun () (funTysTo (TyVar () q)) (TyVar () q) + + s <- freshTyName "S" + + -- h : (A1 -> B1) -> ... -> (An -> Bn) -> S + h <- freshName "h" + let hTy = funTysTo (TyVar () s) + + -- branch (ai, bi) i = \x : ai -> k { bi } \(f1 : A1 -> B1) ... (fn : An -> Bn) . fi x + let branch (a, b) i = do + -- names and types for the f arguments + fs <- ifor asbs $ \j (a', b') -> do + f_j <- freshName $ "f_" <> showText j + pure $ VarDecl () f_j (TyFun () (TyVar () a') (TyVar () b')) + + x <- freshName "x" + + pure $ + lamAbs () x (TyVar () a) $ + apply () (tyInst () (var () k) (TyVar () b)) $ + mkIterLamAbs fs $ -- this is an ugly but straightforward way of getting the right fi apply () (mkVar (fs !! i)) (var () x) - -- a list of all the branches - branches <- forM (zip asbs [0..]) $ uncurry branch + -- a list of all the branches + branches <- forM (zip asbs [0 ..]) $ uncurry branch - -- [A1, B1, ..., An, Bn] - let allAsBs = foldMap (\(a, b) -> [a, b]) asbs - let fixNTerm = - -- abstract out all the As and Bs - mkIterTyAbs (fmap (\tn -> TyVarDecl () tn (Type ())) allAsBs) $ + -- [A1, B1, ..., An, Bn] + let allAsBs = foldMap (\(a, b) -> [a, b]) asbs + let fixNTerm = + -- abstract out all the As and Bs + mkIterTyAbs (fmap (\tn -> TyVarDecl () tn (Type ())) allAsBs) $ lamAbs () f fTy $ - mkIterAppNoAnn instantiatedFix + mkIterAppNoAnn + instantiatedFix [ lamAbs () k kTy $ - tyAbs () s (Type ()) $ - lamAbs () h hTy $ - mkIterAppNoAnn (var () h) branches + tyAbs () s (Type ()) $ + lamAbs () h hTy $ + mkIterAppNoAnn (var () h) branches , var () f ] - pure (fixNTerm, fixNType) + pure (fixNTerm, fixNType) -- See Note [Recursion combinators]. + -- | Get the fixed-point of a single recursive function. -getSingleFixOf - :: (TermLike term TyName Name uni fun) - => ann -> term ann -> FunctionDef term TyName Name uni fun ann -> term ann -getSingleFixOf ann fix1 fun@FunctionDef{_functionDefType=(FunctionType _ dom cod)} = - let instantiatedFix = mkIterInst fix1 [(ann, dom), (ann, cod)] - abstractedBody = mkIterLamAbs [functionDefVarDecl fun] $ _functionDefTerm fun - in apply ann instantiatedFix abstractedBody +getSingleFixOf :: + TermLike term TyName Name uni fun => + ann -> term ann -> FunctionDef term TyName Name uni fun ann -> term ann +getSingleFixOf ann fix1 fun@FunctionDef {_functionDefType = (FunctionType _ dom cod)} = + let instantiatedFix = mkIterInst fix1 [(ann, dom), (ann, cod)] + abstractedBody = mkIterLamAbs [functionDefVarDecl fun] $ _functionDefTerm fun + in apply ann instantiatedFix abstractedBody -- See Note [Recursion combinators]. + -- | Get the fixed-point of a list of mutually recursive functions. -- -- > MutualFixOf _ fixN [ FunctionDef _ fN1 (FunctionType _ a1 b1) f1 @@ -402,30 +404,30 @@ getSingleFixOf ann fix1 fun@FunctionDef{_functionDefType=(FunctionType _ dom cod -- > fixN {a1} {b1} ... {an} {bn} -- > /\(q :: *) -> \(choose : (a1 -> b1) -> ... -> (an -> bn) -> q) -> -- > \(fN1 : a1 -> b1) ... (fNn : an -> bn) -> choose f1 ... fn -getMutualFixOf - :: (TermLike term TyName Name uni fun) - => ann -> term ann -> [FunctionDef term TyName Name uni fun ann] -> Quote (Tuple term uni ann) +getMutualFixOf :: + TermLike term TyName Name uni fun => + ann -> term ann -> [FunctionDef term TyName Name uni fun ann] -> Quote (Tuple term uni ann) getMutualFixOf ann fixn funs = do - let funTys = map functionDefToType funs + let funTys = map functionDefToType funs - q <- liftQuote $ freshTyName "Q" - -- TODO: It was 'safeFreshName' previously. Should we perhaps have @freshName = safeFreshName@? - choose <- freshName "choose" - let chooseTy = mkIterTyFun ann funTys (TyVar ann q) + q <- liftQuote $ freshTyName "Q" + -- TODO: It was 'safeFreshName' previously. Should we perhaps have @freshName = safeFreshName@? + choose <- freshName "choose" + let chooseTy = mkIterTyFun ann funTys (TyVar ann q) - -- \v1 ... vn -> choose f1 ... fn - let rhss = map _functionDefTerm funs - chosen = mkIterApp (var ann choose) ((ann,) <$> rhss) - vsLam = mkIterLamAbs (map functionDefVarDecl funs) chosen + -- \v1 ... vn -> choose f1 ... fn + let rhss = map _functionDefTerm funs + chosen = mkIterApp (var ann choose) ((ann,) <$> rhss) + vsLam = mkIterLamAbs (map functionDefVarDecl funs) chosen - -- abstract out Q and choose - let cLam = tyAbs ann q (Type ann) $ lamAbs ann choose chooseTy vsLam + -- abstract out Q and choose + let cLam = tyAbs ann q (Type ann) $ lamAbs ann choose chooseTy vsLam - -- fixN {A1} {B1} ... {An} {Bn} - instantiatedFix <- do - let domCods = foldMap (\(FunctionDef _ _ (FunctionType _ dom cod) _) -> [dom, cod]) funs - pure $ mkIterInst fixn ((ann,) <$> domCods) + -- fixN {A1} {B1} ... {An} {Bn} + instantiatedFix <- do + let domCods = foldMap (\(FunctionDef _ _ (FunctionType _ dom cod) _) -> [dom, cod]) funs + pure $ mkIterInst fixn ((ann,) <$> domCods) - let term = apply ann instantiatedFix cLam + let term = apply ann instantiatedFix cLam - pure $ Tuple funTys term + pure $ Tuple funTys term diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Integer.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Integer.hs index a37c452898c..d4b65cff5d4 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Integer.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Integer.hs @@ -1,13 +1,12 @@ --- | Functions related to @integer@. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.Integer - ( integer - , succInteger - ) where +-- | Functions related to @integer@. +module PlutusCore.StdLib.Data.Integer ( + integer, + succInteger, +) where import PlutusCore.Core import PlutusCore.Default.Builtins @@ -21,13 +20,13 @@ integer = mkTyBuiltin @_ @Integer () -- | @succ :: Integer -> Integer@ as a PLC term. -- -- > \(i : integer) -> addInteger i 1 -succInteger - :: (TermLike term tyname Name uni DefaultFun, uni `HasTypeAndTermLevel` Integer) => term () +succInteger :: + (TermLike term tyname Name uni DefaultFun, uni `HasTypeAndTermLevel` Integer) => term () succInteger = runQuote $ do - i <- freshName "i" - return - . lamAbs () i integer - . mkIterAppNoAnn (builtin () AddInteger) - $ [ var () i - , mkConstant @Integer () 1 - ] + i <- freshName "i" + return + . lamAbs () i integer + . mkIterAppNoAnn (builtin () AddInteger) + $ [ var () i + , mkConstant @Integer () 1 + ] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/List.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/List.hs index 8bbf699a06d..26b14c5e0e0 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/List.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/List.hs @@ -1,19 +1,18 @@ --- | Built-in @list@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.List - ( list - , MatchOption (..) - , matchList - , foldrList - , foldList - , sum - , sumr - , product - ) where +-- | Built-in @list@ and related functions. +module PlutusCore.StdLib.Data.List ( + list, + MatchOption (..), + matchList, + foldrList, + foldList, + sum, + sumr, + product, +) where import Prelude hiding (enumFromTo, map, product, reverse, sum) @@ -58,34 +57,37 @@ list = mkTyBuiltin @_ @[] () -- depending on the 'MatchOption' argument. matchList :: TermLike term TyName Name DefaultUni DefaultFun => MatchOption -> term () matchList optMatch = runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - xs <- freshName "xs" - z <- freshName "z" - f <- freshName "f" - u <- freshName "u" - let listA = TyApp () list $ TyVar () a - funAtXs fun = apply () (tyInst () (builtin () fun) $ TyVar () a) $ var () xs - return - . tyAbs () a (Type ()) - . lamAbs () xs listA - . tyAbs () r (Type ()) - . lamAbs () z (TyVar () r) - . lamAbs () f (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) - $ case optMatch of - UseChoose -> - mkIterAppNoAnn - (mkIterInstNoAnn (builtin () ChooseList) - [ TyVar () a - , TyFun () unit $ TyVar () r - ]) - [ var () xs - , lamAbs () u unit $ var () z - , lamAbs () u unit - $ mkIterAppNoAnn (var () f) - [funAtXs HeadList, funAtXs TailList] - , unitval - ] + a <- freshTyName "a" + r <- freshTyName "r" + xs <- freshName "xs" + z <- freshName "z" + f <- freshName "f" + u <- freshName "u" + let listA = TyApp () list $ TyVar () a + funAtXs fun = apply () (tyInst () (builtin () fun) $ TyVar () a) $ var () xs + return + . tyAbs () a (Type ()) + . lamAbs () xs listA + . tyAbs () r (Type ()) + . lamAbs () z (TyVar () r) + . lamAbs () f (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) + $ case optMatch of + UseChoose -> + mkIterAppNoAnn + ( mkIterInstNoAnn + (builtin () ChooseList) + [ TyVar () a + , TyFun () unit $ TyVar () r + ] + ) + [ var () xs + , lamAbs () u unit $ var () z + , lamAbs () u unit $ + mkIterAppNoAnn + (var () f) + [funAtXs HeadList, funAtXs TailList] + , unitval + ] -- | @foldr@ over built-in lists. -- @@ -94,32 +96,33 @@ matchList optMatch = runQuote $ do -- > matchList {a} xs {r} z \(x : a) (xs' : list a) -> f x (rec xs') foldrList :: TermLike term TyName Name DefaultUni DefaultFun => MatchOption -> term () foldrList optMatch = runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - rec <- freshName "rec" - xs <- freshName "xs" - x <- freshName "x" - xs' <- freshName "xs'" - let listA = TyApp () list $ TyVar () a - unwrap' ann = apply ann . tyInst () (matchList optMatch) $ TyVar () a - -- Copypasted verbatim from @foldrList@ over Scott-encoded lists. - return - . tyAbs () a (Type ()) - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () a) . TyFun () (TyVar () r) $ TyVar () r) - . lamAbs () z (TyVar () r) - . apply () (mkIterInstNoAnn fix [listA, TyVar () r]) - . lamAbs () rec (TyFun () listA $ TyVar () r) - . lamAbs () xs listA - . apply () (apply () (tyInst () (unwrap' () (var () xs)) $ TyVar () r) $ var () z) - . lamAbs () x (TyVar () a) - . lamAbs () xs' listA - $ mkIterAppNoAnn (var () f) - [ var () x - , apply () (var () rec) $ var () xs' - ] + a <- freshTyName "a" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + rec <- freshName "rec" + xs <- freshName "xs" + x <- freshName "x" + xs' <- freshName "xs'" + let listA = TyApp () list $ TyVar () a + unwrap' ann = apply ann . tyInst () (matchList optMatch) $ TyVar () a + -- Copypasted verbatim from @foldrList@ over Scott-encoded lists. + return + . tyAbs () a (Type ()) + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () a) . TyFun () (TyVar () r) $ TyVar () r) + . lamAbs () z (TyVar () r) + . apply () (mkIterInstNoAnn fix [listA, TyVar () r]) + . lamAbs () rec (TyFun () listA $ TyVar () r) + . lamAbs () xs listA + . apply () (apply () (tyInst () (unwrap' () (var () xs)) $ TyVar () r) $ var () z) + . lamAbs () x (TyVar () a) + . lamAbs () xs' listA + $ mkIterAppNoAnn + (var () f) + [ var () x + , apply () (var () rec) $ var () xs' + ] -- | 'foldl\'' as a PLC term. -- @@ -128,57 +131,57 @@ foldrList optMatch = runQuote $ do -- > matchList {a} xs {r} z \(x : a) (xs' : list a) -> rec (f z x) xs' foldList :: TermLike term TyName Name DefaultUni DefaultFun => MatchOption -> term () foldList optMatch = runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - f <- freshName "f" - rec <- freshName "rec" - z <- freshName "z" - xs <- freshName "xs" - x <- freshName "x" - xs' <- freshName "xs'" - let listA = TyApp () list $ TyVar () a - unwrap' ann = apply ann . tyInst () (matchList optMatch) $ TyVar () a - return - . tyAbs () a (Type ()) - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () r) . TyFun () (TyVar () a) $ TyVar () r) - . apply () (mkIterInstNoAnn fix [TyVar () r, TyFun () listA $ TyVar () r]) - . lamAbs () rec (TyFun () (TyVar () r) . TyFun () listA $ TyVar () r) - . lamAbs () z (TyVar () r) - . lamAbs () xs listA - . apply () (apply () (tyInst () (unwrap' () (var () xs)) $ TyVar () r) $ var () z) - . lamAbs () x (TyVar () a) - . lamAbs () xs' listA - . mkIterAppNoAnn (var () rec) - $ [ mkIterAppNoAnn (var () f) [var () z, var () x] - , var () xs' - ] + a <- freshTyName "a" + r <- freshTyName "r" + f <- freshName "f" + rec <- freshName "rec" + z <- freshName "z" + xs <- freshName "xs" + x <- freshName "x" + xs' <- freshName "xs'" + let listA = TyApp () list $ TyVar () a + unwrap' ann = apply ann . tyInst () (matchList optMatch) $ TyVar () a + return + . tyAbs () a (Type ()) + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () r) . TyFun () (TyVar () a) $ TyVar () r) + . apply () (mkIterInstNoAnn fix [TyVar () r, TyFun () listA $ TyVar () r]) + . lamAbs () rec (TyFun () (TyVar () r) . TyFun () listA $ TyVar () r) + . lamAbs () z (TyVar () r) + . lamAbs () xs listA + . apply () (apply () (tyInst () (unwrap' () (var () xs)) $ TyVar () r) $ var () z) + . lamAbs () x (TyVar () a) + . lamAbs () xs' listA + . mkIterAppNoAnn (var () rec) + $ [ mkIterAppNoAnn (var () f) [var () z, var () x] + , var () xs' + ] -- > foldList {integer} {integer} addInteger 0 sum :: TermLike term TyName Name DefaultUni DefaultFun => MatchOption -> term () sum optMatch = runQuote $ do - let int = mkTyBuiltin @_ @Integer () - add = builtin () AddInteger - return - . mkIterAppNoAnn (mkIterInstNoAnn (foldList optMatch) [int, int]) - $ [ add , mkConstant @Integer () 0] + let int = mkTyBuiltin @_ @Integer () + add = builtin () AddInteger + return + . mkIterAppNoAnn (mkIterInstNoAnn (foldList optMatch) [int, int]) + $ [add, mkConstant @Integer () 0] -- > foldrList {integer} {integer} 0 addInteger sumr :: TermLike term TyName Name DefaultUni DefaultFun => MatchOption -> term () sumr optMatch = runQuote $ do - let int = mkTyBuiltin @_ @Integer () - add = builtin () AddInteger - return - . mkIterAppNoAnn (mkIterInstNoAnn (foldrList optMatch) [int, int]) - $ [ add, mkConstant @Integer () 0 ] + let int = mkTyBuiltin @_ @Integer () + add = builtin () AddInteger + return + . mkIterAppNoAnn (mkIterInstNoAnn (foldrList optMatch) [int, int]) + $ [add, mkConstant @Integer () 0] -- | 'product' as a PLC term. -- -- > foldList {integer} {integer} multiplyInteger 1 product :: TermLike term TyName Name DefaultUni DefaultFun => MatchOption -> term () product optMatch = runQuote $ do - let int = mkTyBuiltin @_ @Integer () - mul = builtin () MultiplyInteger - return - . mkIterAppNoAnn (mkIterInstNoAnn (foldList optMatch) [int, int]) - $ [ mul , mkConstant @Integer () 1] + let int = mkTyBuiltin @_ @Integer () + mul = builtin () MultiplyInteger + return + . mkIterAppNoAnn (mkIterInstNoAnn (foldList optMatch) [int, int]) + $ [mul, mkConstant @Integer () 1] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/MatchOption.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/MatchOption.hs index 5885f30ca0c..76dc8bf7f76 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/MatchOption.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/MatchOption.hs @@ -1,9 +1,9 @@ -module PlutusCore.StdLib.Data.MatchOption - ( MatchOption (..) - ) where +module PlutusCore.StdLib.Data.MatchOption ( + MatchOption (..), +) where -- | Allows one to choose which way of doing pattern matching on built-in types to use: currently -- only 'ChooseList'-like builtins are supported. data MatchOption - = UseChoose - deriving stock (Show, Eq, Bounded, Enum) + = UseChoose + deriving stock (Show, Eq, Bounded, Enum) diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Nat.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Nat.hs index a6d43b7c1b7..7e348791159 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Nat.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Nat.hs @@ -1,18 +1,17 @@ --- | @nat@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.Nat - ( natData - , natTy - , zero - , succ - , foldrNat - , foldNat - , natToInteger - ) where +-- | @nat@ and related functions. +module PlutusCore.StdLib.Data.Nat ( + natData, + natTy, + zero, + succ, + foldrNat, + foldNat, + natToInteger, +) where import Prelude hiding (succ) @@ -30,13 +29,13 @@ import PlutusCore.StdLib.Type -- > fix \(nat :: *) -> all r. r -> (nat -> r) -> r natData :: RecursiveType uni fun () natData = runQuote $ do - nat <- freshTyName "nat" - r <- freshTyName "r" - makeRecursiveType () nat [] - . TyForall () r (Type ()) - . TyFun () (TyVar () r) - . TyFun () (TyFun () (TyVar () nat) $ TyVar () r) - $ TyVar () r + nat <- freshTyName "nat" + r <- freshTyName "r" + makeRecursiveType () nat [] + . TyForall () r (Type ()) + . TyFun () (TyVar () r) + . TyFun () (TyFun () (TyVar () nat) $ TyVar () r) + $ TyVar () r natTy :: Type TyName uni () natTy = _recursiveType natData @@ -46,35 +45,35 @@ natTy = _recursiveType natData -- > wrapNat [] /\(r :: *) -> \(z : r) (f : nat -> r) -> z zero :: TermLike term TyName Name uni fun => term () zero = runQuote $ do - let RecursiveType nat wrapNat = natData - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - return - . wrapNat [] - . tyAbs () r (Type ()) - . lamAbs () z (TyVar () r) - . lamAbs () f (TyFun () nat $ TyVar () r) - $ var () z + let RecursiveType nat wrapNat = natData + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + return + . wrapNat [] + . tyAbs () r (Type ()) + . lamAbs () z (TyVar () r) + . lamAbs () f (TyFun () nat $ TyVar () r) + $ var () z -- | 'succ' as a PLC term. -- -- > \(n : nat) -> wrapNat [] /\(r :: *) -> \(z : r) (f : nat -> r) -> f n succ :: TermLike term TyName Name uni fun => term () succ = runQuote $ do - let RecursiveType nat wrapNat = natData - n <- freshName "n" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - return - . lamAbs () n nat - . wrapNat [] - . tyAbs () r (Type ()) - . lamAbs () z (TyVar () r) - . lamAbs () f (TyFun () nat $ TyVar () r) - . apply () (var () f) - $ var () n + let RecursiveType nat wrapNat = natData + n <- freshName "n" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + return + . lamAbs () n nat + . wrapNat [] + . tyAbs () r (Type ()) + . lamAbs () z (TyVar () r) + . lamAbs () f (TyFun () nat $ TyVar () r) + . apply () (var () f) + $ var () n -- | @foldrNat@ as a PLC term. -- @@ -83,25 +82,25 @@ succ = runQuote $ do -- > unwrap n {r} z \(n' : nat) -> f (rec n') foldrNat :: TermLike term TyName Name uni fun => term () foldrNat = runQuote $ do - let nat = _recursiveType natData - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - rec <- freshName "rec" - n <- freshName "n" - n' <- freshName "n'" - return - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () r) (TyVar () r)) - . lamAbs () z (TyVar () r) - . apply () (mkIterInstNoAnn fix [nat, TyVar () r]) - . lamAbs () rec (TyFun () nat $ TyVar () r) - . lamAbs () n nat - . apply () (apply () (tyInst () (unwrap () (var () n)) $ TyVar () r) $ var () z) - . lamAbs () n' nat - . apply () (var () f) - . apply () (var () rec) - $ var () n' + let nat = _recursiveType natData + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + rec <- freshName "rec" + n <- freshName "n" + n' <- freshName "n'" + return + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () r) (TyVar () r)) + . lamAbs () z (TyVar () r) + . apply () (mkIterInstNoAnn fix [nat, TyVar () r]) + . lamAbs () rec (TyFun () nat $ TyVar () r) + . lamAbs () n nat + . apply () (apply () (tyInst () (unwrap () (var () n)) $ TyVar () r) $ var () z) + . lamAbs () n' nat + . apply () (var () f) + . apply () (var () rec) + $ var () n' -- | @foldNat@ as a PLC term. -- @@ -110,35 +109,36 @@ foldrNat = runQuote $ do -- > unwrap n {r} z (\(n' : nat) -> rec (f z) n') foldNat :: TermLike term TyName Name uni fun => term () foldNat = runQuote $ do - let nat = _recursiveType natData - r <- freshTyName "r" - f <- freshName "f" - rec <- freshName "rec" - z <- freshName "z" - n <- freshName "n" - n' <- freshName "n'" - return - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () r) (TyVar () r)) - . apply () (mkIterInstNoAnn fix [TyVar () r, TyFun () nat $ TyVar () r]) - . lamAbs () rec (TyFun () (TyVar () r) . TyFun () nat $ TyVar () r) - . lamAbs () z (TyVar () r) - . lamAbs () n nat - . apply () (apply () (tyInst () (unwrap () (var () n)) $ TyVar () r) $ var () z) - . lamAbs () n' nat - . mkIterAppNoAnn (var () rec) - $ [ apply () (var () f) $ var () z - , var () n' - ] + let nat = _recursiveType natData + r <- freshTyName "r" + f <- freshName "f" + rec <- freshName "rec" + z <- freshName "z" + n <- freshName "n" + n' <- freshName "n'" + return + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () r) (TyVar () r)) + . apply () (mkIterInstNoAnn fix [TyVar () r, TyFun () nat $ TyVar () r]) + . lamAbs () rec (TyFun () (TyVar () r) . TyFun () nat $ TyVar () r) + . lamAbs () z (TyVar () r) + . lamAbs () n nat + . apply () (apply () (tyInst () (unwrap () (var () n)) $ TyVar () r) $ var () z) + . lamAbs () n' nat + . mkIterAppNoAnn (var () rec) + $ [ apply () (var () f) $ var () z + , var () n' + ] -- | Convert a @nat@ to an @integer@. -- -- > foldNat {integer} (addInteger 1) 1 -natToInteger - :: (TermLike term TyName Name uni DefaultFun, uni `HasTypeAndTermLevel` Integer) => term () +natToInteger :: + (TermLike term TyName Name uni DefaultFun, uni `HasTypeAndTermLevel` Integer) => term () natToInteger = runQuote $ do - return $ - mkIterAppNoAnn (tyInst () foldNat $ mkTyBuiltin @_ @Integer ()) - [ apply () (builtin () AddInteger) (mkConstant @Integer () 1) - , mkConstant @Integer () 0 - ] + return $ + mkIterAppNoAnn + (tyInst () foldNat $ mkTyBuiltin @_ @Integer ()) + [ apply () (builtin () AddInteger) (mkConstant @Integer () 1) + , mkConstant @Integer () 0 + ] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Pair.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Pair.hs index 17205d93206..ee0845ed953 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Pair.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Pair.hs @@ -1,15 +1,14 @@ --- | Built-in @pair@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.Pair - ( pair - , fstPair - , sndPair - , uncurry - ) where +-- | Built-in @pair@ and related functions. +module PlutusCore.StdLib.Data.Pair ( + pair, + fstPair, + sndPair, + uncurry, +) where import Prelude hiding (fst, snd, uncurry) @@ -41,18 +40,19 @@ sndPair = builtin () SndPair -- > f (fst {a} {b} p) (snd {a} {b} p) uncurry :: TermLike term TyName Name DefaultUni DefaultFun => term () uncurry = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - c <- freshTyName "c" - f <- freshName "f" - p <- freshName "p" - return - . tyAbs () a (Type ()) - . tyAbs () b (Type ()) - . tyAbs () c (Type ()) - . lamAbs () f (TyFun () (TyVar () a) . TyFun () (TyVar () b) $ TyVar () c) - . lamAbs () p (mkIterTyAppNoAnn pair [TyVar () a, TyVar () b]) - $ mkIterAppNoAnn (var () f) - [ apply () (mkIterInstNoAnn fstPair [TyVar () a, TyVar () b]) $ var () p - , apply () (mkIterInstNoAnn sndPair [TyVar () a, TyVar () b]) $ var () p - ] + a <- freshTyName "a" + b <- freshTyName "b" + c <- freshTyName "c" + f <- freshName "f" + p <- freshName "p" + return + . tyAbs () a (Type ()) + . tyAbs () b (Type ()) + . tyAbs () c (Type ()) + . lamAbs () f (TyFun () (TyVar () a) . TyFun () (TyVar () b) $ TyVar () c) + . lamAbs () p (mkIterTyAppNoAnn pair [TyVar () a, TyVar () b]) + $ mkIterAppNoAnn + (var () f) + [ apply () (mkIterInstNoAnn fstPair [TyVar () a, TyVar () b]) $ var () p + , apply () (mkIterInstNoAnn sndPair [TyVar () a, TyVar () b]) $ var () p + ] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottList.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottList.hs index 988ec406be4..8275a0f8594 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottList.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottList.hs @@ -1,23 +1,22 @@ --- | @list@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.ScottList - ( listData - , listTy - , nil - , cons - , foldrList - , foldList - , map - , reverse - , enumFromTo - , sum - , sumr - , product - ) where +-- | @list@ and related functions. +module PlutusCore.StdLib.Data.ScottList ( + listData, + listTy, + nil, + cons, + foldrList, + foldList, + map, + reverse, + enumFromTo, + sum, + sumr, + product, +) where import Prelude hiding (enumFromTo, map, product, reverse, sum) @@ -38,15 +37,15 @@ import PlutusCore.StdLib.Type -- > fix \(list :: * -> *) (a :: *) -> all (r :: *). r -> (a -> list a -> r) -> r listData :: RecursiveType uni fun () listData = runQuote $ do - a <- freshTyName "a" - list <- freshTyName "list" - r <- freshTyName "r" - let listA = TyApp () (TyVar () list) (TyVar () a) - makeRecursiveType () list [TyVarDecl () a $ Type ()] - . TyForall () r (Type ()) - . TyFun () (TyVar () r) - . TyFun () (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) - $ TyVar () r + a <- freshTyName "a" + list <- freshTyName "list" + r <- freshTyName "r" + let listA = TyApp () (TyVar () list) (TyVar () a) + makeRecursiveType () list [TyVarDecl () a $ Type ()] + . TyForall () r (Type ()) + . TyFun () (TyVar () r) + . TyFun () (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) + $ TyVar () r listTy :: Type TyName uni () listTy = _recursiveType listData @@ -56,19 +55,19 @@ listTy = _recursiveType listData -- > /\(a :: *) -> wrapList [a] /\(r :: *) -> \(z : r) (f : a -> list a -> r) -> z) nil :: TermLike term TyName Name uni fun => term () nil = runQuote $ do - let RecursiveType list wrapList = listData - a <- freshTyName "a" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - let listA = TyApp () list (TyVar () a) - return - . tyAbs () a (Type ()) - . wrapList [TyVar () a] - . tyAbs () r (Type ()) - . lamAbs () z (TyVar () r) - . lamAbs () f (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) - $ var () z + let RecursiveType list wrapList = listData + a <- freshTyName "a" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + let listA = TyApp () list (TyVar () a) + return + . tyAbs () a (Type ()) + . wrapList [TyVar () a] + . tyAbs () r (Type ()) + . lamAbs () z (TyVar () r) + . lamAbs () f (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) + $ var () z -- | '(:)' as a PLC term. -- @@ -76,26 +75,27 @@ nil = runQuote $ do -- > wrapList [a] /\(r :: *) -> \(z : r) (f : a -> list a -> r) -> f x xs cons :: TermLike term TyName Name uni fun => term () cons = runQuote $ do - let RecursiveType list wrapList = listData - a <- freshTyName "a" - x <- freshName "x" - xs <- freshName "xs" - r <- freshTyName "r" - z <- freshName "z" - f <- freshName "f" - let listA = TyApp () list (TyVar () a) - return - . tyAbs () a (Type ()) - . lamAbs () x (TyVar () a) - . lamAbs () xs listA - . wrapList [TyVar () a] - . tyAbs () r (Type ()) - . lamAbs () z (TyVar () r) - . lamAbs () f (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) - $ mkIterAppNoAnn (var () f) - [ var () x - , var () xs - ] + let RecursiveType list wrapList = listData + a <- freshTyName "a" + x <- freshName "x" + xs <- freshName "xs" + r <- freshTyName "r" + z <- freshName "z" + f <- freshName "f" + let listA = TyApp () list (TyVar () a) + return + . tyAbs () a (Type ()) + . lamAbs () x (TyVar () a) + . lamAbs () xs listA + . wrapList [TyVar () a] + . tyAbs () r (Type ()) + . lamAbs () z (TyVar () r) + . lamAbs () f (TyFun () (TyVar () a) . TyFun () listA $ TyVar () r) + $ mkIterAppNoAnn + (var () f) + [ var () x + , var () xs + ] -- | @foldrList@ as a PLC term. -- @@ -104,30 +104,31 @@ cons = runQuote $ do -- > unwrap xs {r} z \(x : a) (xs' : list a) -> f x (rec xs') foldrList :: TermLike term TyName Name uni fun => term () foldrList = runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - f <- freshName "f" - z <- freshName "z" - rec <- freshName "rec" - xs <- freshName "xs" - x <- freshName "x" - xs' <- freshName "xs'" - let listA = TyApp () listTy (TyVar () a) - return - . tyAbs () a (Type ()) - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () a) . TyFun () (TyVar () r) $ TyVar () r) - . lamAbs () z (TyVar () r) - . apply () (mkIterInstNoAnn fix [listA, TyVar () r]) - . lamAbs () rec (TyFun () listA $ TyVar () r) - . lamAbs () xs listA - . apply () (apply () (tyInst () (unwrap () (var () xs)) $ TyVar () r) $ var () z) - . lamAbs () x (TyVar () a) - . lamAbs () xs' listA - $ mkIterAppNoAnn (var () f) - [ var () x - , apply () (var () rec) $ var () xs' - ] + a <- freshTyName "a" + r <- freshTyName "r" + f <- freshName "f" + z <- freshName "z" + rec <- freshName "rec" + xs <- freshName "xs" + x <- freshName "x" + xs' <- freshName "xs'" + let listA = TyApp () listTy (TyVar () a) + return + . tyAbs () a (Type ()) + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () a) . TyFun () (TyVar () r) $ TyVar () r) + . lamAbs () z (TyVar () r) + . apply () (mkIterInstNoAnn fix [listA, TyVar () r]) + . lamAbs () rec (TyFun () listA $ TyVar () r) + . lamAbs () xs listA + . apply () (apply () (tyInst () (unwrap () (var () xs)) $ TyVar () r) $ var () z) + . lamAbs () x (TyVar () a) + . lamAbs () xs' listA + $ mkIterAppNoAnn + (var () f) + [ var () x + , apply () (var () rec) $ var () xs' + ] -- | @map@ as a PLC term. -- @@ -135,21 +136,21 @@ foldrList = runQuote $ do -- > foldrList {a} {list b} (\(x : a) -> cons {b} (f x)) (nil {b}) map :: TermLike term TyName Name uni fun => term () map = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - f <- freshName "f" - x <- freshName "x" - return - . tyAbs () a (Type ()) - . tyAbs () b (Type ()) - . lamAbs () f (TyFun () (TyVar () a) $ TyVar () b) - . mkIterAppNoAnn (mkIterInstNoAnn foldrList [TyVar () a, TyApp () listTy $ TyVar () b]) - $ [ lamAbs () x (TyVar () a) - . apply () (tyInst () cons (TyVar () b)) - . apply () (var () f) - $ var () x - , tyInst () nil $ TyVar () b - ] + a <- freshTyName "a" + b <- freshTyName "b" + f <- freshName "f" + x <- freshName "x" + return + . tyAbs () a (Type ()) + . tyAbs () b (Type ()) + . lamAbs () f (TyFun () (TyVar () a) $ TyVar () b) + . mkIterAppNoAnn (mkIterInstNoAnn foldrList [TyVar () a, TyApp () listTy $ TyVar () b]) + $ [ lamAbs () x (TyVar () a) + . apply () (tyInst () cons (TyVar () b)) + . apply () (var () f) + $ var () x + , tyInst () nil $ TyVar () b + ] -- | 'foldl\'' as a PLC term. -- @@ -158,30 +159,30 @@ map = runQuote $ do -- > unwrap xs {r} z \(x : a) (xs' : list a) -> rec (f z x) xs' foldList :: TermLike term TyName Name uni fun => term () foldList = runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - f <- freshName "f" - rec <- freshName "rec" - z <- freshName "z" - xs <- freshName "xs" - x <- freshName "x" - xs' <- freshName "xs'" - let listA = TyApp () listTy (TyVar () a) - return - . tyAbs () a (Type ()) - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () r) . TyFun () (TyVar () a) $ TyVar () r) - . apply () (mkIterInstNoAnn fix [TyVar () r, TyFun () listA $ TyVar () r]) - . lamAbs () rec (TyFun () (TyVar () r) . TyFun () listA $ TyVar () r) - . lamAbs () z (TyVar () r) - . lamAbs () xs listA - . apply () (apply () (tyInst () (unwrap () (var () xs)) $ TyVar () r) $ var () z) - . lamAbs () x (TyVar () a) - . lamAbs () xs' listA - . mkIterAppNoAnn (var () rec) - $ [ mkIterAppNoAnn (var () f) [var () z, var () x] - , var () xs' - ] + a <- freshTyName "a" + r <- freshTyName "r" + f <- freshName "f" + rec <- freshName "rec" + z <- freshName "z" + xs <- freshName "xs" + x <- freshName "x" + xs' <- freshName "xs'" + let listA = TyApp () listTy (TyVar () a) + return + . tyAbs () a (Type ()) + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () r) . TyFun () (TyVar () a) $ TyVar () r) + . apply () (mkIterInstNoAnn fix [TyVar () r, TyFun () listA $ TyVar () r]) + . lamAbs () rec (TyFun () (TyVar () r) . TyFun () listA $ TyVar () r) + . lamAbs () z (TyVar () r) + . lamAbs () xs listA + . apply () (apply () (tyInst () (unwrap () (var () xs)) $ TyVar () r) $ var () z) + . lamAbs () x (TyVar () a) + . lamAbs () xs' listA + . mkIterAppNoAnn (var () rec) + $ [ mkIterAppNoAnn (var () f) [var () z, var () x] + , var () xs' + ] -- | 'reverse' as a PLC term. -- @@ -189,21 +190,22 @@ foldList = runQuote $ do -- > foldList {a} {list a} (\(r : list a) (x : a) -> cons {a} x r) (nil {a}) reverse :: TermLike term TyName Name uni fun => term () reverse = runQuote $ do - a <- freshTyName "a" - xs <- freshName "xs" - x <- freshName "x" - r <- freshName "r" - let vA = TyVar () a - listA = TyApp () listTy vA - return - . tyAbs () a (Type ()) - . lamAbs () xs listA - $ mkIterAppNoAnn (mkIterInstNoAnn foldList [vA, listA]) - [ lamAbs () r listA . lamAbs () x vA $ - mkIterAppNoAnn (tyInst () cons vA) [var () x, var () r] - , tyInst () nil vA - , var () xs - ] + a <- freshTyName "a" + xs <- freshName "xs" + x <- freshName "x" + r <- freshName "r" + let vA = TyVar () a + listA = TyApp () listTy vA + return + . tyAbs () a (Type ()) + . lamAbs () xs listA + $ mkIterAppNoAnn + (mkIterInstNoAnn foldList [vA, listA]) + [ lamAbs () r listA . lamAbs () x vA $ + mkIterAppNoAnn (tyInst () cons vA) [var () x, var () r] + , tyInst () nil vA + , var () xs + ] -- | 'enumFromTo' as a PLC term -- @@ -215,68 +217,70 @@ reverse = runQuote $ do -- > (cons {integer} n' (rec (succInteger n'))) -- > (nil {integer})) -- > n -enumFromTo - :: ( TermLike term TyName Name uni DefaultFun - , uni `HasTypeAndTermLevel` Integer - , uni `HasTypeAndTermLevel` () - , uni `HasTypeAndTermLevel` Bool - ) - => term () +enumFromTo :: + ( TermLike term TyName Name uni DefaultFun + , uni `HasTypeAndTermLevel` Integer + , uni `HasTypeAndTermLevel` () + , uni `HasTypeAndTermLevel` Bool + ) => + term () enumFromTo = runQuote $ do - n <- freshName "n" - m <- freshName "m" - rec <- freshName "rec" - n' <- freshName "n'" - u <- freshName "u" - let leqInteger = builtin () LessThanEqualsInteger - int = mkTyBuiltin @_ @Integer () - listInt = TyApp () listTy int - return - . lamAbs () n int - . lamAbs () m int - . mkIterAppNoAnn (mkIterInstNoAnn fix [int, listInt]) - $ [ lamAbs () rec (TyFun () int listInt) - . lamAbs () n' int - . mkIterAppNoAnn (tyInst () ifThenElse listInt) - $ [ mkIterAppNoAnn leqInteger [ var () n' , var () m] - , lamAbs () u unit $ mkIterAppNoAnn (tyInst () cons int) - [ var () n' - , apply () (var () rec) - . apply () succInteger - $ var () n' - ] - , lamAbs () u unit $ tyInst () nil int - ] - , var () n - ] + n <- freshName "n" + m <- freshName "m" + rec <- freshName "rec" + n' <- freshName "n'" + u <- freshName "u" + let leqInteger = builtin () LessThanEqualsInteger + int = mkTyBuiltin @_ @Integer () + listInt = TyApp () listTy int + return + . lamAbs () n int + . lamAbs () m int + . mkIterAppNoAnn (mkIterInstNoAnn fix [int, listInt]) + $ [ lamAbs () rec (TyFun () int listInt) + . lamAbs () n' int + . mkIterAppNoAnn (tyInst () ifThenElse listInt) + $ [ mkIterAppNoAnn leqInteger [var () n', var () m] + , lamAbs () u unit $ + mkIterAppNoAnn + (tyInst () cons int) + [ var () n' + , apply () (var () rec) + . apply () succInteger + $ var () n' + ] + , lamAbs () u unit $ tyInst () nil int + ] + , var () n + ] -- | 'sum' as a PLC term. -- -- > foldList {integer} {integer} addInteger 0 sum :: (TermLike term TyName Name uni DefaultFun, uni `HasTypeAndTermLevel` Integer) => term () sum = runQuote $ do - let int = mkTyBuiltin @_ @Integer () - add = builtin () AddInteger - return - . mkIterAppNoAnn (mkIterInstNoAnn foldList [int, int]) - $ [ add , mkConstant @Integer () 0] + let int = mkTyBuiltin @_ @Integer () + add = builtin () AddInteger + return + . mkIterAppNoAnn (mkIterInstNoAnn foldList [int, int]) + $ [add, mkConstant @Integer () 0] -- > foldrList {integer} {integer} 0 addInteger sumr :: (TermLike term TyName Name uni DefaultFun, uni `HasTypeAndTermLevel` Integer) => term () sumr = runQuote $ do - let int = mkTyBuiltin @_ @Integer () - add = builtin () AddInteger - return - . mkIterAppNoAnn (mkIterInstNoAnn foldrList [int, int]) - $ [ add, mkConstant @Integer () 0 ] + let int = mkTyBuiltin @_ @Integer () + add = builtin () AddInteger + return + . mkIterAppNoAnn (mkIterInstNoAnn foldrList [int, int]) + $ [add, mkConstant @Integer () 0] -- | 'product' as a PLC term. -- -- > foldList {integer} {integer} multiplyInteger 1 product :: (TermLike term TyName Name uni DefaultFun, uni `HasTypeAndTermLevel` Integer) => term () product = runQuote $ do - let int = mkTyBuiltin @_ @Integer () - mul = builtin () MultiplyInteger - return - . mkIterAppNoAnn (mkIterInstNoAnn foldList [int, int]) - $ [ mul , mkConstant @Integer () 1] + let int = mkTyBuiltin @_ @Integer () + mul = builtin () MultiplyInteger + return + . mkIterAppNoAnn (mkIterInstNoAnn foldList [int, int]) + $ [mul, mkConstant @Integer () 1] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottUnit.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottUnit.hs index 5b6b4278b42..00869fcd062 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottUnit.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/ScottUnit.hs @@ -1,11 +1,10 @@ --- | Scott-encoded @unit@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.StdLib.Data.ScottUnit - ( unit - , unitval - ) where +-- | Scott-encoded @unit@ and related functions. +module PlutusCore.StdLib.Data.ScottUnit ( + unit, + unitval, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -17,20 +16,20 @@ import PlutusCore.Quote -- > all (A :: *). A -> A unit :: Type TyName uni () unit = runQuote $ do - a <- freshTyName "a" - return - . TyForall () a (Type ()) - . TyFun () (TyVar () a) - $ TyVar () a + a <- freshTyName "a" + return + . TyForall () a (Type ()) + . TyFun () (TyVar () a) + $ TyVar () a -- | '()' as a PLC term. -- -- > /\(A :: *) -> \(x : A) -> x unitval :: TermLike term TyName Name uni fun => term () unitval = runQuote $ do - a <- freshTyName "a" - x <- freshName "x" - return - . tyAbs () a (Type ()) - . lamAbs () x (TyVar () a) - $ var () x + a <- freshTyName "a" + x <- freshName "x" + return + . tyAbs () a (Type ()) + . lamAbs () x (TyVar () a) + $ var () x diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Sum.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Sum.hs index 351a174ef55..89aa80b8fae 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Sum.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Sum.hs @@ -1,12 +1,11 @@ --- | @sum@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.StdLib.Data.Sum - ( sum - , left - , right - ) where +-- | @sum@ and related functions. +module PlutusCore.StdLib.Data.Sum ( + sum, + left, + right, +) where import Prelude hiding (sum) @@ -20,55 +19,55 @@ import PlutusCore.Quote -- > \(a b :: *) -> all (r :: *). (a -> r) -> (b -> r) -> r sum :: Type TyName uni () sum = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - r <- freshTyName "r" - return - . TyLam () a (Type ()) - . TyLam () b (Type ()) - . TyForall () r (Type ()) - . TyFun () (TyFun () (TyVar () a) $ TyVar () r) - . TyFun () (TyFun () (TyVar () b) $ TyVar () r) - $ TyVar () r + a <- freshTyName "a" + b <- freshTyName "b" + r <- freshTyName "r" + return + . TyLam () a (Type ()) + . TyLam () b (Type ()) + . TyForall () r (Type ()) + . TyFun () (TyFun () (TyVar () a) $ TyVar () r) + . TyFun () (TyFun () (TyVar () b) $ TyVar () r) + $ TyVar () r -- | 'Left' as a PLC term. -- -- > /\(a b :: *) -> \(x : a) -> /\(r :: *) -> \(f : a -> r) -> (g : b -> r) -> f x left :: TermLike term TyName Name uni fun => term () left = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - x <- freshName "x" - r <- freshTyName "r" - f <- freshName "f" - g <- freshName "g" - return - . tyAbs () a (Type ()) - . tyAbs () b (Type ()) - . lamAbs () x (TyVar () a) - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () a) $ TyVar () r) - . lamAbs () g (TyFun () (TyVar () b) $ TyVar () r) - . apply () (var () f) - $ var () x + a <- freshTyName "a" + b <- freshTyName "b" + x <- freshName "x" + r <- freshTyName "r" + f <- freshName "f" + g <- freshName "g" + return + . tyAbs () a (Type ()) + . tyAbs () b (Type ()) + . lamAbs () x (TyVar () a) + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () a) $ TyVar () r) + . lamAbs () g (TyFun () (TyVar () b) $ TyVar () r) + . apply () (var () f) + $ var () x -- | 'Right' as a PLC term. -- -- > /\(a b :: *) -> \(y : b) -> /\(r :: *) -> \(f : a -> r) -> (g : b -> r) -> g y right :: TermLike term TyName Name uni fun => term () right = runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - y <- freshName "y" - r <- freshTyName "r" - f <- freshName "f" - g <- freshName "g" - return - . tyAbs () a (Type ()) - . tyAbs () b (Type ()) - . lamAbs () y (TyVar () b) - . tyAbs () r (Type ()) - . lamAbs () f (TyFun () (TyVar () a) $ TyVar () r) - . lamAbs () g (TyFun () (TyVar () b) $ TyVar () r) - . apply () (var () g) - $ var () y + a <- freshTyName "a" + b <- freshTyName "b" + y <- freshName "y" + r <- freshTyName "r" + f <- freshName "f" + g <- freshName "g" + return + . tyAbs () a (Type ()) + . tyAbs () b (Type ()) + . lamAbs () y (TyVar () b) + . tyAbs () r (Type ()) + . lamAbs () f (TyFun () (TyVar () a) $ TyVar () r) + . lamAbs () g (TyFun () (TyVar () b) $ TyVar () r) + . apply () (var () g) + $ var () y diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Unit.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Unit.hs index 0c57e466053..ee7d08ec74b 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Unit.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Data/Unit.hs @@ -1,14 +1,13 @@ --- | @unit@ and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module PlutusCore.StdLib.Data.Unit - ( unit - , unitval - , sequ - ) where +-- | @unit@ and related functions. +module PlutusCore.StdLib.Data.Unit ( + unit, + unitval, + sequ, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -26,9 +25,9 @@ unitval = mkConstant () () -- | 'seq' specified to '()' as a PLC term. sequ :: (TermLike term tyname Name uni fun, uni `HasTypeAndTermLevel` ()) => term () sequ = runQuote $ do - x <- freshName "x" - y <- freshName "y" - return - . lamAbs () x unit - . lamAbs () y unit - $ unitval + x <- freshName "x" + y <- freshName "y" + return + . lamAbs () x unit + . lamAbs () y unit + $ unitval diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Everything.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Everything.hs index 0795e49f5ea..ac3f8ba6535 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Everything.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Everything.hs @@ -1,14 +1,13 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | This module exports everything from the stdlib via a data type which allows to test -- various procedures (pretty-printing, type checking, etc) over the entire stdlib in a -- convenient way: each time a function / data type is added to the stdlib, none of the -- tests is required to be adapted, instead you just add the new definition to 'stdLib' -- defined below and all the tests see it automatically. - -{-# LANGUAGE ScopedTypeVariables #-} - -module PlutusCore.StdLib.Everything - ( stdLib - ) where +module PlutusCore.StdLib.Everything ( + stdLib, +) where import PlutusPrelude @@ -32,90 +31,105 @@ import PlutusCore.StdLib.Type -- | The entire stdlib exported as a single value. stdLib :: PlcFolderContents DefaultUni DefaultFun stdLib = - FolderContents - [ treeFolderContents "StdLib" - [ treeFolderContents "Data" - [ treeFolderContents "Bool" - [ plcTypeFile "Bool" bool - , plcTermFile "True" true - , plcTermFile "False" false - , plcTermFile "IfThenElse" ifThenElse - ] - , treeFolderContents "ChurchNat" - [ plcTypeFile "ChurchNat" churchNat - , plcTermFile "ChurchZero" churchZero - , plcTermFile "ChurchSucc" churchSucc - ] - , treeFolderContents "Function" - [ plcTermFile "Const" Function.const - , plcTermFile "Apply" applyFun - , plcTypeFile "Self" $ _recursiveType selfData - , plcTermFile "Unroll" unroll - , plcTermFile "Fix" fix - , plcTermFile "Fix2" $ fixN 2 fixBy - ] - , treeFolderContents "Integer" - [ plcTypeFile "integer" integer - , plcTermFile "SuccInteger" succInteger - ] - , treeFolderContents "Pair" - [ plcTypeFile "Pair" pair - , plcTermFile "Fst" Builtin.fstPair - , plcTermFile "Snd" Builtin.sndPair - , plcTermFile "Uncurry" Builtin.uncurry - ] - , treeFolderContents "List" - $ plcTypeFile "List" list + FolderContents + [ treeFolderContents + "StdLib" + [ treeFolderContents + "Data" + [ treeFolderContents + "Bool" + [ plcTypeFile "Bool" bool + , plcTermFile "True" true + , plcTermFile "False" false + , plcTermFile "IfThenElse" ifThenElse + ] + , treeFolderContents + "ChurchNat" + [ plcTypeFile "ChurchNat" churchNat + , plcTermFile "ChurchZero" churchZero + , plcTermFile "ChurchSucc" churchSucc + ] + , treeFolderContents + "Function" + [ plcTermFile "Const" Function.const + , plcTermFile "Apply" applyFun + , plcTypeFile "Self" $ _recursiveType selfData + , plcTermFile "Unroll" unroll + , plcTermFile "Fix" fix + , plcTermFile "Fix2" $ fixN 2 fixBy + ] + , treeFolderContents + "Integer" + [ plcTypeFile "integer" integer + , plcTermFile "SuccInteger" succInteger + ] + , treeFolderContents + "Pair" + [ plcTypeFile "Pair" pair + , plcTermFile "Fst" Builtin.fstPair + , plcTermFile "Snd" Builtin.sndPair + , plcTermFile "Uncurry" Builtin.uncurry + ] + , treeFolderContents "List" $ + plcTypeFile "List" list : [ plcTermFile (name ++ show optMatch) $ f optMatch | optMatch <- enumerate , (name, f) <- [ ("MatchList", Builtin.matchList) , ("FoldrList", Builtin.foldrList) - , ("FoldList", Builtin.foldList) + , ("FoldList", Builtin.foldList) ] ] - , treeFolderContents "Data" - [ plcTypeFile "Data" dataTy - , plcTermFile "matchDataUseChoose" matchData - ] - , treeFolderContents "ScottList" - [ plcTypeFile "List" listTy - , plcTermFile "Nil" nil - , plcTermFile "Cons" cons - , plcTermFile "FoldrList" Scott.foldrList - , plcTermFile "FoldList" Scott.foldList - , plcTermFile "Reverse" Scott.reverse - , plcTermFile "EnumFromTo" Scott.enumFromTo - , plcTermFile "Sum" Scott.sum - , plcTermFile "Product" Scott.product - ] - , treeFolderContents "Nat" - [ plcTypeFile "Nat" natTy - , plcTermFile "Zero" zero - , plcTermFile "Succ" Nat.succ - , plcTermFile "FoldrNat" foldrNat - , plcTermFile "FoldNat" foldNat - , plcTermFile "NatToInteger" natToInteger - ] - , treeFolderContents "Sum" - [ plcTypeFile "Sum" Sum.sum - , plcTermFile "Left" left - , plcTermFile "Right" right - ] - , treeFolderContents "Unit" - [ plcTypeFile "Unit" unit - , plcTermFile "Unitval" unitval - ] - ] - , treeFolderContents "Meta" - [ treeFolderContents "Data" - [ treeFolderContents "Tuple" - [ plcTypeFile "ProdN2" $ prodN 2 - , plcTermFile "ProdN2_0" $ prodNAccessor 2 0 - , plcTermFile "ProdN2_1" $ prodNAccessor 2 1 - , plcTermFile "MkProdN2" $ prodNConstructor 2 - ] - ] - ] - ] - ] + , treeFolderContents + "Data" + [ plcTypeFile "Data" dataTy + , plcTermFile "matchDataUseChoose" matchData + ] + , treeFolderContents + "ScottList" + [ plcTypeFile "List" listTy + , plcTermFile "Nil" nil + , plcTermFile "Cons" cons + , plcTermFile "FoldrList" Scott.foldrList + , plcTermFile "FoldList" Scott.foldList + , plcTermFile "Reverse" Scott.reverse + , plcTermFile "EnumFromTo" Scott.enumFromTo + , plcTermFile "Sum" Scott.sum + , plcTermFile "Product" Scott.product + ] + , treeFolderContents + "Nat" + [ plcTypeFile "Nat" natTy + , plcTermFile "Zero" zero + , plcTermFile "Succ" Nat.succ + , plcTermFile "FoldrNat" foldrNat + , plcTermFile "FoldNat" foldNat + , plcTermFile "NatToInteger" natToInteger + ] + , treeFolderContents + "Sum" + [ plcTypeFile "Sum" Sum.sum + , plcTermFile "Left" left + , plcTermFile "Right" right + ] + , treeFolderContents + "Unit" + [ plcTypeFile "Unit" unit + , plcTermFile "Unitval" unitval + ] + ] + , treeFolderContents + "Meta" + [ treeFolderContents + "Data" + [ treeFolderContents + "Tuple" + [ plcTypeFile "ProdN2" $ prodN 2 + , plcTermFile "ProdN2_0" $ prodNAccessor 2 0 + , plcTermFile "ProdN2_1" $ prodNAccessor 2 1 + , plcTermFile "MkProdN2" $ prodNConstructor 2 + ] + ] + ] + ] + ] diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta.hs index 9aa2a54be1e..bc1337496fd 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta.hs @@ -1,12 +1,11 @@ --- | Functions that generate Plutus Core terms from Haskell values and vice versa. - {-# LANGUAGE OverloadedStrings #-} -module PlutusCore.StdLib.Meta - ( metaIntegerToNat - , metaEitherToSum - , metaListToScottList - ) where +-- | Functions that generate Plutus Core terms from Haskell values and vice versa. +module PlutusCore.StdLib.Meta ( + metaIntegerToNat, + metaEitherToSum, + metaListToScottList, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -19,25 +18,26 @@ import PlutusCore.StdLib.Data.Sum -- | Convert an 'Integer' to a @nat@. TODO: convert PLC's @integer@ to @nat@ instead. metaIntegerToNat :: TermLike term TyName Name uni fun => Integer -> term () metaIntegerToNat n - | n < 0 = Prelude.error $ "getBuiltinIntegerToNat: negative argument: " ++ show n - | otherwise = go n where - go 0 = zero - go m = apply () Plc.succ $ go (m - 1) + | n < 0 = Prelude.error $ "getBuiltinIntegerToNat: negative argument: " ++ show n + | otherwise = go n + where + go 0 = zero + go m = apply () Plc.succ $ go (m - 1) -- | Convert a Haskell 'Either' to a PLC @sum@. -metaEitherToSum - :: TermLike term TyName Name uni fun - => Type TyName uni () - -> Type TyName uni () - -> Either (term ()) (term ()) - -> term () -metaEitherToSum a b (Left x) = apply () (mkIterInstNoAnn left [a, b]) x +metaEitherToSum :: + TermLike term TyName Name uni fun => + Type TyName uni () -> + Type TyName uni () -> + Either (term ()) (term ()) -> + term () +metaEitherToSum a b (Left x) = apply () (mkIterInstNoAnn left [a, b]) x metaEitherToSum a b (Right y) = apply () (mkIterInstNoAnn right [a, b]) y -- | Convert a Haskell list of 'Term's to a PLC @list@. -metaListToScottList - :: TermLike term TyName Name uni fun => Type TyName uni () -> [term ()] -> term () +metaListToScottList :: + TermLike term TyName Name uni fun => Type TyName uni () -> [term ()] -> term () metaListToScottList ty = - foldr - (\x xs -> mkIterAppNoAnn (tyInst () cons ty) [x, xs]) - (tyInst () nil ty) + foldr + (\x xs -> mkIterAppNoAnn (tyInst () cons ty) [x, xs]) + (tyInst () nil ty) diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Function.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Function.hs index 07e58e276e6..b186d355226 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Function.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Function.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} + -- | Meta-functions relating to functions. -module PlutusCore.StdLib.Meta.Data.Function - ( constPartial - , etaExpand - ) where +module PlutusCore.StdLib.Meta.Data.Function ( + constPartial, + etaExpand, +) where import PlutusCore.Core import PlutusCore.MkPlc @@ -15,12 +16,12 @@ import PlutusCore.Quote -- > constPartial t = /\(A :: *) -> \(x : A) -> t constPartial :: TermLike term TyName Name uni fun => term () -> term () constPartial t = runQuote $ do - a <- freshTyName "a" - x <- freshName "x" - return - . tyAbs () a (Type ()) - . lamAbs () x (TyVar () a) - $ t + a <- freshTyName "a" + x <- freshName "x" + return + . tyAbs () a (Type ()) + . lamAbs () x (TyVar () a) + $ t -- | Eta-expand a function at a given type. Note that this has to be a \"meta\" function -- for it not force the function it receives and instead directly hide it under a lambda. @@ -28,8 +29,8 @@ constPartial t = runQuote $ do -- > etaExpand ty fun = \(x : ty) -> fun x etaExpand :: TermLike term tyname Name uni fun => Type tyname uni () -> term () -> term () etaExpand ty fun = runQuote $ do - x <- freshName "x" - return - . lamAbs () x ty - . apply () fun - $ var () x + x <- freshName "x" + return + . lamAbs () x ty + . apply () fun + $ var () x diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Tuple.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Tuple.hs index e80e678c56d..4ad1dc73976 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Tuple.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Meta/Data/Tuple.hs @@ -1,21 +1,20 @@ -- editorconfig-checker-disable-file --- | @tuple@s of various sizes and related functions. - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module PlutusCore.StdLib.Meta.Data.Tuple - ( Tuple (..) - , getTupleType - , tupleTypeTermAt - , tupleTermAt - , tupleDefAt - , bindTuple - , prodN - , prodNConstructor - , prodNAccessor - , getSpineToTuple - ) where +{-# LANGUAGE TupleSections #-} + +-- | @tuple@s of various sizes and related functions. +module PlutusCore.StdLib.Meta.Data.Tuple ( + Tuple (..), + getTupleType, + tupleTypeTermAt, + tupleTermAt, + tupleDefAt, + bindTuple, + prodN, + prodNConstructor, + prodNAccessor, + getSpineToTuple, +) where import PlutusPrelude (showText) @@ -28,70 +27,72 @@ import Control.Lens.Indexed (ifor, itraverse) import Data.Traversable -- | A Plutus Core (Scott-encoded) tuple. -data Tuple term uni ann = - Tuple - { _tupleElementTypes :: [Type TyName uni ann] -- ^ The types of elements of a tuple. - , _tupleTerm :: term ann -- ^ A term representation of the tuple. - } +data Tuple term uni ann + = Tuple + { _tupleElementTypes :: [Type TyName uni ann] + -- ^ The types of elements of a tuple. + , _tupleTerm :: term ann + -- ^ A term representation of the tuple. + } -- | Get the type of a 'Tuple'. -- -- > getTupleType _ (Tuple [a1, ... , an] _) = all r. (a1 -> ... -> an -> r) -> r getTupleType :: MonadQuote m => ann -> Tuple term uni ann -> m (Type TyName uni ann) getTupleType ann (Tuple elTys _) = liftQuote $ do - r <- freshTyName "r" - let caseTy = mkIterTyFun ann elTys $ TyVar ann r - pure . TyForall ann r (Type ann) . TyFun ann caseTy $ TyVar ann r + r <- freshTyName "r" + let caseTy = mkIterTyFun ann elTys $ TyVar ann r + pure . TyForall ann r (Type ann) . TyFun ann caseTy $ TyVar ann r -- | Convert a Haskell spine of 'Term's to a PLC 'Tuple'. -- -- > getSpineToTuple _ [(a1, x1), ... , (an, xn)] = -- > Tuple [a1, ... , an] (/\(r :: *) -> \(f :: a1 -> ... -> an -> r) -> f x1 ... xn) -getSpineToTuple - :: (TermLike term TyName Name uni fun, MonadQuote m) - => ann -> [(Type TyName uni ann, term ann)] -> m (Tuple term uni ann) +getSpineToTuple :: + (TermLike term TyName Name uni fun, MonadQuote m) => + ann -> [(Type TyName uni ann, term ann)] -> m (Tuple term uni ann) getSpineToTuple ann spine = liftQuote $ do - r <- freshTyName "r" - f <- freshName "f" - let (as, xs) = unzip spine - caseTy = mkIterTyFun ann as $ TyVar ann r - y = mkIterApp (var ann f) ((ann,) <$> xs) - pure . Tuple as . tyAbs ann r (Type ann) $ lamAbs ann f caseTy y + r <- freshTyName "r" + f <- freshName "f" + let (as, xs) = unzip spine + caseTy = mkIterTyFun ann as $ TyVar ann r + y = mkIterApp (var ann f) ((ann,) <$> xs) + pure . Tuple as . tyAbs ann r (Type ann) $ lamAbs ann f caseTy y -- | Get the type of the ith element of a 'Tuple' along with the element itself. -- -- > tupleTypeTermAt _ i (Tuple [a0, ... , an] term) = -- > (ai, term {ai} (\(x0 : a0) ... (xn : an) -> xi)) -tupleTypeTermAt - :: (TermLike term TyName Name uni fun, MonadQuote m) - => ann -> Int -> Tuple term uni ann -> m (Type TyName uni ann, term ann) +tupleTypeTermAt :: + (TermLike term TyName Name uni fun, MonadQuote m) => + ann -> Int -> Tuple term uni ann -> m (Type TyName uni ann, term ann) tupleTypeTermAt ann ind (Tuple elTys term) = liftQuote $ do - args <- ifor elTys $ \i ty -> do - n <- freshName $ "arg_" <> showText i - pure $ VarDecl ann n ty - let selectedTy = elTys !! ind - selectedArg = mkVar $ args !! ind - selector = mkIterLamAbs args selectedArg - - pure - ( selectedTy - , apply ann (tyInst ann term selectedTy) selector - ) + args <- ifor elTys $ \i ty -> do + n <- freshName $ "arg_" <> showText i + pure $ VarDecl ann n ty + let selectedTy = elTys !! ind + selectedArg = mkVar $ args !! ind + selector = mkIterLamAbs args selectedArg + + pure + ( selectedTy + , apply ann (tyInst ann term selectedTy) selector + ) -- | Get the ith element of a 'Tuple'. -tupleTermAt - :: (TermLike term TyName Name uni fun, MonadQuote m) - => ann -> Int -> Tuple term uni ann -> m (term ann) +tupleTermAt :: + (TermLike term TyName Name uni fun, MonadQuote m) => + ann -> Int -> Tuple term uni ann -> m (term ann) tupleTermAt ann ind tuple = snd <$> tupleTypeTermAt ann ind tuple -- | Get the ith element of a 'Tuple' as a 'TermDef'. -tupleDefAt - :: (TermLike term TyName Name uni fun, MonadQuote m) - => ann - -> Int - -> Name - -> Tuple term uni ann - -> m (TermDef term TyName Name uni ann) +tupleDefAt :: + (TermLike term TyName Name uni fun, MonadQuote m) => + ann -> + Int -> + Name -> + Tuple term uni ann -> + m (TermDef term TyName Name uni ann) tupleDefAt ann ind name tuple = uncurry (Def . VarDecl ann name) <$> tupleTypeTermAt ann ind tuple -- | Bind all elements of a 'Tuple' inside a 'Term'. @@ -103,32 +104,32 @@ tupleDefAt ann ind name tuple = uncurry (Def . VarDecl ann name) <$> tupleTypeTe -- > x_n = _n tup -- > in body -- > ) term -bindTuple - :: (TermLike term TyName Name uni fun, MonadQuote m) - => ann -> [Name] -> Tuple term uni ann -> term ann -> m (term ann) +bindTuple :: + (TermLike term TyName Name uni fun, MonadQuote m) => + ann -> [Name] -> Tuple term uni ann -> term ann -> m (term ann) bindTuple ann names (Tuple elTys term) body = liftQuote $ do - tup <- freshName "tup" - let tupVar = Tuple elTys $ var ann tup - tupTy <- getTupleType ann tupVar - tupDefs <- itraverse (\i name -> tupleDefAt ann i name tupVar) names - pure $ apply ann (lamAbs ann tup tupTy $ foldr (termLet ann) body tupDefs) term + tup <- freshName "tup" + let tupVar = Tuple elTys $ var ann tup + tupTy <- getTupleType ann tupVar + tupDefs <- itraverse (\i name -> tupleDefAt ann i name tupVar) names + pure $ apply ann (lamAbs ann tup tupTy $ foldr (termLet ann) body tupDefs) term -- | Given an arity @n@, create the n-ary product type. -- -- @\(T_1 :: *) .. (T_n :: *) . all (R :: *) . (T_1 -> .. -> T_n -> R) -> R@ prodN :: Int -> Type TyName uni () prodN arity = runQuote $ do - tyVars <- for [0..(arity-1)] $ \i -> do - tn <- liftQuote $ freshTyName $ "t_" <> showText i - pure $ TyVarDecl () tn $ Type () - - resultType <- liftQuote $ freshTyName "r" - let caseType = mkIterTyFun () (fmap (mkTyVar ()) tyVars) (TyVar () resultType) - pure $ - -- \T_1 .. T_n - mkIterTyLam tyVars $ - -- all R - TyForall () resultType (Type ()) $ + tyVars <- for [0 .. (arity - 1)] $ \i -> do + tn <- liftQuote $ freshTyName $ "t_" <> showText i + pure $ TyVarDecl () tn $ Type () + + resultType <- liftQuote $ freshTyName "r" + let caseType = mkIterTyFun () (fmap (mkTyVar ()) tyVars) (TyVar () resultType) + pure $ + -- \T_1 .. T_n + mkIterTyLam tyVars $ + -- all R + TyForall () resultType (Type ()) $ -- (T_1 -> .. -> T_n -> r) -> r TyFun () caseType (TyVar () resultType) @@ -142,29 +143,30 @@ prodN arity = runQuote $ do -- @ prodNConstructor :: TermLike term TyName Name uni fun => Int -> term () prodNConstructor arity = runQuote $ do - tyVars <- for [0..(arity-1)] $ \i -> do - tn <- liftQuote $ freshTyName $ "t_" <> showText i - pure $ TyVarDecl () tn $ Type () - - resultType <- liftQuote $ freshTyName "r" - - args <- for [0..(arity -1)] $ \i -> do - n <- liftQuote $ freshName $ "arg_" <> showText i - pure $ VarDecl () n $ mkTyVar () $ tyVars !! i - - caseArg <- liftQuote $ freshName "case" - let caseTy = mkIterTyFun () (fmap (mkTyVar ()) tyVars) (TyVar () resultType) - pure $ - -- /\T_1 .. T_n - mkIterTyAbs tyVars $ - -- \arg_1 .. arg_n - mkIterLamAbs args $ + tyVars <- for [0 .. (arity - 1)] $ \i -> do + tn <- liftQuote $ freshTyName $ "t_" <> showText i + pure $ TyVarDecl () tn $ Type () + + resultType <- liftQuote $ freshTyName "r" + + args <- for [0 .. (arity - 1)] $ \i -> do + n <- liftQuote $ freshName $ "arg_" <> showText i + pure $ VarDecl () n $ mkTyVar () $ tyVars !! i + + caseArg <- liftQuote $ freshName "case" + let caseTy = mkIterTyFun () (fmap (mkTyVar ()) tyVars) (TyVar () resultType) + pure $ + -- /\T_1 .. T_n + mkIterTyAbs tyVars $ + -- \arg_1 .. arg_n + mkIterLamAbs args $ -- /\R tyAbs () resultType (Type ()) $ - -- \case - lamAbs () caseArg caseTy $ - -- case arg_1 .. arg_n - mkIterAppNoAnn (var () caseArg) $ fmap mkVar args + -- \case + lamAbs () caseArg caseTy $ + -- case arg_1 .. arg_n + mkIterAppNoAnn (var () caseArg) $ + fmap mkVar args -- | Given an arity @n@ and an index @i@, create a function for accessing the i'th component of a n-tuple. -- @@ -175,25 +177,25 @@ prodNConstructor arity = runQuote $ do -- @ prodNAccessor :: TermLike term TyName Name uni fun => Int -> Int -> term () prodNAccessor arity index = runQuote $ do - tyVars <- for [0..(arity-1)] $ \i -> do - tn <- liftQuote $ freshTyName $ "t_" <> showText i - pure $ TyVarDecl () tn $ Type () - - let tupleTy = mkIterTyAppNoAnn (prodN arity) (fmap (mkTyVar ()) tyVars) - selectedTy = mkTyVar () $ tyVars !! index - - args <- for [0..(arity -1)] $ \i -> do - n <- liftQuote $ freshName $ "arg_" <> showText i - pure $ VarDecl () n $ mkTyVar () $ tyVars !! i - let selectedArg = mkVar $ args !! index - - tupleArg <- liftQuote $ freshName "tuple" - pure $ - -- /\T_1 .. T_n - mkIterTyAbs tyVars $ - -- \tuple :: (tupleN T_1 .. T_n) - lamAbs () tupleArg tupleTy $ + tyVars <- for [0 .. (arity - 1)] $ \i -> do + tn <- liftQuote $ freshTyName $ "t_" <> showText i + pure $ TyVarDecl () tn $ Type () + + let tupleTy = mkIterTyAppNoAnn (prodN arity) (fmap (mkTyVar ()) tyVars) + selectedTy = mkTyVar () $ tyVars !! index + + args <- for [0 .. (arity - 1)] $ \i -> do + n <- liftQuote $ freshName $ "arg_" <> showText i + pure $ VarDecl () n $ mkTyVar () $ tyVars !! i + let selectedArg = mkVar $ args !! index + + tupleArg <- liftQuote $ freshName "tuple" + pure $ + -- /\T_1 .. T_n + mkIterTyAbs tyVars $ + -- \tuple :: (tupleN T_1 .. T_n) + lamAbs () tupleArg tupleTy $ -- tuple {T_i} apply () (tyInst () (var () tupleArg) selectedTy) $ - -- \arg_1 .. arg_n . arg_i - mkIterLamAbs args selectedArg + -- \arg_1 .. arg_n . arg_i + mkIterLamAbs args selectedArg diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs index bcff55db06c..9345de16165 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs @@ -1,15 +1,14 @@ -- editorconfig-checker-disable-file --- | This module defines Haskell data types that simplify construction of PLC types and terms. - -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TupleSections #-} -module PlutusCore.StdLib.Type - ( RecursiveType (..) - , makeRecursiveType - ) where +-- | This module defines Haskell data types that simplify construction of PLC types and terms. +module PlutusCore.StdLib.Type ( + RecursiveType (..), + makeRecursiveType, +) where import PlutusPrelude @@ -492,26 +491,35 @@ are rather high while the benefits are minor, and thus we go with the semantic p -- | A recursive type packaged along with a specified 'Wrap' that allows to construct elements -- of this type. data RecursiveType uni fun ann = RecursiveType - { _recursiveType :: Type TyName uni ann - , _recursiveWrap :: forall term . TermLike term TyName Name uni fun - => [Type TyName uni ann] -> term ann -> term ann - } + { _recursiveType :: Type TyName uni ann + , _recursiveWrap :: + forall term. + TermLike term TyName Name uni fun => + [Type TyName uni ann] -> term ann -> term ann + } -- | This exception is thrown when @_recursiveWrap@ is applied to a spine the length of which -- is not equal to the length of the spine that @_recursiveType@ contains. -- This can only happen if someone writing/generating Plutus Core made a mistake. data IndicesLengthsMismatchException = IndicesLengthsMismatchException - { _indicesLengthsMismatchExceptionExpected :: Int - , _indicesLengthsMismatchExceptionActual :: Int - , _indicesLengthsMismatchExceptionTyName :: TyName - } deriving anyclass (Exception) + { _indicesLengthsMismatchExceptionExpected :: Int + , _indicesLengthsMismatchExceptionActual :: Int + , _indicesLengthsMismatchExceptionTyName :: TyName + } + deriving anyclass (Exception) instance Show IndicesLengthsMismatchException where - show (IndicesLengthsMismatchException expected actual tyName) = concat - [ "Wrong number of elements\n" - , "expected: ", show expected, " , actual: ", show actual, "\n" - , "while constructing a ", displayPlc tyName - ] + show (IndicesLengthsMismatchException expected actual tyName) = + concat + [ "Wrong number of elements\n" + , "expected: " + , show expected + , " , actual: " + , show actual + , "\n" + , "while constructing a " + , displayPlc tyName + ] -- | Get the kind of a data type having the kinds of its arguments. -- @@ -542,12 +550,12 @@ spineKindToRecKind ann spineKind = KindArrow ann spineKind $ Type ann -- > \[a1 :: k1, a2 :: k2] -> (dat :: k1 -> k2 -> *) -> dat a1 a2 getToSpine :: ann -> Quote ([TyDecl TyName uni ann] -> Type TyName uni ann) getToSpine ann = do - dat <- freshTyName "dat" + dat <- freshTyName "dat" - return $ \args -> - TyLam ann dat (argKindsToDataKindN ann $ map _tyDeclKind args) - . mkIterTyApp (TyVar ann dat) - $ map ((ann,) . _tyDeclType) args + return $ \args -> + TyLam ann dat (argKindsToDataKindN ann $ map _tyDeclKind args) + . mkIterTyApp (TyVar ann dat) + $ map ((ann,) . _tyDeclType) args -- | Pack a list of 'TyDecl's as a spine using the CPS trick. -- @@ -562,6 +570,7 @@ getSpine :: ann -> [TyDecl TyName uni ann] -> Quote (Type TyName uni ann) getSpine ann args = ($ args) <$> getToSpine ann -- See Note [Packing n-ary pattern functors semantically]. + -- | Having a list of type variables along with their kinds, make a function that receives -- -- 1. a function expecting a spine in CPS form @@ -579,23 +588,28 @@ getSpine ann args = ($ args) <$> getToSpine ann -- > getWithSpine _ [v1 :: k1, v2 :: k2] = -- > \(cont : ((k1 -> k2 -> *) -> *) -> *) (v1 :: k1) (v2 :: k2) -> -- > cont \(dat :: k1 -> k2 -> *) -> dat v1 v2 -getWithSpine - :: ann - -> [TyVarDecl TyName ann] - -> Quote ((Type TyName uni ann -> Type TyName uni ann) -> Type TyName uni ann) +getWithSpine :: + ann -> + [TyVarDecl TyName ann] -> + Quote ((Type TyName uni ann -> Type TyName uni ann) -> Type TyName uni ann) getWithSpine ann argVars = do - spine <- getSpine ann $ map tyDeclVar argVars - return $ \k -> mkIterTyLam argVars $ k spine + spine <- getSpine ann $ map tyDeclVar argVars + return $ \k -> mkIterTyLam argVars $ k spine -- See Note [Spiney API]. -type FromDataPieces uni ann a - = ann -- ^ An annotation placed everywhere we do not have annotations. - -> TyName -- ^ The name of the data type being defined. - -> [TyVarDecl TyName ann] -- ^ A list of @n@ type variables bound in a pattern functor. - -> Type TyName uni ann -- ^ The body of the n-ary pattern functor. - -> Quote a +type FromDataPieces uni ann a = + -- | An annotation placed everywhere we do not have annotations. + ann -> + -- | The name of the data type being defined. + TyName -> + -- | A list of @n@ type variables bound in a pattern functor. + [TyVarDecl TyName ann] -> + -- | The body of the n-ary pattern functor. + Type TyName uni ann -> + Quote a -- See Note [Packing n-ary pattern functors semantically]. + -- | Pack the body of an n-ary pattern functor and make the corresponding 1-ary pattern functor. -- -- > packPatternFunctorBodyN _ dataName [v1 :: k1, v2 :: k2 ... vn :: kn] patBodyN = @@ -615,51 +629,52 @@ type FromDataPieces uni ann a -- > spine (patN (withSpine rec)) packPatternFunctorBodyN :: FromDataPieces uni ann (Type TyName uni ann) packPatternFunctorBodyN ann dataName argVars patBodyN = do - let dataKind = argKindsToDataKindN ann $ map _tyVarDeclKind argVars - spineKind = dataKindToSpineKind ann dataKind - recKind = spineKindToRecKind ann spineKind - vDat = TyVarDecl ann dataName dataKind - patN = mkIterTyLam (vDat : argVars) patBodyN - - withSpine <- getWithSpine ann argVars - - rec <- freshTyName "rec" - spine <- freshTyName "spine" - - return - . TyLam ann rec recKind - . TyLam ann spine spineKind - . TyApp ann (TyVar ann spine) - . TyApp ann patN - . withSpine - . TyApp ann - $ TyVar ann rec + let dataKind = argKindsToDataKindN ann $ map _tyVarDeclKind argVars + spineKind = dataKindToSpineKind ann dataKind + recKind = spineKindToRecKind ann spineKind + vDat = TyVarDecl ann dataName dataKind + patN = mkIterTyLam (vDat : argVars) patBodyN + + withSpine <- getWithSpine ann argVars + + rec <- freshTyName "rec" + spine <- freshTyName "spine" + + return + . TyLam ann rec recKind + . TyLam ann spine spineKind + . TyApp ann (TyVar ann spine) + . TyApp ann patN + . withSpine + . TyApp ann + $ TyVar ann rec -- | Construct a data type out of pieces. getPackedType :: FromDataPieces uni ann (Type TyName uni ann) getPackedType ann dataName argVars patBodyN = do - withSpine <- getWithSpine ann argVars - withSpine . TyIFix ann <$> packPatternFunctorBodyN ann dataName argVars patBodyN + withSpine <- getWithSpine ann argVars + withSpine . TyIFix ann <$> packPatternFunctorBodyN ann dataName argVars patBodyN -- | An auxiliary type for returning a polymorphic @wrap@. Haskell's support for impredicative -- polymorphism isn't good enough to do without this. -newtype PolyWrap uni fun ann = PolyWrap - (forall term. TermLike term TyName Name uni fun => [Type TyName uni ann] -> term ann -> term ann) +newtype PolyWrap uni fun ann + = PolyWrap + (forall term. TermLike term TyName Name uni fun => [Type TyName uni ann] -> term ann -> term ann) -- | Make a generic @wrap@ that takes a spine of type arguments and the rest of a term, packs -- the spine using the CPS trick and passes the spine and the term to 'IWrap' along with a 1-ary -- pattern functor constructed from pieces of a data type passed as arguments to 'getWrap'. getPackedWrap :: FromDataPieces uni ann (PolyWrap uni fun ann) getPackedWrap ann dataName argVars patBodyN = do - pat1 <- packPatternFunctorBodyN ann dataName argVars patBodyN - toSpine <- getToSpine ann - let instVar v ty = TyDecl ann ty $ _tyVarDeclKind v - return $ PolyWrap $ \args -> - let argVarsLen = length argVars - argsLen = length args - in if argVarsLen == argsLen - then iWrap ann pat1 . toSpine $ zipWith instVar argVars args - else throw . IndicesLengthsMismatchException argVarsLen argsLen $ dataName + pat1 <- packPatternFunctorBodyN ann dataName argVars patBodyN + toSpine <- getToSpine ann + let instVar v ty = TyDecl ann ty $ _tyVarDeclKind v + return $ PolyWrap $ \args -> + let argVarsLen = length argVars + argsLen = length args + in if argVarsLen == argsLen + then iWrap ann pat1 . toSpine $ zipWith instVar argVars args + else throw . IndicesLengthsMismatchException argVarsLen argsLen $ dataName {- Note [Special cases] The notes above describe how the general case is compiled, however for the 0-ary and 1-ary cases @@ -707,72 +722,82 @@ index. -} -- See Note [Special cases]. + -- | Construct a 'RecursiveType' by passing a 0-ary pattern functor to 'TyIFix' and 'IWrap' -- /as an index/. -makeRecursiveType0 - :: ann -- ^ An annotation placed everywhere we do not have annotations. - -> TyName -- ^ The name of the data type being defined. - -> Type TyName uni ann -- ^ The body of the pattern functor. - -> Quote (RecursiveType uni fun ann) +makeRecursiveType0 :: + -- | An annotation placed everywhere we do not have annotations. + ann -> + -- | The name of the data type being defined. + TyName -> + -- | The body of the pattern functor. + Type TyName uni ann -> + Quote (RecursiveType uni fun ann) makeRecursiveType0 ann dataName patBody0 = do - rec <- freshTyName "rec" - f <- freshTyName "f" - let argKind = KindArrow ann (Type ann) $ Type ann - recKind = KindArrow ann argKind $ Type ann - pat1 - = TyLam ann rec recKind - . TyLam ann f argKind - . TyApp ann (TyVar ann f) - . TyApp ann (TyVar ann rec) - $ TyVar ann f - arg = TyLam ann dataName (Type ann) patBody0 - -- recType = - -- ifix - -- (\(rec :: (* -> *) -> *) (f :: * -> *) -> f (rec f)) - -- (\(dataName :: *) -> patBody0) - recType = TyIFix ann pat1 arg - wrap args = case args of - [] -> iWrap ann pat1 arg - _ -> throw . IndicesLengthsMismatchException 0 (length args) $ dataName - return $ RecursiveType recType wrap + rec <- freshTyName "rec" + f <- freshTyName "f" + let argKind = KindArrow ann (Type ann) $ Type ann + recKind = KindArrow ann argKind $ Type ann + pat1 = + TyLam ann rec recKind + . TyLam ann f argKind + . TyApp ann (TyVar ann f) + . TyApp ann (TyVar ann rec) + $ TyVar ann f + arg = TyLam ann dataName (Type ann) patBody0 + -- recType = + -- ifix + -- (\(rec :: (* -> *) -> *) (f :: * -> *) -> f (rec f)) + -- (\(dataName :: *) -> patBody0) + recType = TyIFix ann pat1 arg + wrap args = case args of + [] -> iWrap ann pat1 arg + _ -> throw . IndicesLengthsMismatchException 0 (length args) $ dataName + return $ RecursiveType recType wrap -- See Note [Special cases]. + -- | Construct a 'RecursiveType' by passing a 1-ary pattern functor to 'TyIFix' and 'IWrap'. -makeRecursiveType1 - :: ann -- ^ An annotation placed everywhere we do not have annotations. - -> TyName -- ^ The name of the data type being defined. - -> TyVarDecl TyName ann -- ^ The index type variable. - -> Type TyName uni ann -- ^ The body of the pattern functor. - -> Quote (RecursiveType uni fun ann) +makeRecursiveType1 :: + -- | An annotation placed everywhere we do not have annotations. + ann -> + -- | The name of the data type being defined. + TyName -> + -- | The index type variable. + TyVarDecl TyName ann -> + -- | The body of the pattern functor. + Type TyName uni ann -> + Quote (RecursiveType uni fun ann) makeRecursiveType1 ann dataName argVar patBody1 = do - let varName = _tyVarDeclName argVar - varKind = _tyVarDeclKind argVar - varName' <- freshenTyName varName - let - recKind = KindArrow ann varKind $ Type ann - pat1 = TyLam ann dataName recKind $ TyLam ann varName varKind patBody1 - -- recType = \(v :: k) -> ifix (\(dataName :: k -> *) (v :: k) -> patBody1) v - recType = TyLam ann varName' varKind . TyIFix ann pat1 $ TyVar ann varName' - wrap args = case args of - [arg] -> iWrap ann pat1 arg - _ -> throw . IndicesLengthsMismatchException 1 (length args) $ dataName - return $ RecursiveType recType wrap + let varName = _tyVarDeclName argVar + varKind = _tyVarDeclKind argVar + varName' <- freshenTyName varName + let + recKind = KindArrow ann varKind $ Type ann + pat1 = TyLam ann dataName recKind $ TyLam ann varName varKind patBody1 + -- recType = \(v :: k) -> ifix (\(dataName :: k -> *) (v :: k) -> patBody1) v + recType = TyLam ann varName' varKind . TyIFix ann pat1 $ TyVar ann varName' + wrap args = case args of + [arg] -> iWrap ann pat1 arg + _ -> throw . IndicesLengthsMismatchException 1 (length args) $ dataName + return $ RecursiveType recType wrap -- See all the Notes above. + -- | Construct a 'RecursiveType' by encoding an n-ary pattern functor as the corresponding 1-ary one -- and passing it to 'TyIFix' and 'IWrap'. @n@ type arguments get packaged together as a CPS-encoded -- spine. makeRecursiveTypeN :: FromDataPieces uni ann (RecursiveType uni fun ann) makeRecursiveTypeN ann dataName argVars patBodyN = do - recType <- getPackedType ann dataName argVars patBodyN - PolyWrap wrap <- getPackedWrap ann dataName argVars patBodyN - return $ RecursiveType recType wrap + recType <- getPackedType ann dataName argVars patBodyN + PolyWrap wrap <- getPackedWrap ann dataName argVars patBodyN + return $ RecursiveType recType wrap -- | Construct a 'RecursiveType' out of its name, variables bound in its pattern functor -- and the body of the pattern functor. The 0- and 1-ary pattern functors are special-cased, -- while in the general case the pattern functor and type arguments get encoded into a 1-ary -- form first. makeRecursiveType :: FromDataPieces uni ann (RecursiveType uni fun ann) -makeRecursiveType ann dataName [] = makeRecursiveType0 ann dataName +makeRecursiveType ann dataName [] = makeRecursiveType0 ann dataName makeRecursiveType ann dataName [argVar] = makeRecursiveType1 ann dataName argVar -makeRecursiveType ann dataName argVars = makeRecursiveTypeN ann dataName argVars +makeRecursiveType ann dataName argVars = makeRecursiveTypeN ann dataName argVars diff --git a/plutus-core/plutus-core/test/CBOR/DataStability.hs b/plutus-core/plutus-core/test/CBOR/DataStability.hs index b8466d1cd7c..60b334daf8e 100644 --- a/plutus-core/plutus-core/test/CBOR/DataStability.hs +++ b/plutus-core/plutus-core/test/CBOR/DataStability.hs @@ -1,19 +1,7 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{- | The `flat` files containing validation scripts in `plutus-benchmarks` were -generated in August 2021. In May 2022 it was observed that deserialising them -to memory and then reserialising them usually caused the size of the `flat` -files to increase. This was because the CBOR encoding of `Data` objects had -changed: it formerly used a definite-length encoding for lists but changed to -using an indefinite-length encoding, which requires an extra 0xff tag to mark -the end of the list (see Section 3.2 of RFC 8949). The serialised versions show -significant differences (see `testData` below) but deserialise to identical -objects. These tests contain pairs of different encodings of Data objects from -a selection of the scripts and check that they continue to deserialise to -thesame thing, and that both deserialise to the expected object. -} +{-# LANGUAGE TypeApplications #-} {- Note also that Data has special treatment for ByteStrings and Integers: see (see Note [Evading the 64-byte limit] in PlutusCore.Data). Indefinite length @@ -26,7 +14,17 @@ first place: see PR 3730. This is quite delicate and there's a possibility that someone might change it accidentally. The examples here don't contain any B or I entries longer than 64 bytes and so don't trigger the decoding error. -} - +-- | The `flat` files containing validation scripts in `plutus-benchmarks` were +-- generated in August 2021. In May 2022 it was observed that deserialising them +-- to memory and then reserialising them usually caused the size of the `flat` +-- files to increase. This was because the CBOR encoding of `Data` objects had +-- changed: it formerly used a definite-length encoding for lists but changed to +-- using an indefinite-length encoding, which requires an extra 0xff tag to mark +-- the end of the list (see Section 3.2 of RFC 8949). The serialised versions show +-- significant differences (see `testData` below) but deserialise to identical +-- objects. These tests contain pairs of different encodings of Data objects from +-- a selection of the scripts and check that they continue to deserialise to +-- thesame thing, and that both deserialise to the expected object. module CBOR.DataStability (tests) where @@ -45,10 +43,11 @@ import Test.Tasty import Test.Tasty.HUnit tests :: TestTree -tests = testGroup "CBOR" - [ - testGroup "data-cbor-stability" (fmap maketest testData) - ] +tests = + testGroup + "CBOR" + [ testGroup "data-cbor-stability" (fmap maketest testData) + ] -- | Convert the Text objects in the testData entries to bytestrings and then -- deserialise them and check that both give the same Data object and that both @@ -56,86 +55,87 @@ tests = testGroup "CBOR" -- misleading places. maketest :: (String, Text, Text, Data) -> TestTree maketest (name, s1, s2, expected) = - testCaseSteps name $ \step -> do - let !bs1 = BSL.fromStrict . fromJust . decodeHex $ s1 - size1 = BSL.length bs1 - step $ printf "Deserialising Data object 1 from CBOR bytestring (%s)" (numBytes size1) - let !object1 = deserialise @Data bs1 - let !bs2 = BSL.fromStrict . fromJust . decodeHex $ s2 - size2 = BSL.length bs2 - step $ printf "Deserialising Data object 2 from CBOR bytestring (%s)" (numBytes size2) - let !object2 = deserialise @Data bs2 - step $ printf "CBOR size difference: %s" (numBytes (size2 - size1)) - step "Checking that object1 decoded correctly" - object1 @?= expected - step "Checking that object2 decoded correctly" - object2 @?= expected - step "Checking object1 and object2 for equality" - assertEqual "Deserialisation produced different objects" object1 object2 - where numBytes s = - if s == 1 - then "1 byte" - else printf "%d bytes" s :: String + testCaseSteps name $ \step -> do + let !bs1 = BSL.fromStrict . fromJust . decodeHex $ s1 + size1 = BSL.length bs1 + step $ printf "Deserialising Data object 1 from CBOR bytestring (%s)" (numBytes size1) + let !object1 = deserialise @Data bs1 + let !bs2 = BSL.fromStrict . fromJust . decodeHex $ s2 + size2 = BSL.length bs2 + step $ printf "Deserialising Data object 2 from CBOR bytestring (%s)" (numBytes size2) + let !object2 = deserialise @Data bs2 + step $ printf "CBOR size difference: %s" (numBytes (size2 - size1)) + step "Checking that object1 decoded correctly" + object1 @?= expected + step "Checking that object2 decoded correctly" + object2 @?= expected + step "Checking object1 and object2 for equality" + assertEqual "Deserialisation produced different objects" object1 object2 + where + numBytes s = + if s == 1 + then "1 byte" + else printf "%d bytes" s :: String -- A list of tuples containing (Script/data-item name, encoded version 1, -- encoded version 2, expected object) testData :: [(String, Text, Text, Data)] testData = - [ - ( "auction_1-1" - , "d87982581cbd99a373075d42fe4ac9109515e46303d0940cb9620bf058b87986a9d87980" - , "d8799f581cbd99a373075d42fe4ac9109515e46303d0940cb9620bf058b87986a9d87980ff" - , Constr 0 [B "\189\153\163s\a]B\254J\201\DLE\149\NAK\228c\ETX\208\148\f\185b\v\240X\184y\134\169", Constr 0 []] - ) - , - ( "future-increase-margin-5 (a)" - , "d87981d8798281d879824081d879824019084b81d879824081d87982401908af" - , "d8799fd8799f9fd8799f409fd8799f4019084bffffffff9fd8799f409fd8799f401908afffffffffffff" - , Constr 0 [Constr 0 [List [Constr 0 [B "",List [Constr 0 [B "",I 2123]]]],List [Constr 0 [B "",List [Constr 0 [B "",I 2223]]]]]] - ) - , - ( "future-increase-margin-5 (b)" - , "d87a81d879835840c40f1dc048cc8b8b490cf6f58fbb582f01ecb8199094ed84961ab079dda95df47930e1607f41806587229912a670b64f2c6e67db22c2187781fce00df43c240f5820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8798281d879824081d87982401904641b000001739c8a86d8" - , "d87a9fd8799f5840c40f1dc048cc8b8b490cf6f58fbb582f01ecb8199094ed84961ab079dda95df47930e1607f41806587229912a670b64f2c6e67db22c2187781fce00df43c240f5820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8799f9fd8799f409fd8799f40190464ffffffff1b000001739c8a86d8ffffff" - , Constr 1 [Constr 0 [B "\196\SI\GS\192H\204\139\139I\f\246\245\143\187X/\SOH\236\184\EM\144\148\237\132\150\SUB\176y\221\169]\244y0\225`\DELA\128e\135\"\153\DC2\166p\182O,ng\219\"\194\CANw\129\252\224\r\244<$\SI",B "\216\175\152\238\207-\f\135Tbq:\232a\SYNM\224\STX\249\160\131\SI\SOH\177\157\195:N'Y%\DC3",Constr 0 [List [Constr 0 [B "",List [Constr 0 [B "",I 1124]]]],I 1596059191000]]] - ) - , - ( "future-increase-margin-5 (c)" - , "d87982d8798a82d87982d87982d87981582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f615700d87983d87982d87981581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27d87a8081d879824081d87982401a05f5aaa2d87a80d87982d87982d87981582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f615701d87983d87982d87a81581c12b132132c2b41a484de3b7a5db19be8ca28441de2b4148609079d19d87a8081d879824081d87982401910fad8798158208eb8c339886d3979c8edaf8feafd5fd410e127f312d3c6fcec8b5f979e68957283d87983d87982d87981581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27d87a8081d879824081d87982401a05f57cfdd87a80d87983d87982d87a81581c08535dc84e7823d63a787f1229ff1863e6c009907093b384289d50cdd87a8081d879824081d8798240190790d8798158202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0d87983d87982d87a81581cea16da21adb923d789313ccef2644d9ea19c2141f8f92bada80efb06d87a8081d879824081d879824019096ad8798158202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e081d879824081d8798240192da5808080d87982d87982d87a811b000001739c8a86d8d87a80d87982d87b80d87a8081581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f2782d8798258202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0d87980d879825820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8798281d879824081d87982401904641b000001739c8a86d8d879815820db145e448a2af884a7430ac31cec85bc700a89f35f1feb71544b5e31f4c68446d87a81d87982d87981582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f615701" - , "d8799fd8799f9fd8799fd8799fd8799f582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f6157ff00ffd8799fd8799fd8799f581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27ffd87a80ff9fd8799f409fd8799f401a05f5aaa2ffffffffd87a80ffffd8799fd8799fd8799f582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f6157ff01ffd8799fd8799fd87a9f581c12b132132c2b41a484de3b7a5db19be8ca28441de2b4148609079d19ffd87a80ff9fd8799f409fd8799f401910faffffffffd8799f58208eb8c339886d3979c8edaf8feafd5fd410e127f312d3c6fcec8b5f979e689572ffffffff9fd8799fd8799fd8799f581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27ffd87a80ff9fd8799f409fd8799f401a05f57cfdffffffffd87a80ffd8799fd8799fd87a9f581c08535dc84e7823d63a787f1229ff1863e6c009907093b384289d50cdffd87a80ff9fd8799f409fd8799f40190790ffffffffd8799f58202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0ffffd8799fd8799fd87a9f581cea16da21adb923d789313ccef2644d9ea19c2141f8f92bada80efb06ffd87a80ff9fd8799f409fd8799f4019096affffffffd8799f58202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0ffffff9fd8799f409fd8799f40192da5ffffffff808080d8799fd8799fd87a9f1b000001739c8a86d8ffd87a80ffd8799fd87b80d87a80ffff9f581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27ff9fd8799f58202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0d87980ffd8799f5820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8799f9fd8799f409fd8799f40190464ffffffff1b000001739c8a86d8ffffffd8799f5820db145e448a2af884a7430ac31cec85bc700a89f35f1feb71544b5e31f4c68446ffffd87a9fd8799fd8799f582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f6157ff01ffffff" - , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "D\171 :\132\219\158\249FIZ\FS\241)\r'\237\128\164S\139\&8\159\230\227\179\158\241\212OaW"],I 0],Constr 0 [Constr 0 [Constr 0 [B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99986082]]]],Constr 1 []]],Constr 0 [Constr 0 [Constr 0 [B "D\171 :\132\219\158\249FIZ\FS\241)\r'\237\128\164S\139\&8\159\230\227\179\158\241\212OaW"],I 1],Constr 0 [Constr 0 [Constr 1 [B "\DC2\177\&2\DC3,+A\164\132\222;z]\177\155\232\202(D\GS\226\180\DC4\134\t\a\157\EM"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 4346]]]],Constr 0 [B "\142\184\195\&9\136m9y\200\237\175\143\234\253_\212\DLE\225'\243\DC2\211\198\252\236\139_\151\158h\149r"]]]],List [Constr 0 [Constr 0 [Constr 0 [B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99974397]]]],Constr 1 []],Constr 0 [Constr 0 [Constr 1 [B "\bS]\200Nx#\214:x\DEL\DC2)\255\CANc\230\192\t\144p\147\179\132(\157P\205"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 1936]]]],Constr 0 [B ",\219&\139\174\206\250\216\"\229q/\158i\SO\ETB\135\241\134\245\200L4?\253\192`\178\US\STXA\224"]],Constr 0 [Constr 0 [Constr 1 [B "\234\SYN\218!\173\185#\215\137\&1<\206\242dM\158\161\156!A\248\249+\173\168\SO\251\ACK"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 2410]]]],Constr 0 [B ",\219&\139\174\206\250\216\"\229q/\158i\SO\ETB\135\241\134\245\200L4?\253\192`\178\US\STXA\224"]]],List [Constr 0 [B "",List [Constr 0 [B "",I 11685]]]],List [],List [],List [],Constr 0 [Constr 0 [Constr 1 [I 1596059191000],Constr 1 []],Constr 0 [Constr 2 [],Constr 1 []]],List [B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'"],List [Constr 0 [B ",\219&\139\174\206\250\216\"\229q/\158i\SO\ETB\135\241\134\245\200L4?\253\192`\178\US\STXA\224",Constr 0 []],Constr 0 [B "\216\175\152\238\207-\f\135Tbq:\232a\SYNM\224\STX\249\160\131\SI\SOH\177\157\195:N'Y%\DC3",Constr 0 [List [Constr 0 [B "",List [Constr 0 [B "",I 1124]]]],I 1596059191000]]],Constr 0 [B "\219\DC4^D\138*\248\132\167C\n\195\FS\236\133\188p\n\137\243_\US\235qTK^1\244\198\132F"]],Constr 1 [Constr 0 [Constr 0 [B "D\171 :\132\219\158\249FIZ\FS\241)\r'\237\128\164S\139\&8\159\230\227\179\158\241\212OaW"],I 1]]] - ) - , - ( "uniswap-1" - , "d87982d8798a81d87982d87982d8798158200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8fae06d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e100d87a8081d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8082d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a003d0900d8798241421a003d0900d8798241431a003d0900d8798241441a003d0900d879824081d87982401a05f5cf58d87a8081d879824081d87982401911a881d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a003d0900d8798241421a003d0900d8798241431a003d0900d8798241441a003d09008080d87982d87982d87980d87a80d87982d87b80d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a380d879815820f154625e0831084f4981dd205ec3d7dc93d87951645fd963d445d5c2075d982bd87981581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb76" - , "d8799fd8799f9fd8799fd8799fd8799f58200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8faeff06ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e100ffffffffd87a80ffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a003d0900ffd8799f41421a003d0900ffd8799f41431a003d0900ffd8799f41441a003d0900ffffffd8799f409fd8799f401a05f5cf58ffffffffd87a80ffff9fd8799f409fd8799f401911a8ffffffff9fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a003d0900ffd8799f41421a003d0900ffd8799f41431a003d0900ffd8799f41441a003d0900ffffffff8080d8799fd8799fd87980d87a80ffd8799fd87b80d87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff80d8799f5820f154625e0831084f4981dd205ec3d7dc93d87951645fd963d445d5c2075d982bffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb76ffff" - , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\ACK6%\n\239'T\151\180\243\128}f\SUB)\158\&4\229>Z\211\188\DC1\DLE\228=\US4 \188\143\174"],I 6],Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 100000000]]]],Constr 1 []]]],List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",List [Constr 0 [B "A",I 4000000],Constr 0 [B "B",I 4000000],Constr 0 [B "C",I 4000000],Constr 0 [B "D",I 4000000]]],Constr 0 [B "",List [Constr 0 [B "",I 99995480]]]],Constr 1 []]],List [Constr 0 [B "",List [Constr 0 [B "",I 4520]]]],List [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",List [Constr 0 [B "A",I 4000000],Constr 0 [B "B",I 4000000],Constr 0 [B "C",I 4000000],Constr 0 [B "D",I 4000000]]]],List [],List [],Constr 0 [Constr 0 [Constr 0 [],Constr 1 []],Constr 0 [Constr 2 [],Constr 1 []]],List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],List [],Constr 0 [B "\241Tb^\b1\bOI\129\221 ^\195\215\220\147\216yQd_\217c\212E\213\194\a]\152+"]],Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v"]] - ) - , - ( "escrow-refund-1" - , "d87982d8798a82d87982d87982d8798158201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a3900d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e0e2d87a80d87982d87982d8798158201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a3901d87983d87982d87a81581ce7cf3ddee4924dbef3fdceb67f67f11057fe57636443bc3b2ae498f3d87a8081d879824081d879824014d879815820ca54c8836c475a77c6914b4fd598080acadb0f0067778773484d2c12ae7dc75681d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5c936d87a8081d879824081d87982401917c0808080d87982d87982d87a811b000001739c8a8abfd87980d87982d87b80d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a380d8798158202affd3baa0837dd427ae8924f5fb9729577a25280c4c24dd055f8184fd5b5513d87a81d87982d8798158201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a3901" - , "d8799fd8799f9fd8799fd8799fd8799f58201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a39ff00ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e0e2ffffffffd87a80ffffd8799fd8799fd8799f58201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a39ff01ffd8799fd8799fd87a9f581ce7cf3ddee4924dbef3fdceb67f67f11057fe57636443bc3b2ae498f3ffd87a80ff9fd8799f409fd8799f4014ffffffffd8799f5820ca54c8836c475a77c6914b4fd598080acadb0f0067778773484d2c12ae7dc756ffffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5c936ffffffffd87a80ffff9fd8799f409fd8799f401917c0ffffffff808080d8799fd8799fd87a9f1b000001739c8a8abfffd87980ffd8799fd87b80d87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff80d8799f58202affd3baa0837dd427ae8924f5fb9729577a25280c4c24dd055f8184fd5b5513ffffd87a9fd8799fd8799f58201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a39ff01ffffff" - , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\SUBc\SI\254\179\190\154\DLE}\224\169H\206X\194<\165i\142\NUL\t%\197\219\184\230\158\EMfez9"],I 0],Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99999970]]]],Constr 1 []]],Constr 0 [Constr 0 [Constr 0 [B "\SUBc\SI\254\179\190\154\DLE}\224\169H\206X\194<\165i\142\NUL\t%\197\219\184\230\158\EMfez9"],I 1],Constr 0 [Constr 0 [Constr 1 [B "\231\207=\222\228\146M\190\243\253\206\182\DELg\241\DLEW\254WcdC\188;*\228\152\243"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 20]]]],Constr 0 [B "\202T\200\131lGZw\198\145KO\213\152\b\n\202\219\SI\NULgw\135sHM,\DC2\174}\199V"]]]],List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99993910]]]],Constr 1 []]],List [Constr 0 [B "",List [Constr 0 [B "",I 6080]]]],List [],List [],List [],Constr 0 [Constr 0 [Constr 1 [I 1596059191999],Constr 0 []],Constr 0 [Constr 2 [],Constr 1 []]],List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],List [],Constr 0 [B "*\255\211\186\160\131}\212'\174\137$\245\251\151)Wz%(\fL$\221\ENQ_\129\132\253[U\DC3"]],Constr 1 [Constr 0 [Constr 0 [B "\SUBc\SI\254\179\190\154\DLE}\224\169H\206X\194<\165i\142\NUL\t%\197\219\184\230\158\EMfez9"],I 1]]] - ) - , - ( "multisig-sm-2" - , "d87982d8798a82d87982d87982d87981582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42a01d87983d87982d87a81581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8d87a8081d879824081d87982400ad87981582021588ed1ce48a9a88b74e143fb697199fa8da46edf04bb2d3da8970266f51849d87982d87982d879815820ca554bdd535583761a73982bbaa329ace796e73290cf41f10b5208f09138aacb00d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e0ecd87a8082d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5b8cad87a80d87983d87982d87a81581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8d87a8081d879824081d87982400ad879815820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f4496581d879824081d8798240192822808080d87982d87982d87980d87a80d87982d87b80d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a381d879825820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f44965d87a82d8798381d879824081d879824005581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f271b000001739c894e5881581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87981582022fe5664b828b42c51aa9accb87a448808a89978e8adcd2788b04b204f704664d87a81d87982d87981582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42a01" - , "d8799fd8799f9fd8799fd8799fd8799f582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42aff01ffd8799fd8799fd87a9f581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8ffd87a80ff9fd8799f409fd8799f400affffffffd8799f582021588ed1ce48a9a88b74e143fb697199fa8da46edf04bb2d3da8970266f51849ffffffd8799fd8799fd8799f5820ca554bdd535583761a73982bbaa329ace796e73290cf41f10b5208f09138aacbff00ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e0ecffffffffd87a80ffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5b8caffffffffd87a80ffd8799fd8799fd87a9f581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8ffd87a80ff9fd8799f409fd8799f400affffffffd8799f5820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f44965ffffff9fd8799f409fd8799f40192822ffffffff808080d8799fd8799fd87980d87a80ffd8799fd87b80d87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff9fd8799f5820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f44965d87a9fd8799f9fd8799f409fd8799f4005ffffffff581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f271b000001739c894e58ff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffffffffd8799f582022fe5664b828b42c51aa9accb87a448808a89978e8adcd2788b04b204f704664ffffd87a9fd8799fd8799f582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42aff01ffffff" - , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "2\255\143T&\131\234i\230\225\250#\223\vb\132\DEL\FS\r\217\223\248\214R0\237\CAN(\NAKz\164*"],I 1],Constr 0 [Constr 0 [Constr 1 [B "8\ETXLp>!\146G\159\EM?\151\254\EOT7\252\NUL\210l\aX\212\250\167I\244\194\184"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 10]]]],Constr 0 [B "!X\142\209\206H\169\168\139t\225C\251iq\153\250\141\164n\223\EOT\187-=\168\151\STXf\245\CANI"]]],Constr 0 [Constr 0 [Constr 0 [B "\202UK\221SU\131v\SUBs\152+\186\163)\172\231\150\231\&2\144\207A\241\vR\b\240\145\&8\170\203"],I 0],Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99999980]]]],Constr 1 []]]],List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99989706]]]],Constr 1 []],Constr 0 [Constr 0 [Constr 1 [B "8\ETXLp>!\146G\159\EM?\151\254\EOT7\252\NUL\210l\aX\212\250\167I\244\194\184"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 10]]]],Constr 0 [B "\204v\a\n\160\240'\219[>\238\181\136\DLE\250W\226\212WC\190\147\191e\203c\162\136\213\244Ie"]]],List [Constr 0 [B "",List [Constr 0 [B "",I 10274]]]],List [],List [],List [],Constr 0 [Constr 0 [Constr 0 [],Constr 1 []],Constr 0 [Constr 2 [],Constr 1 []]],List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],List [Constr 0 [B "\204v\a\n\160\240'\219[>\238\181\136\DLE\250W\226\212WC\190\147\191e\203c\162\136\213\244Ie",Constr 1 [Constr 0 [List [Constr 0 [B "",List [Constr 0 [B "",I 5]]]],B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'",I 1596059111000],List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"]]]],Constr 0 [B "\"\254Vd\184(\180,Q\170\154\204\184zD\136\b\168\153x\232\173\205'\136\176K OpFd"]],Constr 1 [Constr 0 [Constr 0 [B "2\255\143T&\131\234i\230\225\250#\223\vb\132\DEL\FS\r\217\223\248\214R0\237\CAN(\NAKz\164*"],I 1]]] - ) - , - ( "crowdfunding-success-2" - , "d87982d8798a84d87982d87982d8798158200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8fae06d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e100d87a80d87982d87982d87981582009c21de7ece5b224ead247754e2fb80ce2dd69eb180d29286612a7c55ec05d3c01d87983d87982d87a81581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809d87a8081d879824081d87982401864d87981582002aa535e8c850b40786b9a6c169072d3368b8fb67833413db7bf893bdd4a46f1d87982d87982d8798158206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb301d87983d87982d87a81581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809d87a8081d879824081d87982401819d8798158203999f2739f0bbcb9727893a0d2e8cae660f0ce36a73e42a58a7102894473a7e0d87982d87982d879815820f9d5959ed383550d28c45b30dce80260df7bf4741392f2ec1e3e743aa071c55601d87983d87982d87a81581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809d87a8081d879824081d87982401864d879815820509b58c2b6fe87f4888de7c11e6ba23ba34a19cadec76b1b7e7904f39ba0608a81d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5ab11d87a8081d879824081d87982401936d0808080d87982d87982d87a811b000001739c894e58d87a80d87982d87a811b000001739c897567d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a380d879815820a50a890e9f6b1e4ca495b72cc681e5d52061ef26d49bdd075f2fa8c182af1140d87a81d87982d8798158206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb301" - , "d8799fd8799f9fd8799fd8799fd8799f58200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8faeff06ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e100ffffffffd87a80ffffd8799fd8799fd8799f582009c21de7ece5b224ead247754e2fb80ce2dd69eb180d29286612a7c55ec05d3cff01ffd8799fd8799fd87a9f581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809ffd87a80ff9fd8799f409fd8799f401864ffffffffd8799f582002aa535e8c850b40786b9a6c169072d3368b8fb67833413db7bf893bdd4a46f1ffffffd8799fd8799fd8799f58206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb3ff01ffd8799fd8799fd87a9f581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809ffd87a80ff9fd8799f409fd8799f401819ffffffffd8799f58203999f2739f0bbcb9727893a0d2e8cae660f0ce36a73e42a58a7102894473a7e0ffffffd8799fd8799fd8799f5820f9d5959ed383550d28c45b30dce80260df7bf4741392f2ec1e3e743aa071c556ff01ffd8799fd8799fd87a9f581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809ffd87a80ff9fd8799f409fd8799f401864ffffffffd8799f5820509b58c2b6fe87f4888de7c11e6ba23ba34a19cadec76b1b7e7904f39ba0608affffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5ab11ffffffffd87a80ffff9fd8799f409fd8799f401936d0ffffffff808080d8799fd8799fd87a9f1b000001739c894e58ffd87a80ffd8799fd87a9f1b000001739c897567ffd87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff80d8799f5820a50a890e9f6b1e4ca495b72cc681e5d52061ef26d49bdd075f2fa8c182af1140ffffd87a9fd8799fd8799f58206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb3ff01ffffff" - , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\ACK6%\n\239'T\151\180\243\128}f\SUB)\158\&4\229>Z\211\188\DC1\DLE\228=\US4 \188\143\174"],I 6],Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 100000000]]]],Constr 1 []]],Constr 0 [Constr 0 [Constr 0 [B "\t\194\GS\231\236\229\178$\234\210GuN/\184\f\226\221i\235\CAN\r)(f\DC2\167\197^\192]<"],I 1],Constr 0 [Constr 0 [Constr 1 [B "^@\164z\182\226A#;\205\158\174\222\146 t<^\130\156\DLE]\188e\179\255\168\t"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 100]]]],Constr 0 [B "\STX\170S^\140\133\v@xk\154l\SYN\144r\211\&6\139\143\182x3A=\183\191\137;\221JF\241"]]],Constr 0 [Constr 0 [Constr 0 [B "n\229\222pG\190\144\DC3\"\175\SO\US\241\a\206\145\DC27\240\182\SO\163\140\217\&56\f\190\202\139\FS\179"],I 1],Constr 0 [Constr 0 [Constr 1 [B "^@\164z\182\226A#;\205\158\174\222\146 t<^\130\156\DLE]\188e\179\255\168\t"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 25]]]],Constr 0 [B "9\153\242s\159\v\188\185rx\147\160\210\232\202\230`\240\206\&6\167>B\165\138q\STX\137Ds\167\224"]]],Constr 0 [Constr 0 [Constr 0 [B "\249\213\149\158\211\131U\r(\196[0\220\232\STX`\223{\244t\DC3\146\242\236\RS>t:\160q\197V"],I 1],Constr 0 [Constr 0 [Constr 1 [B "^@\164z\182\226A#;\205\158\174\222\146 t<^\130\156\DLE]\188e\179\255\168\t"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 100]]]],Constr 0 [B "P\155X\194\182\254\135\244\136\141\231\193\RSk\162;\163J\EM\202\222\199k\ESC~y\EOT\243\155\160`\138"]]]],List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99986193]]]],Constr 1 []]],List [Constr 0 [B "",List [Constr 0 [B "",I 14032]]]],List [],List [],List [],Constr 0 [Constr 0 [Constr 1 [I 1596059111000],Constr 1 []],Constr 0 [Constr 1 [I 1596059120999],Constr 1 []]],List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"],List [],Constr 0 [B "\165\n\137\SO\159k\RSL\164\149\183,\198\129\229\213 a\239&\212\155\221\a_/\168\193\130\175\DC1@"]],Constr 1 [Constr 0 [Constr 0 [B "n\229\222pG\190\144\DC3\"\175\SO\US\241\a\206\145\DC27\240\182\SO\163\140\217\&56\f\190\202\139\FS\179"],I 1]]] - ) - , - ( "uniswap-6" - , "d87982d8798a83d87982d87982d8798158200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8fae08d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8081d879824081d87982401a05f5e100d87a80d87982d87982d87981582010a7b86c76306acc6dd7aa0002f90309c4e762b74d490364d072d8606e97e2dc01d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8081d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a000f4240d8798241421a000f4240d8798241431a000f4240d8798241441a000f4240d87a80d87982d87982d8798158208e42db798a023468c23085d2cc0018415f16ddc813ae049f8734c2dc7dc7aef002d87983d87982d87a81581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562d87a8083d879824081d87982401a000186a0d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7681d8798241411a0007a120d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d879824a506f6f6c20537461746501d879815820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd4783d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8083d879824081d87982401a05f5a1d3d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a000f2eb8d8798241421a000f4240d8798241431a000f4240d8798241441a000f4240d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d879824a506f6f6c20537461746500d87a80d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8083d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d87982582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bcd879824080d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7680d87a80d87983d87982d87a81581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562d87a8083d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d879824a506f6f6c20537461746501d879824081d87982401a00018a88d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7681d8798241411a0007b4a8d879815820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce9781d879824081d8798240193b4581d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d87982582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bc8080d87982d87982d87980d87a80d87982d87b80d87a8081581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0a82d879825820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd47d87a82d87982d87981d879824040d87981d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141d879811a00036977d879825820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce97d87a82d87982d87981d879824040d87981d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141d879811a00037233d8798158205f690e6656e0318d065f01c5fc6931495bfbc65d300a95520b34c6772d05fb87d87981581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a7647" - , "d8799fd8799f9fd8799fd8799fd8799f58200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8faeff08ffd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f409fd8799f401a05f5e100ffffffffd87a80ffffd8799fd8799fd8799f582010a7b86c76306acc6dd7aa0002f90309c4e762b74d490364d072d8606e97e2dcff01ffd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a000f4240ffd8799f41421a000f4240ffd8799f41431a000f4240ffd8799f41441a000f4240ffffffffd87a80ffffd8799fd8799fd8799f58208e42db798a023468c23085d2cc0018415f16ddc813ae049f8734c2dc7dc7aef0ff02ffd8799fd8799fd87a9f581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562ffd87a80ff9fd8799f409fd8799f401a000186a0ffffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a0007a120ffffffd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f4a506f6f6c20537461746501ffffffffd8799f5820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd47ffffffff9fd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f409fd8799f401a05f5a1d3ffffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a000f2eb8ffd8799f41421a000f4240ffd8799f41431a000f4240ffd8799f41441a000f4240ffffffd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f4a506f6f6c20537461746500ffffffffd87a80ffd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bcffffffd8799f4080ffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7680ffffd87a80ffd8799fd8799fd87a9f581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562ffd87a80ff9fd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f4a506f6f6c20537461746501ffffffd8799f409fd8799f401a00018a88ffffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a0007b4a8ffffffffd8799f5820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce97ffffff9fd8799f409fd8799f40193b45ffffffff9fd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bcffffffff8080d8799fd8799fd87980d87a80ffd8799fd87b80d87a80ffff9f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0aff9fd8799f5820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd47d87a9fd8799fd8799fd8799f4040ffffd8799fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141ffffffd8799f1a00036977ffffffd8799f5820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce97d87a9fd8799fd8799fd8799f4040ffffd8799fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141ffffffd8799f1a00037233ffffffffd8799f58205f690e6656e0318d065f01c5fc6931495bfbc65d300a95520b34c6772d05fb87ffffd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a7647ffff" - , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\ACK6%\n\239'T\151\180\243\128}f\SUB)\158\&4\229>Z\211\188\DC1\DLE\228=\US4 \188\143\174"],I 8],Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 100000000]]]],Constr 1 []]],Constr 0 [Constr 0 [Constr 0 [B "\DLE\167\184lv0j\204m\215\170\NUL\STX\249\ETX\t\196\231b\183MI\ETXd\208r\216`n\151\226\220"],I 1],Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"],Constr 1 []],List [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",List [Constr 0 [B "A",I 1000000],Constr 0 [B "B",I 1000000],Constr 0 [B "C",I 1000000],Constr 0 [B "D",I 1000000]]]],Constr 1 []]],Constr 0 [Constr 0 [Constr 0 [B "\142B\219y\138\STX4h\194\&0\133\210\204\NUL\CANA_\SYN\221\200\DC3\174\EOT\159\135\&4\194\220}\199\174\240"],I 2],Constr 0 [Constr 0 [Constr 1 [B "<\186\249{\148O\230\229\149\254\212+\254\210\183\CANyx\129\142\207\249\206\206\165`%b"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 100000]]],Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",List [Constr 0 [B "A",I 500000]]],Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG",List [Constr 0 [B "Pool State",I 1]]]],Constr 0 [B "\DC3\n\\\185\US\US9O\161r\DC4\162O\182c+\189\143_\SI\188\138<\250\206\&76\176w\DC2\189G"]]]],List [Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"],Constr 1 []],List [Constr 0 [B "",List [Constr 0 [B "",I 99983827]]],Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",List [Constr 0 [B "A",I 995000],Constr 0 [B "B",I 1000000],Constr 0 [B "C",I 1000000],Constr 0 [B "D",I 1000000]]],Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG",List [Constr 0 [B "Pool State",I 0]]]],Constr 1 []],Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"],Constr 1 []],List [Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG",List [Constr 0 [B "%\161\fW,`,\STX\233\&8\151\163\230\157c\249Hd|fa\EOT\DC3`2\181t\SI\216j\162Z",I 2236]]],Constr 0 [B "",List []],Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",List []]],Constr 1 []],Constr 0 [Constr 0 [Constr 1 [B "<\186\249{\148O\230\229\149\254\212+\254\210\183\CANyx\129\142\207\249\206\206\165`%b"],Constr 1 []],List [Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG",List [Constr 0 [B "Pool State",I 1]]],Constr 0 [B "",List [Constr 0 [B "",I 101000]]],Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",List [Constr 0 [B "A",I 505000]]]],Constr 0 [B "\222\158\US=%4\231^\\\224\194\198\235\221IJ\157\181L\SUB\184\241\230Y/\128\"\ESC\215E\206\151"]]],List [Constr 0 [B "",List [Constr 0 [B "",I 15173]]]],List [Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG",List [Constr 0 [B "%\161\fW,`,\STX\233\&8\151\163\230\157c\249Hd|fa\EOT\DC3`2\181t\SI\216j\162Z",I 2236]]]],List [],List [],Constr 0 [Constr 0 [Constr 0 [],Constr 1 []],Constr 0 [Constr 2 [],Constr 1 []]],List [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"],List [Constr 0 [B "\DC3\n\\\185\US\US9O\161r\DC4\162O\182c+\189\143_\SI\188\138<\250\206\&76\176w\DC2\189G",Constr 1 [Constr 0 [Constr 0 [Constr 0 [B "",B ""]],Constr 0 [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",B "A"]]],Constr 0 [I 223607]]],Constr 0 [B "\222\158\US=%4\231^\\\224\194\198\235\221IJ\157\181L\SUB\184\241\230Y/\128\"\ESC\215E\206\151",Constr 1 [Constr 0 [Constr 0 [Constr 0 [B "",B ""]],Constr 0 [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v",B "A"]]],Constr 0 [I 225843]]]],Constr 0 [B "_i\SOfV\224\&1\141\ACK_\SOH\197\252i1I[\251\198]0\n\149R\v4\198w-\ENQ\251\135"]],Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG"]] - ) - ] + [ + ( "auction_1-1" + , "d87982581cbd99a373075d42fe4ac9109515e46303d0940cb9620bf058b87986a9d87980" + , "d8799f581cbd99a373075d42fe4ac9109515e46303d0940cb9620bf058b87986a9d87980ff" + , Constr 0 [B "\189\153\163s\a]B\254J\201\DLE\149\NAK\228c\ETX\208\148\f\185b\v\240X\184y\134\169", Constr 0 []] + ) + , + ( "future-increase-margin-5 (a)" + , "d87981d8798281d879824081d879824019084b81d879824081d87982401908af" + , "d8799fd8799f9fd8799f409fd8799f4019084bffffffff9fd8799f409fd8799f401908afffffffffffff" + , Constr 0 [Constr 0 [List [Constr 0 [B "", List [Constr 0 [B "", I 2123]]]], List [Constr 0 [B "", List [Constr 0 [B "", I 2223]]]]]] + ) + , + ( "future-increase-margin-5 (b)" + , "d87a81d879835840c40f1dc048cc8b8b490cf6f58fbb582f01ecb8199094ed84961ab079dda95df47930e1607f41806587229912a670b64f2c6e67db22c2187781fce00df43c240f5820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8798281d879824081d87982401904641b000001739c8a86d8" + , "d87a9fd8799f5840c40f1dc048cc8b8b490cf6f58fbb582f01ecb8199094ed84961ab079dda95df47930e1607f41806587229912a670b64f2c6e67db22c2187781fce00df43c240f5820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8799f9fd8799f409fd8799f40190464ffffffff1b000001739c8a86d8ffffff" + , Constr 1 [Constr 0 [B "\196\SI\GS\192H\204\139\139I\f\246\245\143\187X/\SOH\236\184\EM\144\148\237\132\150\SUB\176y\221\169]\244y0\225`\DELA\128e\135\"\153\DC2\166p\182O,ng\219\"\194\CANw\129\252\224\r\244<$\SI", B "\216\175\152\238\207-\f\135Tbq:\232a\SYNM\224\STX\249\160\131\SI\SOH\177\157\195:N'Y%\DC3", Constr 0 [List [Constr 0 [B "", List [Constr 0 [B "", I 1124]]]], I 1596059191000]]] + ) + , + ( "future-increase-margin-5 (c)" + , "d87982d8798a82d87982d87982d87981582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f615700d87983d87982d87981581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27d87a8081d879824081d87982401a05f5aaa2d87a80d87982d87982d87981582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f615701d87983d87982d87a81581c12b132132c2b41a484de3b7a5db19be8ca28441de2b4148609079d19d87a8081d879824081d87982401910fad8798158208eb8c339886d3979c8edaf8feafd5fd410e127f312d3c6fcec8b5f979e68957283d87983d87982d87981581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27d87a8081d879824081d87982401a05f57cfdd87a80d87983d87982d87a81581c08535dc84e7823d63a787f1229ff1863e6c009907093b384289d50cdd87a8081d879824081d8798240190790d8798158202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0d87983d87982d87a81581cea16da21adb923d789313ccef2644d9ea19c2141f8f92bada80efb06d87a8081d879824081d879824019096ad8798158202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e081d879824081d8798240192da5808080d87982d87982d87a811b000001739c8a86d8d87a80d87982d87b80d87a8081581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f2782d8798258202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0d87980d879825820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8798281d879824081d87982401904641b000001739c8a86d8d879815820db145e448a2af884a7430ac31cec85bc700a89f35f1feb71544b5e31f4c68446d87a81d87982d87981582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f615701" + , "d8799fd8799f9fd8799fd8799fd8799f582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f6157ff00ffd8799fd8799fd8799f581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27ffd87a80ff9fd8799f409fd8799f401a05f5aaa2ffffffffd87a80ffffd8799fd8799fd8799f582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f6157ff01ffd8799fd8799fd87a9f581c12b132132c2b41a484de3b7a5db19be8ca28441de2b4148609079d19ffd87a80ff9fd8799f409fd8799f401910faffffffffd8799f58208eb8c339886d3979c8edaf8feafd5fd410e127f312d3c6fcec8b5f979e689572ffffffff9fd8799fd8799fd8799f581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27ffd87a80ff9fd8799f409fd8799f401a05f57cfdffffffffd87a80ffd8799fd8799fd87a9f581c08535dc84e7823d63a787f1229ff1863e6c009907093b384289d50cdffd87a80ff9fd8799f409fd8799f40190790ffffffffd8799f58202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0ffffd8799fd8799fd87a9f581cea16da21adb923d789313ccef2644d9ea19c2141f8f92bada80efb06ffd87a80ff9fd8799f409fd8799f4019096affffffffd8799f58202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0ffffff9fd8799f409fd8799f40192da5ffffffff808080d8799fd8799fd87a9f1b000001739c8a86d8ffd87a80ffd8799fd87b80d87a80ffff9f581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f27ff9fd8799f58202cdb268baecefad822e5712f9e690e1787f186f5c84c343ffdc060b21f0241e0d87980ffd8799f5820d8af98eecf2d0c875462713ae861164de002f9a0830f01b19dc33a4e27592513d8799f9fd8799f409fd8799f40190464ffffffff1b000001739c8a86d8ffffffd8799f5820db145e448a2af884a7430ac31cec85bc700a89f35f1feb71544b5e31f4c68446ffffd87a9fd8799fd8799f582044ab203a84db9ef946495a1cf1290d27ed80a4538b389fe6e3b39ef1d44f6157ff01ffffff" + , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "D\171 :\132\219\158\249FIZ\FS\241)\r'\237\128\164S\139\&8\159\230\227\179\158\241\212OaW"], I 0], Constr 0 [Constr 0 [Constr 0 [B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99986082]]]], Constr 1 []]], Constr 0 [Constr 0 [Constr 0 [B "D\171 :\132\219\158\249FIZ\FS\241)\r'\237\128\164S\139\&8\159\230\227\179\158\241\212OaW"], I 1], Constr 0 [Constr 0 [Constr 1 [B "\DC2\177\&2\DC3,+A\164\132\222;z]\177\155\232\202(D\GS\226\180\DC4\134\t\a\157\EM"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 4346]]]], Constr 0 [B "\142\184\195\&9\136m9y\200\237\175\143\234\253_\212\DLE\225'\243\DC2\211\198\252\236\139_\151\158h\149r"]]]], List [Constr 0 [Constr 0 [Constr 0 [B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99974397]]]], Constr 1 []], Constr 0 [Constr 0 [Constr 1 [B "\bS]\200Nx#\214:x\DEL\DC2)\255\CANc\230\192\t\144p\147\179\132(\157P\205"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 1936]]]], Constr 0 [B ",\219&\139\174\206\250\216\"\229q/\158i\SO\ETB\135\241\134\245\200L4?\253\192`\178\US\STXA\224"]], Constr 0 [Constr 0 [Constr 1 [B "\234\SYN\218!\173\185#\215\137\&1<\206\242dM\158\161\156!A\248\249+\173\168\SO\251\ACK"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 2410]]]], Constr 0 [B ",\219&\139\174\206\250\216\"\229q/\158i\SO\ETB\135\241\134\245\200L4?\253\192`\178\US\STXA\224"]]], List [Constr 0 [B "", List [Constr 0 [B "", I 11685]]]], List [], List [], List [], Constr 0 [Constr 0 [Constr 1 [I 1596059191000], Constr 1 []], Constr 0 [Constr 2 [], Constr 1 []]], List [B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'"], List [Constr 0 [B ",\219&\139\174\206\250\216\"\229q/\158i\SO\ETB\135\241\134\245\200L4?\253\192`\178\US\STXA\224", Constr 0 []], Constr 0 [B "\216\175\152\238\207-\f\135Tbq:\232a\SYNM\224\STX\249\160\131\SI\SOH\177\157\195:N'Y%\DC3", Constr 0 [List [Constr 0 [B "", List [Constr 0 [B "", I 1124]]]], I 1596059191000]]], Constr 0 [B "\219\DC4^D\138*\248\132\167C\n\195\FS\236\133\188p\n\137\243_\US\235qTK^1\244\198\132F"]], Constr 1 [Constr 0 [Constr 0 [B "D\171 :\132\219\158\249FIZ\FS\241)\r'\237\128\164S\139\&8\159\230\227\179\158\241\212OaW"], I 1]]] + ) + , + ( "uniswap-1" + , "d87982d8798a81d87982d87982d8798158200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8fae06d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e100d87a8081d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8082d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a003d0900d8798241421a003d0900d8798241431a003d0900d8798241441a003d0900d879824081d87982401a05f5cf58d87a8081d879824081d87982401911a881d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a003d0900d8798241421a003d0900d8798241431a003d0900d8798241441a003d09008080d87982d87982d87980d87a80d87982d87b80d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a380d879815820f154625e0831084f4981dd205ec3d7dc93d87951645fd963d445d5c2075d982bd87981581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb76" + , "d8799fd8799f9fd8799fd8799fd8799f58200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8faeff06ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e100ffffffffd87a80ffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a003d0900ffd8799f41421a003d0900ffd8799f41431a003d0900ffd8799f41441a003d0900ffffffd8799f409fd8799f401a05f5cf58ffffffffd87a80ffff9fd8799f409fd8799f401911a8ffffffff9fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a003d0900ffd8799f41421a003d0900ffd8799f41431a003d0900ffd8799f41441a003d0900ffffffff8080d8799fd8799fd87980d87a80ffd8799fd87b80d87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff80d8799f5820f154625e0831084f4981dd205ec3d7dc93d87951645fd963d445d5c2075d982bffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb76ffff" + , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\ACK6%\n\239'T\151\180\243\128}f\SUB)\158\&4\229>Z\211\188\DC1\DLE\228=\US4 \188\143\174"], I 6], Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 100000000]]]], Constr 1 []]]], List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", List [Constr 0 [B "A", I 4000000], Constr 0 [B "B", I 4000000], Constr 0 [B "C", I 4000000], Constr 0 [B "D", I 4000000]]], Constr 0 [B "", List [Constr 0 [B "", I 99995480]]]], Constr 1 []]], List [Constr 0 [B "", List [Constr 0 [B "", I 4520]]]], List [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", List [Constr 0 [B "A", I 4000000], Constr 0 [B "B", I 4000000], Constr 0 [B "C", I 4000000], Constr 0 [B "D", I 4000000]]]], List [], List [], Constr 0 [Constr 0 [Constr 0 [], Constr 1 []], Constr 0 [Constr 2 [], Constr 1 []]], List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], List [], Constr 0 [B "\241Tb^\b1\bOI\129\221 ^\195\215\220\147\216yQd_\217c\212E\213\194\a]\152+"]], Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v"]] + ) + , + ( "escrow-refund-1" + , "d87982d8798a82d87982d87982d8798158201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a3900d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e0e2d87a80d87982d87982d8798158201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a3901d87983d87982d87a81581ce7cf3ddee4924dbef3fdceb67f67f11057fe57636443bc3b2ae498f3d87a8081d879824081d879824014d879815820ca54c8836c475a77c6914b4fd598080acadb0f0067778773484d2c12ae7dc75681d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5c936d87a8081d879824081d87982401917c0808080d87982d87982d87a811b000001739c8a8abfd87980d87982d87b80d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a380d8798158202affd3baa0837dd427ae8924f5fb9729577a25280c4c24dd055f8184fd5b5513d87a81d87982d8798158201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a3901" + , "d8799fd8799f9fd8799fd8799fd8799f58201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a39ff00ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e0e2ffffffffd87a80ffffd8799fd8799fd8799f58201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a39ff01ffd8799fd8799fd87a9f581ce7cf3ddee4924dbef3fdceb67f67f11057fe57636443bc3b2ae498f3ffd87a80ff9fd8799f409fd8799f4014ffffffffd8799f5820ca54c8836c475a77c6914b4fd598080acadb0f0067778773484d2c12ae7dc756ffffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5c936ffffffffd87a80ffff9fd8799f409fd8799f401917c0ffffffff808080d8799fd8799fd87a9f1b000001739c8a8abfffd87980ffd8799fd87b80d87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff80d8799f58202affd3baa0837dd427ae8924f5fb9729577a25280c4c24dd055f8184fd5b5513ffffd87a9fd8799fd8799f58201a630ffeb3be9a107de0a948ce58c23ca5698e000925c5dbb8e69e1966657a39ff01ffffff" + , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\SUBc\SI\254\179\190\154\DLE}\224\169H\206X\194<\165i\142\NUL\t%\197\219\184\230\158\EMfez9"], I 0], Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99999970]]]], Constr 1 []]], Constr 0 [Constr 0 [Constr 0 [B "\SUBc\SI\254\179\190\154\DLE}\224\169H\206X\194<\165i\142\NUL\t%\197\219\184\230\158\EMfez9"], I 1], Constr 0 [Constr 0 [Constr 1 [B "\231\207=\222\228\146M\190\243\253\206\182\DELg\241\DLEW\254WcdC\188;*\228\152\243"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 20]]]], Constr 0 [B "\202T\200\131lGZw\198\145KO\213\152\b\n\202\219\SI\NULgw\135sHM,\DC2\174}\199V"]]]], List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99993910]]]], Constr 1 []]], List [Constr 0 [B "", List [Constr 0 [B "", I 6080]]]], List [], List [], List [], Constr 0 [Constr 0 [Constr 1 [I 1596059191999], Constr 0 []], Constr 0 [Constr 2 [], Constr 1 []]], List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], List [], Constr 0 [B "*\255\211\186\160\131}\212'\174\137$\245\251\151)Wz%(\fL$\221\ENQ_\129\132\253[U\DC3"]], Constr 1 [Constr 0 [Constr 0 [B "\SUBc\SI\254\179\190\154\DLE}\224\169H\206X\194<\165i\142\NUL\t%\197\219\184\230\158\EMfez9"], I 1]]] + ) + , + ( "multisig-sm-2" + , "d87982d8798a82d87982d87982d87981582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42a01d87983d87982d87a81581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8d87a8081d879824081d87982400ad87981582021588ed1ce48a9a88b74e143fb697199fa8da46edf04bb2d3da8970266f51849d87982d87982d879815820ca554bdd535583761a73982bbaa329ace796e73290cf41f10b5208f09138aacb00d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e0ecd87a8082d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5b8cad87a80d87983d87982d87a81581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8d87a8081d879824081d87982400ad879815820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f4496581d879824081d8798240192822808080d87982d87982d87980d87a80d87982d87b80d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a381d879825820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f44965d87a82d8798381d879824081d879824005581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f271b000001739c894e5881581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87981582022fe5664b828b42c51aa9accb87a448808a89978e8adcd2788b04b204f704664d87a81d87982d87981582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42a01" + , "d8799fd8799f9fd8799fd8799fd8799f582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42aff01ffd8799fd8799fd87a9f581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8ffd87a80ff9fd8799f409fd8799f400affffffffd8799f582021588ed1ce48a9a88b74e143fb697199fa8da46edf04bb2d3da8970266f51849ffffffd8799fd8799fd8799f5820ca554bdd535583761a73982bbaa329ace796e73290cf41f10b5208f09138aacbff00ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e0ecffffffffd87a80ffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5b8caffffffffd87a80ffd8799fd8799fd87a9f581c38034c703e2192479f193f97fe0437fc00d26c0758d4faa749f4c2b8ffd87a80ff9fd8799f409fd8799f400affffffffd8799f5820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f44965ffffff9fd8799f409fd8799f40192822ffffffff808080d8799fd8799fd87980d87a80ffd8799fd87b80d87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff9fd8799f5820cc76070aa0f027db5b3eeeb58810fa57e2d45743be93bf65cb63a288d5f44965d87a9fd8799f9fd8799f409fd8799f4005ffffffff581c977efb35ab621d39dbeb7274ec7795a34708ff4d25a01a1df04c1f271b000001739c894e58ff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffffffffd8799f582022fe5664b828b42c51aa9accb87a448808a89978e8adcd2788b04b204f704664ffffd87a9fd8799fd8799f582032ff8f542683ea69e6e1fa23df0b62847f1c0dd9dff8d65230ed1828157aa42aff01ffffff" + , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "2\255\143T&\131\234i\230\225\250#\223\vb\132\DEL\FS\r\217\223\248\214R0\237\CAN(\NAKz\164*"], I 1], Constr 0 [Constr 0 [Constr 1 [B "8\ETXLp>!\146G\159\EM?\151\254\EOT7\252\NUL\210l\aX\212\250\167I\244\194\184"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 10]]]], Constr 0 [B "!X\142\209\206H\169\168\139t\225C\251iq\153\250\141\164n\223\EOT\187-=\168\151\STXf\245\CANI"]]], Constr 0 [Constr 0 [Constr 0 [B "\202UK\221SU\131v\SUBs\152+\186\163)\172\231\150\231\&2\144\207A\241\vR\b\240\145\&8\170\203"], I 0], Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99999980]]]], Constr 1 []]]], List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99989706]]]], Constr 1 []], Constr 0 [Constr 0 [Constr 1 [B "8\ETXLp>!\146G\159\EM?\151\254\EOT7\252\NUL\210l\aX\212\250\167I\244\194\184"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 10]]]], Constr 0 [B "\204v\a\n\160\240'\219[>\238\181\136\DLE\250W\226\212WC\190\147\191e\203c\162\136\213\244Ie"]]], List [Constr 0 [B "", List [Constr 0 [B "", I 10274]]]], List [], List [], List [], Constr 0 [Constr 0 [Constr 0 [], Constr 1 []], Constr 0 [Constr 2 [], Constr 1 []]], List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], List [Constr 0 [B "\204v\a\n\160\240'\219[>\238\181\136\DLE\250W\226\212WC\190\147\191e\203c\162\136\213\244Ie", Constr 1 [Constr 0 [List [Constr 0 [B "", List [Constr 0 [B "", I 5]]]], B "\151~\251\&5\171b\GS9\219\235rt\236w\149\163G\b\255M%\160\SUB\GS\240L\US'", I 1596059111000], List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"]]]], Constr 0 [B "\"\254Vd\184(\180,Q\170\154\204\184zD\136\b\168\153x\232\173\205'\136\176K OpFd"]], Constr 1 [Constr 0 [Constr 0 [B "2\255\143T&\131\234i\230\225\250#\223\vb\132\DEL\FS\r\217\223\248\214R0\237\CAN(\NAKz\164*"], I 1]]] + ) + , + ( "crowdfunding-success-2" + , "d87982d8798a84d87982d87982d8798158200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8fae06d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5e100d87a80d87982d87982d87981582009c21de7ece5b224ead247754e2fb80ce2dd69eb180d29286612a7c55ec05d3c01d87983d87982d87a81581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809d87a8081d879824081d87982401864d87981582002aa535e8c850b40786b9a6c169072d3368b8fb67833413db7bf893bdd4a46f1d87982d87982d8798158206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb301d87983d87982d87a81581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809d87a8081d879824081d87982401819d8798158203999f2739f0bbcb9727893a0d2e8cae660f0ce36a73e42a58a7102894473a7e0d87982d87982d879815820f9d5959ed383550d28c45b30dce80260df7bf4741392f2ec1e3e743aa071c55601d87983d87982d87a81581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809d87a8081d879824081d87982401864d879815820509b58c2b6fe87f4888de7c11e6ba23ba34a19cadec76b1b7e7904f39ba0608a81d87983d87982d87981581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3d87a8081d879824081d87982401a05f5ab11d87a8081d879824081d87982401936d0808080d87982d87982d87a811b000001739c894e58d87a80d87982d87a811b000001739c897567d87a8081581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a380d879815820a50a890e9f6b1e4ca495b72cc681e5d52061ef26d49bdd075f2fa8c182af1140d87a81d87982d8798158206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb301" + , "d8799fd8799f9fd8799fd8799fd8799f58200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8faeff06ffd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5e100ffffffffd87a80ffffd8799fd8799fd8799f582009c21de7ece5b224ead247754e2fb80ce2dd69eb180d29286612a7c55ec05d3cff01ffd8799fd8799fd87a9f581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809ffd87a80ff9fd8799f409fd8799f401864ffffffffd8799f582002aa535e8c850b40786b9a6c169072d3368b8fb67833413db7bf893bdd4a46f1ffffffd8799fd8799fd8799f58206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb3ff01ffd8799fd8799fd87a9f581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809ffd87a80ff9fd8799f409fd8799f401819ffffffffd8799f58203999f2739f0bbcb9727893a0d2e8cae660f0ce36a73e42a58a7102894473a7e0ffffffd8799fd8799fd8799f5820f9d5959ed383550d28c45b30dce80260df7bf4741392f2ec1e3e743aa071c556ff01ffd8799fd8799fd87a9f581c5e40a47ab6e241233bcd9eaede9220743c5e829c105dbc65b3ffa809ffd87a80ff9fd8799f409fd8799f401864ffffffffd8799f5820509b58c2b6fe87f4888de7c11e6ba23ba34a19cadec76b1b7e7904f39ba0608affffffff9fd8799fd8799fd8799f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ffd87a80ff9fd8799f409fd8799f401a05f5ab11ffffffffd87a80ffff9fd8799f409fd8799f401936d0ffffffff808080d8799fd8799fd87a9f1b000001739c894e58ffd87a80ffd8799fd87a9f1b000001739c897567ffd87a80ffff9f581c35dedd2982a03cf39e7dce03c839994ffdec2ec6b04f1cf2d40e61a3ff80d8799f5820a50a890e9f6b1e4ca495b72cc681e5d52061ef26d49bdd075f2fa8c182af1140ffffd87a9fd8799fd8799f58206ee5de7047be901322af0e1ff107ce911237f0b60ea38cd935360cbeca8b1cb3ff01ffffff" + , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\ACK6%\n\239'T\151\180\243\128}f\SUB)\158\&4\229>Z\211\188\DC1\DLE\228=\US4 \188\143\174"], I 6], Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 100000000]]]], Constr 1 []]], Constr 0 [Constr 0 [Constr 0 [B "\t\194\GS\231\236\229\178$\234\210GuN/\184\f\226\221i\235\CAN\r)(f\DC2\167\197^\192]<"], I 1], Constr 0 [Constr 0 [Constr 1 [B "^@\164z\182\226A#;\205\158\174\222\146 t<^\130\156\DLE]\188e\179\255\168\t"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 100]]]], Constr 0 [B "\STX\170S^\140\133\v@xk\154l\SYN\144r\211\&6\139\143\182x3A=\183\191\137;\221JF\241"]]], Constr 0 [Constr 0 [Constr 0 [B "n\229\222pG\190\144\DC3\"\175\SO\US\241\a\206\145\DC27\240\182\SO\163\140\217\&56\f\190\202\139\FS\179"], I 1], Constr 0 [Constr 0 [Constr 1 [B "^@\164z\182\226A#;\205\158\174\222\146 t<^\130\156\DLE]\188e\179\255\168\t"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 25]]]], Constr 0 [B "9\153\242s\159\v\188\185rx\147\160\210\232\202\230`\240\206\&6\167>B\165\138q\STX\137Ds\167\224"]]], Constr 0 [Constr 0 [Constr 0 [B "\249\213\149\158\211\131U\r(\196[0\220\232\STX`\223{\244t\DC3\146\242\236\RS>t:\160q\197V"], I 1], Constr 0 [Constr 0 [Constr 1 [B "^@\164z\182\226A#;\205\158\174\222\146 t<^\130\156\DLE]\188e\179\255\168\t"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 100]]]], Constr 0 [B "P\155X\194\182\254\135\244\136\141\231\193\RSk\162;\163J\EM\202\222\199k\ESC~y\EOT\243\155\160`\138"]]]], List [Constr 0 [Constr 0 [Constr 0 [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99986193]]]], Constr 1 []]], List [Constr 0 [B "", List [Constr 0 [B "", I 14032]]]], List [], List [], List [], Constr 0 [Constr 0 [Constr 1 [I 1596059111000], Constr 1 []], Constr 0 [Constr 1 [I 1596059120999], Constr 1 []]], List [B "5\222\221)\130\160<\243\158}\206\ETX\200\&9\153O\253\236.\198\176O\FS\242\212\SOa\163"], List [], Constr 0 [B "\165\n\137\SO\159k\RSL\164\149\183,\198\129\229\213 a\239&\212\155\221\a_/\168\193\130\175\DC1@"]], Constr 1 [Constr 0 [Constr 0 [B "n\229\222pG\190\144\DC3\"\175\SO\US\241\a\206\145\DC27\240\182\SO\163\140\217\&56\f\190\202\139\FS\179"], I 1]]] + ) + , + ( "uniswap-6" + , "d87982d8798a83d87982d87982d8798158200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8fae08d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8081d879824081d87982401a05f5e100d87a80d87982d87982d87981582010a7b86c76306acc6dd7aa0002f90309c4e762b74d490364d072d8606e97e2dc01d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8081d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a000f4240d8798241421a000f4240d8798241431a000f4240d8798241441a000f4240d87a80d87982d87982d8798158208e42db798a023468c23085d2cc0018415f16ddc813ae049f8734c2dc7dc7aef002d87983d87982d87a81581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562d87a8083d879824081d87982401a000186a0d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7681d8798241411a0007a120d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d879824a506f6f6c20537461746501d879815820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd4783d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8083d879824081d87982401a05f5a1d3d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7684d8798241411a000f2eb8d8798241421a000f4240d8798241431a000f4240d8798241441a000f4240d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d879824a506f6f6c20537461746500d87a80d87983d87982d87981581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0ad87a8083d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d87982582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bcd879824080d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7680d87a80d87983d87982d87a81581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562d87a8083d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d879824a506f6f6c20537461746501d879824081d87982401a00018a88d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7681d8798241411a0007b4a8d879815820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce9781d879824081d8798240193b4581d87982581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a764781d87982582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bc8080d87982d87982d87980d87a80d87982d87b80d87a8081581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0a82d879825820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd47d87a82d87982d87981d879824040d87981d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141d879811a00036977d879825820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce97d87a82d87982d87981d879824040d87981d87982581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141d879811a00037233d8798158205f690e6656e0318d065f01c5fc6931495bfbc65d300a95520b34c6772d05fb87d87981581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a7647" + , "d8799fd8799f9fd8799fd8799fd8799f58200636250aef275497b4f3807d661a299e34e53e5ad3bc1110e43d1f3420bc8faeff08ffd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f409fd8799f401a05f5e100ffffffffd87a80ffffd8799fd8799fd8799f582010a7b86c76306acc6dd7aa0002f90309c4e762b74d490364d072d8606e97e2dcff01ffd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a000f4240ffd8799f41421a000f4240ffd8799f41431a000f4240ffd8799f41441a000f4240ffffffffd87a80ffffd8799fd8799fd8799f58208e42db798a023468c23085d2cc0018415f16ddc813ae049f8734c2dc7dc7aef0ff02ffd8799fd8799fd87a9f581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562ffd87a80ff9fd8799f409fd8799f401a000186a0ffffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a0007a120ffffffd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f4a506f6f6c20537461746501ffffffffd8799f5820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd47ffffffff9fd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f409fd8799f401a05f5a1d3ffffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a000f2eb8ffd8799f41421a000f4240ffd8799f41431a000f4240ffd8799f41441a000f4240ffffffd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f4a506f6f6c20537461746500ffffffffd87a80ffd8799fd8799fd8799f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0affd87a80ff9fd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bcffffffd8799f4080ffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb7680ffffd87a80ffd8799fd8799fd87a9f581c3cbaf97b944fe6e595fed42bfed2b7187978818ecff9cecea5602562ffd87a80ff9fd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f4a506f6f6c20537461746501ffffffd8799f409fd8799f401a00018a88ffffffd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb769fd8799f41411a0007b4a8ffffffffd8799f5820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce97ffffff9fd8799f409fd8799f40193b45ffffffff9fd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a76479fd8799f582025a10c572c602c02e93897a3e69d63f948647c666104136032b5740fd86aa25a1908bcffffffff8080d8799fd8799fd87980d87a80ffd8799fd87b80d87a80ffff9f581c7f8a76c0ebaa4ad20dfdcd51a5de070ab771f4bf377f2c41e6b71c0aff9fd8799f5820130a5cb91f1f394fa17214a24fb6632bbd8f5f0fbc8a3cface3736b07712bd47d87a9fd8799fd8799fd8799f4040ffffd8799fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141ffffffd8799f1a00036977ffffffd8799f5820de9e1f3d2534e75e5ce0c2c6ebdd494a9db54c1ab8f1e6592f80221bd745ce97d87a9fd8799fd8799fd8799f4040ffffd8799fd8799f581c60bab65c3fbe2ba8c920d0ba15cdb2489767c81349271ecd5bbbeb764141ffffffd8799f1a00037233ffffffffd8799f58205f690e6656e0318d065f01c5fc6931495bfbc65d300a95520b34c6772d05fb87ffffd8799f581c8d823ac08ef4c337a234c64514fe6fa3f5243909109d60d5780a7647ffff" + , Constr 0 [Constr 0 [List [Constr 0 [Constr 0 [Constr 0 [B "\ACK6%\n\239'T\151\180\243\128}f\SUB)\158\&4\229>Z\211\188\DC1\DLE\228=\US4 \188\143\174"], I 8], Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 100000000]]]], Constr 1 []]], Constr 0 [Constr 0 [Constr 0 [B "\DLE\167\184lv0j\204m\215\170\NUL\STX\249\ETX\t\196\231b\183MI\ETXd\208r\216`n\151\226\220"], I 1], Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"], Constr 1 []], List [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", List [Constr 0 [B "A", I 1000000], Constr 0 [B "B", I 1000000], Constr 0 [B "C", I 1000000], Constr 0 [B "D", I 1000000]]]], Constr 1 []]], Constr 0 [Constr 0 [Constr 0 [B "\142B\219y\138\STX4h\194\&0\133\210\204\NUL\CANA_\SYN\221\200\DC3\174\EOT\159\135\&4\194\220}\199\174\240"], I 2], Constr 0 [Constr 0 [Constr 1 [B "<\186\249{\148O\230\229\149\254\212+\254\210\183\CANyx\129\142\207\249\206\206\165`%b"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 100000]]], Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", List [Constr 0 [B "A", I 500000]]], Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG", List [Constr 0 [B "Pool State", I 1]]]], Constr 0 [B "\DC3\n\\\185\US\US9O\161r\DC4\162O\182c+\189\143_\SI\188\138<\250\206\&76\176w\DC2\189G"]]]], List [Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"], Constr 1 []], List [Constr 0 [B "", List [Constr 0 [B "", I 99983827]]], Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", List [Constr 0 [B "A", I 995000], Constr 0 [B "B", I 1000000], Constr 0 [B "C", I 1000000], Constr 0 [B "D", I 1000000]]], Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG", List [Constr 0 [B "Pool State", I 0]]]], Constr 1 []], Constr 0 [Constr 0 [Constr 0 [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"], Constr 1 []], List [Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG", List [Constr 0 [B "%\161\fW,`,\STX\233\&8\151\163\230\157c\249Hd|fa\EOT\DC3`2\181t\SI\216j\162Z", I 2236]]], Constr 0 [B "", List []], Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", List []]], Constr 1 []], Constr 0 [Constr 0 [Constr 1 [B "<\186\249{\148O\230\229\149\254\212+\254\210\183\CANyx\129\142\207\249\206\206\165`%b"], Constr 1 []], List [Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG", List [Constr 0 [B "Pool State", I 1]]], Constr 0 [B "", List [Constr 0 [B "", I 101000]]], Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", List [Constr 0 [B "A", I 505000]]]], Constr 0 [B "\222\158\US=%4\231^\\\224\194\198\235\221IJ\157\181L\SUB\184\241\230Y/\128\"\ESC\215E\206\151"]]], List [Constr 0 [B "", List [Constr 0 [B "", I 15173]]]], List [Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG", List [Constr 0 [B "%\161\fW,`,\STX\233\&8\151\163\230\157c\249Hd|fa\EOT\DC3`2\181t\SI\216j\162Z", I 2236]]]], List [], List [], Constr 0 [Constr 0 [Constr 0 [], Constr 1 []], Constr 0 [Constr 2 [], Constr 1 []]], List [B "\DEL\138v\192\235\170J\210\r\253\205Q\165\222\a\n\183q\244\191\&7\DEL,A\230\183\FS\n"], List [Constr 0 [B "\DC3\n\\\185\US\US9O\161r\DC4\162O\182c+\189\143_\SI\188\138<\250\206\&76\176w\DC2\189G", Constr 1 [Constr 0 [Constr 0 [Constr 0 [B "", B ""]], Constr 0 [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", B "A"]]], Constr 0 [I 223607]]], Constr 0 [B "\222\158\US=%4\231^\\\224\194\198\235\221IJ\157\181L\SUB\184\241\230Y/\128\"\ESC\215E\206\151", Constr 1 [Constr 0 [Constr 0 [Constr 0 [B "", B ""]], Constr 0 [Constr 0 [B "`\186\182\\?\190+\168\201 \208\186\NAK\205\178H\151g\200\DC3I'\RS\205[\187\235v", B "A"]]], Constr 0 [I 225843]]]], Constr 0 [B "_i\SOfV\224\&1\141\ACK_\SOH\197\252i1I[\251\198]0\n\149R\v4\198w-\ENQ\251\135"]], Constr 0 [B "\141\130:\192\142\244\195\&7\162\&4\198E\DC4\254o\163\245$9\t\DLE\157`\213x\nvG"]] + ) + ] -- Lifted from the `hex-text` package which is being dropped because it -- is poorly maintained. diff --git a/plutus-core/plutus-core/test/Check/Spec.hs b/plutus-core/plutus-core/test/Check/Spec.hs index 5404d009226..7bd6e89e6e8 100644 --- a/plutus-core/plutus-core/test/Check/Spec.hs +++ b/plutus-core/plutus-core/test/Check/Spec.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} + module Check.Spec (tests) where import PlutusPrelude @@ -16,11 +17,13 @@ import PlutusCore.MkPlc import Control.Monad.Except import Hedgehog hiding (Var) import Test.Tasty -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog tests :: TestTree -tests = testGroup "checks" +tests = + testGroup + "checks" [ testPropertyNamed "renaming ensures global uniqueness" "propRenameCheck" propRenameCheck , shadowed , multiplyDefined @@ -33,150 +36,148 @@ tests = testGroup "checks" data Tag = Tag Int | Ignore deriving stock (Show, Eq, Ord) checkTermUniques :: (Ord a, MonadError (UniqueError a) m) => Term TyName Name uni fun a -> m () -checkTermUniques = Uniques.checkTerm (\case FreeVariable{} -> False; _ -> True) +checkTermUniques = Uniques.checkTerm (\case FreeVariable {} -> False; _ -> True) shadowed :: TestTree shadowed = - let - u = Unique (-1) - checked = runExcept $ runQuoteT $ do - ty <- freshTyName "ty" - let n = Name "yo" u - let term = - LamAbs (Tag 1) n (TyVar Ignore ty) $ - LamAbs (Tag 2) n (TyVar Ignore ty) $ - Var Ignore n - checkTermUniques term - assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) - in testCase "shadowed" assertion + let + u = Unique (-1) + checked = runExcept $ runQuoteT $ do + ty <- freshTyName "ty" + let n = Name "yo" u + let term = + LamAbs (Tag 1) n (TyVar Ignore ty) $ + LamAbs (Tag 2) n (TyVar Ignore ty) $ + Var Ignore n + checkTermUniques term + assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) + in + testCase "shadowed" assertion multiplyDefined :: TestTree multiplyDefined = - let - u = Unique (-1) - checked = runExcept $ runQuoteT $ do - ty <- freshTyName "ty" - let n = Name "yo" u - let term = - Apply Ignore - (LamAbs (Tag 1) n (TyVar Ignore ty) (Var Ignore n)) - (LamAbs (Tag 2) n (TyVar Ignore ty) (Var Ignore n)) - checkTermUniques term - assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) - in testCase "multiplyDefined" assertion + let + u = Unique (-1) + checked = runExcept $ runQuoteT $ do + ty <- freshTyName "ty" + let n = Name "yo" u + let term = + Apply + Ignore + (LamAbs (Tag 1) n (TyVar Ignore ty) (Var Ignore n)) + (LamAbs (Tag 2) n (TyVar Ignore ty) (Var Ignore n)) + checkTermUniques term + assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) + in + testCase "multiplyDefined" assertion incoherentUse :: TestTree incoherentUse = - let - u = Unique 0 - checked = runExcept $ runQuoteT $ do - let n = Name "yo" u - let ty = TyName n - let term = - LamAbs (Tag 1) n (TyVar (Tag 2) ty) $ - TyInst Ignore (Var (Tag 3) n) (TyVar (Tag 4) ty) - checkTermUniques term - assertion = checked @?= Left (IncoherentUsage u (Tag 1) (Tag 2)) - in testCase "incoherentUse" assertion + let + u = Unique 0 + checked = runExcept $ runQuoteT $ do + let n = Name "yo" u + let ty = TyName n + let term = + LamAbs (Tag 1) n (TyVar (Tag 2) ty) $ + TyInst Ignore (Var (Tag 3) n) (TyVar (Tag 4) ty) + checkTermUniques term + assertion = checked @?= Left (IncoherentUsage u (Tag 1) (Tag 2)) + in + testCase "incoherentUse" assertion propRenameCheck :: Property propRenameCheck = property $ do - prog <- forAllPretty $ runAstGen (genProgram @DefaultFun) - renamed <- runQuoteT $ rename prog - annotateShow $ ShowPretty renamed - Hedgehog.evalExceptT $ checkUniques renamed - where - checkUniques :: (Ord a, MonadError (UniqueError a) m) - => Program TyName Name uni fun a -> m () - -- the renamer will fix incoherency between *bound* variables, but it ignores free - -- variables, so we can still get incoherent usage errors, ignore them for now - checkUniques = - Uniques.checkProgram - (\case { FreeVariable{} -> False; IncoherentUsage {} -> False; _ -> True}) + prog <- forAllPretty $ runAstGen (genProgram @DefaultFun) + renamed <- runQuoteT $ rename prog + annotateShow $ ShowPretty renamed + Hedgehog.evalExceptT $ checkUniques renamed + where + checkUniques :: + (Ord a, MonadError (UniqueError a) m) => + Program TyName Name uni fun a -> m () + -- the renamer will fix incoherency between *bound* variables, but it ignores free + -- variables, so we can still get incoherent usage errors, ignore them for now + checkUniques = + Uniques.checkProgram + (\case FreeVariable {} -> False; IncoherentUsage {} -> False; _ -> True) values :: TestTree values = runQuote $ do - aN <- freshTyName "a" - let aV = TyVar () aN - val = mkConstant @Integer @DefaultUni () 2 - nonVal = Error () aV - pure $ testGroup "values" [ - testCase "wrapNonValue" $ VR.isTermValue (IWrap () aV aV nonVal) @?= False - , testCase "wrapValue" $ VR.isTermValue (IWrap () aV aV val) @?= True - - , testCase "absNonValue" $ VR.isTermValue (TyAbs () aN (Type ()) nonVal) @?= True - , testCase "absValue" $ VR.isTermValue (TyAbs () aN (Type()) val) @?= True - - , testCase "error" $ VR.isTermValue (Error () aV) @?= False - , testCase "lam" $ VR.isTermValue (LamAbs () (Var () aN) aV nonVal) @?= True - , testCase "app" $ VR.isTermValue (Apply () val val) @?= False - , testCase "unwrap" $ VR.isTermValue (Unwrap () val) @?= False - , testCase "inst" $ VR.isTermValue (TyInst () val aV) @?= False - , testCase "constant" $ VR.isTermValue (mkConstant @Integer @DefaultUni () 1) @?= True - , testCase "builtin" $ VR.isTermValue (Builtin () AddInteger) @?= False + aN <- freshTyName "a" + let aV = TyVar () aN + val = mkConstant @Integer @DefaultUni () 2 + nonVal = Error () aV + pure $ + testGroup + "values" + [ testCase "wrapNonValue" $ VR.isTermValue (IWrap () aV aV nonVal) @?= False + , testCase "wrapValue" $ VR.isTermValue (IWrap () aV aV val) @?= True + , testCase "absNonValue" $ VR.isTermValue (TyAbs () aN (Type ()) nonVal) @?= True + , testCase "absValue" $ VR.isTermValue (TyAbs () aN (Type ()) val) @?= True + , testCase "error" $ VR.isTermValue (Error () aV) @?= False + , testCase "lam" $ VR.isTermValue (LamAbs () (Var () aN) aV nonVal) @?= True + , testCase "app" $ VR.isTermValue (Apply () val val) @?= False + , testCase "unwrap" $ VR.isTermValue (Unwrap () val) @?= False + , testCase "inst" $ VR.isTermValue (TyInst () val aV) @?= False + , testCase "constant" $ VR.isTermValue (mkConstant @Integer @DefaultUni () 1) @?= True + , testCase "builtin" $ VR.isTermValue (Builtin () AddInteger) @?= False ] normalTypes :: TestTree normalTypes = runQuote $ do - aN <- freshTyName "a" - let integer = mkTyBuiltin @_ @Integer @DefaultUni () - neutral = TyVar () aN - normal = integer - nonNormal = TyApp () (TyLam () aN (Type ()) neutral) normal - pure $ testGroup "normal types" [ - testCase "var" $ Normal.isNormalType @DefaultUni neutral @?= True - - , testCase "funNormal" $ Normal.isNormalType (TyFun () normal normal) @?= True - , testCase "funNotNormal" $ Normal.isNormalType (TyFun () normal nonNormal) @?= False - - , testCase "lamNormal" $ Normal.isNormalType (TyLam () aN (Type ()) normal) @?= True - , testCase "lamNonNormal" $ Normal.isNormalType (TyLam () aN (Type ()) nonNormal) @?= False - - , testCase "forallNormal" $ Normal.isNormalType (TyForall () aN (Type ()) normal) @?= True - , testCase "forallNonNormal" - $ Normal.isNormalType (TyForall () aN (Type ()) nonNormal) @?= False - , testCase "ifixNormal" $ Normal.isNormalType (TyIFix () normal normal) @?= True - , testCase "ifixNonNormal" $ Normal.isNormalType (TyIFix () nonNormal normal) @?= False - - , testCase "appNormal" $ Normal.isNormalType (TyApp () neutral normal) @?= True - , testCase "appNonNormal" $ Normal.isNormalType (TyApp () nonNormal normal) @?= False - - , testCase "builtin" $ Normal.isNormalType integer @?= True + aN <- freshTyName "a" + let integer = mkTyBuiltin @_ @Integer @DefaultUni () + neutral = TyVar () aN + normal = integer + nonNormal = TyApp () (TyLam () aN (Type ()) neutral) normal + pure $ + testGroup + "normal types" + [ testCase "var" $ Normal.isNormalType @DefaultUni neutral @?= True + , testCase "funNormal" $ Normal.isNormalType (TyFun () normal normal) @?= True + , testCase "funNotNormal" $ Normal.isNormalType (TyFun () normal nonNormal) @?= False + , testCase "lamNormal" $ Normal.isNormalType (TyLam () aN (Type ()) normal) @?= True + , testCase "lamNonNormal" $ Normal.isNormalType (TyLam () aN (Type ()) nonNormal) @?= False + , testCase "forallNormal" $ Normal.isNormalType (TyForall () aN (Type ()) normal) @?= True + , testCase "forallNonNormal" $ + Normal.isNormalType (TyForall () aN (Type ()) nonNormal) @?= False + , testCase "ifixNormal" $ Normal.isNormalType (TyIFix () normal normal) @?= True + , testCase "ifixNonNormal" $ Normal.isNormalType (TyIFix () nonNormal normal) @?= False + , testCase "appNormal" $ Normal.isNormalType (TyApp () neutral normal) @?= True + , testCase "appNonNormal" $ Normal.isNormalType (TyApp () nonNormal normal) @?= False + , testCase "builtin" $ Normal.isNormalType integer @?= True ] normalTypesCheck :: TestTree normalTypesCheck = runQuote $ do - aN <- freshTyName "a" - xN <- freshName "x" - let integer = mkTyBuiltin @_ @Integer () - aV = TyVar () aN - xV = Var () xN - normal = integer - nonNormal = TyApp () (TyLam () aN (Type ()) aV) normal - pure $ testGroup "normalized types check" [ - testCase "lamNormal" $ isRight (checkNormal (LamAbs () xN normal xV)) @? "Normalization" - , testCase "lamNonNormal" $ - isLeft (checkNormal (LamAbs () xN nonNormal xV)) @? "Normalization" - - , testCase "abs" $ isRight (checkNormal (TyAbs () aN (Type ()) xV)) @? "Normalization" - - , testCase "wrapNormal" $ - isRight (checkNormal (IWrap () normal normal xV)) @? "Normalization" - , testCase "wrapNonNormal" $ - isLeft (checkNormal (IWrap () nonNormal nonNormal xV)) @? "Normalization" - - , testCase "unwrap" $ isRight (checkNormal (Unwrap () xV)) @? "Normalization" - - , testCase "app" $ isRight (checkNormal (Apply () xV xV)) @? "Normalization" - - , testCase "errorNormal" $ isRight (checkNormal (Error () normal)) @? "Normalization" - , testCase "errorNonNormal" $ isLeft (checkNormal (Error () nonNormal)) @? "Normalization" - - , testCase "constant" $ isRight (checkNormal (mkConstant @Integer () 2)) @? "Normalization" - - , testCase "builtin" $ isRight (checkNormal (Builtin () AddInteger)) @? "Normalization" + aN <- freshTyName "a" + xN <- freshName "x" + let integer = mkTyBuiltin @_ @Integer () + aV = TyVar () aN + xV = Var () xN + normal = integer + nonNormal = TyApp () (TyLam () aN (Type ()) aV) normal + pure $ + testGroup + "normalized types check" + [ testCase "lamNormal" $ isRight (checkNormal (LamAbs () xN normal xV)) @? "Normalization" + , testCase "lamNonNormal" $ + isLeft (checkNormal (LamAbs () xN nonNormal xV)) @? "Normalization" + , testCase "abs" $ isRight (checkNormal (TyAbs () aN (Type ()) xV)) @? "Normalization" + , testCase "wrapNormal" $ + isRight (checkNormal (IWrap () normal normal xV)) @? "Normalization" + , testCase "wrapNonNormal" $ + isLeft (checkNormal (IWrap () nonNormal nonNormal xV)) @? "Normalization" + , testCase "unwrap" $ isRight (checkNormal (Unwrap () xV)) @? "Normalization" + , testCase "app" $ isRight (checkNormal (Apply () xV xV)) @? "Normalization" + , testCase "errorNormal" $ isRight (checkNormal (Error () normal)) @? "Normalization" + , testCase "errorNonNormal" $ isLeft (checkNormal (Error () nonNormal)) @? "Normalization" + , testCase "constant" $ isRight (checkNormal (mkConstant @Integer () 2)) @? "Normalization" + , testCase "builtin" $ isRight (checkNormal (Builtin () AddInteger)) @? "Normalization" ] - where - checkNormal :: Term TyName Name DefaultUni DefaultFun () - -> Either (Normal.NormCheckError TyName Name DefaultUni DefaultFun ()) () - checkNormal = Normal.checkTerm + where + checkNormal :: + Term TyName Name DefaultUni DefaultFun () -> + Either (Normal.NormCheckError TyName Name DefaultUni DefaultFun ()) () + checkNormal = Normal.checkTerm diff --git a/plutus-core/plutus-core/test/CostModelInterface/Spec.hs b/plutus-core/plutus-core/test/CostModelInterface/Spec.hs index 7f7e4b042a6..99949a28677 100644 --- a/plutus-core/plutus-core/test/CostModelInterface/Spec.hs +++ b/plutus-core/plutus-core/test/CostModelInterface/Spec.hs @@ -1,7 +1,8 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + module CostModelInterface.Spec (test_costModelInterface) where import PlutusCore.Evaluation.Machine.BuiltinCostModel @@ -23,9 +24,9 @@ import Instances.TH.Lift () import Language.Haskell.TH.Syntax qualified as TH import Prettyprinter import System.FilePath +import TH.RelativePaths import Test.Tasty import Test.Tasty.HUnit -import TH.RelativePaths {- Note [Testing the expected ledger cost model parameters] The ledger is going to call us with a particular 'CostModelParams'. This will be originally derived from the model @@ -36,7 +37,7 @@ that we provide, but there's opportunity for things to move out of sync: So it's sensible to have some regression tests. We can't just test against our own 'defaultCostModelParams', since in the case of error 2 that would -*also* change, so we instead need to have a checked-in version of the parameters. +\*also* change, so we instead need to have a checked-in version of the parameters. -} -- | A checked-in of the default cost model params, frozen by calling 'CostModelInterface.extractCostModelParams' @@ -49,21 +50,21 @@ type CekCostModel = CostModel CekMachineCosts BuiltinCostModel -- Just for testing randomCekCosts :: CekMachineCosts randomCekCosts = - CekMachineCostsBase - { cekStartupCost = pure $ ExBudget 2342 234321 - , cekVarCost = pure $ ExBudget 12312 56545 - , cekConstCost = pure $ ExBudget 23490290838 2323423 - , cekLamCost = pure $ ExBudget 0 712127381 - , cekDelayCost = pure $ ExBudget 999 7777 - , cekForceCost = pure $ ExBudget 1028234 0 - , cekApplyCost = pure $ ExBudget 324628348 8273 - , cekBuiltinCost = pure $ ExBudget 4 4 - , cekConstrCost = pure $ ExBudget 8 100000 - , cekCaseCost = pure $ ExBudget 3324234 555 - } + CekMachineCostsBase + { cekStartupCost = pure $ ExBudget 2342 234321 + , cekVarCost = pure $ ExBudget 12312 56545 + , cekConstCost = pure $ ExBudget 23490290838 2323423 + , cekLamCost = pure $ ExBudget 0 712127381 + , cekDelayCost = pure $ ExBudget 999 7777 + , cekForceCost = pure $ ExBudget 1028234 0 + , cekApplyCost = pure $ ExBudget 324628348 8273 + , cekBuiltinCost = pure $ ExBudget 4 4 + , cekConstrCost = pure $ ExBudget 8 100000 + , cekCaseCost = pure $ ExBudget 3324234 555 + } cekVarCostCpuKey :: Text.Text -cekVarCostCpuKey = "cekVarCost-exBudgetCPU" -- This is the result of flatten . toJSON +cekVarCostCpuKey = "cekVarCost-exBudgetCPU" -- This is the result of flatten . toJSON randomCekCostModel :: CekCostModel randomCekCostModel = CostModel randomCekCosts defaultBuiltinCostModelForTesting @@ -75,7 +76,7 @@ extractParams :: CekCostModel -> IO CostModelParams extractParams model = do case extractCostModelParams model of Nothing -> assertFailure "extractCostModelParams failed" - Just p -> pure p + Just p -> pure p -- | Extract some params from a cost model and return the updated version, failing if it doesn't work applyParams :: CekCostModel -> CostModelParams -> IO CekCostModel @@ -84,7 +85,7 @@ applyParams model params = fromRightM (assertFailure . show . pretty) $ applyCos -- | Just check that extraction works. testExtraction :: CekCostModel -> IO () testExtraction model = do - _extracted <- extractParams model -- We're not going to use this but it may still fail. + _extracted <- extractParams model -- We're not going to use this but it may still fail. pure () -- Update a model with its own parameters and check that we get the same model back @@ -110,118 +111,131 @@ testOverwrite model1 model2 = do -- Update a model with its own params with an extra entry. This is NOT OK. testSelfUpdateWithExtraEntry :: CekCostModel -> IO () testSelfUpdateWithExtraEntry model = - do - params <- extractParams model - let params' = Map.insert "XYZ" 123 params - mModel = applyCostModelParams model params' - assertBool "Superfluous costparam was not caught." $ isLeft mModel + do + params <- extractParams model + let params' = Map.insert "XYZ" 123 params + mModel = applyCostModelParams model params' + assertBool "Superfluous costparam was not caught." $ isLeft mModel -- Update a model with its own params with an entry deleted: this should -- be OK because the original member of the model will still be there. testSelfUpdateWithMissingEntry :: CekCostModel -> IO () testSelfUpdateWithMissingEntry model = - do - params <- extractParams model - assertBool (Text.unpack cekVarCostCpuKey ++ " not found in params") (Map.member cekVarCostCpuKey params) - let params' = Map.delete cekVarCostCpuKey params - model' <- applyParams model params' - model' @?= model + do + params <- extractParams model + assertBool (Text.unpack cekVarCostCpuKey ++ " not found in params") (Map.member cekVarCostCpuKey params) + let params' = Map.delete cekVarCostCpuKey params + model' <- applyParams model params' + model' @?= model -- Update a model with the params from another model with an entry -- deleted. The result should be different from both of the original models. testOtherUpdateWithMissingEntry :: CekCostModel -> CekCostModel -> IO () testOtherUpdateWithMissingEntry model1 model2 = - do - params2 <- extractParams model2 - assertBool (Text.unpack cekVarCostCpuKey ++ " not found in params") (Map.member cekVarCostCpuKey params2) - let params2' = Map.delete cekVarCostCpuKey params2 - assertBool (Text.unpack cekVarCostCpuKey ++ " still in params") (not (Map.member cekVarCostCpuKey params2')) - assertBool "params are the same" (params2 /= params2') - model1' <- applyParams model1 params2' - assertBool "The updated model is the same as the other model" (model1' /= model2) - assertBool "The updated model is the same as the original" (model1' /= model1) + do + params2 <- extractParams model2 + assertBool (Text.unpack cekVarCostCpuKey ++ " not found in params") (Map.member cekVarCostCpuKey params2) + let params2' = Map.delete cekVarCostCpuKey params2 + assertBool (Text.unpack cekVarCostCpuKey ++ " still in params") (not (Map.member cekVarCostCpuKey params2')) + assertBool "params are the same" (params2 /= params2') + model1' <- applyParams model1 params2' + assertBool "The updated model is the same as the other model" (model1' /= model2) + assertBool "The updated model is the same as the original" (model1' /= model1) -- Update a model with the params from another and then check that -- extraction returns the same params. -testExtractAfterUpdate :: CekCostModel -> CekCostModel -> IO () +testExtractAfterUpdate :: CekCostModel -> CekCostModel -> IO () testExtractAfterUpdate model1 model2 = - do - params <- extractParams model2 - updated <- applyParams model1 params - params' <- extractParams updated - params' @?= params + do + params <- extractParams model2 + updated <- applyParams model1 params + params' <- extractParams updated + params' @?= params -- | Test that we can deserialise the default ledger params testDeserialise :: IO () -testDeserialise = assertBool "Failed to decode default ledger cost params" $ - isJust $ decode @CostModelParams ledgerParamsBS +testDeserialise = + assertBool "Failed to decode default ledger cost params" $ + isJust $ + decode @CostModelParams ledgerParamsBS -- | Test that we can apply the ledger params to our cost model testApply :: IO () testApply = do - let decodedParams = fromJust $ decode @CostModelParams ledgerParamsBS - assertBool "Failed to load the ledger cost params into our cost model" $ - isRight $ applyCostModelParams defaultCekCostModelForTesting decodedParams + let decodedParams = fromJust $ decode @CostModelParams ledgerParamsBS + assertBool "Failed to load the ledger cost params into our cost model" $ + isRight $ + applyCostModelParams defaultCekCostModelForTesting decodedParams -- | Test to catch a mispelled/missing param. -- A parameter with that name exists in the ledger params but is missing from the cost model, and that is an error. testMispelled :: IO () testMispelled = do - let params = fromJust $ decode @CostModelParams ledgerParamsBS - (cekVarCostValueM, paramsReducted) = deleteLookup cekVarCostCpuKey params - paramsMispelled = Map.insert cekVarCostCpuKeyMispelled (fromJust cekVarCostValueM) paramsReducted - assertBool "Failed to catch mispelled cost param" $ - isLeft $ applyCostModelParams defaultCekCostModelForTesting paramsMispelled + let params = fromJust $ decode @CostModelParams ledgerParamsBS + (cekVarCostValueM, paramsReducted) = deleteLookup cekVarCostCpuKey params + paramsMispelled = Map.insert cekVarCostCpuKeyMispelled (fromJust cekVarCostValueM) paramsReducted + assertBool "Failed to catch mispelled cost param" $ + isLeft $ + applyCostModelParams defaultCekCostModelForTesting paramsMispelled where - cekVarCostCpuKeyMispelled = "cekVarCost--exBudgetCPU" - deleteLookup = Map.updateLookupWithKey (const $ const Nothing) + cekVarCostCpuKeyMispelled = "cekVarCost--exBudgetCPU" + deleteLookup = Map.updateLookupWithKey (const $ const Nothing) test_costModelInterface :: TestTree test_costModelInterface = - testGroup "cost model interface tests" - [ testGroup "extractCostModelParams works" - [ testCase "defaultCekCostModel" $ testExtraction defaultCekCostModelForTesting - , testCase "randomCekCostModel" $ testExtraction randomCekCostModel - ] - , testGroup "self-update is identity" - [ testCase "defaultCekCostModel <- defaultCekCostModel" $ testSelfUpdate defaultCekCostModelForTesting - , testCase "randomCekCostModel <- randomCekCostModel" $ testSelfUpdate randomCekCostModel - ] - , testGroup "update-empty is identity" - [ testCase "defaultCekCostModel <- defaultCekCostModel" $ testUpdateEmpty defaultCekCostModelForTesting - , testCase "randomCekCostModel <- randomCekCostModel" $ testUpdateEmpty randomCekCostModel - ] - , testGroup "overwriting works" - [ testCase "defaultCekCostModel <- randomCekCostModel" $ testOverwrite defaultCekCostModelForTesting randomCekCostModel - , testCase "randomCekCostModel <- defaultCekCostModel" $ testOverwrite randomCekCostModel defaultCekCostModelForTesting - ] - , testGroup "superfluous entry in params is NOT OK in self-update" - [ testCase "defaultCekCostModel" $ testSelfUpdateWithExtraEntry defaultCekCostModelForTesting - , testCase "randomCekCostModel" $ testSelfUpdateWithExtraEntry randomCekCostModel - ] - , testGroup "missing entry in params is OK in self-update" - [ testCase "defaultCekCostModel" $ testSelfUpdateWithMissingEntry defaultCekCostModelForTesting - , testCase "randomCekCostModel" $ testSelfUpdateWithMissingEntry randomCekCostModel - ] - , testGroup "missing entry in update of different model" - [ testCase "defaultCekCostModel" $ testOtherUpdateWithMissingEntry defaultCekCostModelForTesting randomCekCostModel - , testCase "randomCekCostModel" $ testOtherUpdateWithMissingEntry randomCekCostModel defaultCekCostModelForTesting - ] - , testGroup "extract after apply is identity" - [ testCase "defaultCekCostModel <- defaultCekCostModel" $ - testExtractAfterUpdate defaultCekCostModelForTesting defaultCekCostModelForTesting - , testCase "randomCekCostModel <- randomCekCostModel" $ - testExtractAfterUpdate randomCekCostModel randomCekCostModel - , testCase "randomCekCostModel <- defaultCekCostModel" $ - testExtractAfterUpdate randomCekCostModel defaultCekCostModelForTesting - , testCase "defaultCekCostModel <- randomCekCostModel" $ - testExtractAfterUpdate defaultCekCostModelForTesting randomCekCostModel - ] - , testGroup "default ledger params" - [ testCase "default ledger params deserialize" testDeserialise - -- TODO: do something here for each version of the cost model? - , testCase "default ledger params can be applied to default cost model" testApply - , testCase "mispelled param in ledger params " testMispelled - ] - ] - + testGroup + "cost model interface tests" + [ testGroup + "extractCostModelParams works" + [ testCase "defaultCekCostModel" $ testExtraction defaultCekCostModelForTesting + , testCase "randomCekCostModel" $ testExtraction randomCekCostModel + ] + , testGroup + "self-update is identity" + [ testCase "defaultCekCostModel <- defaultCekCostModel" $ testSelfUpdate defaultCekCostModelForTesting + , testCase "randomCekCostModel <- randomCekCostModel" $ testSelfUpdate randomCekCostModel + ] + , testGroup + "update-empty is identity" + [ testCase "defaultCekCostModel <- defaultCekCostModel" $ testUpdateEmpty defaultCekCostModelForTesting + , testCase "randomCekCostModel <- randomCekCostModel" $ testUpdateEmpty randomCekCostModel + ] + , testGroup + "overwriting works" + [ testCase "defaultCekCostModel <- randomCekCostModel" $ testOverwrite defaultCekCostModelForTesting randomCekCostModel + , testCase "randomCekCostModel <- defaultCekCostModel" $ testOverwrite randomCekCostModel defaultCekCostModelForTesting + ] + , testGroup + "superfluous entry in params is NOT OK in self-update" + [ testCase "defaultCekCostModel" $ testSelfUpdateWithExtraEntry defaultCekCostModelForTesting + , testCase "randomCekCostModel" $ testSelfUpdateWithExtraEntry randomCekCostModel + ] + , testGroup + "missing entry in params is OK in self-update" + [ testCase "defaultCekCostModel" $ testSelfUpdateWithMissingEntry defaultCekCostModelForTesting + , testCase "randomCekCostModel" $ testSelfUpdateWithMissingEntry randomCekCostModel + ] + , testGroup + "missing entry in update of different model" + [ testCase "defaultCekCostModel" $ testOtherUpdateWithMissingEntry defaultCekCostModelForTesting randomCekCostModel + , testCase "randomCekCostModel" $ testOtherUpdateWithMissingEntry randomCekCostModel defaultCekCostModelForTesting + ] + , testGroup + "extract after apply is identity" + [ testCase "defaultCekCostModel <- defaultCekCostModel" $ + testExtractAfterUpdate defaultCekCostModelForTesting defaultCekCostModelForTesting + , testCase "randomCekCostModel <- randomCekCostModel" $ + testExtractAfterUpdate randomCekCostModel randomCekCostModel + , testCase "randomCekCostModel <- defaultCekCostModel" $ + testExtractAfterUpdate randomCekCostModel defaultCekCostModelForTesting + , testCase "defaultCekCostModel <- randomCekCostModel" $ + testExtractAfterUpdate defaultCekCostModelForTesting randomCekCostModel + ] + , testGroup + "default ledger params" + [ testCase "default ledger params deserialize" testDeserialise + , -- TODO: do something here for each version of the cost model? + testCase "default ledger params can be applied to default cost model" testApply + , testCase "mispelled param in ledger params " testMispelled + ] + ] diff --git a/plutus-core/plutus-core/test/CostModelSafety/Spec.hs b/plutus-core/plutus-core/test/CostModelSafety/Spec.hs index 59600bc1cb6..57f3774e435 100644 --- a/plutus-core/plutus-core/test/CostModelSafety/Spec.hs +++ b/plutus-core/plutus-core/test/CostModelSafety/Spec.hs @@ -1,27 +1,26 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{- | Tests to make sure that all of the CEK costs are positive and that no -builtins have a costing function which is identically zero. During the -implementation of a new builtin it may be necessary to add a temporary costing -function. It's tempting to make such a function return 0 for all inputs, but -this might allow the builtin to be used for free on a testnet (for example) -which might be confusing. We try to encourage the use of a default costing -function which is maximally expensive, but the implementer might miss that. -It's still possible to provide a costing function which is unrealistically -cheap, but it would be difficult to spot that automatically. Here we check that -the costing functions for each builtin are nonzero at a single point, and we do -this by running the function with a list of small arguments. For CPU costs we -actually check that the cost is at least 1000 ExCPU and for memory costs we -check that the cost is strictly positive. -} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | Tests to make sure that all of the CEK costs are positive and that no +-- builtins have a costing function which is identically zero. During the +-- implementation of a new builtin it may be necessary to add a temporary costing +-- function. It's tempting to make such a function return 0 for all inputs, but +-- this might allow the builtin to be used for free on a testnet (for example) +-- which might be confusing. We try to encourage the use of a default costing +-- function which is maximally expensive, but the implementer might miss that. +-- It's still possible to provide a costing function which is unrealistically +-- cheap, but it would be difficult to spot that automatically. Here we check that +-- the costing functions for each builtin are nonzero at a single point, and we do +-- this by running the function with a list of small arguments. For CPU costs we +-- actually check that the cost is at least 1000 ExCPU and for memory costs we +-- check that the cost is strictly positive. module CostModelSafety.Spec (test_costModelSafety) where @@ -35,15 +34,19 @@ import PlutusCore.Data (Data (..)) import PlutusCore.Default.Builtins import PlutusCore.Evaluation.Machine.BuiltinCostModel (BuiltinCostModel) import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (ExBudget)) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (cekCostModelForVariant) import PlutusCore.Evaluation.Machine.ExBudgetStream (sumExBudgetStream) -import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally, - NumBytesCostedAsNumWords) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (cekCostModelForVariant) +import PlutusCore.Evaluation.Machine.ExMemoryUsage ( + IntegerCostedLiterally, + NumBytesCostedAsNumWords, + ) import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..)) import PlutusCore.Value (Value) import PlutusCore.Value qualified as Value -import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts, - CekMachineCostsBase (..)) +import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts ( + CekMachineCosts, + CekMachineCostsBase (..), + ) import Data.ByteString qualified as BS import Data.Functor.Identity (Identity (..)) @@ -56,10 +59,10 @@ import Data.Word (Word8) import GHC.Natural import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, testCase) -import Type.Reflection (TypeRep, eqTypeRep, pattern App, typeRep, (:~~:) (..)) +import Type.Reflection (TypeRep, eqTypeRep, typeRep, (:~~:) (..), pattern App) -- Machine costs -checkBudget :: Identity ExBudget -> Assertion +checkBudget :: Identity ExBudget -> Assertion checkBudget (Identity (ExBudget cpu mem)) = do assertBool "exBudgetCPU <= 0 in CEK machine costs" $ cpu > 0 assertBool "exBudgetMemory <= 0 in CEK machine costs" $ mem > 0 @@ -67,19 +70,19 @@ checkBudget (Identity (ExBudget cpu mem)) = do -- Check that the machine costs are all strictly positive. All of the fields are matched explicitly -- to make sure that we don't forget any new ones that get added. testMachineCostModel :: CekMachineCosts -> Assertion -testMachineCostModel ( - CekMachineCostsBase - cekStartupBudget - cekVarBudget - cekConstBudget - cekLamBudget - cekDelayBudget - cekForceBudget - cekApplyBudget - cekBuiltinBudget - cekConstrBudget - cekCaseBudget - ) = do +testMachineCostModel + ( CekMachineCostsBase + cekStartupBudget + cekVarBudget + cekConstBudget + cekLamBudget + cekDelayBudget + cekForceBudget + cekApplyBudget + cekBuiltinBudget + cekConstrBudget + cekCaseBudget + ) = do checkBudget cekStartupBudget checkBudget cekVarBudget checkBudget cekConstBudget @@ -111,93 +114,97 @@ data SomeConst uni = forall a. uni `HasTermLevel` a => SomeConst a smallConstant :: forall (a :: GHC.Type). TypeRep a -> SomeConst DefaultUni smallConstant tr - | Just HRefl <- eqTypeRep tr (typeRep @()) = SomeConst () - | Just HRefl <- eqTypeRep tr (typeRep @Integer) = SomeConst (0 :: Integer) - | Just HRefl <- eqTypeRep tr (typeRep @Natural) = SomeConst (0 :: Integer) - | Just HRefl <- eqTypeRep tr (typeRep @Int) = SomeConst (0 :: Integer) - | Just HRefl <- eqTypeRep tr (typeRep @Word8) = SomeConst (0 :: Integer) - | Just HRefl <- eqTypeRep tr (typeRep @NumBytesCostedAsNumWords) = SomeConst (0 :: Integer) - | Just HRefl <- eqTypeRep tr (typeRep @IntegerCostedLiterally) = SomeConst (0 :: Integer) - | Just HRefl <- eqTypeRep tr (typeRep @Bool) = SomeConst False - | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = SomeConst $ BS.pack [] - | Just HRefl <- eqTypeRep tr (typeRep @Text) = SomeConst ("" :: Text) - | Just HRefl <- eqTypeRep tr (typeRep @Data) = SomeConst $ I 0 - | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G1.Element) = - SomeConst $ BLS12_381.G1.offchain_zero - | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G2.Element) = - SomeConst $ BLS12_381.G2.offchain_zero - | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.Pairing.MlResult) = - SomeConst $ BLS12_381.Pairing.millerLoop - BLS12_381.G1.offchain_zero BLS12_381.G2.offchain_zero - | Just HRefl <- eqTypeRep tr (typeRep @Value) = SomeConst $ Value.empty - | trPair `App` tr1 `App` tr2 <- tr - , Just HRefl <- eqTypeRep trPair (typeRep @(,)) = - case (smallConstant tr1, smallConstant tr2) of - (SomeConst c1, SomeConst c2) -> SomeConst (c1, c2) - | trList `App` trElem <- tr - , Just HRefl <- eqTypeRep trList (typeRep @[]) = - case smallConstant trElem of - SomeConst c -> SomeConst ([] `asTypeOf` [c]) - | trArray `App` trElem <- tr - , Just HRefl <- eqTypeRep trArray (typeRep @Vector) = - case smallConstant trElem of - SomeConst c -> SomeConst (Vector.fromList ([] `asTypeOf` [c])) - | trSomeConstant `App` _ `App` trEl <- tr - , Just HRefl <- eqTypeRep trSomeConstant (typeRep @SomeConstant) = - smallConstant trEl - | trLastArg `App` _ `App` trY <- tr - , Just HRefl <- eqTypeRep trLastArg (typeRep @LastArg) = - smallConstant trY - | trTyVarRep `App` _ <- tr - , Just HRefl <- eqTypeRep trTyVarRep (typeRep @(TyVarRep @GHC.Type)) = - -- In the current implementation, all type variables are instantiated - -- to `Integer` (TODO: change this?). - smallConstant $ typeRep @Integer - | otherwise = error $ + | Just HRefl <- eqTypeRep tr (typeRep @()) = SomeConst () + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = SomeConst (0 :: Integer) + | Just HRefl <- eqTypeRep tr (typeRep @Natural) = SomeConst (0 :: Integer) + | Just HRefl <- eqTypeRep tr (typeRep @Int) = SomeConst (0 :: Integer) + | Just HRefl <- eqTypeRep tr (typeRep @Word8) = SomeConst (0 :: Integer) + | Just HRefl <- eqTypeRep tr (typeRep @NumBytesCostedAsNumWords) = SomeConst (0 :: Integer) + | Just HRefl <- eqTypeRep tr (typeRep @IntegerCostedLiterally) = SomeConst (0 :: Integer) + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = SomeConst False + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = SomeConst $ BS.pack [] + | Just HRefl <- eqTypeRep tr (typeRep @Text) = SomeConst ("" :: Text) + | Just HRefl <- eqTypeRep tr (typeRep @Data) = SomeConst $ I 0 + | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G1.Element) = + SomeConst $ BLS12_381.G1.offchain_zero + | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G2.Element) = + SomeConst $ BLS12_381.G2.offchain_zero + | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.Pairing.MlResult) = + SomeConst $ + BLS12_381.Pairing.millerLoop + BLS12_381.G1.offchain_zero + BLS12_381.G2.offchain_zero + | Just HRefl <- eqTypeRep tr (typeRep @Value) = SomeConst $ Value.empty + | trPair `App` tr1 `App` tr2 <- tr + , Just HRefl <- eqTypeRep trPair (typeRep @(,)) = + case (smallConstant tr1, smallConstant tr2) of + (SomeConst c1, SomeConst c2) -> SomeConst (c1, c2) + | trList `App` trElem <- tr + , Just HRefl <- eqTypeRep trList (typeRep @[]) = + case smallConstant trElem of + SomeConst c -> SomeConst ([] `asTypeOf` [c]) + | trArray `App` trElem <- tr + , Just HRefl <- eqTypeRep trArray (typeRep @Vector) = + case smallConstant trElem of + SomeConst c -> SomeConst (Vector.fromList ([] `asTypeOf` [c])) + | trSomeConstant `App` _ `App` trEl <- tr + , Just HRefl <- eqTypeRep trSomeConstant (typeRep @SomeConstant) = + smallConstant trEl + | trLastArg `App` _ `App` trY <- tr + , Just HRefl <- eqTypeRep trLastArg (typeRep @LastArg) = + smallConstant trY + | trTyVarRep `App` _ <- tr + , Just HRefl <- eqTypeRep trTyVarRep (typeRep @(TyVarRep @GHC.Type)) = + -- In the current implementation, all type variables are instantiated + -- to `Integer` (TODO: change this?). + smallConstant $ typeRep @Integer + | otherwise = + error $ "smallConstant: I don't know how to generate constants of type " <> show tr -- | Return a trivial constant or an n-ary function returning a trivial constant, depending on the -- given 'TypeRep'. smallTerm :: - forall (a :: GHC.Type). - KnownTypeAst PLC.TyName DefaultUni a => - TypeRep a -> - PLC.Term PLC.TyName PLC.Name DefaultUni PLC.DefaultFun () -smallTerm tr0 = go (toTypeAst tr0) tr0 where + forall (a :: GHC.Type). + KnownTypeAst PLC.TyName DefaultUni a => + TypeRep a -> + PLC.Term PLC.TyName PLC.Name DefaultUni PLC.DefaultFun () +smallTerm tr0 = go (toTypeAst tr0) tr0 + where go :: - forall (b :: GHC.Type) fun. - PLC.Type PLC.TyName DefaultUni () -> - TypeRep b -> - PLC.Term PLC.TyName PLC.Name DefaultUni fun () + forall (b :: GHC.Type) fun. + PLC.Type PLC.TyName DefaultUni () -> + TypeRep b -> + PLC.Term PLC.TyName PLC.Name DefaultUni fun () go sch tr - | trOpaque `App` _ `App` trEl <- tr - , Just HRefl <- eqTypeRep trOpaque (typeRep @Opaque) = - go sch trEl + | trOpaque `App` _ `App` trEl <- tr + , Just HRefl <- eqTypeRep trOpaque (typeRep @Opaque) = + go sch trEl go (PLC.TyFun _ dom cod) tr - | trFun `App` _ `App` trCod <- tr - , Just HRefl <- eqTypeRep trFun (typeRep @(->)) = - PLC.LamAbs () (PLC.Name "_" (PLC.Unique 0)) dom $ go cod trCod + | trFun `App` _ `App` trCod <- tr + , Just HRefl <- eqTypeRep trFun (typeRep @(->)) = + PLC.LamAbs () (PLC.Name "_" (PLC.Unique 0)) dom $ go cod trCod go _ tr = case smallConstant tr of - SomeConst x -> PLC.Constant () (PLC.someValue x) + SomeConst x -> PLC.Constant () (PLC.someValue x) type Term = PLC.Term PLC.TyName PLC.Name DefaultUni DefaultFun () type family Head a where - Head (x ': xs) = x + Head (x ': xs) = x -- | Generate value arguments to a builtin function based on its `TypeScheme`. -genArgs - :: BuiltinSemanticsVariant DefaultFun - -> DefaultFun - -> [Term] +genArgs :: + BuiltinSemanticsVariant DefaultFun -> + DefaultFun -> + [Term] genArgs semvar bn = case meaning of - BuiltinMeaning tySch _ _ -> go tySch - where - go :: forall args res. TypeScheme Term args res -> [Term] - go = \case - TypeSchemeResult -> [] - TypeSchemeArrow sch -> smallTerm (typeRep @(Head args)) : go sch - TypeSchemeAll _ sch -> go sch + BuiltinMeaning tySch _ _ -> go tySch + where + go :: forall args res. TypeScheme Term args res -> [Term] + go = \case + TypeSchemeResult -> [] + TypeSchemeArrow sch -> smallTerm (typeRep @(Head args)) : go sch + TypeSchemeAll _ sch -> go sch where meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning semvar bn @@ -207,11 +214,11 @@ genArgs semvar bn = case meaning of -- function 10-2*size we'll only test it on for a small value of size (0 or 1) -- so we won't spot that it can give you a negative result. We do want to check -- small sizes, but we should also check larger ones. -testCosts - :: BuiltinSemanticsVariant DefaultFun - -> BuiltinsRuntime DefaultFun Term - -> DefaultFun - -> TestTree +testCosts :: + BuiltinSemanticsVariant DefaultFun -> + BuiltinsRuntime DefaultFun Term -> + DefaultFun -> + TestTree testCosts semvar runtimes bn = let args0 = genArgs semvar bn runtime0 = lookupBuiltin bn runtimes @@ -226,28 +233,30 @@ testCosts semvar runtimes bn = error $ "Wrong number of args for builtin " <> show bn <> ": " <> show args0 ExBudget cpuUsage memUsage = eval args0 runtime0 - in testCase (show bn) $ do - -- Every builtin is expected to have a CPU cost of at least 1000 ExCPU (~ 1 - -- ns). There's code in models.R which is supposed to ensure this. - assertBool ("CPU cost < 1000 in " ++ show bn) $ cpuUsage >= 1000 - -- Some memory usage functions return 0 for inputs of size zero, but this - -- should be OK since there should never be any inputs of size zero. - assertBool ("Memory usage <= 0 in " ++ show bn) $ memUsage > 0 + in testCase (show bn) $ do + -- Every builtin is expected to have a CPU cost of at least 1000 ExCPU (~ 1 + -- ns). There's code in models.R which is supposed to ensure this. + assertBool ("CPU cost < 1000 in " ++ show bn) $ cpuUsage >= 1000 + -- Some memory usage functions return 0 for inputs of size zero, but this + -- should be OK since there should never be any inputs of size zero. + assertBool ("Memory usage <= 0 in " ++ show bn) $ memUsage > 0 testBuiltinCostModel :: BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel -> [TestTree] testBuiltinCostModel semvar model = {- The next line is where toBuiltinsRuntime might ignore what's in the model and supply its own costing function (see the comment at the top of the file). -} let runtimes = toBuiltinsRuntime semvar model - in map (testCosts semvar runtimes) (enumerate @DefaultFun) + in map (testCosts semvar runtimes) (enumerate @DefaultFun) test_costModelSafety :: TestTree test_costModelSafety = let mkTest semvar = let CostModel machineCosts builtinCosts = cekCostModelForVariant semvar - in testGroup ("Cost model for " ++ show semvar) - [ testCase "Machine costs" $ testMachineCostModel machineCosts - , testGroup "Builtin costs" $ testBuiltinCostModel semvar builtinCosts - ] - in testGroup "Cost model safety test" $ - map mkTest $ enumerate @(BuiltinSemanticsVariant DefaultFun) + in testGroup + ("Cost model for " ++ show semvar) + [ testCase "Machine costs" $ testMachineCostModel machineCosts + , testGroup "Builtin costs" $ testBuiltinCostModel semvar builtinCosts + ] + in testGroup "Cost model safety test" $ + map mkTest $ + enumerate @(BuiltinSemanticsVariant DefaultFun) diff --git a/plutus-core/plutus-core/test/Evaluation/Machines.hs b/plutus-core/plutus-core/test/Evaluation/Machines.hs index ee578452b10..28e282c8b7a 100644 --- a/plutus-core/plutus-core/test/Evaluation/Machines.hs +++ b/plutus-core/plutus-core/test/Evaluation/Machines.hs @@ -1,10 +1,10 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Evaluation.Machines - ( test_machines - ) +module Evaluation.Machines ( + test_machines, +) where import GHC.Exts (fromString) @@ -21,22 +21,24 @@ import Data.Default.Class (def) import Test.Tasty import Test.Tasty.Hedgehog -testMachine - :: (uni ~ DefaultUni, fun ~ DefaultFun, PrettyPlc structural) - => String - -> (Term TyName Name uni fun () -> - Either - (EvaluationException structural operational (Term TyName Name uni fun ())) - (Term TyName Name uni fun ())) - -> TestTree +testMachine :: + (uni ~ DefaultUni, fun ~ DefaultFun, PrettyPlc structural) => + String -> + ( Term TyName Name uni fun () -> + Either + (EvaluationException structural operational (Term TyName Name uni fun ())) + (Term TyName Name uni fun ()) + ) -> + TestTree testMachine machine eval = - testGroup machine $ fromInterestingTermGens $ \name -> - testPropertyNamed name (fromString name) - . mapTestLimitAtLeast 50 (`div` 10) - . propEvaluate eval + testGroup machine $ fromInterestingTermGens $ \name -> + testPropertyNamed name (fromString name) + . mapTestLimitAtLeast 50 (`div` 10) + . propEvaluate eval test_machines :: TestTree -test_machines = testGroup +test_machines = + testGroup "machines" [ testMachine "CK" $ evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def ] diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index e2b83d5a57c..baf72fb3f90 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -1,22 +1,22 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Evaluation.Spec (test_evaluation) where import PlutusCore hiding (Term) import PlutusCore qualified as PLC import PlutusCore.Builtin as PLC -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults import PlutusCore.Evaluation.Machine.ExBudgetStream (ExBudgetStream (..)) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults import PlutusCore.Generators.Hedgehog (GenArbitraryTerm (..), GenTypedTerm (..), forAllNoShow) import PlutusCore.Pretty import PlutusCore.Test @@ -36,161 +36,161 @@ import Type.Reflection type Term uni fun = PLC.Term TyName Name uni fun () -{- | Evaluating a builtin function should never throw any exception (the evaluation is allowed - to fail with a `BuiltinError`, of course). - - The test covers both succeeding and failing evaluations and verifies that in either case - no exception is thrown. The failing cases use arbitrary `Term` arguments (which doesn't - guarantee failure, but most likely), and the succeeding cases generate `Term` arguments - based on a builtin function's `TypeScheme`. For `Opaque` arguments it generates arbitrary - `Term`s (which technically doesn't guarantee evaluation success, although it is the case - with all current builtin functions). --} +-- | Evaluating a builtin function should never throw any exception (the evaluation is allowed +-- to fail with a `BuiltinError`, of course). +-- +-- The test covers both succeeding and failing evaluations and verifies that in either case +-- no exception is thrown. The failing cases use arbitrary `Term` arguments (which doesn't +-- guarantee failure, but most likely), and the succeeding cases generate `Term` arguments +-- based on a builtin function's `TypeScheme`. For `Opaque` arguments it generates arbitrary +-- `Term`s (which technically doesn't guarantee evaluation success, although it is the case +-- with all current builtin functions). test_builtinsDon'tThrow :: TestTree test_builtinsDon'tThrow = - testGroup "Builtins don't throw" $ - enumerate @(BuiltinSemanticsVariant DefaultFun) <&> \semvar -> - testGroup (fromString . render $ "Version: " <> pretty semvar) $ - let runtimes = toBuiltinsRuntime semvar defaultBuiltinCostModelForTesting - in enumerate @DefaultFun <&> \fun -> - -- Perhaps using @maxBound@ (with @Enum@, @Bounded@) is indeed better than - -- @Default@ for BuiltinSemanticsVariants - testPropertyNamed - (display fun) - (fromString $ display fun) - (mapTestLimitAtLeast 99 (`div` 50) $ - prop_builtinEvaluation runtimes fun gen f) + testGroup "Builtins don't throw" $ + enumerate @(BuiltinSemanticsVariant DefaultFun) <&> \semvar -> + testGroup (fromString . render $ "Version: " <> pretty semvar) $ + let runtimes = toBuiltinsRuntime semvar defaultBuiltinCostModelForTesting + in enumerate @DefaultFun <&> \fun -> + -- Perhaps using @maxBound@ (with @Enum@, @Bounded@) is indeed better than + -- @Default@ for BuiltinSemanticsVariants + testPropertyNamed + (display fun) + (fromString $ display fun) + ( mapTestLimitAtLeast 99 (`div` 50) $ + prop_builtinEvaluation runtimes fun gen f + ) where gen bn = Gen.choice [genArgsWellTyped def bn, genArgsArbitrary def bn] f bn args = \case - Left e -> do - annotate "Builtin function evaluation failed" - annotate $ "Function: " <> display bn - annotate $ "Arguments: " <> display args - annotate $ "Error " <> show e - failure - Right _ -> success + Left e -> do + annotate "Builtin function evaluation failed" + annotate $ "Function: " <> display bn + annotate $ "Arguments: " <> display args + annotate $ "Error " <> show e + failure + Right _ -> success data AlwaysThrows - = -- | A builtin function whose denotation always throws an exception. - AlwaysThrows - deriving stock (Eq, Ord, Show, Bounded, Enum, Ix) + = -- | A builtin function whose denotation always throws an exception. + AlwaysThrows + deriving stock (Eq, Ord, Show, Bounded, Enum, Ix) instance Pretty AlwaysThrows where - pretty = pretty . show + pretty = pretty . show instance uni ~ DefaultUni => ToBuiltinMeaning uni AlwaysThrows where - type CostingPart uni AlwaysThrows = () - data BuiltinSemanticsVariant AlwaysThrows = AlwaysThrowsSemanticsVariantX + type CostingPart uni AlwaysThrows = () + data BuiltinSemanticsVariant AlwaysThrows = AlwaysThrowsSemanticsVariantX - toBuiltinMeaning _semvar AlwaysThrows = makeBuiltinMeaning f $ \_ _ -> ExBudgetLast mempty - where - f :: Integer -> Integer - f _ = error "This builtin function always throws an exception." + toBuiltinMeaning _semvar AlwaysThrows = makeBuiltinMeaning f $ \_ _ -> ExBudgetLast mempty + where + f :: Integer -> Integer + f _ = error "This builtin function always throws an exception." instance Default (BuiltinSemanticsVariant AlwaysThrows) where - def = AlwaysThrowsSemanticsVariantX + def = AlwaysThrowsSemanticsVariantX -{- | This test verifies that if evaluating a builtin function actually throws an exception, - we'd get a `Left` value, which would cause `test_builtinsDon'tThrow` to fail. --} +-- | This test verifies that if evaluating a builtin function actually throws an exception, +-- we'd get a `Left` value, which would cause `test_builtinsDon'tThrow` to fail. test_alwaysThrows :: TestTree test_alwaysThrows = - testGroup - "Builtins throwing exceptions should cause tests to fail" - [ testPropertyNamed (display AlwaysThrows) (fromString . display $ AlwaysThrows) $ - prop_builtinEvaluation @_ @AlwaysThrows runtimes AlwaysThrows (genArgsWellTyped semvar) f - ] + testGroup + "Builtins throwing exceptions should cause tests to fail" + [ testPropertyNamed (display AlwaysThrows) (fromString . display $ AlwaysThrows) $ + prop_builtinEvaluation @_ @AlwaysThrows runtimes AlwaysThrows (genArgsWellTyped semvar) f + ] where semvar = AlwaysThrowsSemanticsVariantX runtimes = toBuiltinsRuntime semvar () f bn args = \case - Left _ -> success - Right _ -> do - annotate "Expect builtin function evaluation to throw exceptions, but it didn't" - annotate $ "Function: " <> display bn - annotate $ "Arguments: " <> display args - failure + Left _ -> success + Right _ -> do + annotate "Expect builtin function evaluation to throw exceptions, but it didn't" + annotate $ "Function: " <> display bn + annotate $ "Arguments: " <> display args + failure prop_builtinEvaluation :: - forall uni fun. - (PrettyUni uni, Pretty fun) => - BuiltinsRuntime fun (Term uni fun) -> - fun -> - -- | A function making a generator for @fun@'s arguments. - (fun -> Gen [Term uni fun]) -> - -- | A function that takes a builtin function, a list of arguments, and the evaluation - -- outcome, and decides whether to pass or fail the property. - (fun -> - [Term uni fun] -> - Either SomeException (BuiltinResult (Term uni fun)) -> - PropertyT IO ()) -> - Property + forall uni fun. + (PrettyUni uni, Pretty fun) => + BuiltinsRuntime fun (Term uni fun) -> + fun -> + -- | A function making a generator for @fun@'s arguments. + (fun -> Gen [Term uni fun]) -> + -- | A function that takes a builtin function, a list of arguments, and the evaluation + -- outcome, and decides whether to pass or fail the property. + ( fun -> + [Term uni fun] -> + Either SomeException (BuiltinResult (Term uni fun)) -> + PropertyT IO () + ) -> + Property prop_builtinEvaluation runtimes bn mkGen f = property $ do - args0 <- forAllNoShow $ mkGen bn - let - eval :: - [Term uni fun] -> - BuiltinRuntime (Term uni fun) -> - BuiltinResult (Term uni fun) - eval [] (BuiltinCostedResult _ y) = - y - eval (arg : args) (BuiltinExpectArgument toRuntime) = - eval args (toRuntime arg) - eval args (BuiltinExpectForce runtime) = - eval args runtime - eval _ _ = - -- TODO: can we make this function run in @GenT BuiltinResult@ and generate arguments - -- on the fly to avoid this error case? - error $ "Wrong number of args for builtin " <> display bn <> ": " <> display args0 - runtime0 = lookupBuiltin bn runtimes - f bn args0 =<< liftIO (try @SomeException . evaluate $ eval args0 runtime0) + args0 <- forAllNoShow $ mkGen bn + let + eval :: + [Term uni fun] -> + BuiltinRuntime (Term uni fun) -> + BuiltinResult (Term uni fun) + eval [] (BuiltinCostedResult _ y) = + y + eval (arg : args) (BuiltinExpectArgument toRuntime) = + eval args (toRuntime arg) + eval args (BuiltinExpectForce runtime) = + eval args runtime + eval _ _ = + -- TODO: can we make this function run in @GenT BuiltinResult@ and generate arguments + -- on the fly to avoid this error case? + error $ "Wrong number of args for builtin " <> display bn <> ": " <> display args0 + runtime0 = lookupBuiltin bn runtimes + f bn args0 =<< liftIO (try @SomeException . evaluate $ eval args0 runtime0) genArgsWellTyped :: - forall uni fun. - (GenTypedTerm uni, ToBuiltinMeaning uni fun) - => PLC.BuiltinSemanticsVariant fun - -> fun - -> Gen [Term uni fun] + forall uni fun. + (GenTypedTerm uni, ToBuiltinMeaning uni fun) => + PLC.BuiltinSemanticsVariant fun -> + fun -> + Gen [Term uni fun] genArgsWellTyped semvar = genArgs semvar genTypedTerm -- | Generate arbitrary (most likely ill-typed) Term arguments to a builtin function. genArgsArbitrary :: - forall uni fun. - (GenArbitraryTerm uni, ToBuiltinMeaning uni fun) - => PLC.BuiltinSemanticsVariant fun - -> fun -> - Gen [Term uni fun] + forall uni fun. + (GenArbitraryTerm uni, ToBuiltinMeaning uni fun) => + PLC.BuiltinSemanticsVariant fun -> + fun -> + Gen [Term uni fun] genArgsArbitrary semvar = genArgs semvar (\_ -> genArbitraryTerm @uni) -- | Generate value arguments to a builtin function based on its `TypeScheme`. genArgs :: - forall uni fun. - ToBuiltinMeaning uni fun - => PLC.BuiltinSemanticsVariant fun - -> (forall (a :: GHC.Type). KnownTypeAst TyName uni a => TypeRep a -> Gen (Term uni fun)) - -> fun - -> Gen [Term uni fun] + forall uni fun. + ToBuiltinMeaning uni fun => + PLC.BuiltinSemanticsVariant fun -> + (forall (a :: GHC.Type). KnownTypeAst TyName uni a => TypeRep a -> Gen (Term uni fun)) -> + fun -> + Gen [Term uni fun] genArgs semvar genArg bn = sequenceA $ case meaning of - BuiltinMeaning tySch _ _ -> go tySch - where - go :: forall args res. TypeScheme (Term uni fun) args res -> [Gen (Term uni fun)] - go = \case - TypeSchemeResult -> [] - TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch - TypeSchemeAll _ sch -> go sch + BuiltinMeaning tySch _ _ -> go tySch + where + go :: forall args res. TypeScheme (Term uni fun) args res -> [Gen (Term uni fun)] + go = \case + TypeSchemeResult -> [] + TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch + TypeSchemeAll _ sch -> go sch where meaning :: BuiltinMeaning (Term uni fun) (CostingPart uni fun) meaning = toBuiltinMeaning semvar bn type family Head a where - Head (x ': xs) = x + Head (x ': xs) = x test_evaluation :: TestTree test_evaluation = - testGroup - "evaluation" - [ test_machines - , test_builtinsDon'tThrow - , test_alwaysThrows - ] + testGroup + "evaluation" + [ test_machines + , test_builtinsDon'tThrow + , test_alwaysThrows + ] diff --git a/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs b/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs index 95d50209ec2..8122c95f482 100644 --- a/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs +++ b/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs @@ -15,61 +15,67 @@ import Test.Tasty.QuickCheck -- back the input. test_multiSplitSound :: TestTree test_multiSplitSound = - testGroup "soundness" $ do - (name, split) <- - [ ("multiSplit1", coerce $ multiSplit1 @Int) - , ("multiSplit0", multiSplit0 0.1) - ] - pure . testProperty name $ \(xs :: [Int]) -> - withMaxSuccess 10000 . forAll (split xs) $ \aSplit -> - xs === concat aSplit + testGroup "soundness" $ do + (name, split) <- + [ ("multiSplit1", coerce $ multiSplit1 @Int) + , ("multiSplit0", multiSplit0 0.1) + ] + pure . testProperty name $ \(xs :: [Int]) -> + withMaxSuccess 10000 . forAll (split xs) $ \aSplit -> + xs === concat aSplit -- | Show the distribution of lists generated by a split function for a list of the given length. test_listDistribution :: Int -> ([()] -> Gen [[()]]) -> Int -> TestTree test_listDistribution numRuns split n = - testProperty ("for a list of length " ++ show n) $ - withMaxSuccess numRuns . forAll (split $ replicate n ()) $ \aSplit -> - label (show $ map length aSplit) True + testProperty ("for a list of length " ++ show n) $ + withMaxSuccess numRuns . forAll (split $ replicate n ()) $ \aSplit -> + label (show $ map length aSplit) True -- | Count the number of 'I' and 'B' nodes in a 'Data' object. countIandBs :: Data -> Int -countIandBs = go 0 where +countIandBs = go 0 + where go :: Int -> Data -> Int go acc (Constr _ ds) = foldl' go acc ds - go acc (Map ps) = foldl' (\acc' (d1, d2) -> go (go acc' d1) d2) acc ps - go acc (List ds) = foldl' go acc ds - go acc (I _) = acc + 1 - go acc (B _) = acc + 1 + go acc (Map ps) = foldl' (\acc' (d1, d2) -> go (go acc' d1) d2) acc ps + go acc (List ds) = foldl' go acc ds + go acc (I _) = acc + 1 + go acc (B _) = acc + 1 -- | Test the number of 'I' and 'B' nodes in a 'Data' generated from a @spine :: [()]@ equals the -- length of the spine. Ensures that the 'Data' generator is not exponential in 'B' and 'I' nodes -- (exponentiality in other nodes will not get caught by this test). test_arbitraryDataExpectedLeafs :: TestTree test_arbitraryDataExpectedLeafs = - testProperty "'arbitrary @Data' has the expected number of 'B' and 'I' leaves" $ - withMaxSuccess 1000 . mapSize (* 5) $ \spine -> - forAll (genDataFromSpine spine) $ \dat -> - countIandBs dat === length spine + testProperty "'arbitrary @Data' has the expected number of 'B' and 'I' leaves" $ + withMaxSuccess 1000 . mapSize (* 5) $ \spine -> + forAll (genDataFromSpine spine) $ \dat -> + countIandBs dat === length spine test_multiSplitDistribution :: TestTree test_multiSplitDistribution = - testGroup "distribution of values generated by" - [ testGroup "multiSplit1" - [ test_listDistribution 10000 (coerce $ multiSplit1 @()) 1 - , test_listDistribution 10000 (coerce $ multiSplit1 @()) 2 - , test_listDistribution 10000 (coerce $ multiSplit1 @()) 3 - , test_listDistribution 10000 (coerce $ multiSplit1 @()) 4 - , test_listDistribution 10000 (coerce $ multiSplit1 @()) 5 - ] - , testGroup "multiSplit0" - [ test_listDistribution 1000 (multiSplit0 0.1) 1 - , test_listDistribution 1000 (multiSplit0 0.05) 2 - , test_listDistribution 1000 (multiSplit0 0.01) 3 - ] + testGroup + "distribution of values generated by" + [ testGroup + "multiSplit1" + [ test_listDistribution 10000 (coerce $ multiSplit1 @()) 1 + , test_listDistribution 10000 (coerce $ multiSplit1 @()) 2 + , test_listDistribution 10000 (coerce $ multiSplit1 @()) 3 + , test_listDistribution 10000 (coerce $ multiSplit1 @()) 4 + , test_listDistribution 10000 (coerce $ multiSplit1 @()) 5 ] + , testGroup + "multiSplit0" + [ test_listDistribution 1000 (multiSplit0 0.1) 1 + , test_listDistribution 1000 (multiSplit0 0.05) 2 + , test_listDistribution 1000 (multiSplit0 0.01) 3 + ] + ] test_utils :: TestTree -test_utils = testGroup "utils" +test_utils = + testGroup + "utils" [ test_arbitraryDataExpectedLeafs , test_multiSplitSound , test_multiSplitDistribution diff --git a/plutus-core/plutus-core/test/Names/Spec.hs b/plutus-core/plutus-core/test/Names/Spec.hs index e6516b231b2..f64a90f50ab 100644 --- a/plutus-core/plutus-core/test/Names/Spec.hs +++ b/plutus-core/plutus-core/test/Names/Spec.hs @@ -1,27 +1,56 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Names.Spec where -import PlutusCore (DefaultFun, DefaultUni, FreeVariableError, Kind (Type), Name (..), NamedDeBruijn, - NamedTyDeBruijn, Program, Quote, Rename (rename), Term (..), TyName (..), - Type (..), Unique (..), deBruijnTerm, runQuote, runQuoteT, unDeBruijnTerm) +import PlutusCore ( + DefaultFun, + DefaultUni, + FreeVariableError, + Kind (Type), + Name (..), + NamedDeBruijn, + NamedTyDeBruijn, + Program, + Quote, + Rename (rename), + Term (..), + TyName (..), + Type (..), + Unique (..), + deBruijnTerm, + runQuote, + runQuoteT, + unDeBruijnTerm, + ) import PlutusCore qualified import PlutusCore.Error qualified as PLC import PlutusCore.Generators.Hedgehog (TermOf (..), forAllNoShowT, forAllPretty, generalizeT) -import PlutusCore.Generators.Hedgehog.AST as AST (genName, genProgram, genTerm, mangleNames, - runAstGen) +import PlutusCore.Generators.Hedgehog.AST as AST ( + genName, + genProgram, + genTerm, + mangleNames, + runAstGen, + ) import PlutusCore.Generators.Hedgehog.Interesting (fromInterestingTermGens) import PlutusCore.Mark (markNonFreshProgram) import PlutusCore.Parser qualified as Parser import PlutusCore.Pretty (display, displayPlcSimple) import PlutusCore.Rename.Internal (renameProgramM) -import PlutusCore.Test (BindingRemoval (BindingRemovalNotOk), Prerename (PrerenameNo), brokenRename, - checkFails, mapTestLimitAtLeast, noMarkRename, test_scopingGood, - test_scopingSpoilRenamer) +import PlutusCore.Test ( + BindingRemoval (BindingRemovalNotOk), + Prerename (PrerenameNo), + brokenRename, + checkFails, + mapTestLimitAtLeast, + noMarkRename, + test_scopingGood, + test_scopingSpoilRenamer, + ) import Control.Monad.Except (modifyError) import Data.String (IsString (fromString)) @@ -29,17 +58,17 @@ import Data.Text qualified as Text import Hedgehog (Gen, Property, forAll, property, tripping, (/==), (===)) import Hedgehog.Gen qualified as Gen import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testPropertyNamed) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.Hedgehog (testPropertyNamed) prop_DeBruijn :: Gen (TermOf (Term TyName Name DefaultUni DefaultFun ()) a) -> Property prop_DeBruijn gen = property $ generalizeT do TermOf body _ <- forAllNoShowT gen let forward = deBruijnTerm - backward - :: Either FreeVariableError (Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun a) - -> Either FreeVariableError (Term TyName Name DefaultUni DefaultFun a) + backward :: + Either FreeVariableError (Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun a) -> + Either FreeVariableError (Term TyName Name DefaultUni DefaultFun a) backward e = e >>= runQuoteT . unDeBruijnTerm tripping body forward backward @@ -62,10 +91,10 @@ test_mangle = termMangled /== term -- | Test equality of a program and its renamed version, given a renamer. -prop_equalityFor - :: program ~ Program TyName Name DefaultUni DefaultFun () - => (program -> Quote program) - -> Property +prop_equalityFor :: + program ~ Program TyName Name DefaultUni DefaultFun () => + (program -> Quote program) -> + Property prop_equalityFor ren = property do prog <- forAllPretty $ runAstGen genProgram let progRen = runQuote $ ren prog diff --git a/plutus-core/plutus-core/test/Normalization/Check.hs b/plutus-core/plutus-core/test/Normalization/Check.hs index 3f27d626550..a1070a197ac 100644 --- a/plutus-core/plutus-core/test/Normalization/Check.hs +++ b/plutus-core/plutus-core/test/Normalization/Check.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -module Normalization.Check ( test_normalizationCheck ) where +module Normalization.Check (test_normalizationCheck) where import PlutusCore import PlutusCore.Check.Normal @@ -11,20 +11,25 @@ import Test.Tasty.HUnit -- test that [rec (lam dat (fun (type) (type)) [dat a])] is a type value test_applyToValue :: IO () test_applyToValue = - let ty = TyApp () - recVar - (TyLam () datName - (KindArrow () (Type ()) (Type ())) - (TyApp () datVar aVar) - ) - in isNormalType @DefaultUni ty @?= True - - where recVar = TyVar () (TyName (Name "rec" (Unique 0))) - datVar = TyVar () datName - datName = TyName (Name "dat" (Unique 1)) - aVar = TyVar () (TyName (Name "a" (Unique 2))) + let ty = + TyApp + () + recVar + ( TyLam + () + datName + (KindArrow () (Type ()) (Type ())) + (TyApp () datVar aVar) + ) + in isNormalType @DefaultUni ty @?= True + where + recVar = TyVar () (TyName (Name "rec" (Unique 0))) + datVar = TyVar () datName + datName = TyName (Name "dat" (Unique 1)) + aVar = TyVar () (TyName (Name "a" (Unique 2))) test_normalizationCheck :: TestTree test_normalizationCheck = - testGroup "isTypeValue" - [ testCase "valueApply" test_applyToValue ] + testGroup + "isTypeValue" + [testCase "valueApply" test_applyToValue] diff --git a/plutus-core/plutus-core/test/Normalization/Type.hs b/plutus-core/plutus-core/test/Normalization/Type.hs index c1211a14c40..248d08a60b4 100644 --- a/plutus-core/plutus-core/test/Normalization/Type.hs +++ b/plutus-core/plutus-core/test/Normalization/Type.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -module Normalization.Type - ( test_typeNormalization - ) where +module Normalization.Type ( + test_typeNormalization, +) where import PlutusCore import PlutusCore.Generators.Hedgehog.AST @@ -16,33 +16,35 @@ import Control.Monad.Morph (hoist) import Hedgehog import Hedgehog.Internal.Property (forAllT) import Test.Tasty -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog test_appAppLamLam :: IO () test_appAppLamLam = do - let integer2 = mkTyBuiltin @_ @Integer @DefaultUni () - Normalized integer2' = runQuote $ do - x <- freshTyName "x" - y <- freshTyName "y" - normalizeType $ mkIterTyAppNoAnn - (TyLam () x (Type ()) (TyLam () y (Type ()) $ TyVar () y)) - [integer2, integer2] - integer2 @?= integer2' + let integer2 = mkTyBuiltin @_ @Integer @DefaultUni () + Normalized integer2' = runQuote $ do + x <- freshTyName "x" + y <- freshTyName "y" + normalizeType $ + mkIterTyAppNoAnn + (TyLam () x (Type ()) (TyLam () y (Type ()) $ TyVar () y)) + [integer2, integer2] + integer2 @?= integer2' test_normalizeTypesInIdempotent :: Property test_normalizeTypesInIdempotent = - mapTestLimitAtLeast 300 (`div` 10) . property . hoist (pure . runQuote) $ do - termNormTypes <- forAllT $ runAstGen (genTerm @DefaultFun) >>= normalizeTypesIn - termNormTypes' <- normalizeTypesIn termNormTypes - termNormTypes === termNormTypes' + mapTestLimitAtLeast 300 (`div` 10) . property . hoist (pure . runQuote) $ do + termNormTypes <- forAllT $ runAstGen (genTerm @DefaultFun) >>= normalizeTypesIn + termNormTypes' <- normalizeTypesIn termNormTypes + termNormTypes === termNormTypes' test_typeNormalization :: TestTree test_typeNormalization = - testGroup "typeNormalization" - [ testCase "appAppLamLam" test_appAppLamLam - , testPropertyNamed - "normalizeTypesInIdempotent" - "normalizeTypesInIdempotent" - test_normalizeTypesInIdempotent - ] + testGroup + "typeNormalization" + [ testCase "appAppLamLam" test_appAppLamLam + , testPropertyNamed + "normalizeTypesInIdempotent" + "normalizeTypesInIdempotent" + test_normalizeTypesInIdempotent + ] diff --git a/plutus-core/plutus-core/test/Parser/Spec.hs b/plutus-core/plutus-core/test/Parser/Spec.hs index d056d0c1f05..4db81aec211 100644 --- a/plutus-core/plutus-core/test/Parser/Spec.hs +++ b/plutus-core/plutus-core/test/Parser/Spec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for TPLC parser. module Parser.Spec (tests) where @@ -14,78 +14,82 @@ import Hedgehog hiding (Var) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Test.Tasty -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog -- | The `SrcSpan` of a parsed `Term` should not including trailing whitespaces. propTermSrcSpan :: Property propTermSrcSpan = property $ do - term <- _progTerm <$> - forAllWith display (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) - let code = display (term :: Term TyName Name DefaultUni DefaultFun ()) - let (endingLine, endingCol) = length &&& T.length . last $ T.lines code - trailingSpaces <- forAll $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n']) - case runQuoteT . parseTerm $ code <> trailingSpaces of - Right parsed -> - let sp = termAnn parsed - in (srcSpanELine sp, srcSpanECol sp) === (endingLine, endingCol + 1) - Left err -> annotate (display err) >> failure + term <- + _progTerm + <$> forAllWith display (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) + let code = display (term :: Term TyName Name DefaultUni DefaultFun ()) + let (endingLine, endingCol) = length &&& T.length . last $ T.lines code + trailingSpaces <- forAll $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n']) + case runQuoteT . parseTerm $ code <> trailingSpaces of + Right parsed -> + let sp = termAnn parsed + in (srcSpanELine sp, srcSpanECol sp) === (endingLine, endingCol + 1) + Left err -> annotate (display err) >> failure expectParserSuccess :: T.Text -> Assertion expectParserSuccess code = case runQuoteT (parseTerm code) of Right _ -> pure () - Left _ -> assertFailure $ "Unexpected failure when parsing term: " <> T.unpack code + Left _ -> assertFailure $ "Unexpected failure when parsing term: " <> T.unpack code expectParserFailure :: T.Text -> Assertion expectParserFailure code = case runQuoteT (parseTerm code) of Right _ -> assertFailure $ "Unexpected success when parsing term: " <> T.unpack code - Left _ -> pure () + Left _ -> pure () parseValueInvalidCurrency :: Assertion parseValueInvalidCurrency = do expectParserFailure code where -- Currency is 33 bytes - code = "(con value \ - \[ ( #616161616161616161616161616161616161616161616161616161616161616161\ - \, [ ( #6161616161616161616161616161616161616161616161616161616161616161\ - \ , -100 ) ] ) ])" + code = + "(con value \ + \[ ( #616161616161616161616161616161616161616161616161616161616161616161\ + \, [ ( #6161616161616161616161616161616161616161616161616161616161616161\ + \ , -100 ) ] ) ])" parseValueInvalidToken :: Assertion parseValueInvalidToken = do expectParserFailure code where -- Token is 33 bytes - code = "(con value \ - \[ ( #6161616161616161616161616161616161616161616161616161616161616161\ - \, [ ( #616161616161616161616161616161616161616161616161616161616161616161\ - \ , -100 ) ] ) ])" + code = + "(con value \ + \[ ( #6161616161616161616161616161616161616161616161616161616161616161\ + \, [ ( #616161616161616161616161616161616161616161616161616161616161616161\ + \ , -100 ) ] ) ])" parseValueValid :: Assertion parseValueValid = do expectParserSuccess code where -- Both currency and token are 32 bytes - code = "(con value \ - \[ ( #6161616161616161616161616161616161616161616161616161616161616161\ - \, [ ( #6161616161616161616161616161616161616161616161616161616161616161\ - \ , -100 ) ] ) ])" + code = + "(con value \ + \[ ( #6161616161616161616161616161616161616161616161616161616161616161\ + \, [ ( #6161616161616161616161616161616161616161616161616161616161616161\ + \ , -100 ) ] ) ])" tests :: TestTree tests = - testGroup - "parsing" - [ testPropertyNamed - "parser captures ending positions correctly" - "propTermSrcSpan" - propTermSrcSpan - , testCase - "parser of Value should fail upon invalid currency" - parseValueInvalidCurrency - , testCase - "parser of Value should fail upon invalid token" - parseValueInvalidToken - , testCase - "parser of Value should succeed" - parseValueValid - ] + testGroup + "parsing" + [ testPropertyNamed + "parser captures ending positions correctly" + "propTermSrcSpan" + propTermSrcSpan + , testCase + "parser of Value should fail upon invalid currency" + parseValueInvalidCurrency + , testCase + "parser of Value should fail upon invalid token" + parseValueInvalidToken + , testCase + "parser of Value should succeed" + parseValueValid + ] diff --git a/plutus-core/plutus-core/test/Pretty/Readable.hs b/plutus-core/plutus-core/test/Pretty/Readable.hs index 3cf2ef8cd69..34da12422cd 100644 --- a/plutus-core/plutus-core/test/Pretty/Readable.hs +++ b/plutus-core/plutus-core/test/Pretty/Readable.hs @@ -19,7 +19,7 @@ prettyConfigReadable = . PrettyConfigPlcReadable $ botPrettyConfigReadable prettyConfigNameSimple def -testReadable :: (PrettyPlc a) => TestName -> a -> TestNested +testReadable :: PrettyPlc a => TestName -> a -> TestNested testReadable name = nestedGoldenVsDoc name "" . prettyBy prettyConfigReadable test_PrettyReadable :: TestTree @@ -31,8 +31,8 @@ test_PrettyReadable = ] where folder :: Pretty fun => PlcFolderContents DefaultUni fun -> TestTree - folder - = runTestNested ["plutus-core", "test", "Pretty", "Golden", "Readable"] + folder = + runTestNested ["plutus-core", "test", "Pretty", "Golden", "Readable"] . foldPlcFolderContents testNested testReadable testReadable test_Pretty :: TestTree diff --git a/plutus-core/plutus-core/test/Spec.hs b/plutus-core/plutus-core/test/Spec.hs index de64a9d7dfc..c6f6c0e3307 100644 --- a/plutus-core/plutus-core/test/Spec.hs +++ b/plutus-core/plutus-core/test/Spec.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Main ( main, @@ -46,13 +46,13 @@ import Hedgehog hiding (Var) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import PlutusCore.Flat qualified as Flat -import Prelude hiding (readFile) import System.FilePath import Test.Tasty import Test.Tasty.Golden -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog import Test.Tasty.Options +import Prelude hiding (readFile) main :: IO () main = do @@ -77,8 +77,9 @@ main = do propFlat :: Property propFlat = property $ do - prog <- forAllPretty . runAstGen $ - regenConstantsUntil isSerialisable =<< genProgram @DefaultFun + prog <- + forAllPretty . runAstGen $ + regenConstantsUntil isSerialisable =<< genProgram @DefaultFun Hedgehog.tripping prog Flat.flat Flat.unflat {- The following tests check that (A) the parser can @@ -89,10 +90,9 @@ propFlat = property $ do type DefaultError = Error DefaultUni DefaultFun SrcSpan -{- | Test that the parser can successfully consume the output from the - prettyprinter for the unit and boolean types. We use a unit test here - because there are only three possibilities (@()@, @false@, and @true@). --} +-- | Test that the parser can successfully consume the output from the +-- prettyprinter for the unit and boolean types. We use a unit test here +-- because there are only three possibilities (@()@, @false@, and @true@). testLexConstant :: Assertion testLexConstant = for_ smallConsts $ \t -> do @@ -142,9 +142,8 @@ genConstantForTest = k2 = m * m m = fromIntegral (maxBound :: Int) :: Integer -{- | Check that printing followed by parsing is the identity function on - constants. --} +-- | Check that printing followed by parsing is the identity function on +-- constants. propLexConstant :: Property propLexConstant = mapTestLimitAtLeast 200 (`div` 10) . property $ do term <- forAllPretty $ Constant () <$> runAstGen genConstantForTest @@ -155,9 +154,8 @@ propLexConstant = mapTestLimitAtLeast 200 (`div` 10) . property $ do Either ParserErrorBundle (Term TyName Name DefaultUni DefaultFun SrcSpan) parseTm tm = runQuoteT $ parseTerm tm -{- | Generate a random 'Program', pretty-print it, and parse the pretty-printed -text, hopefully returning the same thing. --} +-- | Generate a random 'Program', pretty-print it, and parse the pretty-printed +-- text, hopefully returning the same thing. propParser :: Property propParser = property $ do prog <- forAllPretty . runAstGen $ regenConstantsUntil isSerialisable =<< genProgram @@ -172,7 +170,7 @@ type TestFunction = T.Text -> Either DefaultError T.Text asIO :: TestFunction -> FilePath -> IO BSL.ByteString asIO f = fmap (either errorgen (BSL.fromStrict . encodeUtf8) . f) . readFile -errorgen :: (PrettyPlc a) => a -> BSL.ByteString +errorgen :: PrettyPlc a => a -> BSL.ByteString errorgen = BSL.fromStrict . encodeUtf8 . displayPlcSimple asGolden :: TestFunction -> TestName -> TestTree @@ -183,10 +181,9 @@ asGolden f file = goldenVsString file (base ++ ".golden" ++ ext) (asIO f file) -- TODO: evaluation tests should go under the 'Evaluation' module, -- normalization tests -- under 'Normalization', etc. -{- | Parse and rewrite so that names are globally unique, not just unique within -their scope. -don't require there to be no free variables at this point, we might be parsing an open term --} +-- | Parse and rewrite so that names are globally unique, not just unique within +-- their scope. +-- don't require there to be no free variables at this point, we might be parsing an open term parseScoped :: ( MonadError (Error DefaultUni DefaultFun SrcSpan) m , MonadQuote m @@ -196,12 +193,12 @@ parseScoped :: -- don't require there to be no free variables at this point, we might be parsing an open term parseScoped = through (modifyError UniqueCoherencyErrorE . Uniques.checkProgram (const True)) - <=< rename - <=< modifyError ParseErrorE . parseProgram + <=< rename + <=< modifyError ParseErrorE + . parseProgram printType :: - ( MonadError (Error DefaultUni DefaultFun SrcSpan) m - ) => + MonadError (Error DefaultUni DefaultFun SrcSpan) m => T.Text -> m T.Text printType txt = @@ -215,7 +212,7 @@ testsType :: [FilePath] -> TestTree testsType = testGroup "golden type synthesis tests" . fmap (asGolden printType) format :: - (MonadError ParserErrorBundle m) => + MonadError ParserErrorBundle m => PrettyConfigPlc -> T.Text -> m T.Text diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs b/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs index 7e84227a085..e49f62960bc 100644 --- a/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs +++ b/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs @@ -1,15 +1,15 @@ -- editorconfig-checker-disable-file {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -module TypeSynthesis.Spec - ( test_typecheck - , lookupLastLessThanOrEqualTo - ) where +module TypeSynthesis.Spec ( + test_typecheck, + lookupLastLessThanOrEqualTo, +) where import PlutusPrelude @@ -32,140 +32,147 @@ import Test.Tasty import Test.Tasty.Extras import Test.Tasty.HUnit -kindcheck - :: (uni ~ DefaultUni, fun ~ DefaultFun, MonadError (Error uni fun ()) m) - => Type TyName uni () -> m (Type TyName uni ()) +kindcheck :: + (uni ~ DefaultUni, fun ~ DefaultFun, MonadError (Error uni fun ()) m) => + Type TyName uni () -> m (Type TyName uni ()) kindcheck ty = do - _ <- runQuoteT $ modifyError TypeErrorE $ inferKind defKindCheckConfig ty - return ty + _ <- runQuoteT $ modifyError TypeErrorE $ inferKind defKindCheckConfig ty + return ty -typecheck - :: (uni ~ DefaultUni, MonadError (Error uni fun ()) m, ToBuiltinMeaning uni fun) - => BuiltinSemanticsVariant fun - -> Term TyName Name uni fun () - -> m (Normalized (Type TyName uni ())) +typecheck :: + (uni ~ DefaultUni, MonadError (Error uni fun ()) m, ToBuiltinMeaning uni fun) => + BuiltinSemanticsVariant fun -> + Term TyName Name uni fun () -> + m (Normalized (Type TyName uni ())) typecheck semvar term = runQuoteT $ modifyError TypeErrorE $ do - tcConfig <- TypeCheckConfig defKindCheckConfig <$> builtinMeaningsToTypes semvar () - inferType tcConfig term + tcConfig <- TypeCheckConfig defKindCheckConfig <$> builtinMeaningsToTypes semvar () + inferType tcConfig term -- | Assert a term is ill-typed. -assertIllTyped - :: HasCallStack - => BuiltinSemanticsVariant DefaultFun - -> Term TyName Name DefaultUni DefaultFun () - -> (Error DefaultUni DefaultFun () -> Bool) - -> Assertion +assertIllTyped :: + HasCallStack => + BuiltinSemanticsVariant DefaultFun -> + Term TyName Name DefaultUni DefaultFun () -> + (Error DefaultUni DefaultFun () -> Bool) -> + Assertion assertIllTyped semvar term isExpected = case runExcept . runQuoteT $ typecheck semvar term of - Right _ -> assertFailure $ "Expected ill-typed but got well-typed: " ++ display term - Left err -> do - unless (isExpected err) $ - assertFailure $ "Got an unexpected error: " ++ displayPlcCondensedErrorClassic err + Right _ -> assertFailure $ "Expected ill-typed but got well-typed: " ++ display term + Left err -> do + unless (isExpected err) $ + assertFailure $ + "Got an unexpected error: " ++ displayPlcCondensedErrorClassic err nestedGoldenVsErrorOrThing :: (PrettyPlc e, PrettyReadable a) => String -> Either e a -> TestNested nestedGoldenVsErrorOrThing name = - nestedGoldenVsText name ".plc" + nestedGoldenVsText name ".plc" . either displayPlcCondensedErrorClassic (render . prettyPlcReadableSimple . AsReadable) -foldAssertWell - :: (ToBuiltinMeaning DefaultUni fun, Pretty fun) - => BuiltinSemanticsVariant fun - -> PlcFolderContents DefaultUni fun - -> TestTree -foldAssertWell semvar - = runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden"] - . foldPlcFolderContents testNested - (\name -> nestedGoldenVsErrorOrThing name . kindcheck) - (\name -> nestedGoldenVsErrorOrThing name . typecheck semvar) +foldAssertWell :: + (ToBuiltinMeaning DefaultUni fun, Pretty fun) => + BuiltinSemanticsVariant fun -> + PlcFolderContents DefaultUni fun -> + TestTree +foldAssertWell semvar = + runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden"] + . foldPlcFolderContents + testNested + (\name -> nestedGoldenVsErrorOrThing name . kindcheck) + (\name -> nestedGoldenVsErrorOrThing name . typecheck semvar) test_typecheckAvailable :: TestTree test_typecheckAvailable = let builtinSemanticsVariant :: ToBuiltinMeaning DefaultUni fun => BuiltinSemanticsVariant fun builtinSemanticsVariant = def - in testGroup "Available" - [ foldAssertWell builtinSemanticsVariant stdLib - , foldAssertWell builtinSemanticsVariant examples - ] + in testGroup + "Available" + [ foldAssertWell builtinSemanticsVariant stdLib + , foldAssertWell builtinSemanticsVariant examples + ] -- | Self-application. An example of ill-typed term. -- -- > /\ (A :: *) -> \(x : A) -> x x selfApply :: Term TyName Name uni fun () selfApply = runQuote $ do - a <- freshTyName "a" - x <- freshName "x" - return - . TyAbs () a (Type ()) - . LamAbs () x (TyVar () a) - . Apply () (Var () x) - $ Var () x + a <- freshTyName "a" + x <- freshName "x" + return + . TyAbs () a (Type ()) + . LamAbs () x (TyVar () a) + . Apply () (Var () x) + $ Var () x -- | For checking that attempting to reference a type variable whose name got shadowed results in a -- type error. mismatchTyName :: Term TyName Name uni fun () mismatchTyName = - let toTyName txt = TyName (Name txt (Unique 0)) in - Error () - . TyLam () (toTyName "x") (Type ()) - . TyLam () (toTyName "y") (Type ()) - $ TyVar () (toTyName "x") + let toTyName txt = TyName (Name txt (Unique 0)) + in Error () + . TyLam () (toTyName "x") (Type ()) + . TyLam () (toTyName "y") (Type ()) + $ TyVar () (toTyName "x") -- | For checking that attempting to reference a variable whose name got shadowed results in a -- type error. mismatchName :: Term TyName Name DefaultUni fun () mismatchName = - let toName txt = Name txt (Unique 0) in - LamAbs () (toName "x") (mkTyBuiltin @_ @Integer ()) - . LamAbs () (toName "y") (mkTyBuiltin @_ @Integer ()) - $ Var () (toName "x") + let toName txt = Name txt (Unique 0) + in LamAbs () (toName "x") (mkTyBuiltin @_ @Integer ()) + . LamAbs () (toName "y") (mkTyBuiltin @_ @Integer ()) + $ Var () (toName "x") test_typecheckIllTyped :: TestTree test_typecheckIllTyped = - testCase "ill-typed" $ - foldMap (uncurry $ assertIllTyped def) - [ (,) selfApply $ \case - TypeErrorE (TypeMismatch {}) -> True - _ -> False - , (,) mismatchTyName $ \case - TypeErrorE (TyNameMismatch {}) -> True - _ -> False - , (,) mismatchName $ \case - TypeErrorE (NameMismatch {}) -> True - _ -> False - ] + testCase "ill-typed" $ + foldMap + (uncurry $ assertIllTyped def) + [ (,) selfApply $ \case + TypeErrorE (TypeMismatch {}) -> True + _ -> False + , (,) mismatchTyName $ \case + TypeErrorE (TyNameMismatch {}) -> True + _ -> False + , (,) mismatchName $ \case + TypeErrorE (NameMismatch {}) -> True + _ -> False + ] -test_typecheckAllFun - :: forall fun. (ToBuiltinMeaning DefaultUni fun, Show fun, Show (BuiltinSemanticsVariant fun)) - => String - -> BuiltinSemanticsVariant fun - -> TestNested -test_typecheckAllFun name semVar - = testNestedNamed name (show semVar) +test_typecheckAllFun :: + forall fun. + (ToBuiltinMeaning DefaultUni fun, Show fun, Show (BuiltinSemanticsVariant fun)) => + String -> + BuiltinSemanticsVariant fun -> + TestNested +test_typecheckAllFun name semVar = + testNestedNamed name (show semVar) . map testFun $ enumerate @fun where testFun fun = - nestedGoldenVsErrorOrThing (show fun) . kindcheck $ typeOfBuiltinFunction semVar fun + nestedGoldenVsErrorOrThing (show fun) . kindcheck $ typeOfBuiltinFunction semVar fun test_typecheckDefaultFuns :: TestTree test_typecheckDefaultFuns = - -- This checks that for each set of builtins the Plutus type of every builtin is the same - -- regardless of versioning. - testGroup "builtins" . pure $ - runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden"] $ concat - [ map (test_typecheckAllFun @DefaultFun "DefaultFun") enumerate - , map (test_typecheckAllFun @ExtensionFun "ExtensionFun") enumerate - ] + -- This checks that for each set of builtins the Plutus type of every builtin is the same + -- regardless of versioning. + testGroup "builtins" . pure $ + runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden"] $ + concat + [ map (test_typecheckAllFun @DefaultFun "DefaultFun") enumerate + , map (test_typecheckAllFun @ExtensionFun "ExtensionFun") enumerate + ] -- | A value type to use in instantiated built-in signatures. We could use 'Term' or 'CekValue', -- but those have type parameters and look unwieldy in type signatures, so we define a dedicated -- value type to make golden tests more concise. data Val = Val + type instance UniOf Val = DefaultUni instance ExMemoryUsage Val where - memoryUsage = error "Not supposed to be executed" + memoryUsage = error "Not supposed to be executed" instance HasConstant Val where - asConstant _ = throwError notAConstant - fromConstant _ = Val + asConstant _ = throwError notAConstant + fromConstant _ = Val -- | Return the last element of the list that is smaller than or equal to the given one. -- @@ -179,15 +186,15 @@ instance HasConstant Val where -- >>> lookupLastLessThanOrEqualTo 11 xs -- Just 8 lookupLastLessThanOrEqualTo :: Ord a => a -> [a] -> Maybe a -lookupLastLessThanOrEqualTo _ [] = Nothing +lookupLastLessThanOrEqualTo _ [] = Nothing lookupLastLessThanOrEqualTo xI (x0 : xs0) - | xI < x0 = Nothing - | otherwise = Just $ go x0 xs0 - where - go x [] = x - go x (x' : xs) - | xI < x' = x - | otherwise = go x' xs + | xI < x0 = Nothing + | otherwise = Just $ go x0 xs0 + where + go x [] = x + go x (x' : xs) + | xI < x' = x + | otherwise = go x' xs -- | Dump the type signature of the denotation of each of the built-in functions to a golden file. -- If the signature of the denotation of a built-in function has ever changed and that is reflected @@ -199,62 +206,69 @@ lookupLastLessThanOrEqualTo xI (x0 : xs0) -- This design ensures that all type signature changes of denotations are explicitly reflected and -- the addition of another semantics variant won't mask an unexpected change in the signature of a -- denotation. -test_dumpTypeRepAllFun - :: forall fun. - ( ToBuiltinMeaning DefaultUni fun - , Show fun - , Show (BuiltinSemanticsVariant fun) - , Ord (BuiltinSemanticsVariant fun) - , Bounded (BuiltinSemanticsVariant fun) - ) - => String - -> [(fun, [BuiltinSemanticsVariant fun])] - -> BuiltinSemanticsVariant fun - -> TestNested -test_dumpTypeRepAllFun nameSet semVarChanges semVar - = testNestedNamed nameSet (show semVar) +test_dumpTypeRepAllFun :: + forall fun. + ( ToBuiltinMeaning DefaultUni fun + , Show fun + , Show (BuiltinSemanticsVariant fun) + , Ord (BuiltinSemanticsVariant fun) + , Bounded (BuiltinSemanticsVariant fun) + ) => + String -> + [(fun, [BuiltinSemanticsVariant fun])] -> + BuiltinSemanticsVariant fun -> + TestNested +test_dumpTypeRepAllFun nameSet semVarChanges semVar = + testNestedNamed nameSet (show semVar) . map testFun $ enumerate @fun where testFun fun = - withTypeSchemeOfBuiltinFunction @Val semVar fun $ \sch -> do - let name = show fun ++ - case lookup fun semVarChanges of - Nothing -> "" - Just semVars -> ('_' :) . show $ - case lookupLastLessThanOrEqualTo semVar semVars of - Nothing -> minBound - Just semVarLatest -> semVarLatest - nestedGoldenVsText name ".sig" . Text.pack $ show sch + withTypeSchemeOfBuiltinFunction @Val semVar fun $ \sch -> do + let name = + show fun + ++ case lookup fun semVarChanges of + Nothing -> "" + Just semVars -> ('_' :) . show $ + case lookupLastLessThanOrEqualTo semVar semVars of + Nothing -> minBound + Just semVarLatest -> semVarLatest + nestedGoldenVsText name ".sig" . Text.pack $ show sch test_dumpTypeRepDefaultFuns :: TestTree test_dumpTypeRepDefaultFuns = - testGroup "builtin signatures" . pure $ - runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden", "Signatures"] $ concat - [ let semVarChanges = - -- Keep the inner lists sorted. - [ ( ConsByteString - , [ DefaultFunSemanticsVariantC - ] - ) - ] - in map (test_dumpTypeRepAllFun @DefaultFun "DefaultFun" semVarChanges) enumerate - , let semVarChanges = - -- Keep the inner lists sorted. - [ ( IntNoIntegerNoWord - , [ ExtensionFunSemanticsVariant1 - , ExtensionFunSemanticsVariant3 - ] - ) - ] - in map (test_dumpTypeRepAllFun @ExtensionFun "ExtensionFun" semVarChanges) enumerate - ] + testGroup "builtin signatures" . pure $ + runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden", "Signatures"] $ + concat + [ let semVarChanges = + -- Keep the inner lists sorted. + [ + ( ConsByteString + , + [ DefaultFunSemanticsVariantC + ] + ) + ] + in map (test_dumpTypeRepAllFun @DefaultFun "DefaultFun" semVarChanges) enumerate + , let semVarChanges = + -- Keep the inner lists sorted. + [ + ( IntNoIntegerNoWord + , + [ ExtensionFunSemanticsVariant1 + , ExtensionFunSemanticsVariant3 + ] + ) + ] + in map (test_dumpTypeRepAllFun @ExtensionFun "ExtensionFun" semVarChanges) enumerate + ] test_typecheck :: TestTree test_typecheck = - testGroup "typecheck" - [ test_typecheckDefaultFuns - , test_dumpTypeRepDefaultFuns - , test_typecheckAvailable - , test_typecheckIllTyped - ] + testGroup + "typecheck" + [ test_typecheckDefaultFuns + , test_dumpTypeRepDefaultFuns + , test_typecheckAvailable + , test_typecheckIllTyped + ] diff --git a/plutus-core/plutus-core/test/Value/Spec.hs b/plutus-core/plutus-core/test/Value/Spec.hs index e25db53f2d9..2c1852b3803 100644 --- a/plutus-core/plutus-core/test/Value/Spec.hs +++ b/plutus-core/plutus-core/test/Value/Spec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -31,9 +31,8 @@ prop_packUnpackRoundtrip v = v === V.pack (V.unpack v) prop_packBookkeeping :: V.NestedMap -> Property prop_packBookkeeping = checkBookkeeping . V.pack -{-| Verifies that @pack@ preserves @Value@ invariants, i.e., -no empty inner map or zero amount. --} +-- | Verifies that @pack@ preserves @Value@ invariants, i.e., +-- no empty inner map or zero amount. prop_packPreservesInvariants :: V.NestedMap -> Property prop_packPreservesInvariants = checkInvariants . V.pack @@ -59,8 +58,8 @@ prop_unionCommutative :: Value -> Value -> Property prop_unionCommutative v v' = case (V.unionValue v v', V.unionValue v' v) of (BuiltinSuccess r1, BuiltinSuccess r2) -> r1 === r2 - (BuiltinFailure{}, BuiltinFailure{}) -> property True - _ -> property False + (BuiltinFailure {}, BuiltinFailure {}) -> property True + _ -> property False prop_unionAssociative :: Value -> Value -> Value -> Property prop_unionAssociative v1 v2 v3 = @@ -82,9 +81,10 @@ prop_insertCoinIdempotent :: Value -> Property prop_insertCoinIdempotent v = v === F.foldl' - (\acc (c, t, q) -> - let BuiltinSuccess v' = V.insertCoin (V.unK c) (V.unK t) (V.unQuantity q) acc - in v') + ( \acc (c, t, q) -> + let BuiltinSuccess v' = V.insertCoin (V.unK c) (V.unK t) (V.unQuantity q) acc + in v' + ) v (V.toFlatList v) @@ -94,8 +94,8 @@ prop_insertCoinValidatesCurrency v = forAll gen32BytesOrFewer $ \t -> forAll (arbitraryBuiltin `suchThat` (/= 0)) $ \quantity -> case V.insertCoin c t quantity v of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_insertCoinValidatesToken :: Value -> Property prop_insertCoinValidatesToken v = @@ -103,8 +103,8 @@ prop_insertCoinValidatesToken v = forAll gen33Bytes $ \t -> forAll (arbitraryBuiltin `suchThat` (/= 0)) $ \quantity -> case V.insertCoin c t quantity v of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_insertCoinValidatesQuantityMin :: Value -> Property prop_insertCoinValidatesQuantityMin v = @@ -112,8 +112,8 @@ prop_insertCoinValidatesQuantityMin v = forAll gen32BytesOrFewer $ \t -> forAll genBelowMinQuantity $ \quantity -> case V.insertCoin c t quantity v of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_insertCoinValidatesQuantityMax :: Value -> Property prop_insertCoinValidatesQuantityMax v = @@ -121,8 +121,8 @@ prop_insertCoinValidatesQuantityMax v = forAll gen32BytesOrFewer $ \t -> forAll genAboveMaxQuantity $ \quantity -> case V.insertCoin c t quantity v of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_lookupAfterInsertion :: Value -> V.Quantity -> Property prop_lookupAfterInsertion v quantity = @@ -144,23 +144,23 @@ prop_deleteCoinIdempotent v0 = forAll (elements fl) $ \(V.unK -> c, V.unK -> t, _) -> let v' = V.deleteCoin c t v in v' === V.deleteCoin c t v' - where - BuiltinSuccess v = if V.totalSize v0 > 0 then pure v0 else V.insertCoin "c" "t" 1 v0 - fl = V.toFlatList v + where + BuiltinSuccess v = if V.totalSize v0 > 0 then pure v0 else V.insertCoin "c" "t" 1 v0 + fl = V.toFlatList v prop_deleteCoinBookkeeping :: Value -> Property prop_deleteCoinBookkeeping v = conjoin [property (checkBookkeeping v') | v' <- vs] - where - fl = V.toFlatList v - vs = scanr (\(c, t, _) -> V.deleteCoin (V.unK c) (V.unK t)) v fl + where + fl = V.toFlatList v + vs = scanr (\(c, t, _) -> V.deleteCoin (V.unK c) (V.unK t)) v fl prop_deleteCoinPreservesInvariants :: Value -> Property prop_deleteCoinPreservesInvariants v = conjoin [property (checkInvariants v') | v' <- vs] - where - fl = V.toFlatList v - vs = scanr (\(c, t, _) -> V.deleteCoin (V.unK c) (V.unK t)) v fl + where + fl = V.toFlatList v + vs = scanr (\(c, t, _) -> V.deleteCoin (V.unK c) (V.unK t)) v fl toPositiveValue :: Value -> Value toPositiveValue = @@ -170,23 +170,23 @@ prop_containsReflexive :: Value -> Property prop_containsReflexive (toPositiveValue -> v) = property $ case V.valueContains v v of BuiltinSuccess r -> r - _ -> False + _ -> False prop_containsAfterDeletion :: Value -> Property prop_containsAfterDeletion (toPositiveValue -> v) = conjoin [property (case V.valueContains v v' of BuiltinSuccess r -> r; _ -> False) | v' <- vs] - where - fl = V.toFlatList v - vs = scanr (\(c, t, _) -> V.deleteCoin (V.unK c) (V.unK t)) v fl + where + fl = V.toFlatList v + vs = scanr (\(c, t, _) -> V.deleteCoin (V.unK c) (V.unK t)) v fl prop_containsEnforcesPositivity :: Value -> Property prop_containsEnforcesPositivity v | V.negativeAmounts v == 0 = case (V.valueContains v V.empty, V.valueContains V.empty v) of - (BuiltinSuccess{}, BuiltinSuccess{}) -> property True - _ -> property False + (BuiltinSuccess {}, BuiltinSuccess {}) -> property True + _ -> property False | otherwise = case (V.valueContains v V.empty, V.valueContains V.empty v) of - (BuiltinFailure{}, BuiltinFailure{}) -> property True - _ -> property False + (BuiltinFailure {}, BuiltinFailure {}) -> property True + _ -> property False scaleIncorrectlyBound :: Integer -> Value -> Bool scaleIncorrectlyBound factor val = @@ -198,25 +198,25 @@ prop_scaleBookKeeping :: Integer -> Value -> Property prop_scaleBookKeeping factor v = case V.scaleValue factor v of BuiltinSuccess r -> checkBookkeeping r - _ -> property $ scaleIncorrectlyBound factor v + _ -> property $ scaleIncorrectlyBound factor v prop_scaleByOneIsId :: Value -> Property prop_scaleByOneIsId v = property $ case V.scaleValue 1 v of BuiltinSuccess r -> r == v - _ -> scaleIncorrectlyBound 1 v + _ -> scaleIncorrectlyBound 1 v prop_negateInvolutive :: Value -> Property prop_negateInvolutive v = property $ case V.scaleValue (-1) v >>= V.scaleValue (-1) of BuiltinSuccess r -> r == v - _ -> scaleIncorrectlyBound (-1) v + _ -> scaleIncorrectlyBound (-1) v prop_scaleZeroIsZero :: Value -> Property prop_scaleZeroIsZero v = property $ case V.scaleValue 0 v of BuiltinSuccess r -> r == V.empty - _ -> scaleIncorrectlyBound 0 v + _ -> scaleIncorrectlyBound 0 v prop_negateIsInverse :: Value -> Property prop_negateIsInverse v = @@ -224,9 +224,10 @@ prop_negateIsInverse v = inverseUnion = do vInv <- V.scaleValue (-1) v V.unionValue v vInv - in property $ case inverseUnion of - BuiltinSuccess r -> r == V.empty - _ -> scaleIncorrectlyBound (-1) v + in + property $ case inverseUnion of + BuiltinSuccess r -> r == V.empty + _ -> scaleIncorrectlyBound (-1) v prop_oppositeScaleIsInverse :: Integer -> Value -> Property prop_oppositeScaleIsInverse c v = @@ -235,9 +236,10 @@ prop_oppositeScaleIsInverse c v = vInv <- V.scaleValue (negate c) v v' <- V.scaleValue c v V.unionValue v' vInv - in property $ case scaledValue of - BuiltinSuccess r -> r == V.empty - _ -> scaleIncorrectlyBound c v + in + property $ case scaledValue of + BuiltinSuccess r -> r == V.empty + _ -> scaleIncorrectlyBound c v prop_flatRoundtrip :: Value -> Property prop_flatRoundtrip v = Flat.unflat (Flat.flat v) === Right v @@ -287,14 +289,14 @@ checkBookkeeping v = (expectedMaxInnerSize === actualMaxInnerSize) .&&. (expectedSize === actualSize) .&&. (expectedNeg === actualNeg) - where - expectedMaxInnerSize = fromMaybe 0 . maximumMay $ Map.map Map.size (V.unpack v) - actualMaxInnerSize = V.maxInnerSize v - expectedSize = sum $ Map.map Map.size (V.unpack v) - actualSize = V.totalSize v - expectedNeg = - length [q | inner <- Map.elems (V.unpack v), q <- Map.elems inner, V.unQuantity q < 0] - actualNeg = V.negativeAmounts v + where + expectedMaxInnerSize = fromMaybe 0 . maximumMay $ Map.map Map.size (V.unpack v) + actualMaxInnerSize = V.maxInnerSize v + expectedSize = sum $ Map.map Map.size (V.unpack v) + actualSize = V.totalSize v + expectedNeg = + length [q | inner <- Map.elems (V.unpack v), q <- Map.elems inner, V.unQuantity q < 0] + actualNeg = V.negativeAmounts v checkInvariants :: Value -> Property checkInvariants (V.unpack -> v) = @@ -307,8 +309,8 @@ prop_unValueDataValidatesCurrency quantity = forAll gen32BytesOrFewer $ \t -> let d = Map [(B c, Map [(B t, I (V.unQuantity quantity))])] in case V.unValueData d of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_unValueDataValidatesToken :: V.Quantity -> Property prop_unValueDataValidatesToken quantity = @@ -316,8 +318,8 @@ prop_unValueDataValidatesToken quantity = forAll gen33Bytes $ \t -> let d = Map [(B c, Map [(B t, I (V.unQuantity quantity))])] in case V.unValueData d of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_unValueDataValidatesQuantityMin :: Property prop_unValueDataValidatesQuantityMin = @@ -326,8 +328,8 @@ prop_unValueDataValidatesQuantityMin = forAll genBelowMinQuantity $ \quantity -> let d = Map [(B c, Map [(B t, I quantity)])] in case V.unValueData d of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_unValueDataValidatesQuantityMax :: Property prop_unValueDataValidatesQuantityMax = @@ -336,34 +338,35 @@ prop_unValueDataValidatesQuantityMax = forAll genAboveMaxQuantity $ \quantity -> let d = Map [(B c, Map [(B t, I quantity)])] in case V.unValueData d of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_unValueDataValidatesMixedQuantities :: Property prop_unValueDataValidatesMixedQuantities = forAll genValueDataWithMixedQuantities $ \(dataVal, hasInvalid) -> case V.unValueData dataVal of - BuiltinSuccess{} -> not hasInvalid - BuiltinSuccessWithLogs{} -> not hasInvalid - BuiltinFailure{} -> hasInvalid - where - -- Generate Value Data with mixed valid/invalid quantities (90% valid, 10% invalid) - genValueDataWithMixedQuantities :: Gen (Data, Bool) - genValueDataWithMixedQuantities = do - numEntries <- chooseInt (1, 10) - entries <- vectorOf numEntries $ do - c <- gen32BytesOrFewer - t <- gen32BytesOrFewer - -- 90% valid, 10% invalid - quantity <- frequency - [ (9, arbitraryBuiltin :: Gen Integer) -- valid range - , (1, oneof [genBelowMinQuantity, genAboveMaxQuantity]) -- invalid - ] - pure (B c, Map [(B t, I quantity)]) - let hasInvalid = any (\(_, Map inner) -> any isInvalidQuantity inner) entries - isInvalidQuantity (_, I q) = q < V.unQuantity minBound || q > V.unQuantity maxBound - isInvalidQuantity _ = False - pure (Map entries, hasInvalid) + BuiltinSuccess {} -> not hasInvalid + BuiltinSuccessWithLogs {} -> not hasInvalid + BuiltinFailure {} -> hasInvalid + where + -- Generate Value Data with mixed valid/invalid quantities (90% valid, 10% invalid) + genValueDataWithMixedQuantities :: Gen (Data, Bool) + genValueDataWithMixedQuantities = do + numEntries <- chooseInt (1, 10) + entries <- vectorOf numEntries $ do + c <- gen32BytesOrFewer + t <- gen32BytesOrFewer + -- 90% valid, 10% invalid + quantity <- + frequency + [ (9, arbitraryBuiltin :: Gen Integer) -- valid range + , (1, oneof [genBelowMinQuantity, genAboveMaxQuantity]) -- invalid + ] + pure (B c, Map [(B t, I quantity)]) + let hasInvalid = any (\(_, Map inner) -> any isInvalidQuantity inner) entries + isInvalidQuantity (_, I q) = q < V.unQuantity minBound || q > V.unQuantity maxBound + isInvalidQuantity _ = False + pure (Map entries, hasInvalid) prop_unionValueDetectsOverflow :: Property prop_unionValueDetectsOverflow = @@ -372,8 +375,8 @@ prop_unionValueDetectsOverflow = let BuiltinSuccess v1 = V.insertCoin c t (V.unQuantity maxBound) V.empty BuiltinSuccess v2 = V.insertCoin c t 1 V.empty in case V.unionValue v1 v2 of - BuiltinFailure{} -> property True - _ -> property False + BuiltinFailure {} -> property True + _ -> property False prop_flatDecodeInvalidQuantityMin :: Property prop_flatDecodeInvalidQuantityMin = diff --git a/plutus-core/plutus-ir/cert/PlutusIR/Certifier.hs b/plutus-core/plutus-ir/cert/PlutusIR/Certifier.hs index f74c523649c..9e532d2fb5b 100644 --- a/plutus-core/plutus-ir/cert/PlutusIR/Certifier.hs +++ b/plutus-core/plutus-ir/cert/PlutusIR/Certifier.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} - -- Still some stuff that isn't used yet {-# OPTIONS_GHC -Wno-unused-top-binds #-} @@ -9,8 +8,13 @@ -- - Boolean decision procedures for translation relations module PlutusIR.Certifier (is_dead_code, is_unique) where -import PlutusCore qualified as P (DefaultFun (..), DefaultUni (..), Some (..), SomeTypeIn (..), - ValueOf (..)) +import PlutusCore qualified as P ( + DefaultFun (..), + DefaultUni (..), + Some (..), + SomeTypeIn (..), + ValueOf (..), + ) import PlutusIR qualified as P import PlutusIR.Certifier.Extracted qualified as E @@ -57,131 +61,126 @@ glueNonEmpty :: NonEmpty a -> E.List a glueNonEmpty (x :| xs) = E.Cons x (glueList xs) glueList :: [a] -> E.List a -glueList [] = E.Nil +glueList [] = E.Nil glueList (x : xs) = E.Cons x (glueList xs) glueTerm :: Term a -> ETerm glueTerm = \case - P.Let _ r bs t -> E.Let - (glueRecursivity r) - (glueNonEmpty (fmap glueBinding bs)) - (glueTerm t) - P.Var _ name -> E.Var (glueName name) + P.Let _ r bs t -> + E.Let + (glueRecursivity r) + (glueNonEmpty (fmap glueBinding bs)) + (glueTerm t) + P.Var _ name -> E.Var (glueName name) P.TyAbs _ tyname k t -> E.TyAbs (glueTyName tyname) (glueKind k) (glueTerm t) P.LamAbs _ name ty t -> E.LamAbs (glueName name) (glueType ty) (glueTerm t) - P.Apply _ t t' -> E.Apply (glueTerm t) (glueTerm t') - P.Constant _ c -> E.Constant (glueConstant c) - P.Builtin _ fun -> E.Builtin (glueDefaultFun fun) - P.TyInst _ t ty -> E.TyInst (glueTerm t) (glueType ty) - P.Unwrap _ t -> E.Unwrap (glueTerm t) - P.IWrap _ ty1 ty2 t -> E.IWrap (glueType ty1) (glueType ty2) (glueTerm t) - P.Error _ ty -> E.Error (glueType ty) - P.Case _ _ _ _ -> error "glueTerm: Case not supported" - P.Constr _ _ _ _ -> error "glueTerm: Constr not supported" + P.Apply _ t t' -> E.Apply (glueTerm t) (glueTerm t') + P.Constant _ c -> E.Constant (glueConstant c) + P.Builtin _ fun -> E.Builtin (glueDefaultFun fun) + P.TyInst _ t ty -> E.TyInst (glueTerm t) (glueType ty) + P.Unwrap _ t -> E.Unwrap (glueTerm t) + P.IWrap _ ty1 ty2 t -> E.IWrap (glueType ty1) (glueType ty2) (glueTerm t) + P.Error _ ty -> E.Error (glueType ty) + P.Case _ _ _ _ -> error "glueTerm: Case not supported" + P.Constr _ _ _ _ -> error "glueTerm: Constr not supported" glueRecursivity :: P.Recursivity -> E.Recursivity -glueRecursivity P.Rec = E.Rec +glueRecursivity P.Rec = E.Rec glueRecursivity P.NonRec = E.NonRec - - glueDefaultFun :: P.DefaultFun -> E.DefaultFun glueDefaultFun = \case - P.AddInteger -> E.AddInteger - P.SubtractInteger -> E.SubtractInteger - P.MultiplyInteger -> E.MultiplyInteger - P.DivideInteger -> E.DivideInteger - P.QuotientInteger -> E.QuotientInteger - P.RemainderInteger -> E.RemainderInteger - P.ModInteger -> E.ModInteger - P.LessThanInteger -> E.LessThanInteger - P.LessThanEqualsInteger -> E.LessThanEqInteger + P.AddInteger -> E.AddInteger + P.SubtractInteger -> E.SubtractInteger + P.MultiplyInteger -> E.MultiplyInteger + P.DivideInteger -> E.DivideInteger + P.QuotientInteger -> E.QuotientInteger + P.RemainderInteger -> E.RemainderInteger + P.ModInteger -> E.ModInteger + P.LessThanInteger -> E.LessThanInteger + P.LessThanEqualsInteger -> E.LessThanEqInteger -- P.GreaterThanInteger -> E.GreaterThanInteger -- P.GreaterThanEqInteger -> E.GreaterThanEqInteger - P.EqualsInteger -> E.EqInteger + P.EqualsInteger -> E.EqInteger -- P.Concatenate -> E.Concatenate -- P.TakeByteString -> E.TakeByteString -- P.DropByteString -> E.DropByteString - P.Sha2_256 -> E.SHA2 - P.Sha3_256 -> E.SHA3 + P.Sha2_256 -> E.SHA2 + P.Sha3_256 -> E.SHA3 P.VerifyEd25519Signature -> E.VerifySignature - P.EqualsByteString -> E.EqByteString - P.LessThanByteString -> E.LtByteString + P.EqualsByteString -> E.EqByteString + P.LessThanByteString -> E.LtByteString -- P.GtByteString -> E.GtByteString - P.IfThenElse -> E.IfThenElse + P.IfThenElse -> E.IfThenElse -- P.CharToString -> E.CharToString - P.AppendString -> E.Append - P.Trace -> E.Trace - + P.AppendString -> E.Append + P.Trace -> E.Trace -- TODO: support current set of builtin functions - _ -> E.Trace + _ -> E.Trace glueConstant :: P.Some (P.ValueOf P.DefaultUni) -> E.Some0 E.ValueOf glueConstant (P.Some (P.ValueOf u _x)) = let anyU = case u of _ -> E.unsafeCoerce () - -- P.DefaultUniInteger -> E.unsafeCoerce (glueInteger x) - -- P.DefaultUniChar -> E.unsafeCoerce (glueChar x) - -- P.DefaultUniUnit -> E.unsafeCoerce x -- same rep () - -- P.DefaultUniBool -> E.unsafeCoerce (glueBool x) - -- P.DefaultUniString -> E.unsafeCoerce (glueString x) - -- P.DefaultUniByteString -> E.unsafeCoerce (glueString (show x)) - in E.Some' (glueDefaultUni u) (E.unsafeCoerce anyU) + in -- P.DefaultUniInteger -> E.unsafeCoerce (glueInteger x) + -- P.DefaultUniChar -> E.unsafeCoerce (glueChar x) + -- P.DefaultUniUnit -> E.unsafeCoerce x -- same rep () + -- P.DefaultUniBool -> E.unsafeCoerce (glueBool x) + -- P.DefaultUniString -> E.unsafeCoerce (glueString x) + -- P.DefaultUniByteString -> E.unsafeCoerce (glueString (show x)) + E.Some' (glueDefaultUni u) (E.unsafeCoerce anyU) glueInteger :: Integer -> E.Z glueInteger x | x == 0 = E.Z0 - | x > 0 = E.Zpos (gluePositive x) + | x > 0 = E.Zpos (gluePositive x) | otherwise = E.Zneg (gluePositive (-1 * x)) - - -- Coq's representation of Positive: https://coq.inria.fr/library/Coq.Numbers.BinNums.html gluePositive :: Integer -> E.Positive gluePositive n - | n <= 0 = error "gluePositive: non-positive number provided" + | n <= 0 = error "gluePositive: non-positive number provided" | otherwise = bitsToPos (go n) where go 0 = [] go m = case divMod m 2 of (r, 0) -> False : go r (r, 1) -> True : go r - _ -> error "gluePositive: impossible" + _ -> error "gluePositive: impossible" bitsToPos :: [Bool] -> E.Positive - bitsToPos [True] = E.XH - bitsToPos (True : xs) = E.XI (bitsToPos xs) + bitsToPos [True] = E.XH + bitsToPos (True : xs) = E.XI (bitsToPos xs) bitsToPos (False : xs) = E.XO (bitsToPos xs) - bitsToPos [] = + bitsToPos [] = error "bitsToPos: positive number should have a most significant (leading) 1 bit" - glueBool :: Bool -> E.Bool -glueBool True = E.True +glueBool True = E.True glueBool False = E.False glueStrictness :: P.Strictness -> E.Strictness -glueStrictness P.Strict = E.Strict +glueStrictness P.Strict = E.Strict glueStrictness P.NonStrict = E.NonStrict - glueVarDecl :: PVarDecl a -> EVarDecl glueVarDecl (P.VarDecl _ name ty) = E.VarDecl (glueName name) (glueType ty) glueTyVarDecl :: PTyVarDecl a -> ETyVarDecl glueTyVarDecl (P.TyVarDecl _ tyname k) = E.TyVarDecl (glueTyName tyname) (glueKind k) - glueConstructor :: PVarDecl a -> EConstr glueConstructor (P.VarDecl _ name ty) = E.Constructor - (E.VarDecl (glueName name) - (glueType ty)) + ( E.VarDecl + (glueName name) + (glueType ty) + ) (arity ty) where arity :: P.Type tyname uni a -> E.Nat arity (P.TyFun _ _a b) = E.S (arity b) - arity _ = E.O + arity _ = E.O glueDatatype :: PDatatype a -> EDatatype glueDatatype (P.Datatype _ tvd tvs elim cs) = @@ -193,8 +192,8 @@ glueDatatype (P.Datatype _ tvd tvs elim cs) = glueBinding :: Binding a -> EBinding glueBinding = \case - P.TermBind _ s vd t -> E.TermBind (glueStrictness s) (glueVarDecl vd) (glueTerm t) - P.TypeBind _ tvd ty -> E.TypeBind (glueTyVarDecl tvd) (glueType ty) + P.TermBind _ s vd t -> E.TermBind (glueStrictness s) (glueVarDecl vd) (glueTerm t) + P.TypeBind _ tvd ty -> E.TypeBind (glueTyVarDecl tvd) (glueType ty) P.DatatypeBind _ dtd -> E.DatatypeBind (glueDatatype dtd) -- This is hacky: we use (unique) strings for variable names in Coq, @@ -209,37 +208,36 @@ glueDefaultUni :: P.DefaultUni a -> E.DefaultUni glueDefaultUni u = case u of -- TODO: implement current constructors of DefaultUni -- _ -> E.DefaultUniInteger - P.DefaultUniInteger -> E.DefaultUniInteger + P.DefaultUniInteger -> E.DefaultUniInteger P.DefaultUniByteString -> E.DefaultUniByteString - P.DefaultUniString -> E.DefaultUniString + P.DefaultUniString -> E.DefaultUniString -- P.DefaultUniChar -> E.DefaultUniChar - P.DefaultUniUnit -> E.DefaultUniUnit - P.DefaultUniBool -> E.DefaultUniBool - _ -> E.DefaultUniInteger + P.DefaultUniUnit -> E.DefaultUniUnit + P.DefaultUniBool -> E.DefaultUniBool + _ -> E.DefaultUniInteger glueBuiltinType :: P.SomeTypeIn P.DefaultUni -> E.Some0 () glueBuiltinType (P.SomeTypeIn u) = E.Some' (glueDefaultUni u) () glueType :: Type a -> EType -glueType (P.TyVar _ tyname) = E.Ty_Var (glueTyName tyname) -glueType (P.TyFun _ t t') = E.Ty_Fun (glueType t) (glueType t') -glueType (P.TyIFix _ t t') = E.Ty_IFix (glueType t) (glueType t') +glueType (P.TyVar _ tyname) = E.Ty_Var (glueTyName tyname) +glueType (P.TyFun _ t t') = E.Ty_Fun (glueType t) (glueType t') +glueType (P.TyIFix _ t t') = E.Ty_IFix (glueType t) (glueType t') glueType (P.TyForall _ tyname k t) = E.Ty_Forall (glueTyName tyname) (glueKind k) (glueType t) -glueType (P.TyBuiltin _ b) = E.Ty_Builtin (glueBuiltinType b) -glueType (P.TyLam _ tyname k t) = E.Ty_Lam (glueTyName tyname) (glueKind k) (glueType t) -glueType (P.TyApp _ t t') = E.Ty_App (glueType t) (glueType t') +glueType (P.TyBuiltin _ b) = E.Ty_Builtin (glueBuiltinType b) +glueType (P.TyLam _ tyname k t) = E.Ty_Lam (glueTyName tyname) (glueKind k) (glueType t) +glueType (P.TyApp _ t t') = E.Ty_App (glueType t) (glueType t') -- TODO: Support TySOP -glueType (P.TySOP _ _) = error "glueType: TySOP not supported" +glueType (P.TySOP _ _) = error "glueType: TySOP not supported" glueKind :: Kind a -> EKind -glueKind (P.Type _) = E.Kind_Base +glueKind (P.Type _) = E.Kind_Base glueKind (P.KindArrow _ k1 k2) = E.Kind_Arrow (glueKind k1) (glueKind k2) - -- * Decision procedures for translation relations toBool :: E.Bool -> Bool -toBool E.True = True +toBool E.True = True toBool E.False = False -- | Check if only pure let bindings were eliminated @@ -250,7 +248,7 @@ is_dead_code t1 t2 = toBool $ E.dec_Term (glueTerm t1) (glueTerm t2) is_unique :: Term a -> Bool is_unique t = case E.dec_unique (glueTerm t) infinity of E.Some b -> toBool b - _ -> False + _ -> False where infinity :: E.Nat infinity = E.S infinity diff --git a/plutus-core/plutus-ir/src/PlutusIR.hs b/plutus-core/plutus-ir/src/PlutusIR.hs index cf3f1f25d72..95817385e42 100644 --- a/plutus-core/plutus-ir/src/PlutusIR.hs +++ b/plutus-core/plutus-ir/src/PlutusIR.hs @@ -1,34 +1,34 @@ module PlutusIR ( - -- * AST - Term (..), - progAnn, - progVer, - progTerm, - termSubterms, - termSubtypes, - termBindings, - termAnn, - bindingAnn, - Type (..), - typeSubtypes, - Datatype (..), - datatypeNameString, - datatypeSubtypes, - Kind (..), - Recursivity (..), - Strictness (..), - Binding (..), - bindingSubterms, - bindingSubtypes, - bindingIds, - Program (..), - applyProgram, - TyName (..), - Name (..), - VarDecl (..), - TyVarDecl (..), - varDeclNameString, - tyVarDeclNameString - ) where + -- * AST + Term (..), + progAnn, + progVer, + progTerm, + termSubterms, + termSubtypes, + termBindings, + termAnn, + bindingAnn, + Type (..), + typeSubtypes, + Datatype (..), + datatypeNameString, + datatypeSubtypes, + Kind (..), + Recursivity (..), + Strictness (..), + Binding (..), + bindingSubterms, + bindingSubtypes, + bindingIds, + Program (..), + applyProgram, + TyName (..), + Name (..), + VarDecl (..), + TyVarDecl (..), + varDeclNameString, + tyVarDeclNameString, +) where import PlutusIR.Core diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Builtins.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Builtins.hs index 6baa82fc0cf..fd8aee18f7b 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Builtins.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Builtins.hs @@ -1,27 +1,28 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -module PlutusIR.Analysis.Builtins - ( BuiltinMatcherLike (..) - , bmlSplitMatchContext - , bmlBranchArities - , defaultUniMatcherLike - , BuiltinsInfo (..) - , biSemanticsVariant - , biMatcherLike - , biUnserializableConstants - , builtinArityInfo - , constantIsSerializable - , termIsSerializable - , asBuiltinDatatypeMatch - , builtinDatatypeMatchBranchArities - , defaultUniUnserializableConstants - ) where +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusIR.Analysis.Builtins ( + BuiltinMatcherLike (..), + bmlSplitMatchContext, + bmlBranchArities, + defaultUniMatcherLike, + BuiltinsInfo (..), + biSemanticsVariant, + biMatcherLike, + biUnserializableConstants, + builtinArityInfo, + constantIsSerializable, + termIsSerializable, + asBuiltinDatatypeMatch, + builtinDatatypeMatchBranchArities, + defaultUniUnserializableConstants, +) where import Control.Lens hiding (parts) import Data.Functor (void) @@ -35,47 +36,51 @@ import PlutusCore.Default import PlutusCore.MkPlc (mkIterTyAppNoAnn) import PlutusIR.Contexts import PlutusIR.Core (Term) -import PlutusIR.Core.Plated (_Constant, termSubtermsDeep) +import PlutusIR.Core.Plated (termSubtermsDeep, _Constant) import PlutusPrelude (Default (..)) -- | The information we need to work with a builtin that is like a datatype matcher. data BuiltinMatcherLike uni fun = BuiltinMatcherLike - { _bmlSplitMatchContext :: forall tyname name a . - Prism' (AppContext tyname name uni fun a) (SplitMatchContext tyname name uni fun a) + { _bmlSplitMatchContext :: + forall tyname name a. + Prism' (AppContext tyname name uni fun a) (SplitMatchContext tyname name uni fun a) , _bmlBranchArities :: [Arity] } + makeLenses ''BuiltinMatcherLike -- | All non-static information about builtins that the compiler might want. data BuiltinsInfo (uni :: Type -> Type) fun = BuiltinsInfo - { _biSemanticsVariant :: PLC.BuiltinSemanticsVariant fun - , _biMatcherLike :: Map.Map fun (BuiltinMatcherLike uni fun) - -- See Note [Unserializable constants] - , _biUnserializableConstants :: Some (ValueOf uni) -> Bool + { _biSemanticsVariant :: PLC.BuiltinSemanticsVariant fun + , _biMatcherLike :: Map.Map fun (BuiltinMatcherLike uni fun) + , -- See Note [Unserializable constants] + _biUnserializableConstants :: Some (ValueOf uni) -> Bool } + makeLenses ''BuiltinsInfo instance Default (BuiltinsInfo DefaultUni DefaultFun) where - def = BuiltinsInfo - { _biSemanticsVariant = def - , _biMatcherLike = defaultUniMatcherLike - , _biUnserializableConstants = defaultUniUnserializableConstants - } + def = + BuiltinsInfo + { _biSemanticsVariant = def + , _biMatcherLike = defaultUniMatcherLike + , _biUnserializableConstants = defaultUniUnserializableConstants + } -- | Get the arity of a builtin function from the 'PLC.BuiltinInfo'. -builtinArityInfo - :: forall uni fun - . ToBuiltinMeaning uni fun - => BuiltinsInfo uni fun - -> fun - -> Arity +builtinArityInfo :: + forall uni fun. + ToBuiltinMeaning uni fun => + BuiltinsInfo uni fun -> + fun -> + Arity builtinArityInfo binfo = builtinArity (Proxy @uni) (binfo ^. biSemanticsVariant) -constantIsSerializable - :: forall uni fun - . BuiltinsInfo uni fun - -> Some (ValueOf uni) - -> Bool +constantIsSerializable :: + forall uni fun. + BuiltinsInfo uni fun -> + Some (ValueOf uni) -> + Bool constantIsSerializable bi v = not $ _biUnserializableConstants bi v termIsSerializable :: BuiltinsInfo uni fun -> Term tyname name uni fun a -> Bool @@ -86,100 +91,107 @@ termIsSerializable binfo = -- | Split a builtin 'match'. asBuiltinDatatypeMatch :: - Ord fun - => BuiltinsInfo uni fun - -> fun - -> Maybe (APrism' (AppContext tyname name uni fun a) (SplitMatchContext tyname name uni fun a)) + Ord fun => + BuiltinsInfo uni fun -> + fun -> + Maybe (APrism' (AppContext tyname name uni fun a) (SplitMatchContext tyname name uni fun a)) asBuiltinDatatypeMatch binfo f - | Just (BuiltinMatcherLike p _) <- Map.lookup f (binfo ^. biMatcherLike) - = Just p + | Just (BuiltinMatcherLike p _) <- Map.lookup f (binfo ^. biMatcherLike) = + Just p | otherwise = Nothing -- | Get the branch arities for a builtin 'match'. builtinDatatypeMatchBranchArities :: - Ord fun - => BuiltinsInfo uni fun - -> fun - -> Maybe [Arity] + Ord fun => + BuiltinsInfo uni fun -> + fun -> + Maybe [Arity] builtinDatatypeMatchBranchArities binfo f - | Just (BuiltinMatcherLike _ arities) <- Map.lookup f (binfo ^. biMatcherLike) - = Just arities + | Just (BuiltinMatcherLike _ arities) <- Map.lookup f (binfo ^. biMatcherLike) = + Just arities | otherwise = Nothing defaultUniMatcherLike :: Map.Map DefaultFun (BuiltinMatcherLike DefaultUni DefaultFun) -defaultUniMatcherLike = Map.fromList - [ (IfThenElse, - BuiltinMatcherLike (prism' reconstructIfThenElse splitIfThenElse) ifThenElseBranchArities) - , (ChooseUnit, - BuiltinMatcherLike (prism' reconstructChooseUnit splitChooseUnit) chooseUnitBranchArities) - , (ChooseList, - BuiltinMatcherLike (prism' reconstructChooseList splitChooseList) chooseListBranchArities) - ] +defaultUniMatcherLike = + Map.fromList + [ + ( IfThenElse + , BuiltinMatcherLike (prism' reconstructIfThenElse splitIfThenElse) ifThenElseBranchArities + ) + , + ( ChooseUnit + , BuiltinMatcherLike (prism' reconstructChooseUnit splitChooseUnit) chooseUnitBranchArities + ) + , + ( ChooseList + , BuiltinMatcherLike (prism' reconstructChooseList splitChooseList) chooseListBranchArities + ) + ] where - splitIfThenElse - :: AppContext tyname name DefaultUni DefaultFun a - -> Maybe (SplitMatchContext tyname name DefaultUni DefaultFun a) + splitIfThenElse :: + AppContext tyname name DefaultUni DefaultFun a -> + Maybe (SplitMatchContext tyname name DefaultUni DefaultFun a) splitIfThenElse args -- Okay to use the default semantics variant here as we're assuming the -- type never changes | Just Saturated <- saturates args (builtinArity Proxy def IfThenElse) - -- 1. No ty vars - -- 2. Result type comes first - -- 3. Scrutinee next - -- 4. Then branches - , (TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches)) <- args - = - let - scrutTy = mkTyBuiltin @_ @Bool () - sm = SplitMatchContext mempty (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches - in Just sm + , -- 1. No ty vars + -- 2. Result type comes first + -- 3. Scrutinee next + -- 4. Then branches + (TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches)) <- args = + let + scrutTy = mkTyBuiltin @_ @Bool () + sm = SplitMatchContext mempty (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches + in + Just sm | otherwise = Nothing reconstructIfThenElse (SplitMatchContext _ (scrut, _, scrutAnn) (resTy, resTyAnn) branches) = TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches) -- both branches have no args ifThenElseBranchArities = [[], []] - splitChooseUnit - :: AppContext tyname name DefaultUni DefaultFun a - -> Maybe (SplitMatchContext tyname name DefaultUni DefaultFun a) + splitChooseUnit :: + AppContext tyname name DefaultUni DefaultFun a -> + Maybe (SplitMatchContext tyname name DefaultUni DefaultFun a) splitChooseUnit args -- Okay to use the default semantics variant here as we're assuming the -- type never changes | Just Saturated <- saturates args (builtinArity Proxy def ChooseUnit) - -- 1. No ty vars - -- 2. Result type comes first - -- 3. Scrutinee next - -- 4. Then branches - , (TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches)) <- args - = - let - scrutTy = mkTyBuiltin @_ @() () - sm = SplitMatchContext mempty (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches - in Just sm + , -- 1. No ty vars + -- 2. Result type comes first + -- 3. Scrutinee next + -- 4. Then branches + (TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches)) <- args = + let + scrutTy = mkTyBuiltin @_ @() () + sm = SplitMatchContext mempty (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches + in + Just sm | otherwise = Nothing reconstructChooseUnit (SplitMatchContext _ (scrut, _, scrutAnn) (resTy, resTyAnn) branches) = TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches) -- only branch has no args chooseUnitBranchArities = [[]] - splitChooseList - :: AppContext tyname name DefaultUni DefaultFun a - -> Maybe (SplitMatchContext tyname name DefaultUni DefaultFun a) + splitChooseList :: + AppContext tyname name DefaultUni DefaultFun a -> + Maybe (SplitMatchContext tyname name DefaultUni DefaultFun a) splitChooseList args -- Okay to use the default semantics variant here as we're assuming the -- type never changes | Just Saturated <- saturates args (builtinArity Proxy def ChooseList) - -- 1. One type variable - -- 2. Then the result type - -- 3. Scrutinee next - -- 4. Then branches - , (vars, TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches)) <- - splitAppContext 1 args - = do - tyArgs <- extractTyArgs vars - let scrutTy = mkIterTyAppNoAnn (mkTyBuiltin @_ @[] ()) (fmap void tyArgs) - sm = SplitMatchContext vars (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches - pure sm + , -- 1. One type variable + -- 2. Then the result type + -- 3. Scrutinee next + -- 4. Then branches + (vars, TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches)) <- + splitAppContext 1 args = + do + tyArgs <- extractTyArgs vars + let scrutTy = mkIterTyAppNoAnn (mkTyBuiltin @_ @[] ()) (fmap void tyArgs) + sm = SplitMatchContext vars (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches + pure sm | otherwise = Nothing reconstructChooseList (SplitMatchContext vars (scrut, _, scrutAnn) (resTy, resTyAnn) branches) = vars <> TypeAppContext resTy resTyAnn (TermAppContext scrut scrutAnn branches) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Definitions.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Definitions.hs index 49cb2fb081a..8d0e0176544 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Definitions.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Definitions.hs @@ -1,12 +1,13 @@ {-# LANGUAGE LambdaCase #-} + -- | Definition analysis for Plutus IR. -- This mostly adapts term-related code from PlutusCore.Analysis.Definitions; -- we just re-use the typed machinery to do the hard work here. -module PlutusIR.Analysis.Definitions - ( UniqueInfos - , termDefs - , runTermDefs - ) where +module PlutusIR.Analysis.Definitions ( + UniqueInfos, + termDefs, + runTermDefs, +) where import Control.Lens (forMOf_) import Control.Monad (forM_) @@ -20,82 +21,92 @@ import PlutusIR.Core.Type import PlutusCore.Analysis.Definitions hiding (runTermDefs, termDefs) -- | Add declarations to definition maps. -addBindingDef :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Binding tyname name uni fun ann -> m () +addBindingDef :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Binding tyname name uni fun ann -> m () addBindingDef bd = case bd of - TermBind _a _s (VarDecl varAnn n _) _ -> do - addDef n varAnn TermScope - TypeBind _a (TyVarDecl tyAnn tyN _) _ -> do - addDef tyN tyAnn TypeScope - DatatypeBind - _a - (Datatype - dataAnn - (TyVarDecl tyAnn tyN _) - tyVarDecls - dataName - varDecls - ) -> do - let addTyVarDecl :: (Ord ann, - HasUnique tyname TypeUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => TyVarDecl tyname ann -> m () - addTyVarDecl (TyVarDecl tyVarAnn tyVarN _) = - addDef tyVarN tyVarAnn TypeScope - addVarDecl :: (Ord ann, - HasUnique name TermUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => VarDecl tyname name uni ann -> m () - addVarDecl (VarDecl varAnn n _) = do - addDef n varAnn TermScope - addDef dataName dataAnn TermScope - addDef tyN tyAnn TypeScope - forM_ tyVarDecls addTyVarDecl - forM_ varDecls addVarDecl + TermBind _a _s (VarDecl varAnn n _) _ -> do + addDef n varAnn TermScope + TypeBind _a (TyVarDecl tyAnn tyN _) _ -> do + addDef tyN tyAnn TypeScope + DatatypeBind + _a + ( Datatype + dataAnn + (TyVarDecl tyAnn tyN _) + tyVarDecls + dataName + varDecls + ) -> do + let addTyVarDecl :: + ( Ord ann + , HasUnique tyname TypeUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + TyVarDecl tyname ann -> m () + addTyVarDecl (TyVarDecl tyVarAnn tyVarN _) = + addDef tyVarN tyVarAnn TypeScope + addVarDecl :: + ( Ord ann + , HasUnique name TermUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + VarDecl tyname name uni ann -> m () + addVarDecl (VarDecl varAnn n _) = do + addDef n varAnn TermScope + addDef dataName dataAnn TermScope + addDef tyN tyAnn TypeScope + forM_ tyVarDecls addTyVarDecl + forM_ varDecls addVarDecl -- | Given a PIR term, add all of its term and type definitions and usages, including its subterms -- and subtypes, to a global map. -termDefs - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Term tyname name uni fun ann - -> m () +termDefs :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Term tyname name uni fun ann -> + m () termDefs tm = do - forMOf_ termSubtermsDeep tm handleTerm - forMOf_ termSubtypesDeep tm handleType + forMOf_ termSubtermsDeep tm handleTerm + forMOf_ termSubtypesDeep tm handleType -handleTerm :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Term tyname name uni fun ann - -> m () +handleTerm :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Term tyname name uni fun ann -> + m () handleTerm = \case - Let _ann _r bindings _ -> - forM_ bindings addBindingDef - Var ann n -> - addUsage n ann TermScope - LamAbs ann n _ _ -> - addDef n ann TermScope - TyAbs ann tn _ _ -> - addDef tn ann TypeScope - _ -> pure () + Let _ann _r bindings _ -> + forM_ bindings addBindingDef + Var ann n -> + addUsage n ann TermScope + LamAbs ann n _ _ -> + addDef n ann TermScope + TyAbs ann tn _ _ -> + addDef tn ann TypeScope + _ -> pure () -runTermDefs - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - Monad m) - => Term tyname name uni fun ann - -> m (UniqueInfos ann, [UniqueError ann]) +runTermDefs :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , Monad m + ) => + Term tyname name uni fun ann -> + m (UniqueInfos ann, [UniqueError ann]) runTermDefs = runWriterT . flip execStateT mempty . termDefs diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Dependencies.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Dependencies.hs index eccf0c30dad..bb77d0a969c 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Dependencies.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Dependencies.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - -{- | Functions for computing the dependency graph of variables within a term or type. -A "dependency" between two nodes "A depends on B" means that B cannot be removed -from the program without also removing A. --} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +-- | Functions for computing the dependency graph of variables within a term or type. +-- A "dependency" between two nodes "A depends on B" means that B cannot be removed +-- from the program without also removing A. module PlutusIR.Analysis.Dependencies ( Node (..), DepGraph, @@ -34,35 +33,32 @@ import Data.List.NonEmpty qualified as NE import PlutusIR.Analysis.Builtins import PlutusIR.Analysis.VarInfo -{- | A node in a dependency graph. Either a specific 'PLC.Unique', or a specific -node indicating the root of the graph. We need the root node because when computing the -dependency graph of, say, a term, there will not be a binding for the term itself which -we can use to represent it in the graph. --} +-- | A node in a dependency graph. Either a specific 'PLC.Unique', or a specific +-- node indicating the root of the graph. We need the root node because when computing the +-- dependency graph of, say, a term, there will not be a binding for the term itself which +-- we can use to represent it in the graph. data Node = Variable PLC.Unique | Root deriving stock (Show, Eq, Ord) data DepCtx tyname name uni fun a = DepCtx - { _depNode :: Node + { _depNode :: Node , _depBuiltinsInfo :: BuiltinsInfo uni fun - , _depVarInfo :: VarsInfo tyname name uni a + , _depVarInfo :: VarsInfo tyname name uni a } makeLenses ''DepCtx -{- | A constraint requiring @g@ to be a 'G.Graph' (so we can compute e.g. a @Relation@ from -it), whose vertices are 'Node's. --} +-- | A constraint requiring @g@ to be a 'G.Graph' (so we can compute e.g. a @Relation@ from +-- it), whose vertices are 'Node's. type DepGraph g = (G.Graph g, G.Vertex g ~ Node) -{- | Compute the dependency graph of a 'Term'. The 'Root' node will correspond to the term itself. - -For example, the graph of @[(let (nonrec) (vardecl x t) y) [x z]]@ is -@ - ROOT -> x - ROOT -> z - x -> y - x -> t -@ --} +-- | Compute the dependency graph of a 'Term'. The 'Root' node will correspond to the term itself. +-- +-- For example, the graph of @[(let (nonrec) (vardecl x t) y) [x z]]@ is +-- @ +-- ROOT -> x +-- ROOT -> z +-- x -> y +-- x -> t +-- @ runTermDeps :: ( DepGraph g , PLC.HasUnique tyname PLC.TypeUnique @@ -160,7 +156,7 @@ bindingDeps b = case b of vinfo <- view depVarInfo evalDeps <- case strictness of Strict | not (isPure binfo vinfo rhs) -> currentDependsOn [n ^. PLC.theUnique] - _ -> pure G.empty + _ -> pure G.empty pure $ G.overlays [vDeps, tDeps, evalDeps] TypeBind _ d@(TyVarDecl _ n _) rhs -> do @@ -207,9 +203,8 @@ tyVarDeclDeps :: m g tyVarDeclDeps _ = pure G.empty -{- | Compute the dependency graph of a term. Takes an initial 'Node' indicating what the -term itself depends on (usually 'Root' if it is the real term you are interested in). --} +-- | Compute the dependency graph of a term. Takes an initial 'Node' indicating what the +-- term itself depends on (usually 'Root' if it is the real term you are interested in). termDeps :: ( DepGraph g , MonadReader (DepCtx tyname name uni fun a) m @@ -230,9 +225,8 @@ termDeps = \case tyds <- traverse typeDeps (x ^.. termSubtypes) pure $ G.overlays $ tds ++ tyds -{- | Compute the dependency graph of a type. Takes an initial 'Node' indicating what -the type itself depends on (usually 'Root' if it is the real type you are interested in). --} +-- | Compute the dependency graph of a type. Takes an initial 'Node' indicating what +-- the type itself depends on (usually 'Root' if it is the real type you are interested in). typeDeps :: (DepGraph g, MonadReader (DepCtx tyname name uni fun a) m, PLC.HasUnique tyname PLC.TypeUnique) => Type tyname uni a -> diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs index 9b3a2acda13..d67e276bac7 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs @@ -1,13 +1,13 @@ -- editorconfig-checker-disable-file {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -module PlutusIR.Analysis.RetainedSize - ( RetainedSize (..) - , AstSize (..) - , termRetentionMap - , annotateWithRetainedSize - ) where +module PlutusIR.Analysis.RetainedSize ( + RetainedSize (..), + AstSize (..), + termRetentionMap, + annotateWithRetainedSize, +) where import PlutusPrelude @@ -98,15 +98,16 @@ we know there's a bug somewhere and if it doesn't, we don't care about it. -} data RetainedSize - = Retains AstSize - | NotARetainer - deriving stock (Show) + = Retains AstSize + | NotARetainer + deriving stock (Show) instance Pretty RetainedSize where - pretty (Retains size) = "$" <> pretty size <> "$" - pretty NotARetainer = mempty + pretty (Retains size) = "$" <> pretty size <> "$" + pretty NotARetainer = mempty -- See Note [Handling the root]. + -- | The 'Int' index of the root. rootInt :: Int rootInt = -1 @@ -114,7 +115,7 @@ rootInt = -1 -- See Note [Handling the root]. nodeToInt :: Node -> Int nodeToInt (Variable (PLC.Unique i)) = i -nodeToInt Root = rootInt +nodeToInt Root = rootInt -- | A mapping from the index of a binding to what it directly retains. newtype DirectionRetentionMap = DirectionRetentionMap (IntMap AstSize) @@ -125,8 +126,10 @@ lookupSize i (DirectionRetentionMap ss) = ss IntMap.! i -- | Annotate the dominator tree with the retained size of each entry. The retained size is computed -- as the size directly retained by the binding plus the size of all its dependencies. annotateWithSizes :: DirectionRetentionMap -> Tree Int -> Tree (Int, AstSize) -annotateWithSizes sizeInfo = go where - go (Node i ts) = Node (i, sizeI) rs where +annotateWithSizes sizeInfo = go + where + go (Node i ts) = Node (i, sizeI) rs + where rs = map go ts sizeI = lookupSize i sizeInfo <> foldMap (snd . rootLabel) rs @@ -139,15 +142,15 @@ depsRetentionMap :: DirectionRetentionMap -> C.Graph Node -> IntMap AstSize depsRetentionMap sizeInfo = IntMap.fromList . flatten . annotateWithSizes sizeInfo . toDomTree -- | Construct a 'UniqueMap' having size information for each individual part of a 'Binding'. -bindingSize - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique) - => Binding tyname name uni fun ann -> PLC.UniqueMap Unique AstSize +bindingSize :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique) => + Binding tyname name uni fun ann -> PLC.UniqueMap Unique AstSize bindingSize (TermBind _ _ var term) = - UMap.insertByNameIndex var (varDeclAstSize var <> termAstSize term) mempty + UMap.insertByNameIndex var (varDeclAstSize var <> termAstSize term) mempty bindingSize (TypeBind _ tyVar ty) = - UMap.insertByNameIndex tyVar (tyVarDeclAstSize tyVar <> typeAstSize ty) mempty -bindingSize (DatatypeBind _ (Datatype _ dataDecl params matchName constrs)) - = UMap.insertByNameIndex dataDecl (tyVarDeclAstSize dataDecl) + UMap.insertByNameIndex tyVar (tyVarDeclAstSize tyVar <> typeAstSize ty) mempty +bindingSize (DatatypeBind _ (Datatype _ dataDecl params matchName constrs)) = + UMap.insertByNameIndex dataDecl (tyVarDeclAstSize dataDecl) . flip (foldr $ \param -> UMap.insertByNameIndex param $ tyVarDeclAstSize param) params . UMap.insertByNameIndex matchName (AstSize 1) . flip (foldr $ \constr -> UMap.insertByNameIndex constr $ varDeclAstSize constr) constrs @@ -155,78 +158,83 @@ bindingSize (DatatypeBind _ (Datatype _ dataDecl params matchName constrs)) -- | Construct a 'UniqueMap' having size information for each individual part of every 'Binding' -- in a term. -bindingSizes - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique) - => Term tyname name uni fun ann -> PLC.UniqueMap Unique AstSize +bindingSizes :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique) => + Term tyname name uni fun ann -> PLC.UniqueMap Unique AstSize bindingSizes (Let _ _ binds term) = foldMap bindingSize binds <> bindingSizes term -bindingSizes term = term ^. termSubterms . to bindingSizes +bindingSizes term = term ^. termSubterms . to bindingSizes -- | Same as 'bindingSizes' but is wrapped in a newtype and has a bogus entry for the root. -toDirectionRetentionMap - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique) - => Term tyname name uni fun ann -> DirectionRetentionMap +toDirectionRetentionMap :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique) => + Term tyname name uni fun ann -> DirectionRetentionMap toDirectionRetentionMap term = - DirectionRetentionMap . IntMap.insert rootInt rootSize . PLC.unUniqueMap $ bindingSizes term where - -- See Note [Handling the root]. - rootSize = AstSize (- 10 ^ (10::Int)) + DirectionRetentionMap . IntMap.insert rootInt rootSize . PLC.unUniqueMap $ bindingSizes term + where + -- See Note [Handling the root]. + rootSize = AstSize (-10 ^ (10 :: Int)) -- | Check if a 'Node' appears in 'DirectionRetentionMap'. hasSizeIn :: DirectionRetentionMap -> Node -> Bool -hasSizeIn _ Root = True +hasSizeIn _ Root = True hasSizeIn (DirectionRetentionMap ss) (Variable (PLC.Unique i)) = i `IntMap.member` ss -- | Compute the retention map of a term. -termRetentionMap - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique, ToBuiltinMeaning uni fun) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni ann - -> Term tyname name uni fun ann - -> IntMap AstSize -termRetentionMap binfo vinfo term = depsRetentionMap sizeInfo deps where +termRetentionMap :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique, ToBuiltinMeaning uni fun) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni ann -> + Term tyname name uni fun ann -> + IntMap AstSize +termRetentionMap binfo vinfo term = depsRetentionMap sizeInfo deps + where sizeInfo = toDirectionRetentionMap term deps = C.induce (hasSizeIn sizeInfo) $ runTermDeps binfo vinfo term -- | Apply a function to the annotation of each part of every 'Binding' in a term. -reannotateBindings - :: (HasUnique name TermUnique, HasUnique tyname TypeUnique) - => (Unique -> ann -> ann) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann -reannotateBindings f = goTerm where +reannotateBindings :: + (HasUnique name TermUnique, HasUnique tyname TypeUnique) => + (Unique -> ann -> ann) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann +reannotateBindings f = goTerm + where -- We don't need these helper functions anywhere else, so we make them into local definitions. goVarDecl (VarDecl ann name ty) = VarDecl (f (name ^. theUnique) ann) name ty goTyVarDecl (TyVarDecl ann tyname kind) = TyVarDecl (f (tyname ^. theUnique) ann) tyname kind goDatatype (Datatype ann dataTyDecl paramTyDecls matchName constrDecls) = - Datatype - -- We don't have any other suitable place to associate the name of the matcher with an - -- annotation, so we do it here. Fortunately, the matcher is the only thing that - -- survives erasure, so this even makes some sense. - (f (matchName ^. theUnique) ann) - (goTyVarDecl dataTyDecl) - (goTyVarDecl <$> paramTyDecls) - matchName - (goVarDecl <$> constrDecls) + Datatype + -- We don't have any other suitable place to associate the name of the matcher with an + -- annotation, so we do it here. Fortunately, the matcher is the only thing that + -- survives erasure, so this even makes some sense. + (f (matchName ^. theUnique) ann) + (goTyVarDecl dataTyDecl) + (goTyVarDecl <$> paramTyDecls) + matchName + (goVarDecl <$> constrDecls) -- Note that @goBind@ and @goTerm@ are mutually recursive. goBind (TermBind ann str var term) = TermBind ann str (goVarDecl var) $ goTerm term - goBind (TypeBind ann tyVar ty) = TypeBind ann (goTyVarDecl tyVar) ty + goBind (TypeBind ann tyVar ty) = TypeBind ann (goTyVarDecl tyVar) ty goBind (DatatypeBind ann datatype) = DatatypeBind ann $ goDatatype datatype goTerm (Let ann recy binds term) = Let ann recy (goBind <$> binds) $ goTerm term - goTerm term = term & termSubterms %~ goTerm + goTerm term = term & termSubterms %~ goTerm -- Ideally we should have a separate step putting uniques into annotations, so that we can reuse it -- both here and for scoping analysis. -- See Note [Retained size analysis] + -- | Annotate each part of every 'Binding' in a term with the size that it retains. -annotateWithRetainedSize - :: (HasUnique name TermUnique, HasUnique tyname TypeUnique, ToBuiltinMeaning uni fun) - => BuiltinsInfo uni fun - -> Term tyname name uni fun ann - -> Term tyname name uni fun RetainedSize +annotateWithRetainedSize :: + (HasUnique name TermUnique, HasUnique tyname TypeUnique, ToBuiltinMeaning uni fun) => + BuiltinsInfo uni fun -> + Term tyname name uni fun ann -> + Term tyname name uni fun RetainedSize -- @reannotateBindings@ only processes annotations "associated with" a unique, so it can't change -- the type. Therefore we need to set all the bindings to an appropriate type beforehand. -annotateWithRetainedSize binfo term = reannotateBindings (upd . unUnique) $ NotARetainer <$ term where +annotateWithRetainedSize binfo term = reannotateBindings (upd . unUnique) $ NotARetainer <$ term + where retentionMap = termRetentionMap binfo vinfo term vinfo = termVarInfo term -- If a binding is not in the retention map, then it's still a retainer, just retains zero size. diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Usages.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Usages.hs index 13735f038f4..20535953b2c 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Usages.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Usages.hs @@ -20,7 +20,7 @@ import Data.Set qualified as Set type Usages = MSet.MultiSet PLC.Unique -- | Get the usage count of @n@. -getUsageCount :: (PLC.HasUnique n unique) => n -> Usages -> Int +getUsageCount :: PLC.HasUnique n unique => n -> Usages -> Int getUsageCount n = MSet.occur (n ^. PLC.unique . coerced) -- | Get a set of @n@s which are used at least once. @@ -35,7 +35,7 @@ termUsages = multiSetOf (vTerm . PLC.theUnique <^> tvTerm . PLC.theUnique) -- TODO: move to plutus-core typeUsages :: - (PLC.HasUnique tyname PLC.TypeUnique) => + PLC.HasUnique tyname PLC.TypeUnique => Type tyname uni a -> Usages typeUsages = multiSetOf (tvTy . PLC.theUnique) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/VarInfo.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/VarInfo.hs index b496af2a194..8f5adc34e42 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/VarInfo.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Analysis/VarInfo.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} + module PlutusIR.Analysis.VarInfo where import Control.Lens hiding (Strict) @@ -26,138 +27,142 @@ instance Monoid (VarsInfo tyname name uni a) where -- | Lookup the 'VarInfo' for a 'name'. lookupVarInfo :: - (PLC.HasUnique name PLC.TermUnique) - => name - -> VarsInfo tyname name uni a - -> Maybe (VarInfo tyname name uni a) + PLC.HasUnique name PLC.TermUnique => + name -> + VarsInfo tyname name uni a -> + Maybe (VarInfo tyname name uni a) lookupVarInfo name (VarsInfo vim _) = UMap.lookupName name vim -- | Lookup the 'TyVarInfo' for a 'tyname'. lookupTyVarInfo :: - (PLC.HasUnique tyname PLC.TypeUnique) - => tyname - -> VarsInfo tyname name uni a - -> Maybe (TyVarInfo tyname name uni a) + PLC.HasUnique tyname PLC.TypeUnique => + tyname -> + VarsInfo tyname name uni a -> + Maybe (TyVarInfo tyname name uni a) lookupTyVarInfo name (VarsInfo _ vim) = UMap.lookupName name vim -- | Information about a type variable in the program. -data TyVarInfo tyname name uni a = - -- | A normal type variable, which could be anything. - NormalTyVar - -- | A type variable corresponding to a datatype. - -- Tells us the number of type variables and the constructors. - | DatatypeTyVar (Datatype tyname name uni a) - -data VarInfo tyname name uni a = - -- | A normal term variable, which could be anything. - -- Tells us if it is strictly evaluated, its type, and possibly its arity. - NormalVar Strictness (Type tyname uni a) (Maybe Arity) - -- | A term variable corresponding to a datatype constructor. - -- Tells us the index of the constructor and the name of the datatype that owns it. - | DatatypeConstructor Int tyname - -- | A term variable corresponding to a datatype matcher. - -- Tells us the name of the datatype that owns it. - | DatatypeMatcher tyname +data TyVarInfo tyname name uni a + = -- | A normal type variable, which could be anything. + NormalTyVar + | -- | A type variable corresponding to a datatype. + -- Tells us the number of type variables and the constructors. + DatatypeTyVar (Datatype tyname name uni a) + +data VarInfo tyname name uni a + = -- | A normal term variable, which could be anything. + -- Tells us if it is strictly evaluated, its type, and possibly its arity. + NormalVar Strictness (Type tyname uni a) (Maybe Arity) + | -- | A term variable corresponding to a datatype constructor. + -- Tells us the index of the constructor and the name of the datatype that owns it. + DatatypeConstructor Int tyname + | -- | A term variable corresponding to a datatype matcher. + -- Tells us the name of the datatype that owns it. + DatatypeMatcher tyname varInfoStrictness :: VarInfo tyname name uni a -> Strictness varInfoStrictness = \case - NormalVar s _ _ -> s - DatatypeConstructor{} -> Strict - DatatypeMatcher{} -> Strict + NormalVar s _ _ -> s + DatatypeConstructor {} -> Strict + DatatypeMatcher {} -> Strict varInfoArity :: - (PLC.HasUnique tyname PLC.TypeUnique) - => VarInfo tyname name uni a - -> VarsInfo tyname name uni a - -> Maybe Arity + PLC.HasUnique tyname PLC.TypeUnique => + VarInfo tyname name uni a -> + VarsInfo tyname name uni a -> + Maybe Arity varInfoArity vinfo vinfos = case vinfo of - NormalVar _ _ a -> a + NormalVar _ _ a -> a DatatypeConstructor i dtName -> case lookupTyVarInfo dtName vinfos of Just (DatatypeTyVar dt) -> datatypeConstructorArity i dt - _ -> Nothing - DatatypeMatcher dtName -> case lookupTyVarInfo dtName vinfos of + _ -> Nothing + DatatypeMatcher dtName -> case lookupTyVarInfo dtName vinfos of Just (DatatypeTyVar dt) -> Just $ datatypeMatcherArity dt - _ -> Nothing + _ -> Nothing termVarInfo :: - (PLC.HasUnique name PLC.TermUnique - , PLC.HasUnique tyname PLC.TypeUnique) - => Term tyname name uni fun a - -> VarsInfo tyname name uni a + ( PLC.HasUnique name PLC.TermUnique + , PLC.HasUnique tyname PLC.TypeUnique + ) => + Term tyname name uni fun a -> + VarsInfo tyname name uni a termVarInfo = \case - Let _ _ bs t -> foldMap bindingVarInfo bs <> termVarInfo t + Let _ _ bs t -> foldMap bindingVarInfo bs <> termVarInfo t LamAbs _ n ty t -> VarsInfo (UMap.insertByName n (NormalVar Strict ty Nothing) mempty) mempty - <> termVarInfo t - TyAbs _ n _ t -> + <> termVarInfo t + TyAbs _ n _ t -> VarsInfo mempty (UMap.insertByName n NormalTyVar mempty) - <> termVarInfo t + <> termVarInfo t -- No binders - t@(Apply{}) -> foldMapOf termSubterms termVarInfo t - t@(TyInst{}) -> foldMapOf termSubterms termVarInfo t - t@(IWrap{}) -> foldMapOf termSubterms termVarInfo t - t@(Unwrap{}) -> foldMapOf termSubterms termVarInfo t - t@(Constr{}) -> foldMapOf termSubterms termVarInfo t - t@(Case{}) -> foldMapOf termSubterms termVarInfo t - t@(Var{}) -> foldMapOf termSubterms termVarInfo t - t@(Constant{}) -> foldMapOf termSubterms termVarInfo t - t@(Error{}) -> foldMapOf termSubterms termVarInfo t - t@(Builtin{}) -> foldMapOf termSubterms termVarInfo t + t@(Apply {}) -> foldMapOf termSubterms termVarInfo t + t@(TyInst {}) -> foldMapOf termSubterms termVarInfo t + t@(IWrap {}) -> foldMapOf termSubterms termVarInfo t + t@(Unwrap {}) -> foldMapOf termSubterms termVarInfo t + t@(Constr {}) -> foldMapOf termSubterms termVarInfo t + t@(Case {}) -> foldMapOf termSubterms termVarInfo t + t@(Var {}) -> foldMapOf termSubterms termVarInfo t + t@(Constant {}) -> foldMapOf termSubterms termVarInfo t + t@(Error {}) -> foldMapOf termSubterms termVarInfo t + t@(Builtin {}) -> foldMapOf termSubterms termVarInfo t datatypeMatcherArity :: Datatype tyname uni fun a -> Arity -datatypeMatcherArity (Datatype _ _ tyvars _ constrs)= +datatypeMatcherArity (Datatype _ _ tyvars _ constrs) = -- One parameter for all the datatype type variables fmap (const TypeParam) tyvars - -- The scrutineee, and then a type paramter for the result type - ++ [TermParam, TypeParam] - -- One parameter with the case for each constructor - ++ fmap (const TermParam) constrs + -- The scrutineee, and then a type paramter for the result type + ++ [TermParam, TypeParam] + -- One parameter with the case for each constructor + ++ fmap (const TermParam) constrs datatypeConstructorArity :: Int -> Datatype tyname uni fun a -> Maybe Arity datatypeConstructorArity i (Datatype _ _ tyvars _ constrs) = case constrs !? i of - Just (VarDecl _ _ constrTy) -> Just $ - -- One type parameter for all of the datatype type parameters - fmap (const TypeParam) tyvars - -- One term parameter for all the constructor function type arguments - ++ fmap (const TermParam) (funTyArgs constrTy) + Just (VarDecl _ _ constrTy) -> + Just $ + -- One type parameter for all of the datatype type parameters + fmap (const TypeParam) tyvars + -- One term parameter for all the constructor function type arguments + ++ fmap (const TermParam) (funTyArgs constrTy) _ -> Nothing bindingVarInfo :: - (PLC.HasUnique name PLC.TermUnique - , PLC.HasUnique tyname PLC.TypeUnique) - => Binding tyname name uni fun a - -> VarsInfo tyname name uni a + ( PLC.HasUnique name PLC.TermUnique + , PLC.HasUnique tyname PLC.TypeUnique + ) => + Binding tyname name uni fun a -> + VarsInfo tyname name uni a bindingVarInfo = \case -- TODO: arity for term bindings TermBind _ s (VarDecl _ n ty) t -> VarsInfo (UMap.insertByName n (NormalVar s ty Nothing) mempty) mempty - <> termVarInfo t + <> termVarInfo t TypeBind _ (TyVarDecl _ n _) _ -> VarsInfo mempty (UMap.insertByName n NormalTyVar mempty) DatatypeBind _ d@(Datatype _ (TyVarDecl _ tyname _) _ matcher constrs) -> let dtInfo = let info = DatatypeTyVar d - in VarsInfo mempty (UMap.insertByName tyname info mempty) + in VarsInfo mempty (UMap.insertByName tyname info mempty) matcherInfo = let info = DatatypeMatcher tyname - in VarsInfo (UMap.insertByName matcher info mempty) mempty + in VarsInfo (UMap.insertByName matcher info mempty) mempty constrInfo i (VarDecl _ n _) = let info = DatatypeConstructor i tyname - in VarsInfo (UMap.insertByName n info mempty) mempty - in dtInfo <> matcherInfo <> ifoldMap constrInfo constrs + in VarsInfo (UMap.insertByName n info mempty) mempty + in + dtInfo <> matcherInfo <> ifoldMap constrInfo constrs -- | Get the arities of the constructors for the given datatype name. -getConstructorArities - :: (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) - => tyname - -> VarsInfo tyname name uni a - -> Maybe [Arity] -getConstructorArities tn vinfo | - Just (DatatypeTyVar (Datatype _ _ _ _ constrs)) <- lookupTyVarInfo tn vinfo +getConstructorArities :: + (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => + tyname -> + VarsInfo tyname name uni a -> + Maybe [Arity] +getConstructorArities tn vinfo + | Just (DatatypeTyVar (Datatype _ _ _ _ constrs)) <- lookupTyVarInfo tn vinfo , Just constrArities <- for constrs $ \c -> do cInfo <- lookupVarInfo (_varDeclName c) vinfo - varInfoArity cInfo vinfo - = Just constrArities + varInfoArity cInfo vinfo = + Just constrArities | otherwise = Nothing diff --git a/plutus-core/plutus-ir/src/PlutusIR/Check/Uniques.hs b/plutus-core/plutus-ir/src/PlutusIR/Check/Uniques.hs index 8d63119d161..71a0fe81c1c 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Check/Uniques.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Check/Uniques.hs @@ -1,8 +1,8 @@ -module PlutusIR.Check.Uniques - ( checkProgram - , checkTerm - , UniqueError (..) - ) where +module PlutusIR.Check.Uniques ( + checkProgram, + checkTerm, + UniqueError (..), +) where import PlutusCore.Error import PlutusCore.Name.Unique @@ -14,24 +14,26 @@ import Control.Monad.Except (MonadError, throwError) import Data.Foldable -checkProgram - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadError (UniqueError ann) m) - => (UniqueError ann -> Bool) - -> Program tyname name uni fun ann - -> m () +checkProgram :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadError (UniqueError ann) m + ) => + (UniqueError ann -> Bool) -> + Program tyname name uni fun ann -> + m () checkProgram p (Program _ _ t) = checkTerm p t -checkTerm - :: (Ord ann, - HasUnique name TermUnique, - HasUnique tyname TypeUnique, - MonadError (UniqueError ann) m) - => (UniqueError ann -> Bool) - -> Term tyname name uni fun ann - -> m () +checkTerm :: + ( Ord ann + , HasUnique name TermUnique + , HasUnique tyname TypeUnique + , MonadError (UniqueError ann) m + ) => + (UniqueError ann -> Bool) -> + Term tyname name uni fun ann -> + m () checkTerm p t = do - (_, errs) <- runTermDefs t - for_ errs $ \e -> when (p e) $ throwError e + (_, errs) <- runTermDefs t + for_ errs $ \e -> when (p e) $ throwError e diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs index 82a540db4cd..f84a5810a15 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs @@ -1,56 +1,57 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + module PlutusIR.Compiler ( - compileProgram, - compileToReadable, - compileReadableToPlc, - Compiling, - Error (..), - Provenance (..), - DatatypeComponent (..), - noProvenance, - CompilationOpts (..), - coOptimize, - coTypecheck, - coPedantic, - coVerbose, - coDebug, - coMaxSimplifierIterations, - coDoSimplifierUnwrapCancel, - coDoSimplifierBeta, - coDoSimplifierInline, - coDoSimplifierEvaluateBuiltins, - coDoSimplifierStrictifyBindings, - coDoSimplifierRewrite, - coDoSimplifierKnownCon, - coInlineConstants, - coInlineFix, - coInlineHints, - coInlineCallsiteGrowth, - coProfile, - coRelaxedFloatin, - coCaseOfCaseConservative, - coPreserveLogging, - coDatatypes, - dcoStyle, - DatatypeStyle (..), - defaultCompilationOpts, - CompilationCtx, - ccOpts, - ccEnclosing, - ccTypeCheckConfig, - ccBuiltinsInfo, - ccBuiltinCostModel, - PirTCConfig(..), - AllowEscape(..), - toDefaultCompilationCtx, - runCompilerPass, - simplifier - ) where + compileProgram, + compileToReadable, + compileReadableToPlc, + Compiling, + Error (..), + Provenance (..), + DatatypeComponent (..), + noProvenance, + CompilationOpts (..), + coOptimize, + coTypecheck, + coPedantic, + coVerbose, + coDebug, + coMaxSimplifierIterations, + coDoSimplifierUnwrapCancel, + coDoSimplifierBeta, + coDoSimplifierInline, + coDoSimplifierEvaluateBuiltins, + coDoSimplifierStrictifyBindings, + coDoSimplifierRewrite, + coDoSimplifierKnownCon, + coInlineConstants, + coInlineFix, + coInlineHints, + coInlineCallsiteGrowth, + coProfile, + coRelaxedFloatin, + coCaseOfCaseConservative, + coPreserveLogging, + coDatatypes, + dcoStyle, + DatatypeStyle (..), + defaultCompilationOpts, + CompilationCtx, + ccOpts, + ccEnclosing, + ccTypeCheckConfig, + ccBuiltinsInfo, + ccBuiltinCostModel, + PirTCConfig (..), + AllowEscape (..), + toDefaultCompilationCtx, + runCompilerPass, + simplifier, +) where import Control.Lens import Control.Monad @@ -109,11 +110,14 @@ floatOutPasses = do optimize <- view (ccOpts . coOptimize) tcconfig <- view ccTypeCheckConfig binfo <- view ccBuiltinsInfo - pure $ mwhen optimize $ P.NamedPass "float-out" $ fold - [ LetFloatOut.floatTermPassSC tcconfig binfo - , RecSplit.recSplitPass tcconfig - , LetMerge.letMergePass tcconfig - ] + pure $ + mwhen optimize $ + P.NamedPass "float-out" $ + fold + [ LetFloatOut.floatTermPassSC tcconfig binfo + , RecSplit.recSplitPass tcconfig + , LetMerge.letMergePass tcconfig + ] floatInPasses :: Compiling m uni fun a => m (P.Pass m TyName Name uni fun (Provenance a)) floatInPasses = do @@ -121,10 +125,13 @@ floatInPasses = do tcconfig <- view ccTypeCheckConfig binfo <- view ccBuiltinsInfo relaxed <- view (ccOpts . coRelaxedFloatin) - pure $ mwhen optimize $ P.NamedPass "float-in" $ fold - [ LetFloatIn.floatTermPassSC tcconfig binfo relaxed - , LetMerge.letMergePass tcconfig - ] + pure $ + mwhen optimize $ + P.NamedPass "float-in" $ + fold + [ LetFloatIn.floatTermPassSC tcconfig binfo relaxed + , LetMerge.letMergePass tcconfig + ] simplifierIteration :: Compiling m uni fun a => String -> m (P.Pass m TyName Name uni fun (Provenance a)) simplifierIteration suffix = do @@ -138,16 +145,18 @@ simplifierIteration suffix = do ic <- view (ccOpts . coInlineConstants) thresh <- view (ccOpts . coInlineCallsiteGrowth) - pure $ P.NamedPass ("simplifier" ++ suffix) $ fold - [ mwhen (opts ^. coDoSimplifierUnwrapCancel) $ Unwrap.unwrapCancelPass tcconfig - , mwhen (opts ^. coDoSimplifierCaseReduce) $ CaseReduce.caseReducePass tcconfig - , mwhen (opts ^. coDoSimplifierKnownCon) $ KnownCon.knownConPassSC tcconfig - , mwhen (opts ^. coDoSimplifierBeta) $ Beta.betaPassSC tcconfig - , mwhen (opts ^. coDoSimplifierStrictifyBindings ) $ StrictifyBindings.strictifyBindingsPass tcconfig binfo - , mwhen (opts ^. coDoSimplifierEvaluateBuiltins) $ EvaluateBuiltins.evaluateBuiltinsPass tcconfig preserveLogging binfo costModel - , mwhen (opts ^. coDoSimplifierInline) $ Inline.inlinePassSC thresh ic tcconfig hints binfo - , mwhen (opts ^. coDoSimplifierRewrite) $ RewriteRules.rewritePassSC tcconfig rules - ] + pure $ + P.NamedPass ("simplifier" ++ suffix) $ + fold + [ mwhen (opts ^. coDoSimplifierUnwrapCancel) $ Unwrap.unwrapCancelPass tcconfig + , mwhen (opts ^. coDoSimplifierCaseReduce) $ CaseReduce.caseReducePass tcconfig + , mwhen (opts ^. coDoSimplifierKnownCon) $ KnownCon.knownConPassSC tcconfig + , mwhen (opts ^. coDoSimplifierBeta) $ Beta.betaPassSC tcconfig + , mwhen (opts ^. coDoSimplifierStrictifyBindings) $ StrictifyBindings.strictifyBindingsPass tcconfig binfo + , mwhen (opts ^. coDoSimplifierEvaluateBuiltins) $ EvaluateBuiltins.evaluateBuiltinsPass tcconfig preserveLogging binfo costModel + , mwhen (opts ^. coDoSimplifierInline) $ Inline.inlinePassSC thresh ic tcconfig hints binfo + , mwhen (opts ^. coDoSimplifierRewrite) $ RewriteRules.rewritePassSC tcconfig rules + ] simplifier :: Compiling m uni fun a => m (P.Pass m TyName Name uni fun (Provenance a)) simplifier = do @@ -157,7 +166,7 @@ simplifier = do pure $ mwhen optimize $ P.NamedPass "simplifier" (fold passes) -- | Typecheck a PIR Term iff the context demands it. -typeCheckTerm :: (Compiling m uni fun a) => m (P.Pass m TyName Name uni fun (Provenance a)) +typeCheckTerm :: Compiling m uni fun a => m (P.Pass m TyName Name uni fun (Provenance a)) typeCheckTerm = do doTc <- view (ccOpts . coTypecheck) tcconfig <- view ccTypeCheckConfig @@ -175,11 +184,11 @@ dce = do -- | The 1st half of the PIR compiler pipeline up to floating/merging the lets. -- We stop momentarily here to give a chance to the tx-plugin -- to dump a "readable" version of pir (i.e. floated). -compileToReadable - :: forall m uni fun a b - . (Compiling m uni fun a, b ~ Provenance a) - => Program TyName Name uni fun b - -> m (Program TyName Name uni fun b) +compileToReadable :: + forall m uni fun a b. + (Compiling m uni fun a, b ~ Provenance a) => + Program TyName Name uni fun b -> + m (Program TyName Name uni fun b) compileToReadable (Program a v t) = do validateOpts v let pipeline :: m (P.Pass m TyName Name uni fun b) @@ -189,41 +198,44 @@ compileToReadable (Program a v t) = do -- | The 2nd half of the PIR compiler pipeline. -- Compiles a 'Term' into a PLC Term, by removing/translating step-by-step the PIR's language constructs to PLC. -- Note: the result *does* have globally unique names. -compileReadableToPlc :: forall m uni fun a b . (Compiling m uni fun a, b ~ Provenance a) => Program TyName Name uni fun b -> m (PLCProgram uni fun a) +compileReadableToPlc :: forall m uni fun a b. (Compiling m uni fun a, b ~ Provenance a) => Program TyName Name uni fun b -> m (PLCProgram uni fun a) compileReadableToPlc (Program a v t) = do - let pipeline :: m (P.Pass m TyName Name uni fun b) - pipeline = ala Ap foldMap + pipeline = + ala + Ap + foldMap [ floatInPasses , NonStrict.compileNonStrictBindingsPassSC <$> view ccTypeCheckConfig <*> pure False , ThunkRec.thunkRecursionsPass <$> view ccTypeCheckConfig <*> view ccBuiltinsInfo - -- Process only the non-strict bindings created by 'thunkRecursions' with unit delay/forces - -- See Note [Using unit versus force/delay] - , NonStrict.compileNonStrictBindingsPassSC <$> view ccTypeCheckConfig <*> pure True + , -- Process only the non-strict bindings created by 'thunkRecursions' with unit delay/forces + -- See Note [Using unit versus force/delay] + NonStrict.compileNonStrictBindingsPassSC <$> view ccTypeCheckConfig <*> pure True , Let.compileLetsPassSC <$> view ccTypeCheckConfig <*> pure Let.DataTypes , Let.compileLetsPassSC <$> view ccTypeCheckConfig <*> pure Let.RecTerms - -- We introduce some non-recursive let bindings while eliminating recursive let-bindings, - -- so we can eliminate any of them which are unused here. - , dce + , -- We introduce some non-recursive let bindings while eliminating recursive let-bindings, + -- so we can eliminate any of them which are unused here. + dce , simplifier , Let.compileLetsPassSC <$> view ccTypeCheckConfig <*> pure Let.Types , Let.compileLetsPassSC <$> view ccTypeCheckConfig <*> pure Let.NonRecTerms ] go = - runCompilerPass pipeline + runCompilerPass pipeline >=> (<$ logVerbose " !!! lowerTerm") >=> lowerTerm PLC.Program a v <$> go t --- | Compile a 'Program' into a PLC Program. Note: the result *does* have globally unique names. -compileProgram :: Compiling m uni fun a - => Program TyName Name uni fun a -> m (PLCProgram uni fun a) +compileProgram :: + Compiling m uni fun a => + Program TyName Name uni fun a -> m (PLCProgram uni fun a) compileProgram = (pure . original) - >=> (<$ logDebug "!!! compileToReadable") - >=> compileToReadable - >=> (<$ logDebug "!!! compileReadableToPlc") - >=> compileReadableToPlc + >=> (<$ logDebug "!!! compileToReadable") + >=> compileToReadable + >=> (<$ logDebug "!!! compileReadableToPlc") + >=> compileReadableToPlc diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Datatype.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Datatype.hs index dcdf3989e51..423444677dd 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Datatype.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Datatype.hs @@ -1,19 +1,20 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + -- | Functions for compiling let-bound PIR datatypes into PLC. -module PlutusIR.Compiler.Datatype - ( compileDatatype - , compileDatatypeDefs - , compileRecDatatypes - , mkDatatypeValueType - , mkDestructorTy - , mkScottTy - , resultTypeName - ) where +module PlutusIR.Compiler.Datatype ( + compileDatatype, + compileDatatypeDefs, + compileRecDatatypes, + mkDatatypeValueType, + mkDestructorTy, + mkScottTy, + resultTypeName, +) where import PlutusPrelude (showText) @@ -316,53 +317,52 @@ For a (self-)recursive datatype we have to change three things: -} -- See Note [Encoding of datatypes] + -- | Make the "Scott-encoded" type for a 'Datatype', with type variables free. -- This is exactly the type of an eliminator function for the datatype. -- -- @mkScottTy Maybe = forall out_Maybe. out_Maybe -> (a -> out_Maybe) -> out_Maybe@ mkScottTy :: MonadQuote m => ann -> Datatype TyName Name uni ann -> m (Type TyName uni ann) mkScottTy ann d@(Datatype _ _ _ _ constrs) = do - res <- resultTypeName d - -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1875): - -- normalize datacons' types also here - let caseTys = fmap (constructorCaseType ann (TyVar ann res)) constrs - pure $ - -- forall res. - TyForall ann res (Type ann) $ + res <- resultTypeName d + -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1875): + -- normalize datacons' types also here + let caseTys = fmap (constructorCaseType ann (TyVar ann res)) constrs + pure $ + -- forall res. + TyForall ann res (Type ann) $ -- c_1 -> .. -> c_n -> res PIR.mkIterTyFun ann caseTys (TyVar ann res) mkDatatypeSOPTy :: ann -> Datatype TyName Name uni ann -> Type TyName uni ann mkDatatypeSOPTy ann (Datatype _ _ _ _ constrs) = TySOP ann (fmap constructorArgTypes constrs) -{- | Make the body of the "pattern functor" of a 'Datatype'. This is just the non-abstract datatype type, -but with the type variable for the type itself free and its type variables free. - -Scott: @mkPatternFunctorBody List = forall (out_List :: *) . out_List -> (a -> List a -> out_List) -> out_List@ -SOPs: @mkPatternFunctorBody List = sop [] [a, List a]@ --} +-- | Make the body of the "pattern functor" of a 'Datatype'. This is just the non-abstract datatype type, +-- but with the type variable for the type itself free and its type variables free. +-- +-- Scott: @mkPatternFunctorBody List = forall (out_List :: *) . out_List -> (a -> List a -> out_List) -> out_List@ +-- SOPs: @mkPatternFunctorBody List = sop [] [a, List a]@ mkPatternFunctorBody :: MonadQuote m => DatatypeCompilationOpts -> ann -> Datatype TyName Name uni ann -> m (Type TyName uni ann) mkPatternFunctorBody opts ann d = case _dcoStyle opts of - ScottEncoding -> mkScottTy ann d + ScottEncoding -> mkScottTy ann d SumsOfProducts -> pure $ mkDatatypeSOPTy ann d - BuiltinCasing -> pure $ mkDatatypeSOPTy ann d - -{- | Make the real PLC type corresponding to a 'Datatype' with the given pattern functor body. - -Scott: -@ - mkDatatypeType List - = fix (\(List :: * -> *) (a :: *) -> ) - = fix (\(List :: * -> *) (a :: *) -> forall (r :: *) . r -> (a -> List a -> r) -> r) -@ - -SOPs: -@ - mkDatatypeType List - = fix (\(List :: * -> *) (a :: *) -> ) - = fix (\(List :: * -> *) (a :: *) -> \(a :: *) -> sop [] [a, List a]) -@ --} + BuiltinCasing -> pure $ mkDatatypeSOPTy ann d + +-- | Make the real PLC type corresponding to a 'Datatype' with the given pattern functor body. +-- +-- Scott: +-- @ +-- mkDatatypeType List +-- = fix (\(List :: * -> *) (a :: *) -> ) +-- = fix (\(List :: * -> *) (a :: *) -> forall (r :: *) . r -> (a -> List a -> r) -> r) +-- @ +-- +-- SOPs: +-- @ +-- mkDatatypeType List +-- = fix (\(List :: * -> *) (a :: *) -> ) +-- = fix (\(List :: * -> *) (a :: *) -> \(a :: *) -> sop [] [a, List a]) +-- @ mkDatatypeType :: forall m uni fun a. MonadQuote m => DatatypeCompilationOpts -> Recursivity -> Datatype TyName Name uni (Provenance a) -> m (PLCRecType uni fun a) mkDatatypeType opts r d@(Datatype ann tn tvs _ _) = do pf <- mkPatternFunctorBody opts ann d @@ -371,21 +371,20 @@ mkDatatypeType opts r d@(Datatype ann tn tvs _ _) = do -- See Note [Recursive datatypes] -- We are reusing the same type name for the fixpoint variable. This is fine -- so long as we do renaming later, since we only reuse the name inside an inner binder - Rec -> do - RecursiveType <$> (liftQuote $ Types.makeRecursiveType @uni @(Provenance a) ann (_tyVarDeclName tn) tvs pf) + Rec -> do + RecursiveType <$> (liftQuote $ Types.makeRecursiveType @uni @(Provenance a) ann (_tyVarDeclName tn) tvs pf) -- | The type of a datatype-value is of the form `[TyCon tyarg1 tyarg2 ... tyargn]` mkDatatypeValueType :: a -> Datatype TyName Name uni a -> Type TyName uni a -mkDatatypeValueType ann (Datatype _ tn tvs _ _) = PIR.mkIterTyApp (PIR.mkTyVar ann tn) $ (ann,) . PIR.mkTyVar ann <$> tvs +mkDatatypeValueType ann (Datatype _ tn tvs _ _) = PIR.mkIterTyApp (PIR.mkTyVar ann tn) $ (ann,) . PIR.mkTyVar ann <$> tvs -- Constructors -{- | Make the type of a constructor of a 'Datatype'. This is not quite the same as the declared type because the declared type has the -type variables free. -@ - mkConstructorType List Cons = forall (a :: *) . a -> List a -> List a -@ --} +-- | Make the type of a constructor of a 'Datatype'. This is not quite the same as the declared type because the declared type has the +-- type variables free. +-- @ +-- mkConstructorType List Cons = forall (a :: *) . a -> List a -> List a +-- @ mkConstructorType :: Datatype TyName Name uni (Provenance a) -> VarDecl TyName Name uni (Provenance a) -> PIRType uni a -- this type appears *inside* the scope of the abstraction for the datatype so we can just reference the name and -- we don't need to do anything to the declared type @@ -394,147 +393,148 @@ mkConstructorType :: Datatype TyName Name uni (Provenance a) -> VarDecl TyName N mkConstructorType (Datatype _ _ tvs _ _) constr = PIR.mkIterTyForall tvs $ _varDeclType constr -- See Note [Encoding of datatypes] -{- | Make a constructor of a 'Datatype' with the given pattern functor. The constructor argument mostly serves to identify the constructor -that we are interested in in the list of constructors. - -Scott: -@ - mkConstructor List Cons - = /\(a :: *) . \(x : a) (xs : a) . - wrap /\(out_List :: *) . - \(case_Nil : out_List) (case_Cons : a -> List a -> out_List) . case_Cons arg1 arg2 -@ - -SOPs: -@ - mkConstructor List Cons - = /\(a :: *) . \(x : a) (xs : a) . - wrap - constr ((\(List :: * -> *) . ) ) arg1 arg2 -@ --} + +-- | Make a constructor of a 'Datatype' with the given pattern functor. The constructor argument mostly serves to identify the constructor +-- that we are interested in in the list of constructors. +-- +-- Scott: +-- @ +-- mkConstructor List Cons +-- = /\(a :: *) . \(x : a) (xs : a) . +-- wrap /\(out_List :: *) . +-- \(case_Nil : out_List) (case_Cons : a -> List a -> out_List) . case_Cons arg1 arg2 +-- @ +-- +-- SOPs: +-- @ +-- mkConstructor List Cons +-- = /\(a :: *) . \(x : a) (xs : a) . +-- wrap +-- constr ((\(List :: * -> *) . ) ) arg1 arg2 +-- @ mkConstructor :: MonadQuote m => DatatypeCompilationOpts -> PLCRecType uni fun a -> Datatype TyName Name uni (Provenance a) -> Word64 -> m (PIRTerm uni fun a) mkConstructor opts dty d@(Datatype ann _ tvs _ constrs) index = do - -- This is inelegant, but it should never fail - let thisConstr = constrs !! fromIntegral index + -- This is inelegant, but it should never fail + let thisConstr = constrs !! fromIntegral index - -- constructor args and their types - argsAndTypes <- do + -- constructor args and their types + argsAndTypes <- do + -- these types appear *outside* the scope of the abstraction for the datatype, so we need to use the concrete datatype here + -- see Note [Abstract data types] + -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1875): normalize datacons' types also here + let argTypes = unveilDatatype (getType dty) d <$> constructorArgTypes thisConstr + -- we don't have any names for these things, we just had the type, so we call them "arg_i + argNames <- for [0 .. (length argTypes - 1)] (\i -> safeFreshName $ "arg_" <> showText i) + pure $ zipWith (VarDecl ann) argNames argTypes + + constrBody <- case _dcoStyle opts of + style | style == SumsOfProducts || style == BuiltinCasing -> do + -- We have to be a bit careful annotating the type of the constr. It is inside the 'wrap' so it + -- needs to be one level "unrolled". + + -- The pattern functor with a hole in it + pf <- mkPatternFunctorBody opts ann d + -- ... and with the hole filled in with the datatype type + let unrolled = unveilDatatype (getType dty) d pf + + pure $ Constr ann unrolled index (fmap PIR.mkVar argsAndTypes) + _ScottEncoding -> do + resultType <- resultTypeName d + + -- case arguments and their types + casesAndTypes <- do -- these types appear *outside* the scope of the abstraction for the datatype, so we need to use the concrete datatype here -- see Note [Abstract data types] -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1875): normalize datacons' types also here - let argTypes = unveilDatatype (getType dty) d <$> constructorArgTypes thisConstr - -- we don't have any names for these things, we just had the type, so we call them "arg_i - argNames <- for [0..(length argTypes -1)] (\i -> safeFreshName $ "arg_" <> showText i) - pure $ zipWith (VarDecl ann) argNames argTypes - - constrBody <- case _dcoStyle opts of - style | style == SumsOfProducts || style == BuiltinCasing -> do - -- We have to be a bit careful annotating the type of the constr. It is inside the 'wrap' so it - -- needs to be one level "unrolled". - - -- The pattern functor with a hole in it - pf <- mkPatternFunctorBody opts ann d - -- ... and with the hole filled in with the datatype type - let unrolled = unveilDatatype (getType dty) d pf - - pure $ Constr ann unrolled index (fmap PIR.mkVar argsAndTypes) - _ScottEncoding -> do - resultType <- resultTypeName d - - -- case arguments and their types - casesAndTypes <- do - -- these types appear *outside* the scope of the abstraction for the datatype, so we need to use the concrete datatype here - -- see Note [Abstract data types] - -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1875): normalize datacons' types also here - let caseTypes = unveilDatatype (getType dty) d <$> fmap (constructorCaseType ann (TyVar ann resultType)) constrs - caseArgNames <- for constrs (\c -> safeFreshName $ "case_" <> T.pack (varDeclNameString c)) - pure $ zipWith (VarDecl ann) caseArgNames caseTypes - - -- This is inelegant, but it should never fail - let thisCase = PIR.mkVar $ casesAndTypes !! fromIntegral index - - pure $ - -- forall out - TyAbs ann resultType (Type ann) $ - -- \case_1 .. case_j - PIR.mkIterLamAbs casesAndTypes $ - -- c_i arg_1 .. arg_m - PIR.mkIterApp thisCase (fmap ((ann,) . PIR.mkVar) argsAndTypes) - - let constr = - -- /\t_1 .. t_n - PIR.mkIterTyAbs tvs $ - -- \arg_1 .. arg_m - PIR.mkIterLamAbs argsAndTypes $ + let caseTypes = unveilDatatype (getType dty) d <$> fmap (constructorCaseType ann (TyVar ann resultType)) constrs + caseArgNames <- for constrs (\c -> safeFreshName $ "case_" <> T.pack (varDeclNameString c)) + pure $ zipWith (VarDecl ann) caseArgNames caseTypes + + -- This is inelegant, but it should never fail + let thisCase = PIR.mkVar $ casesAndTypes !! fromIntegral index + + pure $ + -- forall out + TyAbs ann resultType (Type ann) $ + -- \case_1 .. case_j + PIR.mkIterLamAbs casesAndTypes $ + -- c_i arg_1 .. arg_m + PIR.mkIterApp thisCase (fmap ((ann,) . PIR.mkVar) argsAndTypes) + + let constr = + -- /\t_1 .. t_n + PIR.mkIterTyAbs tvs $ + -- \arg_1 .. arg_m + PIR.mkIterLamAbs argsAndTypes $ -- See Note [Recursive datatypes] -- wrap wrap ann dty (fmap (PIR.mkTyVar ann) tvs) constrBody - pure $ fmap (\a -> DatatypeComponent Constructor a) constr + pure $ fmap (\a -> DatatypeComponent Constructor a) constr -- Destructors -- See Note [Encoding of datatypes] -{- | Make the destructor for a 'Datatype'. - -Scott: -@ - mkDestructor List - = /\(a :: *) -> \(x : ( a)) -> unwrap x -@ - -SOPs: -@ - mkDestructor List - = /\(a :: *) -> \(x : ( a)) -> - /\(r :: *) -> - \(case_Nil :: r) (case_Cons :: a -> ( a) -> r) -> case r (unwrap x) case_Nil case_Cons -@ --} + +-- | Make the destructor for a 'Datatype'. +-- +-- Scott: +-- @ +-- mkDestructor List +-- = /\(a :: *) -> \(x : ( a)) -> unwrap x +-- @ +-- +-- SOPs: +-- @ +-- mkDestructor List +-- = /\(a :: *) -> \(x : ( a)) -> +-- /\(r :: *) -> +-- \(case_Nil :: r) (case_Cons :: a -> ( a) -> r) -> case r (unwrap x) case_Nil case_Cons +-- @ mkDestructor :: MonadQuote m => DatatypeCompilationOpts -> PLCRecType uni fun a -> Datatype TyName Name uni (Provenance a) -> m (PIRTerm uni fun a) mkDestructor opts dty d@(Datatype ann _ tvs _ constrs) = do - -- This term appears *outside* the scope of the abstraction for the datatype, so we need to put in the Scott-encoded type here - -- see Note [Abstract data types] - -- dty t_1 .. t_n - let appliedReal = PIR.mkIterTyApp (getType dty) (fmap ((ann,) . PIR.mkTyVar ann) tvs) - - xn <- safeFreshName "x" - - destrBody <- case _dcoStyle opts of - style | style == SumsOfProducts || style == BuiltinCasing -> do - resultType <- resultTypeName d - -- Variables for case arguments, and the bodies to be used as the actual cases - caseVars <- for constrs $ \c -> do - -- these types appear *outside* the scope of the abstraction for the datatype, so we need to use the concrete datatype here - -- see Note [Abstract data types] - -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1875): normalize datacons' types also here - let caseType = constructorCaseType ann (TyVar ann resultType) c - unveiledCaseType = unveilDatatype (getType dty) d caseType - caseArgName <- safeFreshName $ "case_" <> T.pack (varDeclNameString c) - pure $ VarDecl ann caseArgName unveiledCaseType - pure $ - -- forall out - TyAbs ann resultType (Type ann) $ - -- \case_1 .. case_j - PIR.mkIterLamAbs caseVars $ - -- See Note [Recursive datatypes] - -- case (unwrap x) case_1 .. case_j - Case ann (TyVar ann resultType) (unwrap ann dty $ Var ann xn) (fmap PIR.mkVar caseVars) - _ScottEncoding -> - pure $ - -- See Note [Recursive datatypes] - -- unwrap - unwrap ann dty $ - Var ann xn - - let destr = - -- /\t_1 .. t_n - PIR.mkIterTyAbs tvs $ - -- \x - LamAbs ann xn appliedReal destrBody - pure $ DatatypeComponent Destructor <$> destr + -- This term appears *outside* the scope of the abstraction for the datatype, so we need to put in the Scott-encoded type here + -- see Note [Abstract data types] + -- dty t_1 .. t_n + let appliedReal = PIR.mkIterTyApp (getType dty) (fmap ((ann,) . PIR.mkTyVar ann) tvs) + + xn <- safeFreshName "x" + + destrBody <- case _dcoStyle opts of + style | style == SumsOfProducts || style == BuiltinCasing -> do + resultType <- resultTypeName d + -- Variables for case arguments, and the bodies to be used as the actual cases + caseVars <- for constrs $ \c -> do + -- these types appear *outside* the scope of the abstraction for the datatype, so we need to use the concrete datatype here + -- see Note [Abstract data types] + -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1875): normalize datacons' types also here + let caseType = constructorCaseType ann (TyVar ann resultType) c + unveiledCaseType = unveilDatatype (getType dty) d caseType + caseArgName <- safeFreshName $ "case_" <> T.pack (varDeclNameString c) + pure $ VarDecl ann caseArgName unveiledCaseType + pure $ + -- forall out + TyAbs ann resultType (Type ann) $ + -- \case_1 .. case_j + PIR.mkIterLamAbs caseVars $ + -- See Note [Recursive datatypes] + -- case (unwrap x) case_1 .. case_j + Case ann (TyVar ann resultType) (unwrap ann dty $ Var ann xn) (fmap PIR.mkVar caseVars) + _ScottEncoding -> + pure $ + -- See Note [Recursive datatypes] + -- unwrap + unwrap ann dty $ + Var ann xn + + let destr = + -- /\t_1 .. t_n + PIR.mkIterTyAbs tvs $ + -- \x + LamAbs ann xn appliedReal destrBody + pure $ DatatypeComponent Destructor <$> destr -- See Note [Encoding of datatypes] + -- | Make the type of a destructor for a 'Datatype'. -- @ -- mkDestructorTy List @@ -542,73 +542,75 @@ mkDestructor opts dty d@(Datatype ann _ tvs _ constrs) = do -- @ mkDestructorTy :: MonadQuote m => Datatype TyName Name uni a -> m (Type TyName uni a) mkDestructorTy dt@(Datatype ann _ tvs _ _) = do - -- The scott type is exactly the eliminator type, which is what we want here regardless of the compilation style - st <- mkScottTy ann dt - -- these types appear *inside* the scope of the abstraction for the datatype, so we can just directly use - -- references to the name - -- see Note [Abstract data types] - -- t t_1 .. t_n - let valueType = mkDatatypeValueType ann dt - -- forall t_1 .. t_n - pure $ PIR.mkIterTyForall tvs $ TyFun ann valueType st + -- The scott type is exactly the eliminator type, which is what we want here regardless of the compilation style + st <- mkScottTy ann dt + -- these types appear *inside* the scope of the abstraction for the datatype, so we can just directly use + -- references to the name + -- see Note [Abstract data types] + -- t t_1 .. t_n + let valueType = mkDatatypeValueType ann dt + -- forall t_1 .. t_n + pure $ PIR.mkIterTyForall tvs $ TyFun ann valueType st -- The main function -- | Compile a 'Datatype' bound with the given body. -compileDatatype - :: Compiling m uni fun a - => Recursivity - -> PIRTerm uni fun a - -> Datatype TyName Name uni (Provenance a) - -> m (PIRTerm uni fun a) +compileDatatype :: + Compiling m uni fun a => + Recursivity -> + PIRTerm uni fun a -> + Datatype TyName Name uni (Provenance a) -> + m (PIRTerm uni fun a) compileDatatype r body d = do - opts <- view (ccOpts . coDatatypes) - p <- getEnclosing - - (concreteTyDef, constrDefs, destrDef) <- compileDatatypeDefs opts r d - - let - tyVars = [PIR.defVar concreteTyDef] - tys = [getType $ PIR.defVal concreteTyDef] - vars = fmap PIR.defVar constrDefs ++ [ PIR.defVar destrDef ] - vals = fmap PIR.defVal constrDefs ++ [ PIR.defVal destrDef ] - -- See Note [Abstract data types] - pure $ - PIR.mkIterApp - (PIR.mkIterInst (PIR.mkIterTyAbs tyVars (PIR.mkIterLamAbs vars body)) ((p,) <$> tys)) - ((p,) <$> vals) + opts <- view (ccOpts . coDatatypes) + p <- getEnclosing + + (concreteTyDef, constrDefs, destrDef) <- compileDatatypeDefs opts r d + + let + tyVars = [PIR.defVar concreteTyDef] + tys = [getType $ PIR.defVal concreteTyDef] + vars = fmap PIR.defVar constrDefs ++ [PIR.defVar destrDef] + vals = fmap PIR.defVal constrDefs ++ [PIR.defVal destrDef] + -- See Note [Abstract data types] + pure $ + PIR.mkIterApp + (PIR.mkIterInst (PIR.mkIterTyAbs tyVars (PIR.mkIterLamAbs vars body)) ((p,) <$> tys)) + ((p,) <$> vals) -- | Compile a 'Datatype' to a triple of type-constructor, data-constructors, destructor definitions. -compileDatatypeDefs - :: MonadQuote m - => DatatypeCompilationOpts - -> Recursivity - -> Datatype TyName Name uni (Provenance a) - -> m (PLC.Def (TyVarDecl TyName (Provenance a)) (PLCRecType uni fun a), - [PLC.Def (VarDecl TyName Name uni (Provenance a)) (PIRTerm uni fun a)], - PLC.Def (VarDecl TyName Name uni (Provenance a)) (PIRTerm uni fun a)) +compileDatatypeDefs :: + MonadQuote m => + DatatypeCompilationOpts -> + Recursivity -> + Datatype TyName Name uni (Provenance a) -> + m + ( PLC.Def (TyVarDecl TyName (Provenance a)) (PLCRecType uni fun a) + , [PLC.Def (VarDecl TyName Name uni (Provenance a)) (PIRTerm uni fun a)] + , PLC.Def (VarDecl TyName Name uni (Provenance a)) (PIRTerm uni fun a) + ) compileDatatypeDefs opts r d@(Datatype ann tn _ destr constrs) = do - concreteTyDef <- PIR.Def tn <$> mkDatatypeType opts r d + concreteTyDef <- PIR.Def tn <$> mkDatatypeType opts r d - constrDefs <- for (zip constrs [0..]) $ \(constr, i) -> do - let constrTy = DatatypeComponent ConstructorType <$> mkConstructorType d constr - c <- mkConstructor opts (PIR.defVal concreteTyDef) d i - pure $ PIR.Def (VarDecl (DatatypeComponent Constructor ann) (_varDeclName constr) constrTy) c + constrDefs <- for (zip constrs [0 ..]) $ \(constr, i) -> do + let constrTy = DatatypeComponent ConstructorType <$> mkConstructorType d constr + c <- mkConstructor opts (PIR.defVal concreteTyDef) d i + pure $ PIR.Def (VarDecl (DatatypeComponent Constructor ann) (_varDeclName constr) constrTy) c - destrDef <- do - destTy <- fmap (DatatypeComponent DestructorType) <$> mkDestructorTy d - t <- mkDestructor opts (PIR.defVal concreteTyDef) d - pure $ PIR.Def (VarDecl (DatatypeComponent Destructor ann) destr destTy) t + destrDef <- do + destTy <- fmap (DatatypeComponent DestructorType) <$> mkDestructorTy d + t <- mkDestructor opts (PIR.defVal concreteTyDef) d + pure $ PIR.Def (VarDecl (DatatypeComponent Destructor ann) destr destTy) t - pure (concreteTyDef, constrDefs, destrDef) + pure (concreteTyDef, constrDefs, destrDef) -compileRecDatatypes - :: Compiling m uni fun a - => PIRTerm uni fun a - -> NE.NonEmpty (Datatype TyName Name uni (Provenance a)) - -> m (PIRTerm uni fun a) +compileRecDatatypes :: + Compiling m uni fun a => + PIRTerm uni fun a -> + NE.NonEmpty (Datatype TyName Name uni (Provenance a)) -> + m (PIRTerm uni fun a) compileRecDatatypes body ds = case ds of - d NE.:| [] -> compileDatatype Rec body d - _ -> do - p <- getEnclosing - throwError $ UnsupportedError p "Mutually recursive datatypes" + d NE.:| [] -> compileDatatype Rec body d + _ -> do + p <- getEnclosing + throwError $ UnsupportedError p "Mutually recursive datatypes" diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs index 23f25f253b4..f611a513965 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- 9.6 notices that a constraint generated by the deriving machinery is redundant: -- https://gitlab.haskell.org/ghc/ghc/-/issues/23143 {-# OPTIONS_GHC -Wno-redundant-constraints #-} + -- | Support for generating PIR with global definitions with dependencies between them. module PlutusIR.Compiler.Definitions ( DefT, @@ -91,30 +91,30 @@ type TermDefWithStrictness uni fun ann = -- the branches or not. I'm not pursuing this since at the moment we don't need that extra -- power and complexity that will follow. type ManualMatcher uni fun ann = + -- | Type arguments of the datatype [Type TyName uni ann] -> - -- ^ Type arguments of the datatype + -- | Scrutinee Term TyName Name uni fun ann -> - -- ^ Scrutinee + -- | Result type Type TyName uni ann -> - -- ^ Result type + -- | Branches [Term TyName Name uni fun ann] -> - -- ^ Branches Term TyName Name uni fun ann data ManualDatatype uni fun ann = ManualDatatype -- TODO make these take annotations as argument. { _constructors :: [Term TyName Name uni fun ann] - , _matcher :: ManualMatcher uni fun ann - , _bindings :: [Binding TyName Name uni fun ann] + , _matcher :: ManualMatcher uni fun ann + , _bindings :: [Binding TyName Name uni fun ann] } makeLenses ''ManualDatatype data DefState key uni fun ann = DefState - { _termDefs :: DefMap key (TermDefWithStrictness uni fun ann) - , _typeDefs :: DefMap key (TypeDef TyName uni ann) - , _datatypeDefs :: DefMap key (DatatypeDef TyName Name uni ann) + { _termDefs :: DefMap key (TermDefWithStrictness uni fun ann) + , _typeDefs :: DefMap key (TypeDef TyName uni ann) + , _datatypeDefs :: DefMap key (DatatypeDef TyName Name uni ann) , _manualDatatypeDefs :: DefMap key (ManualDatatype uni fun ann) - , _aliases :: Set.Set key + , _aliases :: Set.Set key } makeLenses ''DefState @@ -132,7 +132,7 @@ newtype DefT key uni fun ann m a = DefT {unDefT :: StateT (DefState key uni fun ) -- Need to write this by hand, deriving wants to derive the one for DefState -instance (MonadState s m) => MonadState s (DefT key uni fun ann m) where +instance MonadState s m => MonadState s (DefT key uni fun ann m) where get = lift get put = lift . put state = lift . state @@ -177,10 +177,9 @@ runDefT x act = do in terms `Map.union` types `Map.union` datatypes `Map.union` manualDatatypes -{- | Given the definitions in the program, create a topologically ordered list of the -SCCs using the dependency information --} -defSccs :: (Ord key) => DefMap key def -> [NAM.AdjacencyMap key] +-- | Given the definitions in the program, create a topologically ordered list of the +-- SCCs using the dependency information +defSccs :: Ord key => DefMap key def -> [NAM.AdjacencyMap key] defSccs tds = let perKeyDeps = fmap (\(key, (_, deps)) -> (key, deps)) (Map.assocs tds) @@ -190,10 +189,10 @@ defSccs tds = case AM.topSort keySccs of Right sorted -> sorted -- TODO: report cycle - Left _ -> error "No topological sort of SCC graph" + Left _ -> error "No topological sort of SCC graph" wrapWithDefs :: - (Ord key) => + Ord key => ann -> DefMap key [Binding tyname name uni fun ann] -> Term tyname name uni fun ann -> @@ -217,12 +216,12 @@ class (Monad m, Ord key) => MonadDefs key uni fun ann m | m -> key uni fun ann w instance (Ord key, Monad m) => MonadDefs key uni fun ann (DefT key uni fun ann m) where liftDef = MM.hoist (pure . runIdentity) -instance (MonadDefs key uni fun ann m) => MonadDefs key uni fun ann (StateT s m) -instance (MonadDefs key uni fun ann m) => MonadDefs key uni fun ann (ExceptT e m) -instance (MonadDefs key uni fun ann m) => MonadDefs key uni fun ann (ReaderT r m) +instance MonadDefs key uni fun ann m => MonadDefs key uni fun ann (StateT s m) +instance MonadDefs key uni fun ann m => MonadDefs key uni fun ann (ExceptT e m) +instance MonadDefs key uni fun ann m => MonadDefs key uni fun ann (ReaderT r m) defineTerm :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> TermDefWithStrictness uni fun ann -> Set.Set key -> @@ -230,18 +229,18 @@ defineTerm :: defineTerm name def deps = liftDef $ DefT $ modify $ over termDefs $ Map.insert name (def, deps) modifyTermDef :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> (TermDefWithStrictness uni fun ann -> TermDefWithStrictness uni fun ann) -> m () modifyTermDef name f = liftDef $ DefT $ modify $ over termDefs $ Map.adjust (first f) name -defineType :: (MonadDefs key uni fun ann m) => key -> TypeDef TyName uni ann -> Set.Set key -> m () +defineType :: MonadDefs key uni fun ann m => key -> TypeDef TyName uni ann -> Set.Set key -> m () defineType name def deps = liftDef $ DefT $ modify $ over typeDefs $ Map.insert name (def, deps) modifyTypeDef :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> (TypeDef TyName uni ann -> TypeDef TyName uni ann) -> m () @@ -249,7 +248,7 @@ modifyTypeDef name f = liftDef $ DefT $ modify $ over typeDefs $ Map.adjust (fir defineDatatype :: forall key uni fun ann m. - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> DatatypeDef TyName Name uni ann -> Set.Set key -> @@ -259,7 +258,7 @@ defineDatatype name def deps = defineManualDatatype :: forall key uni fun ann m. - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> ManualDatatype uni fun ann -> Set.Set key -> @@ -268,14 +267,14 @@ defineManualDatatype name def deps = liftDef $ DefT $ modify $ over manualDatatypeDefs $ Map.insert name (def, deps) modifyDatatypeDef :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> (DatatypeDef TyName Name uni ann -> DatatypeDef TyName Name uni ann) -> m () modifyDatatypeDef name f = liftDef $ DefT $ modify $ over datatypeDefs $ Map.adjust (first f) name -- | Modifies the dependency set of a key. -modifyDeps :: (MonadDefs key uni fun ann m) => key -> (Set.Set key -> Set.Set key) -> m () +modifyDeps :: MonadDefs key uni fun ann m => key -> (Set.Set key -> Set.Set key) -> m () modifyDeps name f = liftDef $ DefT $ do -- This is a little crude: we expect most keys will appear in only one map, so we just modify the -- dependencies in all of them! That lets us just have one function. @@ -283,21 +282,21 @@ modifyDeps name f = liftDef $ DefT $ do modify $ over typeDefs $ Map.adjust (second f) name modify $ over datatypeDefs $ Map.adjust (second f) name -recordAlias :: forall key uni fun ann m. (MonadDefs key uni fun ann m) => key -> m () +recordAlias :: forall key uni fun ann m. MonadDefs key uni fun ann m => key -> m () recordAlias name = liftDef @key @uni @fun @ann $ DefT $ modify $ over aliases (Set.insert name) lookupTerm :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> m (Maybe (Term TyName Name uni fun ann)) lookupTerm name = do - DefState{_termDefs = ds, _aliases = as} <- liftDef $ DefT get + DefState {_termDefs = ds, _aliases = as} <- liftDef $ DefT get pure $ case Map.lookup name ds of Just (def, _) | not (Set.member name as) -> Just $ mkVar (PLC.defVar def) - _ -> Nothing + _ -> Nothing lookupOrDefineTerm :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> m (TermDefWithStrictness uni fun ann, Set.Set key) -> m (Term TyName Name uni fun ann) @@ -310,18 +309,18 @@ lookupOrDefineTerm name mdef = do defineTerm name def deps pure $ mkVar (PLC.defVar def) -lookupType :: (MonadDefs key uni fun ann m) => ann -> key -> m (Maybe (Type TyName uni ann)) +lookupType :: MonadDefs key uni fun ann m => ann -> key -> m (Maybe (Type TyName uni ann)) lookupType x name = do - DefState{_typeDefs = tys, _datatypeDefs = dtys, _aliases = as} <- liftDef $ DefT get + DefState {_typeDefs = tys, _datatypeDefs = dtys, _aliases = as} <- liftDef $ DefT get pure $ case Map.lookup name tys of Just (def, _) -> Just $ if Set.member name as then PLC.defVal def else mkTyVar x $ PLC.defVar def Nothing -> case Map.lookup name dtys of Just (def, _) -> Just $ mkTyVar x $ PLC.defVar def - Nothing -> Nothing + Nothing -> Nothing lookupOrDefineType :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => ann -> key -> m (TypeDef TyName uni ann, Set.Set key) -> @@ -336,38 +335,43 @@ lookupOrDefineType x name mdef = do pure $ mkTyVar x $ PLC.defVar def lookupConstructors :: - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => key -> m (Maybe [Term TyName Name uni fun ann]) lookupConstructors name = do - DefState{_datatypeDefs = ds, _manualDatatypeDefs = ms} <- liftDef $ DefT get + DefState {_datatypeDefs = ds, _manualDatatypeDefs = ms} <- liftDef $ DefT get pure $ case Map.lookup name ms of Just (mt, _) -> Just $ mt ^. constructors Nothing -> case Map.lookup name ds of - Just (PLC.Def{PLC.defVal = (Datatype _ _ _ _ constrs)}, _) -> Just $ fmap mkVar constrs - Nothing -> Nothing + Just (PLC.Def {PLC.defVal = (Datatype _ _ _ _ constrs)}, _) -> Just $ fmap mkVar constrs + Nothing -> Nothing lookupDestructor :: forall key uni fun ann m. - (MonadDefs key uni fun ann m) => + MonadDefs key uni fun ann m => ann -> key -> m (Maybe (ManualMatcher uni fun ann)) lookupDestructor x name = do - DefState{_datatypeDefs = ds, _manualDatatypeDefs = ms} <- liftDef $ DefT get + DefState {_datatypeDefs = ds, _manualDatatypeDefs = ms} <- liftDef $ DefT get pure $ case Map.lookup name ms of Just (mt, _) -> Just $ mt ^. matcher - Nothing -> case Map.lookup name ds of - Just (PLC.Def{PLC.defVal = (Datatype _ _ _ destr _)}, _) -> + Nothing -> case Map.lookup name ds of + Just (PLC.Def {PLC.defVal = (Datatype _ _ _ destr _)}, _) -> Just $ \tyArgs scrut resTy branches -> - PLC.mkIterApp - (tyInst x - (apply x - (PLC.mkIterInst - (Var x destr) - ((x,) <$> tyArgs)) - scrut) - resTy) - ((x,) <$> branches) - Nothing -> Nothing + PLC.mkIterApp + ( tyInst + x + ( apply + x + ( PLC.mkIterInst + (Var x destr) + ((x,) <$> tyArgs) + ) + scrut + ) + resTy + ) + ((x,) <$> branches) + Nothing -> Nothing diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs index 67dd46388a8..af8cb14a3eb 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs @@ -1,12 +1,13 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module PlutusIR.Compiler.Error (Error (..)) where import PlutusCore qualified as PLC @@ -20,20 +21,25 @@ import Prettyprinter ((<+>)) import Prettyprinter qualified as PP data Error uni fun a - = CompilationError !a !T.Text -- ^ A generic compilation error. - | UnsupportedError !a !T.Text -- ^ An error relating specifically to an unsupported feature. - | PLCError !(PLC.Error uni fun a) -- ^ An error from running some PLC function, lifted into - -- this error type for convenience. + = -- | A generic compilation error. + CompilationError !a !T.Text + | -- | An error relating specifically to an unsupported feature. + UnsupportedError !a !T.Text + | -- | An error from running some PLC function, lifted into + -- this error type for convenience. + PLCError !(PLC.Error uni fun a) instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty ann) => Show (Error uni fun ann) where - show = show . PLC.prettyPlcClassicSimple + show = show . PLC.prettyPlcClassicSimple -instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty ann) => - PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun ann) where - prettyBy config = \case - CompilationError x e -> "Error during compilation:" <+> PP.pretty e <> "(" <> PP.pretty x <> ")" - UnsupportedError x e -> "Unsupported construct:" <+> PP.pretty e <+> "(" <> PP.pretty x <> ")" - PLCError e -> PP.vsep [ "Error from the PLC compiler:", PLC.prettyBy config e ] +instance + (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty ann) => + PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun ann) + where + prettyBy config = \case + CompilationError x e -> "Error during compilation:" <+> PP.pretty e <> "(" <> PP.pretty x <> ")" + UnsupportedError x e -> "Unsupported construct:" <+> PP.pretty e <+> "(" <> PP.pretty x <> ")" + PLCError e -> PP.vsep ["Error from the PLC compiler:", PLC.prettyBy config e] deriving anyclass instance - (PLC.ThrowableBuiltins uni fun, PP.Pretty ann, Typeable ann) => Exception (Error uni fun ann) + (PLC.ThrowableBuiltins uni fun, PP.Pretty ann, Typeable ann) => Exception (Error uni fun ann) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Let.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Let.hs index 9a0a5cd0bab..8c890b44f47 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Let.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Let.hs @@ -1,9 +1,10 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + -- | Functions for compiling PIR let terms. -module PlutusIR.Compiler.Let (compileLets, LetKind(..), compileLetsPass, compileLetsPassSC) where +module PlutusIR.Compiler.Let (compileLets, LetKind (..), compileLetsPass, compileLetsPassSC) where import PlutusIR import PlutusIR.Compiler.Datatype @@ -41,19 +42,19 @@ Also we should pull out more stuff (e.g. see 'NonStrict' which uses unit). data LetKind = RecTerms | NonRecTerms | Types | DataTypes deriving stock (Show, Eq, Ord) -compileLetsPassSC - :: Compiling m uni fun a - => TC.PirTCConfig uni fun - -> LetKind - -> Pass m TyName Name uni fun (Provenance a) +compileLetsPassSC :: + Compiling m uni fun a => + TC.PirTCConfig uni fun -> + LetKind -> + Pass m TyName Name uni fun (Provenance a) compileLetsPassSC tcconfig letKind = - renamePass <> compileLetsPass tcconfig letKind + renamePass <> compileLetsPass tcconfig letKind -compileLetsPass - :: Compiling m uni fun a - => TC.PirTCConfig uni fun - -> LetKind - -> Pass m TyName Name uni fun (Provenance a) +compileLetsPass :: + Compiling m uni fun a => + TC.PirTCConfig uni fun -> + LetKind -> + Pass m TyName Name uni fun (Provenance a) compileLetsPass tcconfig letKind = NamedPass "compile lets" $ Pass @@ -63,73 +64,81 @@ compileLetsPass tcconfig letKind = -- | Compile the let terms out of a 'Term'. Note: the result does *not* have globally unique names. compileLets :: Compiling m uni fun a => LetKind -> PIRTerm uni fun a -> m (PIRTerm uni fun a) -compileLets kind t = getEnclosing >>= \p -> +compileLets kind t = + getEnclosing >>= \p -> -- See Note [Extra definitions while compiling let-bindings] runDefT p $ transformMOf termSubterms (compileLet kind) t compileLet :: Compiling m uni fun a => LetKind -> PIRTerm uni fun a -> DefT SharedName uni fun (Provenance a) m (PIRTerm uni fun a) compileLet kind = \case - Let p r bs body -> withEnclosing (const $ LetBinding r p) $ case r of - -- Right-associative fold because `let {b1;b2} in t` === `let {b1} in (let {b2} in t)` - NonRec -> lift $ foldrM (compileNonRecBinding kind) body bs - Rec -> compileRecBindings kind body bs - x -> pure x - -compileRecBindings - :: Compiling m uni fun a - => LetKind - -> PIRTerm uni fun a - -> NE.NonEmpty (Binding TyName Name uni fun (Provenance a)) - -> DefT SharedName uni fun (Provenance a) m (PIRTerm uni fun a) + Let p r bs body -> withEnclosing (const $ LetBinding r p) $ case r of + -- Right-associative fold because `let {b1;b2} in t` === `let {b1} in (let {b2} in t)` + NonRec -> lift $ foldrM (compileNonRecBinding kind) body bs + Rec -> compileRecBindings kind body bs + x -> pure x + +compileRecBindings :: + Compiling m uni fun a => + LetKind -> + PIRTerm uni fun a -> + NE.NonEmpty (Binding TyName Name uni fun (Provenance a)) -> + DefT SharedName uni fun (Provenance a) m (PIRTerm uni fun a) compileRecBindings kind body bs = case grouped of singleGroup :| [] -> case NE.head singleGroup of - TermBind {} -> compileRecTermBindings kind body singleGroup - DatatypeBind {} -> lift $ compileRecDataBindings kind body singleGroup - tb@TypeBind {} -> - lift $ getEnclosing >>= \p -> throwError $ - CompilationError p - ("Type bindings cannot appear in recursive let, use datatypebind instead" - <> "The type binding is \n " - <> display tb) + TermBind {} -> compileRecTermBindings kind body singleGroup + DatatypeBind {} -> lift $ compileRecDataBindings kind body singleGroup + tb@TypeBind {} -> + lift $ + getEnclosing >>= \p -> + throwError $ + CompilationError + p + ( "Type bindings cannot appear in recursive let, use datatypebind instead" + <> "The type binding is \n " + <> display tb + ) -- only one single group should appear, we do not allow mixing of bind styles _ -> lift $ getEnclosing >>= \p -> throwError $ CompilationError p "Mixed term/type/data bindings in recursive let" where - -- We group the bindings by their binding style, i.e.: term , data or type bindingstyle - -- All bindings of a let should be of the same style; for that, we make use of the `groupWith1` - -- and we expect to see exactly 1 group returned by it. - -- The `NE.groupWith1` returns N>=1 of "adjacent" grouppings, compared to the similar `NE.groupAllWith1` - -- which returns at most 3 groups (1 => termbind, 2 -> typebind, 3 -> databind). - -- `NE.groupAllWith1` is an overkill here, since we don't care about the minimal number of groups, just that there is exactly 1 group. - grouped = NE.groupWith1 (\case { TermBind {} -> 1 ::Int ; TypeBind {} -> 2; _ -> 3 }) bs - -compileRecTermBindings - :: Compiling m uni fun a - => LetKind - -> PIRTerm uni fun a - -> NE.NonEmpty (Binding TyName Name uni fun (Provenance a)) - -> DefT SharedName uni fun (Provenance a) m (PIRTerm uni fun a) + -- We group the bindings by their binding style, i.e.: term , data or type bindingstyle + -- All bindings of a let should be of the same style; for that, we make use of the `groupWith1` + -- and we expect to see exactly 1 group returned by it. + -- The `NE.groupWith1` returns N>=1 of "adjacent" grouppings, compared to the similar `NE.groupAllWith1` + -- which returns at most 3 groups (1 => termbind, 2 -> typebind, 3 -> databind). + -- `NE.groupAllWith1` is an overkill here, since we don't care about the minimal number of groups, just that there is exactly 1 group. + grouped = NE.groupWith1 (\case TermBind {} -> 1 :: Int; TypeBind {} -> 2; _ -> 3) bs + +compileRecTermBindings :: + Compiling m uni fun a => + LetKind -> + PIRTerm uni fun a -> + NE.NonEmpty (Binding TyName Name uni fun (Provenance a)) -> + DefT SharedName uni fun (Provenance a) m (PIRTerm uni fun a) compileRecTermBindings RecTerms body bs = do - binds <- forM bs $ \case - TermBind _ Strict vd rhs -> pure $ PIR.Def vd rhs - _ -> lift $ getEnclosing >>= \p -> throwError $ CompilationError p "Internal error: type binding in term binding group" - compileRecTerms body binds + binds <- forM bs $ \case + TermBind _ Strict vd rhs -> pure $ PIR.Def vd rhs + _ -> lift $ getEnclosing >>= \p -> throwError $ CompilationError p "Internal error: type binding in term binding group" + compileRecTerms body binds compileRecTermBindings _ body bs = lift $ getEnclosing >>= \p -> pure $ Let p Rec bs body compileRecDataBindings :: Compiling m uni fun a => LetKind -> PIRTerm uni fun a -> NE.NonEmpty (Binding TyName Name uni fun (Provenance a)) -> m (PIRTerm uni fun a) compileRecDataBindings DataTypes body bs = do - binds <- forM bs $ \case - DatatypeBind _ d -> pure d - _ -> getEnclosing >>= \p -> throwError $ CompilationError p "Internal error: term or type binding in datatype binding group" - compileRecDatatypes body binds + binds <- forM bs $ \case + DatatypeBind _ d -> pure d + _ -> getEnclosing >>= \p -> throwError $ CompilationError p "Internal error: term or type binding in datatype binding group" + compileRecDatatypes body binds compileRecDataBindings _ body bs = getEnclosing >>= \p -> pure $ Let p Rec bs body compileNonRecBinding :: Compiling m uni fun a => LetKind -> Binding TyName Name uni fun (Provenance a) -> PIRTerm uni fun a -> m (PIRTerm uni fun a) -compileNonRecBinding NonRecTerms (TermBind x Strict d rhs) body = withEnclosing (const $ TermBinding (varDeclNameString d) x) $ - PIR.mkImmediateLamAbs <$> getEnclosing <*> pure (PIR.Def d rhs) <*> pure body -compileNonRecBinding Types (TypeBind x d rhs) body = withEnclosing (const $ TypeBinding (tyVarDeclNameString d) x) $ - PIR.mkImmediateTyAbs <$> getEnclosing <*> pure (PIR.Def d rhs) <*> pure body -compileNonRecBinding DataTypes (DatatypeBind x d) body = withEnclosing (const $ TypeBinding (datatypeNameString d) x) $ - compileDatatype NonRec body d +compileNonRecBinding NonRecTerms (TermBind x Strict d rhs) body = + withEnclosing (const $ TermBinding (varDeclNameString d) x) $ + PIR.mkImmediateLamAbs <$> getEnclosing <*> pure (PIR.Def d rhs) <*> pure body +compileNonRecBinding Types (TypeBind x d rhs) body = + withEnclosing (const $ TypeBinding (tyVarDeclNameString d) x) $ + PIR.mkImmediateTyAbs <$> getEnclosing <*> pure (PIR.Def d rhs) <*> pure body +compileNonRecBinding DataTypes (DatatypeBind x d) body = + withEnclosing (const $ TypeBinding (datatypeNameString d) x) $ + compileDatatype NonRec body d compileNonRecBinding _ b body = getEnclosing >>= \p -> pure $ Let p NonRec (pure b) body diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Lower.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Lower.hs index dbbebba8650..8b31cec77f5 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Lower.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Lower.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + module PlutusIR.Compiler.Lower where import PlutusIR @@ -15,17 +16,18 @@ import Control.Monad.Except -- translating the constructors across. lowerTerm :: Compiling m uni fun a => PIRTerm uni fun a -> m (PLCTerm uni fun a) lowerTerm = \case - Let x _ _ _ -> throwError $ - CompilationError x "Let bindings should have been eliminated before lowering" - Var x n -> pure $ PLC.Var x n - TyAbs x n k t -> PLC.TyAbs x n k <$> lowerTerm t - LamAbs x n ty t -> PLC.LamAbs x n ty <$> lowerTerm t - Apply x t1 t2 -> PLC.Apply x <$> lowerTerm t1 <*> lowerTerm t2 - Constant x c -> pure $ PLC.Constant x c - Builtin x bi -> pure $ PLC.Builtin x bi - TyInst x t ty -> PLC.TyInst x <$> lowerTerm t <*> pure ty - Error x ty -> pure $ PLC.Error x ty - IWrap x tn ty t -> PLC.IWrap x tn ty <$> lowerTerm t - Unwrap x t -> PLC.Unwrap x <$> lowerTerm t - Constr x ty i es -> PLC.Constr x ty i <$> traverse lowerTerm es - Case x ty arg cs -> PLC.Case x ty <$> lowerTerm arg <*> traverse lowerTerm cs + Let x _ _ _ -> + throwError $ + CompilationError x "Let bindings should have been eliminated before lowering" + Var x n -> pure $ PLC.Var x n + TyAbs x n k t -> PLC.TyAbs x n k <$> lowerTerm t + LamAbs x n ty t -> PLC.LamAbs x n ty <$> lowerTerm t + Apply x t1 t2 -> PLC.Apply x <$> lowerTerm t1 <*> lowerTerm t2 + Constant x c -> pure $ PLC.Constant x c + Builtin x bi -> pure $ PLC.Builtin x bi + TyInst x t ty -> PLC.TyInst x <$> lowerTerm t <*> pure ty + Error x ty -> pure $ PLC.Error x ty + IWrap x tn ty t -> PLC.IWrap x tn ty <$> lowerTerm t + Unwrap x t -> PLC.Unwrap x <$> lowerTerm t + Constr x ty i es -> PLC.Constr x ty i <$> traverse lowerTerm es + Case x ty arg cs -> PLC.Case x ty <$> lowerTerm arg <*> traverse lowerTerm cs diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs index 296d3ffa8d5..01e75607420 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + module PlutusIR.Compiler.Names (safeFreshName, safeFreshTyName) where import PlutusCore qualified as PLC @@ -17,46 +18,47 @@ support unicode identifiers as well. typeReplacements :: [(T.Text, T.Text)] typeReplacements = - [ ("[]", "List") - , ("()", "Unit") - , ("(,)", "Tuple2") - , ("(,,)", "Tuple3") - , ("(,,,)", "Tuple4") - , ("(,,,,)", "Tuple5") - , ("(#,#)", "UTuple2") - , ("(#,,#)", "UTuple3") - , ("(#,,,#)", "UTuple4") - , ("(#,,,,#)", "UTuple5") - ] + [ ("[]", "List") + , ("()", "Unit") + , ("(,)", "Tuple2") + , ("(,,)", "Tuple3") + , ("(,,,)", "Tuple4") + , ("(,,,,)", "Tuple5") + , ("(#,#)", "UTuple2") + , ("(#,,#)", "UTuple3") + , ("(#,,,#)", "UTuple4") + , ("(#,,,,#)", "UTuple5") + ] termReplacements :: [(T.Text, T.Text)] termReplacements = - [ (":", "Cons") - , ("[]", "Nil") - , ("()", "Unit") - , ("(,)", "Tuple2") - , ("(,,)", "Tuple3") - , ("(,,,)", "Tuple4") - , ("(,,,,)", "Tuple5") - , ("(#,#)", "UTuple2") - , ("(#,,#)", "UTuple3") - , ("(#,,,#)", "UTuple4") - , ("(#,,,,#)", "UTuple5") - ] + [ (":", "Cons") + , ("[]", "Nil") + , ("()", "Unit") + , ("(,)", "Tuple2") + , ("(,,)", "Tuple3") + , ("(,,,)", "Tuple4") + , ("(,,,,)", "Tuple5") + , ("(#,#)", "UTuple2") + , ("(#,,#)", "UTuple3") + , ("(#,,,#)", "UTuple4") + , ("(#,,,,#)", "UTuple5") + ] data NameKind = TypeName | TermName safeName :: NameKind -> T.Text -> T.Text safeName kind t = - let - -- replace some special cases - toReplace = case kind of - TypeName -> typeReplacements - TermName -> termReplacements - replaced = List.foldl' (\acc (old, new) -> T.replace old new acc) t toReplace - -- strip out disallowed characters - stripped = T.filter isQuotedIdentifierChar replaced - in if T.null stripped then "bad_name" else stripped + let + -- replace some special cases + toReplace = case kind of + TypeName -> typeReplacements + TermName -> termReplacements + replaced = List.foldl' (\acc (old, new) -> T.replace old new acc) t toReplace + -- strip out disallowed characters + stripped = T.filter isQuotedIdentifierChar replaced + in + if T.null stripped then "bad_name" else stripped safeFreshName :: MonadQuote m => T.Text -> m PLC.Name safeFreshName s = liftQuote $ freshName $ safeName TermName s diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs index 7e21a4c6847..aca61f24fed 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs @@ -1,8 +1,9 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + -- | Module handling provenances of terms. module PlutusIR.Compiler.Provenance where @@ -25,59 +26,61 @@ import Prettyprinter qualified as PP -- The provenance should always be just the original annotation, if we have one. It should only be another -- kind of provenance if we're in the process of generating some term that doesn't correspond directly to a term in -- the original AST. -data Provenance a = Original a - | LetBinding Recursivity (Provenance a) - | TermBinding String (Provenance a) - | TypeBinding String (Provenance a) - | DatatypeComponent DatatypeComponent (Provenance a) - -- | Added for accumulating difference provenances when floating lets - | MultipleSources (S.Set (Provenance a)) - deriving stock (Show, Eq, Ord, Foldable, Generic) - deriving anyclass (Hashable) +data Provenance a + = Original a + | LetBinding Recursivity (Provenance a) + | TermBinding String (Provenance a) + | TypeBinding String (Provenance a) + | DatatypeComponent DatatypeComponent (Provenance a) + | -- | Added for accumulating difference provenances when floating lets + MultipleSources (S.Set (Provenance a)) + deriving stock (Show, Eq, Ord, Foldable, Generic) + deriving anyclass (Hashable) instance Ord a => Semigroup (Provenance a) where - x <> y = MultipleSources (toSet x `S.union` toSet y) - where - toSet = \case - MultipleSources ps -> ps - other -> S.singleton other + x <> y = MultipleSources (toSet x `S.union` toSet y) + where + toSet = \case + MultipleSources ps -> ps + other -> S.singleton other instance Ord a => Monoid (Provenance a) where - mempty = noProvenance + mempty = noProvenance -- workaround, use a smart constructor to replace the older NoProvenance data constructor noProvenance :: Provenance a noProvenance = MultipleSources S.empty instance AnnInline a => AnnInline (Provenance a) where - annAlwaysInline = Original annAlwaysInline - annSafeToInline = Original annSafeToInline - annMayInline = Original annMayInline - -data DatatypeComponent = Constructor - | ConstructorType - | Destructor - | DestructorType - | DatatypeType - | PatternFunctor - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (Hashable) + annAlwaysInline = Original annAlwaysInline + annSafeToInline = Original annSafeToInline + annMayInline = Original annMayInline + +data DatatypeComponent + = Constructor + | ConstructorType + | Destructor + | DestructorType + | DatatypeType + | PatternFunctor + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Hashable) instance PP.Pretty DatatypeComponent where - pretty = \case - Constructor -> "constructor" - ConstructorType -> "constructor type" - Destructor -> "destructor" - DestructorType -> "destructor type" - DatatypeType -> "datatype type" - PatternFunctor -> "pattern functor" + pretty = \case + Constructor -> "constructor" + ConstructorType -> "constructor type" + Destructor -> "destructor" + DestructorType -> "destructor type" + DatatypeType -> "datatype type" + PatternFunctor -> "pattern functor" data GeneratedKind = RecursiveLet - deriving stock (Show, Eq) + deriving stock (Show, Eq) instance PP.Pretty GeneratedKind where - pretty = \case - RecursiveLet -> "recursive let" + pretty = \case + RecursiveLet -> "recursive let" -- | Set the provenance on a term to the given value. setProvenance :: Functor f => Provenance b -> f a -> f (Provenance b) @@ -88,17 +91,18 @@ original :: Functor f => f a -> f (Provenance a) original = fmap Original instance PP.Pretty a => PP.Pretty (Provenance a) where - pretty = \case - DatatypeComponent c p -> PP.pretty c <> ";" <+> "from" <+> PLC.pretty p - Original p -> PLC.pretty p - LetBinding r p -> - let - rstr = case r of - NonRec -> "non-recursive" - Rec -> "recursive" - in "(" <> rstr <> ")" <+> "let binding" <> ";" <+> "from" <+> PLC.pretty p - TermBinding n p -> "term binding" <+> "of" <+> PLC.pretty n <> ";" <+> "from" <+> PLC.pretty p - TypeBinding n p -> "type binding" <+> "of" <+> PLC.pretty n <> ";" <+> "from" <+> PLC.pretty p - MultipleSources p1 -> case S.toList p1 of - [] -> "" - l -> PLC.prettyList l + pretty = \case + DatatypeComponent c p -> PP.pretty c <> ";" <+> "from" <+> PLC.pretty p + Original p -> PLC.pretty p + LetBinding r p -> + let + rstr = case r of + NonRec -> "non-recursive" + Rec -> "recursive" + in + "(" <> rstr <> ")" <+> "let binding" <> ";" <+> "from" <+> PLC.pretty p + TermBinding n p -> "term binding" <+> "of" <+> PLC.pretty n <> ";" <+> "from" <+> PLC.pretty p + TypeBinding n p -> "type binding" <+> "of" <+> PLC.pretty n <> ";" <+> "from" <+> PLC.pretty p + MultipleSources p1 -> case S.toList p1 of + [] -> "" + l -> PLC.prettyList l diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Recursion.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Recursion.hs index c22de9151aa..28cc51fc5d6 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Recursion.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Recursion.hs @@ -1,7 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} + -- | Functions for compiling PIR recursive let-bound functions into PLC. module PlutusIR.Compiler.Recursion where @@ -65,59 +66,61 @@ it directly, we would have to provide the type of the *result* term, which we ma Here we merely have to provide it with the types of the f_is, which we *do* know. -} - -- See Note [Recursive lets] +-- See Note [Recursive lets] + -- | Compile a mutually recursive list of var decls bound in a body. -compileRecTerms - :: Compiling m uni fun a - => PIRTerm uni fun a - -> NonEmpty (TermDef TyName Name uni fun (Provenance a)) - -> DefT SharedName uni fun (Provenance a) m (PIRTerm uni fun a) +compileRecTerms :: + Compiling m uni fun a => + PIRTerm uni fun a -> + NonEmpty (TermDef TyName Name uni fun (Provenance a)) -> + DefT SharedName uni fun (Provenance a) m (PIRTerm uni fun a) compileRecTerms body bs = do - p <- lift getEnclosing - fixpoint <- mkFixpoint bs - Tuple.bindTuple p (PIR._varDeclName . PIR.defVar <$> toList bs) fixpoint body + p <- lift getEnclosing + fixpoint <- mkFixpoint bs + Tuple.bindTuple p (PIR._varDeclName . PIR.defVar <$> toList bs) fixpoint body -- | Given a list of var decls, create a tuples of values that computes their mutually recursive fixpoint. -mkFixpoint - :: forall m uni fun a . Compiling m uni fun a - => NonEmpty (TermDef TyName Name uni fun (Provenance a)) - -> DefT SharedName uni fun (Provenance a) m (Tuple.Tuple (Term TyName Name uni fun) uni (Provenance a)) +mkFixpoint :: + forall m uni fun a. + Compiling m uni fun a => + NonEmpty (TermDef TyName Name uni fun (Provenance a)) -> + DefT SharedName uni fun (Provenance a) m (Tuple.Tuple (Term TyName Name uni fun) uni (Provenance a)) mkFixpoint bs = do - p0 <- lift getEnclosing - - funs <- forM bs $ \(PIR.Def (PIR.VarDecl p name ty) term) -> - case PIR.mkFunctionDef p name ty term of - Just fun -> pure fun - Nothing -> lift $ throwError $ CompilationError (PLC.typeAnn ty) "Recursive values must be of function type" - - inlineFix <- view (ccOpts . coInlineConstants) - - -- See Note [Extra definitions while compiling let-bindings] - let - arity = fromIntegral $ length funs - fixByKey = FixBy - fixNKey = FixpointCombinator arity - ann = if inlineFix then annAlwaysInline else annMayInline - - let mkFixByDef = do - name <- liftQuote $ toProgramName fixByKey - let (fixByTerm, fixByType) = Function.fixByAndType - pure (PLC.Def (PLC.VarDecl ann name (noProvenance <$ fixByType)) (noProvenance <$ fixByTerm, Strict), mempty) - - let mkFixNDef = do - name <- liftQuote $ toProgramName fixNKey - ((fixNTerm, fixNType), fixNDeps) <- - if arity == 1 - then pure (Function.fixAndType, mempty) - -- fixN depends on fixBy - else do - fixBy <- lookupOrDefineTerm fixByKey mkFixByDef - pure (Function.fixNAndType arity (void fixBy), Set.singleton fixByKey) - pure (PLC.Def (PLC.VarDecl ann name (noProvenance <$ fixNType)) (noProvenance <$ fixNTerm, Strict), fixNDeps) - fixN <- lookupOrDefineTerm fixNKey mkFixNDef - - liftQuote $ case funs of - -- Takes a list of function defs and function bodies and turns them into a Scott-encoded tuple, which - -- happens to be exactly what we want - f :| [] -> Tuple.getSpineToTuple p0 [(PLC.functionDefToType f, Function.getSingleFixOf p0 fixN f)] - f :| fs -> Function.getMutualFixOf p0 fixN (f:fs) + p0 <- lift getEnclosing + + funs <- forM bs $ \(PIR.Def (PIR.VarDecl p name ty) term) -> + case PIR.mkFunctionDef p name ty term of + Just fun -> pure fun + Nothing -> lift $ throwError $ CompilationError (PLC.typeAnn ty) "Recursive values must be of function type" + + inlineFix <- view (ccOpts . coInlineConstants) + + -- See Note [Extra definitions while compiling let-bindings] + let + arity = fromIntegral $ length funs + fixByKey = FixBy + fixNKey = FixpointCombinator arity + ann = if inlineFix then annAlwaysInline else annMayInline + + let mkFixByDef = do + name <- liftQuote $ toProgramName fixByKey + let (fixByTerm, fixByType) = Function.fixByAndType + pure (PLC.Def (PLC.VarDecl ann name (noProvenance <$ fixByType)) (noProvenance <$ fixByTerm, Strict), mempty) + + let mkFixNDef = do + name <- liftQuote $ toProgramName fixNKey + ((fixNTerm, fixNType), fixNDeps) <- + if arity == 1 + then pure (Function.fixAndType, mempty) + -- fixN depends on fixBy + else do + fixBy <- lookupOrDefineTerm fixByKey mkFixByDef + pure (Function.fixNAndType arity (void fixBy), Set.singleton fixByKey) + pure (PLC.Def (PLC.VarDecl ann name (noProvenance <$ fixNType)) (noProvenance <$ fixNTerm, Strict), fixNDeps) + fixN <- lookupOrDefineTerm fixNKey mkFixNDef + + liftQuote $ case funs of + -- Takes a list of function defs and function bodies and turns them into a Scott-encoded tuple, which + -- happens to be exactly what we want + f :| [] -> Tuple.getSpineToTuple p0 [(PLC.functionDefToType f, Function.getSingleFixOf p0 fixN f)] + f :| fs -> Function.getMutualFixOf p0 fixN (f : fs) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs index 0fcc21649cd..49e2d851693 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs @@ -1,13 +1,13 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -module PlutusIR.Compiler.Types where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +module PlutusIR.Compiler.Types where import Control.Lens import Control.Monad (when) @@ -19,11 +19,11 @@ import Prettyprinter (viaShow) import PlutusCore qualified as PLC import PlutusCore.Annotation +import PlutusCore.AstSize (AstSize) import PlutusCore.Builtin qualified as PLC import PlutusCore.MkPlc qualified as PLC import PlutusCore.Pretty qualified as PLC import PlutusCore.Quote -import PlutusCore.AstSize (AstSize) import PlutusCore.StdLib.Type qualified as Types import PlutusCore.TypeCheck.Internal qualified as PLC import PlutusCore.Version qualified as PLC @@ -40,18 +40,19 @@ import PlutusPrelude data AllowEscape = YesEscape | NoEscape -- | extending the plc typecheck config with AllowEscape -data PirTCConfig uni fun = PirTCConfig { - _pirConfigTCConfig :: PLC.TypeCheckConfig uni fun - , _pirConfigAllowEscape :: AllowEscape - } +data PirTCConfig uni fun = PirTCConfig + { _pirConfigTCConfig :: PLC.TypeCheckConfig uni fun + , _pirConfigAllowEscape :: AllowEscape + } + makeLenses ''PirTCConfig -- pir config has inside a plc config so it can act like it instance PLC.HasKindCheckConfig (PirTCConfig uni fun) where - kindCheckConfig = pirConfigTCConfig . PLC.kindCheckConfig + kindCheckConfig = pirConfigTCConfig . PLC.kindCheckConfig instance PLC.HasTypeCheckConfig (PirTCConfig uni fun) uni fun where - typeCheckConfig = pirConfigTCConfig + typeCheckConfig = pirConfigTCConfig -- | What style to use when encoding datatypes. -- Generally, 'SumsOfProducts' is superior, unless you are targeting an @@ -59,119 +60,126 @@ instance PLC.HasTypeCheckConfig (PirTCConfig uni fun) uni fun where -- -- See Note [Encoding of datatypes] data DatatypeStyle - = ScottEncoding - | SumsOfProducts - | BuiltinCasing - -- ^ A temporary data type style used to make a couple of V3 ledger-api-test tests pass - -- before we can support casing on values of built-in types in newer protocol versions and - -- merge this into 'SumsOfProducts' (which is what controls whether 'Case' is available or - -- not). - deriving stock (Show, Read, Eq) + = ScottEncoding + | SumsOfProducts + | -- | A temporary data type style used to make a couple of V3 ledger-api-test tests pass + -- before we can support casing on values of built-in types in newer protocol versions and + -- merge this into 'SumsOfProducts' (which is what controls whether 'Case' is available or + -- not). + BuiltinCasing + deriving stock (Show, Read, Eq) instance Pretty DatatypeStyle where pretty = viaShow newtype DatatypeCompilationOpts = DatatypeCompilationOpts - { _dcoStyle :: DatatypeStyle - } deriving newtype (Show, Read, Pretty) + { _dcoStyle :: DatatypeStyle + } + deriving newtype (Show, Read, Pretty) makeLenses ''DatatypeCompilationOpts defaultDatatypeCompilationOpts :: DatatypeCompilationOpts defaultDatatypeCompilationOpts = DatatypeCompilationOpts SumsOfProducts -data CompilationOpts a = CompilationOpts { - _coOptimize :: Bool - , _coTypecheck :: Bool - , _coPedantic :: Bool - , _coVerbose :: Bool - , _coDebug :: Bool - , _coDatatypes :: DatatypeCompilationOpts - -- Simplifier passes - , _coMaxSimplifierIterations :: Int - , _coDoSimplifierUnwrapCancel :: Bool - , _coDoSimplifierCaseReduce :: Bool - , _coDoSimplifierRewrite :: Bool - , _coDoSimplifierBeta :: Bool - , _coDoSimplifierInline :: Bool - , _coDoSimplifierKnownCon :: Bool - , _coDoSimplifierCaseOfCase :: Bool - , _coDoSimplifierEvaluateBuiltins :: Bool - , _coDoSimplifierStrictifyBindings :: Bool - , _coDoSimplifierRemoveDeadBindings :: Bool - , _coInlineHints :: InlineHints PLC.Name (Provenance a) - , _coInlineConstants :: Bool - , _coInlineFix :: Bool - , _coInlineCallsiteGrowth :: AstSize - -- Profiling - , _coProfile :: Bool - , _coRelaxedFloatin :: Bool - , _coCaseOfCaseConservative :: Bool - -- | Whether to try and preserve the logging beahviour of the program. - , _coPreserveLogging :: Bool - } deriving stock (Show) +data CompilationOpts a = CompilationOpts + { _coOptimize :: Bool + , _coTypecheck :: Bool + , _coPedantic :: Bool + , _coVerbose :: Bool + , _coDebug :: Bool + , _coDatatypes :: DatatypeCompilationOpts + , -- Simplifier passes + _coMaxSimplifierIterations :: Int + , _coDoSimplifierUnwrapCancel :: Bool + , _coDoSimplifierCaseReduce :: Bool + , _coDoSimplifierRewrite :: Bool + , _coDoSimplifierBeta :: Bool + , _coDoSimplifierInline :: Bool + , _coDoSimplifierKnownCon :: Bool + , _coDoSimplifierCaseOfCase :: Bool + , _coDoSimplifierEvaluateBuiltins :: Bool + , _coDoSimplifierStrictifyBindings :: Bool + , _coDoSimplifierRemoveDeadBindings :: Bool + , _coInlineHints :: InlineHints PLC.Name (Provenance a) + , _coInlineConstants :: Bool + , _coInlineFix :: Bool + , _coInlineCallsiteGrowth :: AstSize + , -- Profiling + _coProfile :: Bool + , _coRelaxedFloatin :: Bool + , _coCaseOfCaseConservative :: Bool + , _coPreserveLogging :: Bool + -- ^ Whether to try and preserve the logging beahviour of the program. + } + deriving stock (Show) makeLenses ''CompilationOpts defaultCompilationOpts :: CompilationOpts a -defaultCompilationOpts = CompilationOpts - { _coOptimize = True -- synonymous with max-simplifier-iterations=0 - , _coTypecheck = True - , _coPedantic = False - , _coVerbose = False - , _coDebug = False - , _coDatatypes = defaultDatatypeCompilationOpts - , _coMaxSimplifierIterations = 12 - , _coDoSimplifierUnwrapCancel = True - , _coDoSimplifierCaseReduce = True - , _coDoSimplifierRewrite = True - , _coDoSimplifierKnownCon = True - , _coDoSimplifierCaseOfCase = True - , _coDoSimplifierBeta = True - , _coDoSimplifierInline = True - , _coDoSimplifierEvaluateBuiltins = True - , _coDoSimplifierStrictifyBindings = True - , _coInlineHints = def - , _coInlineConstants = True - , _coInlineFix = True - , _coInlineCallsiteGrowth = 5 - , _coProfile = False - , _coRelaxedFloatin = True - , _coCaseOfCaseConservative = True - , _coPreserveLogging = False - , _coDoSimplifierRemoveDeadBindings = True - } - -data CompilationCtx uni fun a = CompilationCtx { - _ccOpts :: CompilationOpts a - , _ccEnclosing :: Provenance a - -- | Decide to either typecheck (passing a specific tcconfig) or not by passing 'Nothing'. - , _ccTypeCheckConfig :: PirTCConfig uni fun - , _ccBuiltinsInfo :: BuiltinsInfo uni fun - , _ccBuiltinCostModel :: PLC.CostingPart uni fun - , _ccRewriteRules :: RewriteRules uni fun +defaultCompilationOpts = + CompilationOpts + { _coOptimize = True -- synonymous with max-simplifier-iterations=0 + , _coTypecheck = True + , _coPedantic = False + , _coVerbose = False + , _coDebug = False + , _coDatatypes = defaultDatatypeCompilationOpts + , _coMaxSimplifierIterations = 12 + , _coDoSimplifierUnwrapCancel = True + , _coDoSimplifierCaseReduce = True + , _coDoSimplifierRewrite = True + , _coDoSimplifierKnownCon = True + , _coDoSimplifierCaseOfCase = True + , _coDoSimplifierBeta = True + , _coDoSimplifierInline = True + , _coDoSimplifierEvaluateBuiltins = True + , _coDoSimplifierStrictifyBindings = True + , _coInlineHints = def + , _coInlineConstants = True + , _coInlineFix = True + , _coInlineCallsiteGrowth = 5 + , _coProfile = False + , _coRelaxedFloatin = True + , _coCaseOfCaseConservative = True + , _coPreserveLogging = False + , _coDoSimplifierRemoveDeadBindings = True } +data CompilationCtx uni fun a = CompilationCtx + { _ccOpts :: CompilationOpts a + , _ccEnclosing :: Provenance a + , _ccTypeCheckConfig :: PirTCConfig uni fun + -- ^ Decide to either typecheck (passing a specific tcconfig) or not by passing 'Nothing'. + , _ccBuiltinsInfo :: BuiltinsInfo uni fun + , _ccBuiltinCostModel :: PLC.CostingPart uni fun + , _ccRewriteRules :: RewriteRules uni fun + } + makeLenses ''CompilationCtx -toDefaultCompilationCtx - :: (Default (BuiltinsInfo uni fun), Default (PLC.CostingPart uni fun), Default (RewriteRules uni fun)) - => PLC.TypeCheckConfig uni fun - -> CompilationCtx uni fun a -toDefaultCompilationCtx configPlc = CompilationCtx - { _ccOpts = defaultCompilationOpts - , _ccEnclosing = noProvenance - , _ccTypeCheckConfig = PirTCConfig configPlc YesEscape - , _ccBuiltinsInfo = def - , _ccBuiltinCostModel = def - , _ccRewriteRules = def - } +toDefaultCompilationCtx :: + (Default (BuiltinsInfo uni fun), Default (PLC.CostingPart uni fun), Default (RewriteRules uni fun)) => + PLC.TypeCheckConfig uni fun -> + CompilationCtx uni fun a +toDefaultCompilationCtx configPlc = + CompilationCtx + { _ccOpts = defaultCompilationOpts + , _ccEnclosing = noProvenance + , _ccTypeCheckConfig = PirTCConfig configPlc YesEscape + , _ccBuiltinsInfo = def + , _ccBuiltinCostModel = def + , _ccRewriteRules = def + } validateOpts :: Compiling m uni fun a => PLC.Version -> m () validateOpts v = do datatypes <- view (ccOpts . coDatatypes . dcoStyle) when ((datatypes == SumsOfProducts || datatypes == BuiltinCasing) && v < PLC.plcVersion110) $ - throwError $ OptionsError $ T.pack $ "Cannot use sums-of-products to compile a program with version less than 1.10. Program version is:" ++ show v + throwError $ + OptionsError $ + T.pack $ + "Cannot use sums-of-products to compile a program with version less than 1.10. Program version is:" ++ show v getEnclosing :: MonadReader (CompilationCtx uni fun a) m => m (Provenance a) getEnclosing = view ccEnclosing @@ -179,11 +187,11 @@ getEnclosing = view ccEnclosing withEnclosing :: MonadReader (CompilationCtx uni fun a) m => (Provenance a -> Provenance a) -> m b -> m b withEnclosing f = local (over ccEnclosing f) -runIf - :: MonadReader (CompilationCtx uni fun a) m - => m Bool - -> (b -> m b) - -> (b -> m b) +runIf :: + MonadReader (CompilationCtx uni fun a) m => + m Bool -> + (b -> m b) -> + (b -> m b) runIf condition pass arg = do doPass <- condition if doPass then pass arg else pure arg @@ -197,56 +205,56 @@ type PLCType uni a = PLC.Type PLC.TyName uni (Provenance a) -- | A possibly recursive type. data PLCRecType uni fun a - = PlainType (PLCType uni a) - | RecursiveType (Types.RecursiveType uni fun (Provenance a)) + = PlainType (PLCType uni a) + | RecursiveType (Types.RecursiveType uni fun (Provenance a)) -- | Get the actual type inside a 'PLCRecType'. getType :: PLCRecType uni fun a -> PLCType uni a getType r = case r of - PlainType t -> t - RecursiveType Types.RecursiveType {Types._recursiveType=t} -> t + PlainType t -> t + RecursiveType Types.RecursiveType {Types._recursiveType = t} -> t -- | Wrap a term appropriately for a possibly recursive type. wrap :: Provenance a -> PLCRecType uni fun a -> [PLCType uni a] -> PIRTerm uni fun a -> PIRTerm uni fun a wrap p r tvs t = case r of - PlainType _ -> t - RecursiveType Types.RecursiveType {Types._recursiveWrap=wrapper} -> setProvenance p $ wrapper tvs t + PlainType _ -> t + RecursiveType Types.RecursiveType {Types._recursiveWrap = wrapper} -> setProvenance p $ wrapper tvs t -- | Unwrap a term appropriately for a possibly recursive type. unwrap :: Provenance a -> PLCRecType uni fun a -> PIRTerm uni fun a -> PIRTerm uni fun a unwrap p r t = case r of - PlainType _ -> t - RecursiveType Types.RecursiveType {} -> PIR.Unwrap p t + PlainType _ -> t + RecursiveType Types.RecursiveType {} -> PIR.Unwrap p t type PIRTerm uni fun a = PIR.Term PIR.TyName PIR.Name uni fun (Provenance a) type PIRType uni a = PIR.Type PIR.TyName uni (Provenance a) type Compiling m uni fun a = - ( Monad m - , MonadReader (CompilationCtx uni fun a) m - , MonadError (Error uni fun (Provenance a)) m - , PLC.AnnotateCaseBuiltin uni - , PLC.CaseBuiltin uni - , MonadQuote m - , Ord a - , AnnInline a - , PLC.Typecheckable uni fun - , PLC.GEq uni - -- Pretty printing instances - , PLC.PrettyUni uni - , PLC.Pretty fun - , PLC.Pretty a - ) + ( Monad m + , MonadReader (CompilationCtx uni fun a) m + , MonadError (Error uni fun (Provenance a)) m + , PLC.AnnotateCaseBuiltin uni + , PLC.CaseBuiltin uni + , MonadQuote m + , Ord a + , AnnInline a + , PLC.Typecheckable uni fun + , PLC.GEq uni + , -- Pretty printing instances + PLC.PrettyUni uni + , PLC.Pretty fun + , PLC.Pretty a + ) type TermDef tyname name uni fun a = PLC.Def (PLC.VarDecl tyname name uni a) (PIR.Term tyname name uni fun a) -- | We generate some shared definitions compilation, this datatype -- defines the "keys" for those definitions. -data SharedName = - FixpointCombinator Integer - | FixBy - deriving stock (Show, Eq, Ord) +data SharedName + = FixpointCombinator Integer + | FixBy + deriving stock (Show, Eq, Ord) toProgramName :: SharedName -> Quote PLC.Name toProgramName (FixpointCombinator n) = freshName ("fix" <> T.pack (show n)) -toProgramName FixBy = freshName "fixBy" +toProgramName FixBy = freshName "fixBy" diff --git a/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs b/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs index 93f52a8e716..157f02ff5e6 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} + -- | Datatypes representing 'contexts with holes' in Plutus IR terms. -- -- Useful for focussing on a sub-part of a term and then reconstructing the term, but @@ -18,79 +19,79 @@ import PlutusIR.MkPir -- | A context for an iterated term/type application, with the hole at the head of the -- application. -data AppContext tyname name uni fun ann = - TermAppContext (Term tyname name uni fun ann) ann (AppContext tyname name uni fun ann) +data AppContext tyname name uni fun ann + = TermAppContext (Term tyname name uni fun ann) ann (AppContext tyname name uni fun ann) | TypeAppContext (Type tyname uni ann) ann (AppContext tyname name uni fun ann) | AppContextEnd -{- | Takes a term and views it as a head plus an 'AppContext', e.g. - -@ - [{ f t } u v] - --> - (f, [{ _ t } u v]) - == - f (TypeAppContext t (TermAppContext u (TermAppContext v AppContextEnd))) -@ --} -splitApplication :: Term tyname name uni fun ann - -> (Term tyname name uni fun ann, AppContext tyname name uni fun ann) -splitApplication tm - = go tm AppContextEnd +-- | Takes a term and views it as a head plus an 'AppContext', e.g. +-- +-- @ +-- [{ f t } u v] +-- --> +-- (f, [{ _ t } u v]) +-- == +-- f (TypeAppContext t (TermAppContext u (TermAppContext v AppContextEnd))) +-- @ +splitApplication :: + Term tyname name uni fun ann -> + (Term tyname name uni fun ann, AppContext tyname name uni fun ann) +splitApplication tm = + go tm AppContextEnd where - go (Apply ann f arg) ctx = go f (TermAppContext arg ann ctx) + go (Apply ann f arg) ctx = go f (TermAppContext arg ann ctx) go (TyInst ann f tyArg) ctx = go f (TypeAppContext tyArg ann ctx) - go t ctx = (t, ctx) + go t ctx = (t, ctx) -- | Fills in the hole in an 'AppContext', the inverse of 'splitApplication'. -fillAppContext - :: Term tyname name uni fun ann - -> AppContext tyname name uni fun ann - -> Term tyname name uni fun ann +fillAppContext :: + Term tyname name uni fun ann -> + AppContext tyname name uni fun ann -> + Term tyname name uni fun ann fillAppContext t = \case - AppContextEnd -> t - TermAppContext arg ann ctx -> fillAppContext (Apply ann t arg) ctx + AppContextEnd -> t + TermAppContext arg ann ctx -> fillAppContext (Apply ann t arg) ctx TypeAppContext tyArg ann ctx -> fillAppContext (TyInst ann t tyArg) ctx dropAppContext :: Int -> AppContext tyname name uni fun a -> AppContext tyname name uni fun a dropAppContext i ctx | i <= 0 = ctx dropAppContext i ctx = case ctx of - AppContextEnd -> ctx - TermAppContext _ _ ctx' -> dropAppContext (i-1) ctx' - TypeAppContext _ _ ctx' -> dropAppContext (i-1) ctx' + AppContextEnd -> ctx + TermAppContext _ _ ctx' -> dropAppContext (i - 1) ctx' + TypeAppContext _ _ ctx' -> dropAppContext (i - 1) ctx' lengthContext :: AppContext tyname name uni fun a -> Int lengthContext = go 0 where go acc = \case - AppContextEnd -> acc - TermAppContext _ _ ctx -> go (acc+1) ctx - TypeAppContext _ _ ctx -> go (acc+1) ctx - -splitAppContext - :: Int - -> AppContext tyname name uni fun a - -> (AppContext tyname name uni fun a, AppContext tyname name uni fun a) + AppContextEnd -> acc + TermAppContext _ _ ctx -> go (acc + 1) ctx + TypeAppContext _ _ ctx -> go (acc + 1) ctx + +splitAppContext :: + Int -> + AppContext tyname name uni fun a -> + (AppContext tyname name uni fun a, AppContext tyname name uni fun a) splitAppContext = go id where - go - :: (AppContext tyname name uni fun a -> AppContext tyname name uni fun a) - -> Int - -> AppContext tyname name uni fun a - -> (AppContext tyname name uni fun a, AppContext tyname name uni fun a) + go :: + (AppContext tyname name uni fun a -> AppContext tyname name uni fun a) -> + Int -> + AppContext tyname name uni fun a -> + (AppContext tyname name uni fun a, AppContext tyname name uni fun a) go acc i ctx | i <= 0 = (acc AppContextEnd, ctx) go acc i ctx = case ctx of - c@AppContextEnd -> (acc c, AppContextEnd) - TermAppContext arg ann ctx' -> go (\end -> acc $ TermAppContext arg ann end) (i-1) ctx' - TypeAppContext arg ann ctx' -> go (\end -> acc $ TypeAppContext arg ann end) (i-1) ctx' - -appendAppContext - :: AppContext tyname name uni fun a - -> AppContext tyname name uni fun a - -> AppContext tyname name uni fun a + c@AppContextEnd -> (acc c, AppContextEnd) + TermAppContext arg ann ctx' -> go (\end -> acc $ TermAppContext arg ann end) (i - 1) ctx' + TypeAppContext arg ann ctx' -> go (\end -> acc $ TypeAppContext arg ann end) (i - 1) ctx' + +appendAppContext :: + AppContext tyname name uni fun a -> + AppContext tyname name uni fun a -> + AppContext tyname name uni fun a appendAppContext ctx1 ctx2 = go ctx1 where - go AppContextEnd = ctx2 + go AppContextEnd = ctx2 go (TermAppContext arg ann ctx') = TermAppContext arg ann $ go ctx' go (TypeAppContext arg ann ctx') = TypeAppContext arg ann $ go ctx' @@ -105,19 +106,19 @@ data Saturation = Oversaturated | Undersaturated | Saturated -- | Do the given arguments saturate the given arity? saturates :: AppContext tyname name uni fun a -> Arity -> Maybe Saturation -- Exactly right -saturates AppContextEnd [] = Just Saturated +saturates AppContextEnd [] = Just Saturated -- Parameters left - undersaturated -saturates AppContextEnd _ = Just Undersaturated +saturates AppContextEnd _ = Just Undersaturated -- Match a term parameter to a term arg -saturates (TermAppContext _ _ ctx) (TermParam:arities) = saturates ctx arities +saturates (TermAppContext _ _ ctx) (TermParam : arities) = saturates ctx arities -- Match a type parameter to a type arg -saturates (TypeAppContext _ _ ctx) (TypeParam:arities) = saturates ctx arities +saturates (TypeAppContext _ _ ctx) (TypeParam : arities) = saturates ctx arities -- Param/arg mismatch -saturates (TermAppContext{}) (TypeParam:_) = Nothing -saturates (TypeAppContext{}) (TermParam:_) = Nothing +saturates (TermAppContext {}) (TypeParam : _) = Nothing +saturates (TypeAppContext {}) (TermParam : _) = Nothing -- Arguments left - undersaturated -saturates (TermAppContext{}) [] = Just Oversaturated -saturates (TypeAppContext{}) [] = Just Oversaturated +saturates (TermAppContext {}) [] = Just Oversaturated +saturates (TypeAppContext {}) [] = Just Oversaturated -- | A split up version of the 'AppContext' for a datatype match, with the various -- parts we might want to look at. @@ -127,10 +128,10 @@ saturates (TypeAppContext{}) [] = Just Oversaturated -- "matchers" have the arguments in a different order to the matchers from normal -- PIR datatypes. data SplitMatchContext tyname name uni fun a = SplitMatchContext - { smTyVars :: AppContext tyname name uni fun a + { smTyVars :: AppContext tyname name uni fun a , smScrutinee :: (Term tyname name uni fun a, Type tyname uni (), a) - , smResTy :: (Type tyname uni a, a) - , smBranches :: AppContext tyname name uni fun a + , smResTy :: (Type tyname uni a, a) + , smBranches :: AppContext tyname name uni fun a } -- | Extract the type application arguments from an 'AppContext'. @@ -141,55 +142,58 @@ extractTyArgs = go DList.empty where go acc = \case TypeAppContext ty _ann ctx -> go (DList.snoc acc ty) ctx - TermAppContext{} -> Nothing - AppContextEnd -> Just (DList.toList acc) + TermAppContext {} -> Nothing + AppContextEnd -> Just (DList.toList acc) -- | Split a normal datatype 'match'. -splitNormalDatatypeMatch - :: (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) - => VarsInfo tyname name uni a - -> name - -> AppContext tyname name uni fun a -> Maybe (SplitMatchContext tyname name uni fun a) +splitNormalDatatypeMatch :: + (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => + VarsInfo tyname name uni a -> + name -> + AppContext tyname name uni fun a -> + Maybe (SplitMatchContext tyname name uni fun a) splitNormalDatatypeMatch vinfo matcherName args | Just dmInfo@(DatatypeMatcher dmParentTyname) <- lookupVarInfo matcherName vinfo - -- Needs to be saturated otherwise we won't find the bits! - , Just dmArity <- varInfoArity dmInfo vinfo + , -- Needs to be saturated otherwise we won't find the bits! + Just dmArity <- varInfoArity dmInfo vinfo , Just Saturated <- saturates args dmArity , Just (DatatypeTyVar (Datatype _ tyname tyvars _ _)) <- lookupTyVarInfo dmParentTyname vinfo - -- Split up the application into: - -- 1. The initial datatype type instantiations - -- 2. The scrutinee - -- 3. The result type variable instantiation - -- 4. The branches - , (vars, TermAppContext scrut scrutAnn (TypeAppContext resTy resTyAnn branches)) <- + , -- Split up the application into: + -- 1. The initial datatype type instantiations + -- 2. The scrutinee + -- 3. The result type variable instantiation + -- 4. The branches + (vars, TermAppContext scrut scrutAnn (TypeAppContext resTy resTyAnn branches)) <- splitAppContext (length tyvars) args - , Just tvs <- extractTyArgs vars - = - let - scrutTy = mkIterTyApp (mkTyVar () (void tyname)) $ ((),) . void <$> tvs - sm = SplitMatchContext vars (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches - in Just sm + , Just tvs <- extractTyArgs vars = + let + scrutTy = mkIterTyApp (mkTyVar () (void tyname)) $ ((),) . void <$> tvs + sm = SplitMatchContext vars (scrut, scrutTy, scrutAnn) (resTy, resTyAnn) branches + in + Just sm | otherwise = Nothing -- | Reconstruct a normal datatype 'match'. -reconstructNormalDatatypeMatch - :: SplitMatchContext tyname name uni fun a - -> AppContext tyname name uni fun a +reconstructNormalDatatypeMatch :: + SplitMatchContext tyname name uni fun a -> + AppContext tyname name uni fun a reconstructNormalDatatypeMatch (SplitMatchContext vars (scrut, _, scrutAnn) (resTy, resTyAnn) branches) = - vars <> TermAppContext scrut scrutAnn (TypeAppContext resTy resTyAnn branches) + vars <> TermAppContext scrut scrutAnn (TypeAppContext resTy resTyAnn branches) -- | Split a normal datatype 'match'. -asNormalDatatypeMatch - :: (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) - => VarsInfo tyname name uni a - -> name - -> Prism' (AppContext tyname name uni fun a) (SplitMatchContext tyname name uni fun a) +asNormalDatatypeMatch :: + (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => + VarsInfo tyname name uni a -> + name -> + Prism' (AppContext tyname name uni fun a) (SplitMatchContext tyname name uni fun a) asNormalDatatypeMatch vinfo name = prism reconstructNormalDatatypeMatch - (\args -> case splitNormalDatatypeMatch vinfo name args of - { Just sm -> Right sm; Nothing -> Left args; }) + ( \args -> case splitNormalDatatypeMatch vinfo name args of + Just sm -> Right sm + Nothing -> Left args + ) {- Note [Context splitting in a recursive pass] When writing a recursive pass that processes the whole program, you must be diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core.hs b/plutus-core/plutus-ir/src/PlutusIR/Core.hs index ef9df4ac426..3aaf55af8b7 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core.hs @@ -1,8 +1,7 @@ module PlutusIR.Core ( - module Export + module Export, ) where - import PlutusIR.Core.Instance () import PlutusIR.Core.Plated as Export import PlutusIR.Core.Type as Export diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs index c4b04e8d12a..e1918c5abc9 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module PlutusIR.Core.Instance.Flat () where import PlutusIR.Core.Type @@ -18,37 +19,45 @@ the underlying representation can vary. The `Generic` instances of the terms can thus be used as backwards compatibility is not required. -} -deriving anyclass instance ( PLC.Closed uni - , uni `PLC.Everywhere` Flat - , Flat a - , Flat tyname - , Flat name - ) => Flat (Datatype tyname name uni a) +deriving anyclass instance + ( PLC.Closed uni + , uni `PLC.Everywhere` Flat + , Flat a + , Flat tyname + , Flat name + ) => + Flat (Datatype tyname name uni a) deriving anyclass instance Flat Recursivity deriving anyclass instance Flat Strictness -deriving anyclass instance ( PLC.Closed uni - , uni `PLC.Everywhere` Flat - , Flat fun - , Flat a - , Flat tyname - , Flat name - ) => Flat (Binding tyname name uni fun a) - -deriving anyclass instance ( PLC.Closed uni - , uni `PLC.Everywhere` Flat - , Flat fun - , Flat a - , Flat tyname - , Flat name - ) => Flat (Term tyname name uni fun a) - -deriving anyclass instance ( PLC.Closed uni - , uni `PLC.Everywhere` Flat - , Flat fun - , Flat a - , Flat tyname - , Flat name - ) => Flat (Program tyname name uni fun a) +deriving anyclass instance + ( PLC.Closed uni + , uni `PLC.Everywhere` Flat + , Flat fun + , Flat a + , Flat tyname + , Flat name + ) => + Flat (Binding tyname name uni fun a) + +deriving anyclass instance + ( PLC.Closed uni + , uni `PLC.Everywhere` Flat + , Flat fun + , Flat a + , Flat tyname + , Flat name + ) => + Flat (Term tyname name uni fun a) + +deriving anyclass instance + ( PLC.Closed uni + , uni `PLC.Everywhere` Flat + , Flat fun + , Flat a + , Flat tyname + , Flat name + ) => + Flat (Program tyname name uni fun a) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs index c40876c21e3..c7e76c7fada 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module PlutusIR.Core.Instance.Pretty () where @@ -22,167 +22,285 @@ import Prettyprinter.Custom -- Pretty-printing -instance ( PLC.PrettyClassicBy configName tyname - , PLC.PrettyClassicBy configName name - , PLC.PrettyParens (PLC.SomeTypeIn uni) - , Pretty ann - ) => PrettyBy (PLC.PrettyConfigClassic configName) (VarDecl tyname name uni ann) where - prettyBy config (VarDecl ann n ty) = - sexp "vardecl" (PLC.consAnnIf config ann [prettyBy config n, prettyBy config ty]) +instance + ( PLC.PrettyClassicBy configName tyname + , PLC.PrettyClassicBy configName name + , PLC.PrettyParens (PLC.SomeTypeIn uni) + , Pretty ann + ) => + PrettyBy (PLC.PrettyConfigClassic configName) (VarDecl tyname name uni ann) + where + prettyBy config (VarDecl ann n ty) = + sexp "vardecl" (PLC.consAnnIf config ann [prettyBy config n, prettyBy config ty]) -instance ( PLC.PrettyClassicBy configName tyname - , Pretty ann - ) => PrettyBy (PLC.PrettyConfigClassic configName) (TyVarDecl tyname ann) where - prettyBy config (TyVarDecl ann n ty) = - sexp "tyvardecl" (PLC.consAnnIf config ann [prettyBy config n, prettyBy config ty]) +instance + ( PLC.PrettyClassicBy configName tyname + , Pretty ann + ) => + PrettyBy (PLC.PrettyConfigClassic configName) (TyVarDecl tyname ann) + where + prettyBy config (TyVarDecl ann n ty) = + sexp "tyvardecl" (PLC.consAnnIf config ann [prettyBy config n, prettyBy config ty]) instance PrettyBy (PLC.PrettyConfigClassic configName) Recursivity where - prettyBy _ = \case - NonRec -> parens "nonrec" - Rec -> parens "rec" + prettyBy _ = \case + NonRec -> parens "nonrec" + Rec -> parens "rec" instance PrettyBy (PLC.PrettyConfigClassic configName) Strictness where - prettyBy _ = \case - NonStrict -> parens "nonstrict" - Strict -> parens "strict" - -instance ( PLC.PrettyClassicBy configName tyname - , PLC.PrettyClassicBy configName name - , PLC.PrettyParens (PLC.SomeTypeIn uni) - , Pretty ann - ) => PrettyBy (PLC.PrettyConfigClassic configName) (Datatype tyname name uni ann) where - prettyBy config (Datatype ann ty tyvars destr constrs) = - sexp "datatype" (PLC.consAnnIf config ann - [ prettyBy config ty - , sep $ fmap (prettyBy config) tyvars - , prettyBy config destr - , sep $ fmap (prettyBy config) constrs - ]) - -instance ( PLC.PrettyClassicBy configName tyname - , PLC.PrettyClassicBy configName name - , PLC.PrettyUni uni - , Pretty fun - , Pretty ann - ) => PrettyBy (PLC.PrettyConfigClassic configName) (Binding tyname name uni fun ann) where - prettyBy config = \case - TermBind ann s d t -> - sexp "termbind" (PLC.consAnnIf config ann - [prettyBy config s, prettyBy config d, prettyBy config t]) - TypeBind ann d ty -> - sexp "typebind" (PLC.consAnnIf config ann - [prettyBy config d, prettyBy config ty]) - DatatypeBind ann d -> - sexp "datatypebind" (PLC.consAnnIf config ann - [prettyBy config d]) - -instance ( PLC.PrettyClassicBy configName tyname - , PLC.PrettyClassicBy configName name - , PLC.PrettyUni uni - , Pretty fun - , Pretty ann - ) => PrettyBy (PLC.PrettyConfigClassic configName) (Term tyname name uni fun ann) where - prettyBy config = \case - Let ann r bs t -> - sexp "let" (PLC.consAnnIf config ann - [prettyBy config r, sep . toList $ fmap (prettyBy config) bs, prettyBy config t]) - Var ann n -> - sep (PLC.consAnnIf config ann - [prettyBy config n]) - TyAbs ann tn k t -> - sexp "abs" (PLC.consAnnIf config ann - [prettyBy config tn, prettyBy config k, prettyBy config t]) - LamAbs ann n ty t -> - sexp "lam" (PLC.consAnnIf config ann - [prettyBy config n, prettyBy config ty, prettyBy config t]) - Apply ann t1 t2 -> - brackets' (sep (PLC.consAnnIf config ann - [prettyBy config t1, prettyBy config t2])) - Constant ann c -> - sexp "con" (PLC.consAnnIf config ann [prettyTypeOf c, pretty c]) - Builtin ann bi -> - sexp "builtin" (PLC.consAnnIf config ann - [pretty bi]) - TyInst ann t ty -> - braces' (sep (PLC.consAnnIf config ann - [prettyBy config t, prettyBy config ty])) - Error ann ty -> - sexp "error" (PLC.consAnnIf config ann - [prettyBy config ty]) - IWrap ann ty1 ty2 t -> - sexp "iwrap" (PLC.consAnnIf config ann - [prettyBy config ty1, prettyBy config ty2, prettyBy config t]) - Unwrap ann t -> - sexp "unwrap" (PLC.consAnnIf config ann - [prettyBy config t]) - Constr ann ty i es -> - sexp "constr" (PLC.consAnnIf config ann - (prettyBy config ty : pretty i : fmap (prettyBy config) es)) - Case ann ty arg cs -> - sexp "case" (PLC.consAnnIf config ann - (prettyBy config ty : prettyBy config arg : fmap (prettyBy config) cs)) - where - prettyTypeOf :: PLC.Some (PLC.ValueOf uni) -> Doc dann - prettyTypeOf (PLC.Some (PLC.ValueOf uni _ )) = - PLC.prettyBy PLC.juxtRenderContext $ PLC.SomeTypeIn uni - - -instance ( PLC.PrettyClassicBy configName tyname - , PLC.PrettyClassicBy configName name - , PLC.PrettyUni uni - , Pretty fun - , Pretty ann - ) => PrettyBy (PLC.PrettyConfigClassic configName) (Program tyname name uni fun ann) where - prettyBy config (Program ann v t) = - sexp "program" (PLC.consAnnIf config ann [pretty v, prettyBy config t]) - -instance (PLC.PrettyClassic tyname, Pretty ann) => - Pretty (TyVarDecl tyname ann) where - pretty = PLC.prettyClassic - -instance ( PLC.PrettyClassic tyname - , PLC.PrettyClassic name - , PLC.PrettyParens (PLC.SomeTypeIn uni) - , Pretty ann - ) => Pretty (VarDecl tyname name uni ann) where - pretty = PLC.prettyClassic - -instance ( PLC.PrettyClassic tyname - , PLC.PrettyClassic name - , PLC.PrettyUni uni - , Pretty ann - ) => Pretty (Datatype tyname name uni ann) where - pretty = PLC.prettyClassic - -instance ( PLC.PrettyClassic tyname - , PLC.PrettyClassic name - , PLC.PrettyUni uni - , Pretty fun - , Pretty ann - ) => Pretty (Binding tyname name uni fun ann) where - pretty = PLC.prettyClassic - -instance ( PLC.PrettyClassic tyname - , PLC.PrettyClassic name - , PLC.PrettyUni uni - , Pretty fun - , Pretty ann - ) => Pretty (Term tyname name uni fun ann) where - pretty = PLC.prettyClassic - -instance ( PLC.PrettyClassic tyname - , PLC.PrettyClassic name - , PLC.PrettyUni uni - , Pretty fun - , Pretty ann - ) => Pretty (Program tyname name uni fun ann) where - pretty = PLC.prettyClassic - - -deriving via PrettyAny (Term tyname name uni fun ann) - instance PLC.DefaultPrettyPlcStrategy (Term tyname name uni fun ann) => - PrettyBy PLC.PrettyConfigPlc (Term tyname name uni fun ann) - -deriving via PrettyAny (Program tyname name uni fun ann) - instance PLC.DefaultPrettyPlcStrategy (Program tyname name uni fun ann) => - PrettyBy PLC.PrettyConfigPlc (Program tyname name uni fun ann) + prettyBy _ = \case + NonStrict -> parens "nonstrict" + Strict -> parens "strict" + +instance + ( PLC.PrettyClassicBy configName tyname + , PLC.PrettyClassicBy configName name + , PLC.PrettyParens (PLC.SomeTypeIn uni) + , Pretty ann + ) => + PrettyBy (PLC.PrettyConfigClassic configName) (Datatype tyname name uni ann) + where + prettyBy config (Datatype ann ty tyvars destr constrs) = + sexp + "datatype" + ( PLC.consAnnIf + config + ann + [ prettyBy config ty + , sep $ fmap (prettyBy config) tyvars + , prettyBy config destr + , sep $ fmap (prettyBy config) constrs + ] + ) + +instance + ( PLC.PrettyClassicBy configName tyname + , PLC.PrettyClassicBy configName name + , PLC.PrettyUni uni + , Pretty fun + , Pretty ann + ) => + PrettyBy (PLC.PrettyConfigClassic configName) (Binding tyname name uni fun ann) + where + prettyBy config = \case + TermBind ann s d t -> + sexp + "termbind" + ( PLC.consAnnIf + config + ann + [prettyBy config s, prettyBy config d, prettyBy config t] + ) + TypeBind ann d ty -> + sexp + "typebind" + ( PLC.consAnnIf + config + ann + [prettyBy config d, prettyBy config ty] + ) + DatatypeBind ann d -> + sexp + "datatypebind" + ( PLC.consAnnIf + config + ann + [prettyBy config d] + ) + +instance + ( PLC.PrettyClassicBy configName tyname + , PLC.PrettyClassicBy configName name + , PLC.PrettyUni uni + , Pretty fun + , Pretty ann + ) => + PrettyBy (PLC.PrettyConfigClassic configName) (Term tyname name uni fun ann) + where + prettyBy config = \case + Let ann r bs t -> + sexp + "let" + ( PLC.consAnnIf + config + ann + [prettyBy config r, sep . toList $ fmap (prettyBy config) bs, prettyBy config t] + ) + Var ann n -> + sep + ( PLC.consAnnIf + config + ann + [prettyBy config n] + ) + TyAbs ann tn k t -> + sexp + "abs" + ( PLC.consAnnIf + config + ann + [prettyBy config tn, prettyBy config k, prettyBy config t] + ) + LamAbs ann n ty t -> + sexp + "lam" + ( PLC.consAnnIf + config + ann + [prettyBy config n, prettyBy config ty, prettyBy config t] + ) + Apply ann t1 t2 -> + brackets' + ( sep + ( PLC.consAnnIf + config + ann + [prettyBy config t1, prettyBy config t2] + ) + ) + Constant ann c -> + sexp "con" (PLC.consAnnIf config ann [prettyTypeOf c, pretty c]) + Builtin ann bi -> + sexp + "builtin" + ( PLC.consAnnIf + config + ann + [pretty bi] + ) + TyInst ann t ty -> + braces' + ( sep + ( PLC.consAnnIf + config + ann + [prettyBy config t, prettyBy config ty] + ) + ) + Error ann ty -> + sexp + "error" + ( PLC.consAnnIf + config + ann + [prettyBy config ty] + ) + IWrap ann ty1 ty2 t -> + sexp + "iwrap" + ( PLC.consAnnIf + config + ann + [prettyBy config ty1, prettyBy config ty2, prettyBy config t] + ) + Unwrap ann t -> + sexp + "unwrap" + ( PLC.consAnnIf + config + ann + [prettyBy config t] + ) + Constr ann ty i es -> + sexp + "constr" + ( PLC.consAnnIf + config + ann + (prettyBy config ty : pretty i : fmap (prettyBy config) es) + ) + Case ann ty arg cs -> + sexp + "case" + ( PLC.consAnnIf + config + ann + (prettyBy config ty : prettyBy config arg : fmap (prettyBy config) cs) + ) + where + prettyTypeOf :: PLC.Some (PLC.ValueOf uni) -> Doc dann + prettyTypeOf (PLC.Some (PLC.ValueOf uni _)) = + PLC.prettyBy PLC.juxtRenderContext $ PLC.SomeTypeIn uni + +instance + ( PLC.PrettyClassicBy configName tyname + , PLC.PrettyClassicBy configName name + , PLC.PrettyUni uni + , Pretty fun + , Pretty ann + ) => + PrettyBy (PLC.PrettyConfigClassic configName) (Program tyname name uni fun ann) + where + prettyBy config (Program ann v t) = + sexp "program" (PLC.consAnnIf config ann [pretty v, prettyBy config t]) + +instance + (PLC.PrettyClassic tyname, Pretty ann) => + Pretty (TyVarDecl tyname ann) + where + pretty = PLC.prettyClassic + +instance + ( PLC.PrettyClassic tyname + , PLC.PrettyClassic name + , PLC.PrettyParens (PLC.SomeTypeIn uni) + , Pretty ann + ) => + Pretty (VarDecl tyname name uni ann) + where + pretty = PLC.prettyClassic + +instance + ( PLC.PrettyClassic tyname + , PLC.PrettyClassic name + , PLC.PrettyUni uni + , Pretty ann + ) => + Pretty (Datatype tyname name uni ann) + where + pretty = PLC.prettyClassic + +instance + ( PLC.PrettyClassic tyname + , PLC.PrettyClassic name + , PLC.PrettyUni uni + , Pretty fun + , Pretty ann + ) => + Pretty (Binding tyname name uni fun ann) + where + pretty = PLC.prettyClassic + +instance + ( PLC.PrettyClassic tyname + , PLC.PrettyClassic name + , PLC.PrettyUni uni + , Pretty fun + , Pretty ann + ) => + Pretty (Term tyname name uni fun ann) + where + pretty = PLC.prettyClassic + +instance + ( PLC.PrettyClassic tyname + , PLC.PrettyClassic name + , PLC.PrettyUni uni + , Pretty fun + , Pretty ann + ) => + Pretty (Program tyname name uni fun ann) + where + pretty = PLC.prettyClassic + +deriving via + PrettyAny (Term tyname name uni fun ann) + instance + PLC.DefaultPrettyPlcStrategy (Term tyname name uni fun ann) => + PrettyBy PLC.PrettyConfigPlc (Term tyname name uni fun ann) + +deriving via + PrettyAny (Program tyname name uni fun ann) + instance + PLC.DefaultPrettyPlcStrategy (Program tyname name uni fun ann) => + PrettyBy PLC.PrettyConfigPlc (Program tyname name uni fun ann) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs index e30f639fbae..5260b821d55 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs @@ -1,15 +1,17 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Eta reduce" #-} -- breaks type inference + +{-# HLINT ignore "Eta reduce" #-} +-- breaks type inference module PlutusIR.Core.Instance.Pretty.Readable () where @@ -22,97 +24,107 @@ import Prettyprinter import Prettyprinter.Custom -- | Split an iterated 'LamAbs' (if any) into a list of variables that it binds and its body. -viewLamAbs - :: Term tyname name uni fun ann - -> Maybe ([VarDecl tyname name uni ann], Term tyname name uni fun ann) -viewLamAbs term0@LamAbs{} = Just $ go term0 where +viewLamAbs :: + Term tyname name uni fun ann -> + Maybe ([VarDecl tyname name uni ann], Term tyname name uni fun ann) +viewLamAbs term0@LamAbs {} = Just $ go term0 + where go (LamAbs ann name ty body) = first (VarDecl ann name ty :) $ go body - go term = ([], term) + go term = ([], term) viewLamAbs _ = Nothing -- | Split an iterated 'TyAbs' (if any) into a list of variables that it binds and its body. -viewTyAbs - :: Term tyname name uni fun ann -> Maybe ([TyVarDecl tyname ann], Term tyname name uni fun ann) -viewTyAbs term0@TyAbs{} = Just $ go term0 where +viewTyAbs :: + Term tyname name uni fun ann -> Maybe ([TyVarDecl tyname ann], Term tyname name uni fun ann) +viewTyAbs term0@TyAbs {} = Just $ go term0 + where go (TyAbs ann name kind body) = first (TyVarDecl ann name kind :) $ go body - go term = ([], term) + go term = ([], term) viewTyAbs _ = Nothing -- | Split an iterated 'Apply'/'TyInst' (if any) into the head of the application and the spine. -viewApp - :: Term tyname name uni fun ann - -> Maybe - ( Term tyname name uni fun ann - , [Either (Type tyname uni ann) (Term tyname name uni fun ann)] - ) -viewApp term0 = go term0 [] where +viewApp :: + Term tyname name uni fun ann -> + Maybe + ( Term tyname name uni fun ann + , [Either (Type tyname uni ann) (Term tyname name uni fun ann)] + ) +viewApp term0 = go term0 [] + where go (Apply _ fun argTerm) args = go fun $ Right argTerm : args - go (TyInst _ fun argTy) args = go fun $ Left argTy : args - go _ [] = Nothing - go fun args = Just (fun, args) + go (TyInst _ fun argTy) args = go fun $ Left argTy : args + go _ [] = Nothing + go fun args = Just (fun, args) -- | Split a 'Let' (if any) into a list of bindings and its body. -viewLet - :: Term tyname name uni fun ann - -> Maybe ([(Recursivity, [Binding tyname name uni fun ann])], Term tyname name uni fun ann) -viewLet term0@Let{} = Just $ go term0 where +viewLet :: + Term tyname name uni fun ann -> + Maybe ([(Recursivity, [Binding tyname name uni fun ann])], Term tyname name uni fun ann) +viewLet term0@Let {} = Just $ go term0 + where go (Let _ rec binds body) = first ((rec, toList binds) :) $ go body - go term = ([], term) -viewLet _ = Nothing + go term = ([], term) +viewLet _ = Nothing type PrettyConstraints configName tyname name uni = - ( PrettyReadableBy configName tyname - , PrettyReadableBy configName name - , PrettyUni uni - ) + ( PrettyReadableBy configName tyname + , PrettyReadableBy configName name + , PrettyUni uni + ) -instance (PrettyConstraints configName tyname name uni, Pretty fun) - => PrettyBy (PrettyConfigReadable configName) (Term tyname name uni fun a) where - prettyBy = inContextM $ \case - Constant _ con -> lmap (ConstConfig . _pcrRenderContext) $ prettyM con - Builtin _ bi -> unitDocM $ pretty bi - (viewApp -> Just (fun, args)) -> iterInterAppPrettyM fun args - Apply {} -> error "Panic: 'Apply' is not covered by 'viewApp'" - TyInst {} -> error "Panic: 'TyInst' is not covered by 'viewApp'" - Var _ name -> prettyM name - (viewTyAbs -> Just (args, body)) -> iterTyAbsPrettyM args body - TyAbs {} -> error "Panic: 'TyAbs' is not covered by 'viewTyAbs'" - (viewLamAbs -> Just (args, body)) -> iterLamAbsPrettyM args body - LamAbs {} -> error "Panic: 'LamAbs' is not covered by 'viewLamAbs'" - Unwrap _ term -> iterAppDocM $ \_ prettyArg -> "unwrap" :| [prettyArg term] - IWrap _ pat arg term -> - iterAppDocM $ \_ prettyArg -> - "iwrap" :| [prettyArg pat, prettyArg arg, prettyArg term] - Error _ ty -> iterAppDocM $ \_ prettyArg -> "error" :| [prettyArg $ inBraces ty] - (viewLet -> Just (lets, body)) -> - compoundDocM binderFixity $ \prettyIn -> - let prettyBot x = prettyIn ToTheRight botFixity x - prec NonRec = "" - prec _ = "rec" - -- nest 2 including the "let": this means that we will always break after the let, - -- so that the bindings can be simply indented by 2 spaces, keeping the indent low - prettyLet r binds = vsep [ nest 2 ("let" <> prec r <> line <> vcatHard (prettyBot <$> binds)), "in"] - -- Lay out let-bindings in a layout-sensitive way - -- - -- let - -- !x : t = a - -- !y : t = b - -- in - -- foo x y - in vsep $ [ prettyLet r binds | (r, binds) <- lets ] ++ [ prettyBot body ] - Let {} -> error "Panic: 'Let' is not covered by 'viewLet'" - Constr _ ty i es -> - iterAppDocM $ \_ prettyArg -> "constr" :| [prettyArg ty, prettyArg i, prettyArg es] - Case _ ty arg cs -> - iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg ty, prettyArg arg, prettyArg cs] +instance + (PrettyConstraints configName tyname name uni, Pretty fun) => + PrettyBy (PrettyConfigReadable configName) (Term tyname name uni fun a) + where + prettyBy = inContextM $ \case + Constant _ con -> lmap (ConstConfig . _pcrRenderContext) $ prettyM con + Builtin _ bi -> unitDocM $ pretty bi + (viewApp -> Just (fun, args)) -> iterInterAppPrettyM fun args + Apply {} -> error "Panic: 'Apply' is not covered by 'viewApp'" + TyInst {} -> error "Panic: 'TyInst' is not covered by 'viewApp'" + Var _ name -> prettyM name + (viewTyAbs -> Just (args, body)) -> iterTyAbsPrettyM args body + TyAbs {} -> error "Panic: 'TyAbs' is not covered by 'viewTyAbs'" + (viewLamAbs -> Just (args, body)) -> iterLamAbsPrettyM args body + LamAbs {} -> error "Panic: 'LamAbs' is not covered by 'viewLamAbs'" + Unwrap _ term -> iterAppDocM $ \_ prettyArg -> "unwrap" :| [prettyArg term] + IWrap _ pat arg term -> + iterAppDocM $ \_ prettyArg -> + "iwrap" :| [prettyArg pat, prettyArg arg, prettyArg term] + Error _ ty -> iterAppDocM $ \_ prettyArg -> "error" :| [prettyArg $ inBraces ty] + (viewLet -> Just (lets, body)) -> + compoundDocM binderFixity $ \prettyIn -> + let prettyBot x = prettyIn ToTheRight botFixity x + prec NonRec = "" + prec _ = "rec" + -- nest 2 including the "let": this means that we will always break after the let, + -- so that the bindings can be simply indented by 2 spaces, keeping the indent low + prettyLet r binds = vsep [nest 2 ("let" <> prec r <> line <> vcatHard (prettyBot <$> binds)), "in"] + in -- Lay out let-bindings in a layout-sensitive way + -- + -- let + -- !x : t = a + -- !y : t = b + -- in + -- foo x y + vsep $ [prettyLet r binds | (r, binds) <- lets] ++ [prettyBot body] + Let {} -> error "Panic: 'Let' is not covered by 'viewLet'" + Constr _ ty i es -> + iterAppDocM $ \_ prettyArg -> "constr" :| [prettyArg ty, prettyArg i, prettyArg es] + Case _ ty arg cs -> + iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg ty, prettyArg arg, prettyArg cs] -instance (PrettyConstraints configName tyname name uni, Pretty fun) - => PrettyBy (PrettyConfigReadable configName) (Program tyname name uni fun a) where +instance + (PrettyConstraints configName tyname name uni, Pretty fun) => + PrettyBy (PrettyConfigReadable configName) (Program tyname name uni fun a) + where prettyBy = inContextM $ \(Program _ version term) -> iterAppDocM $ \_ prettyArg -> "program" :| [pretty version, prettyArg term] -instance (PrettyConstraints configName tyname name uni, Pretty fun) - => PrettyBy (PrettyConfigReadable configName) (Binding tyname name uni fun ann) where +instance + (PrettyConstraints configName tyname name uni, Pretty fun) => + PrettyBy (PrettyConfigReadable configName) (Binding tyname name uni fun ann) + where prettyBy = inContextM $ \case TermBind _ s vdec t -> -- Layout term bindings in lets like @@ -126,16 +138,19 @@ instance (PrettyConstraints configName tyname name uni, Pretty fun) withPrettyAt ToTheRight botFixity $ \prettyBot -> do return $ (bt <> prettyBot vdec) "=" <+> prettyBot t where - bt | Strict <- s = "!" - | otherwise = "~" + bt + | Strict <- s = "!" + | otherwise = "~" TypeBind _ tydec a -> -- Basically the same as above withPrettyAt ToTheRight botFixity $ \prettyBot -> do return $ prettyBot tydec "=" <+> prettyBot a DatatypeBind _ dt -> prettyM dt -instance PrettyConstraints configName tyname name uni - => PrettyBy (PrettyConfigReadable configName) (Datatype tyname name uni ann) where +instance + PrettyConstraints configName tyname name uni => + PrettyBy (PrettyConfigReadable configName) (Datatype tyname name uni ann) + where prettyBy = inContextM $ \case Datatype _ tydec pars name cs -> do -- Layout datatypes as @@ -143,6 +158,6 @@ instance PrettyConstraints configName tyname name uni -- Nothing : D a -- Just : a -> D a header <- sequenceDocM ToTheRight juxtFixity $ \prettyEl -> - "data" <+> fillSep (prettyEl tydec : map prettyEl pars) <+> "|" <+> prettyEl name <+> "where" + "data" <+> fillSep (prettyEl tydec : map prettyEl pars) <+> "|" <+> prettyEl name <+> "where" withPrettyAt ToTheRight botFixity $ \prettyBot -> do return $ vcatHard [header, indent 2 (align . vcatHard . map prettyBot $ cs)] diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Scoping.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Scoping.hs index a99f4fbdbea..41eeb5a55d8 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Scoping.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Scoping.hs @@ -1,11 +1,12 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module PlutusIR.Core.Instance.Scoping where import PlutusPrelude @@ -20,292 +21,298 @@ import Data.List.NonEmpty ((<|)) import Data.List.NonEmpty qualified as NonEmpty instance tyname ~ TyName => Reference TyName (Term tyname name uni fun) where - referenceVia reg tyname term = TyInst NotAName term $ TyVar (reg tyname) tyname + referenceVia reg tyname term = TyInst NotAName term $ TyVar (reg tyname) tyname instance name ~ Name => Reference Name (Term tyname name uni fun) where - referenceVia reg name term = Apply NotAName term $ Var (reg name) name + referenceVia reg name term = Apply NotAName term $ Var (reg name) name instance tyname ~ TyName => Reference TyName (VarDecl tyname name uni) where - referenceVia reg tyname (VarDecl ann varName ty) = - VarDecl ann varName $ referenceVia reg tyname ty + referenceVia reg tyname (VarDecl ann varName ty) = + VarDecl ann varName $ referenceVia reg tyname ty -- | Scoping for data types is hard, so we employ some extra paranoia and reference the provided -- 'TyName' in the type of every single constructor, and also apply the final head to that 'TyName'. instance tyname ~ TyName => Reference TyName (Datatype tyname name uni) where - referenceVia reg tyname (Datatype dataAnn dataDecl params matchName constrs) = - Datatype dataAnn dataDecl params matchName $ map goConstr constrs where - tyVar = TyVar (reg tyname) tyname + referenceVia reg tyname (Datatype dataAnn dataDecl params matchName constrs) = + Datatype dataAnn dataDecl params matchName $ map goConstr constrs + where + tyVar = TyVar (reg tyname) tyname - goConstr (VarDecl ann constrName constrTy) = VarDecl ann constrName $ goSpine constrTy + goConstr (VarDecl ann constrName constrTy) = VarDecl ann constrName $ goSpine constrTy - goSpine (TyForall ann name kind ty) = TyForall ann name kind $ goSpine ty - goSpine (TyFun ann dom cod) = TyFun ann dom $ goSpine cod - goSpine ty = TyFun NotAName tyVar $ goResult ty + goSpine (TyForall ann name kind ty) = TyForall ann name kind $ goSpine ty + goSpine (TyFun ann dom cod) = TyFun ann dom $ goSpine cod + goSpine ty = TyFun NotAName tyVar $ goResult ty - goResult (TyApp ann fun arg) = TyApp ann (goResult fun) arg - goResult ty = TyApp NotAName ty tyVar + goResult (TyApp ann fun arg) = TyApp ann (goResult fun) arg + goResult ty = TyApp NotAName ty tyVar instance tyname ~ TyName => Reference TyName (Binding tyname name uni fun) where - referenceVia reg tyname (TermBind ann strictness varDecl term) = - TermBind ann strictness (referenceVia reg tyname varDecl) $ referenceVia reg tyname term - referenceVia reg tyname (TypeBind ann tyVarDecl ty) = - TypeBind ann tyVarDecl $ referenceVia reg tyname ty - referenceVia reg tyname (DatatypeBind ann datatype) = - DatatypeBind ann $ referenceVia reg tyname datatype + referenceVia reg tyname (TermBind ann strictness varDecl term) = + TermBind ann strictness (referenceVia reg tyname varDecl) $ referenceVia reg tyname term + referenceVia reg tyname (TypeBind ann tyVarDecl ty) = + TypeBind ann tyVarDecl $ referenceVia reg tyname ty + referenceVia reg tyname (DatatypeBind ann datatype) = + DatatypeBind ann $ referenceVia reg tyname datatype -- | Unlike other 'Reference' instances this one does not guarantee that the name will actually be -- referenced, but it's too convenient to have this instance to give up on it, without it would be -- awkward to express \"reference this binding in this thing\". instance name ~ Name => Reference Name (Binding tyname name uni fun) where - referenceVia reg name (TermBind ann strictness varDecl term) = - TermBind ann strictness varDecl $ referenceVia reg name term - referenceVia _ _ typeBind@TypeBind{} = typeBind - referenceVia _ _ datatypeBind@DatatypeBind{} = datatypeBind + referenceVia reg name (TermBind ann strictness varDecl term) = + TermBind ann strictness varDecl $ referenceVia reg name term + referenceVia _ _ typeBind@TypeBind {} = typeBind + referenceVia _ _ datatypeBind@DatatypeBind {} = datatypeBind instance Reference tyname t => Reference (TyVarDecl tyname ann) t where - referenceVia reg = referenceVia reg . _tyVarDeclName + referenceVia reg = referenceVia reg . _tyVarDeclName instance Reference name t => Reference (VarDecl tyname name uni ann) t where - referenceVia reg = referenceVia reg . _varDeclName + referenceVia reg = referenceVia reg . _varDeclName instance (Reference TyName t, Reference Name t) => Reference (Datatype TyName Name uni ann) t where - referenceVia reg (Datatype _ dataDecl params matchName constrs) - = referenceVia reg dataDecl - -- Parameters of a data type are not visible outside of the data type no matter what. - . referenceOutOfScope params - . referenceVia reg matchName - . referenceVia reg constrs + referenceVia reg (Datatype _ dataDecl params matchName constrs) = + referenceVia reg dataDecl + -- Parameters of a data type are not visible outside of the data type no matter what. + . referenceOutOfScope params + . referenceVia reg matchName + . referenceVia reg constrs instance (Reference TyName t, Reference Name t) => Reference (Binding TyName Name uni fun ann) t where - referenceVia reg (TermBind _ _ varDecl _) = referenceVia reg varDecl - referenceVia reg (TypeBind _ tyVarDecl _) = referenceVia reg tyVarDecl - referenceVia reg (DatatypeBind _ datatype) = referenceVia reg datatype + referenceVia reg (TermBind _ _ varDecl _) = referenceVia reg varDecl + referenceVia reg (TypeBind _ tyVarDecl _) = referenceVia reg tyVarDecl + referenceVia reg (DatatypeBind _ datatype) = referenceVia reg datatype -- | Establish scoping for each of the parameters of a datatype by only annotating every parameter -- with 'introduceBound'. establishScopingParams :: [TyVarDecl TyName ann] -> Quote [TyVarDecl TyName NameAnn] establishScopingParams = - traverse $ \(TyVarDecl _ paramNameDup paramKind) -> do - paramName <- freshenTyName paramNameDup - TyVarDecl (introduceBound paramName) paramName <$> establishScoping paramKind + traverse $ \(TyVarDecl _ paramNameDup paramKind) -> do + paramName <- freshenTyName paramNameDup + TyVarDecl (introduceBound paramName) paramName <$> establishScoping paramKind -- See Note [Weird IR data types]. -{- | Establish scoping for the type of a constructor. The updated constructor expects an argument -of the \"the data type applied to all its parameters\" type (that argument is the last one) and -always returns that exact type as a result. For example, this functions turns the following -generated type of constructor - - integer -> a -> _type> - -into - - integer -> a -> D a b -> D a b - -assuming the constructor is supposed to construct a data type @D@ parameterized by two parameters -@a@ and @b@. Note that @_type>@ can be anything as the generator is allowed to generate -mess such as a constructor not actually constructing a value of the data type. - -Whether the name of the data type is referenced as in-scope or out-of-scope one in the types of -arguments of constructors is controlled by the first argument, which ultimately depends on the -recursivity of the data type. --} -establishScopingConstrTy - :: (TyName -> NameAnn) - -> TyName - -> [TyVarDecl TyName NameAnn] - -> Type TyName uni ann - -> Quote (Type TyName uni NameAnn) -establishScopingConstrTy regSelf dataName params = goSpine where - toDataAppliedToParams reg - = mkIterTyApp (TyVar (reg dataName) dataName) - $ map (\(TyVarDecl _ name _) -> (NotAName, TyVar (registerBound name) name)) params + +-- | Establish scoping for the type of a constructor. The updated constructor expects an argument +-- of the \"the data type applied to all its parameters\" type (that argument is the last one) and +-- always returns that exact type as a result. For example, this functions turns the following +-- generated type of constructor +-- +-- integer -> a -> _type> +-- +-- into +-- +-- integer -> a -> D a b -> D a b +-- +-- assuming the constructor is supposed to construct a data type @D@ parameterized by two parameters +-- @a@ and @b@. Note that @_type>@ can be anything as the generator is allowed to generate +-- mess such as a constructor not actually constructing a value of the data type. +-- +-- Whether the name of the data type is referenced as in-scope or out-of-scope one in the types of +-- arguments of constructors is controlled by the first argument, which ultimately depends on the +-- recursivity of the data type. +establishScopingConstrTy :: + (TyName -> NameAnn) -> + TyName -> + [TyVarDecl TyName NameAnn] -> + Type TyName uni ann -> + Quote (Type TyName uni NameAnn) +establishScopingConstrTy regSelf dataName params = goSpine + where + toDataAppliedToParams reg = + mkIterTyApp (TyVar (reg dataName) dataName) $ + map (\(TyVarDecl _ name _) -> (NotAName, TyVar (registerBound name) name)) params goSpine (TyForall _ nameDup kindDup ty) = do - -- Similar to 'establishScopingBinder', but uses 'TyFun' rather than whatever 'registerVia' - -- uses in order not to break the invariants described in Note [Weird IR data types]. - -- Also calls 'goSpine' recursively rather than 'establishScoping'. - name <- freshenTyName nameDup - kind <- establishScoping kindDup - TyFun NotAName (TyVar (registerOutOfScope name) name) . - TyForall (introduceBound name) name kind . - TyFun NotAName (TyVar (registerBound name) name) <$> - goSpine ty + -- Similar to 'establishScopingBinder', but uses 'TyFun' rather than whatever 'registerVia' + -- uses in order not to break the invariants described in Note [Weird IR data types]. + -- Also calls 'goSpine' recursively rather than 'establishScoping'. + name <- freshenTyName nameDup + kind <- establishScoping kindDup + TyFun NotAName (TyVar (registerOutOfScope name) name) + . TyForall (introduceBound name) name kind + . TyFun NotAName (TyVar (registerBound name) name) + <$> goSpine ty goSpine (TyFun _ dom cod) = TyFun NotAName <$> establishScoping dom <*> goSpine cod - goSpine _ = - pure . TyFun NotAName (toDataAppliedToParams regSelf) $ toDataAppliedToParams registerBound + goSpine _ = + pure . TyFun NotAName (toDataAppliedToParams regSelf) $ toDataAppliedToParams registerBound -- | Establish scoping for all constructors of a data type by establishing scoping for each of them -- individually. If there are no constructors, then a dummy one is added, because we need to -- maintain the invariant that every binding is referenced as an in-scope one somewhere and the only -- place where parameters of a data type can be referenced this way is a constructor of that data -- type. -establishScopingConstrs - :: (TyName -> NameAnn) - -> ann - -> TyName - -> [TyVarDecl TyName NameAnn] - -> [VarDecl TyName Name uni ann] - -> Quote [VarDecl TyName Name uni NameAnn] +establishScopingConstrs :: + (TyName -> NameAnn) -> + ann -> + TyName -> + [TyVarDecl TyName NameAnn] -> + [VarDecl TyName Name uni ann] -> + Quote [VarDecl TyName Name uni NameAnn] establishScopingConstrs regSelf dataAnn dataName params constrsPossiblyEmpty = do - cons0Name <- freshName "cons0" - let cons0 = VarDecl dataAnn cons0Name $ TyVar dataAnn dataName - constrs = if null constrsPossiblyEmpty then [cons0] else constrsPossiblyEmpty - for constrs $ \(VarDecl _ constrNameDup constrTyDup) -> do - constrName <- freshenName constrNameDup - constrTy <- establishScopingConstrTy regSelf dataName params constrTyDup - pure $ VarDecl (introduceBound constrName) constrName constrTy + cons0Name <- freshName "cons0" + let cons0 = VarDecl dataAnn cons0Name $ TyVar dataAnn dataName + constrs = if null constrsPossiblyEmpty then [cons0] else constrsPossiblyEmpty + for constrs $ \(VarDecl _ constrNameDup constrTyDup) -> do + constrName <- freshenName constrNameDup + constrTy <- establishScopingConstrTy regSelf dataName params constrTyDup + pure $ VarDecl (introduceBound constrName) constrName constrTy -- | Establish scoping of a binding. Each bindings gets referenced in its own body either as an -- in-scope or out-of-scope one, which is controlled by the first argument and ultimately depends on -- the recursivity of the binding. -establishScopingBinding - :: (forall name. ToScopedName name => name -> NameAnn) - -> Binding TyName Name uni fun ann - -> Quote (Binding TyName Name uni fun NameAnn) +establishScopingBinding :: + (forall name. ToScopedName name => name -> NameAnn) -> + Binding TyName Name uni fun ann -> + Quote (Binding TyName Name uni fun NameAnn) establishScopingBinding regSelf (TermBind _ strictness (VarDecl _ nameDup ty) term) = do - name <- freshenName nameDup - varDecl <- VarDecl (introduceBound name) name <$> establishScoping ty - TermBind NotAName strictness varDecl . referenceVia regSelf name <$> establishScoping term + name <- freshenName nameDup + varDecl <- VarDecl (introduceBound name) name <$> establishScoping ty + TermBind NotAName strictness varDecl . referenceVia regSelf name <$> establishScoping term establishScopingBinding regSelf (TypeBind _ (TyVarDecl _ nameDup kind) ty) = do - name <- freshenTyName nameDup - tyVarDecl <- TyVarDecl (introduceBound name) name <$> establishScoping kind - TypeBind NotAName tyVarDecl . referenceVia regSelf name <$> establishScoping ty + name <- freshenTyName nameDup + tyVarDecl <- TyVarDecl (introduceBound name) name <$> establishScoping kind + TypeBind NotAName tyVarDecl . referenceVia regSelf name <$> establishScoping ty establishScopingBinding regSelf (DatatypeBind dataAnn datatypeDup) = do - let Datatype _ dataDeclDup paramsDup matchNameDup constrsDup = datatypeDup - TyVarDecl _ dataNameDup dataKind = dataDeclDup - dataName <- freshenTyName dataNameDup - dataDecl <- TyVarDecl (introduceBound dataName) dataName <$> establishScoping dataKind - params <- establishScopingParams paramsDup - matchName <- freshenName matchNameDup - constrs <- establishScopingConstrs regSelf dataAnn dataName params constrsDup - let datatype = Datatype (introduceBound matchName) dataDecl params matchName constrs - pure $ DatatypeBind NotAName datatype + let Datatype _ dataDeclDup paramsDup matchNameDup constrsDup = datatypeDup + TyVarDecl _ dataNameDup dataKind = dataDeclDup + dataName <- freshenTyName dataNameDup + dataDecl <- TyVarDecl (introduceBound dataName) dataName <$> establishScoping dataKind + params <- establishScopingParams paramsDup + matchName <- freshenName matchNameDup + constrs <- establishScopingConstrs regSelf dataAnn dataName params constrsDup + let datatype = Datatype (introduceBound matchName) dataDecl params matchName constrs + pure $ DatatypeBind NotAName datatype -- | Reference each binding in the last one apart from itself. -referenceViaBindings - :: (forall name. ToScopedName name => name -> NameAnn) - -> NonEmpty (Binding TyName Name uni fun NameAnn) - -> NonEmpty (Binding TyName Name uni fun NameAnn) -referenceViaBindings _ (b0 :| []) = b0 :| [] -referenceViaBindings reg (b0 :| bs0) = go [] b0 bs0 where - go prevs b [] = referenceVia reg prevs b :| [] +referenceViaBindings :: + (forall name. ToScopedName name => name -> NameAnn) -> + NonEmpty (Binding TyName Name uni fun NameAnn) -> + NonEmpty (Binding TyName Name uni fun NameAnn) +referenceViaBindings _ (b0 :| []) = b0 :| [] +referenceViaBindings reg (b0 :| bs0) = go [] b0 bs0 + where + go prevs b [] = referenceVia reg prevs b :| [] go prevs b (c : bs) = b <| go (b : prevs) c bs -- | Reference each binding in the first one apart from itself and in the last one also apart from -- itself. Former bindings are always visible in latter ones and whether latter bindings are visible -- in former ones is controlled by the first argument and ultimately depends on the recursivity -- of the family of bindings. -referenceBindingsBothWays - :: (forall name. ToScopedName name => name -> NameAnn) - -> NonEmpty (Binding TyName Name uni fun NameAnn) - -> NonEmpty (Binding TyName Name uni fun NameAnn) -referenceBindingsBothWays regRec -- Whether latter bindings are visible in former ones - = NonEmpty.reverse -- or not depends on the recursivity and so we have - . referenceViaBindings regRec -- the registering function as an argument. +referenceBindingsBothWays :: + (forall name. ToScopedName name => name -> NameAnn) -> + NonEmpty (Binding TyName Name uni fun NameAnn) -> + NonEmpty (Binding TyName Name uni fun NameAnn) +referenceBindingsBothWays regRec -- Whether latter bindings are visible in former ones + = + NonEmpty.reverse -- or not depends on the recursivity and so we have + . referenceViaBindings regRec -- the registering function as an argument. . NonEmpty.reverse - . referenceViaBindings registerBound -- Former bindings are always visible in latter ones. + . referenceViaBindings registerBound -- Former bindings are always visible in latter ones. -- | Establish scoping for a family of bindings. -establishScopingBindings - :: (forall name. ToScopedName name => name -> NameAnn) - -> NonEmpty (Binding TyName Name uni fun ann) - -> Quote (NonEmpty (Binding TyName Name uni fun NameAnn)) +establishScopingBindings :: + (forall name. ToScopedName name => name -> NameAnn) -> + NonEmpty (Binding TyName Name uni fun ann) -> + Quote (NonEmpty (Binding TyName Name uni fun NameAnn)) establishScopingBindings regRec = - -- Note that mutual recursion and self-recursion are handled separately. - fmap (referenceBindingsBothWays regRec) . traverse (establishScopingBinding regRec) + -- Note that mutual recursion and self-recursion are handled separately. + fmap (referenceBindingsBothWays regRec) . traverse (establishScopingBinding regRec) -- | Return a registering function depending on the recursivity. registerByRecursivity :: ToScopedName name => Recursivity -> name -> NameAnn -registerByRecursivity Rec = registerBound +registerByRecursivity Rec = registerBound registerByRecursivity NonRec = registerOutOfScope firstBound :: Term tyname name uni fun ann -> [name] firstBound (Apply _ (LamAbs _ name _ body) _) = name : firstBound body -firstBound _ = [] +firstBound _ = [] instance (tyname ~ TyName, name ~ Name) => EstablishScoping (Term tyname name uni fun) where - establishScoping (Let _ recy bindingsDup body) = do - bindings <- establishScopingBindings (registerByRecursivity recy) bindingsDup - -- Follows the shape of 'establishScopingBinder', but subtly differs (for example, - -- does not bind a single name, does not have a @sort@ etc), hence we write things out - -- manually. - referenceOutOfScope bindings . - Let NotAName recy bindings . - referenceBound bindings <$> - establishScoping body - establishScoping (LamAbs _ nameDup ty body) = do - name <- freshenName nameDup - establishScopingBinder LamAbs name ty body - establishScoping (TyAbs _ nameDup kind body) = do - name <- freshenTyName nameDup - establishScopingBinder TyAbs name kind body - establishScoping (IWrap _ pat arg term) = - IWrap NotAName <$> establishScoping pat <*> establishScoping arg <*> establishScoping term - establishScoping (Apply _ fun arg) = - Apply NotAName <$> establishScoping fun <*> establishScoping arg - establishScoping (Unwrap _ term) = Unwrap NotAName <$> establishScoping term - establishScoping (Error _ ty) = Error NotAName <$> establishScoping ty - establishScoping (TyInst _ term ty) = - TyInst NotAName <$> establishScoping term <*> establishScoping ty - establishScoping (Var _ nameDup) = do - name <- freshenName nameDup - pure $ Var (registerFree name) name - establishScoping (Constant _ con) = pure $ Constant NotAName con - establishScoping (Builtin _ bi) = pure $ Builtin NotAName bi - establishScoping (Constr _ ty i es) = Constr NotAName <$> establishScoping ty <*> pure i <*> traverse establishScoping es - establishScoping (Case _ ty a es) = do - esScoped <- traverse establishScoping es - let esScopedPoked = addTheRest $ map (\e -> (e, firstBound e)) esScoped - branchBounds = map (snd . fst) esScopedPoked - referenceInBranch ((branch, _), others) = referenceOutOfScope (map snd others) branch - tyScoped <- establishScoping ty - aScoped <- establishScoping a - -- For each of the branches reference (as out-of-scope) the variables bound in that branch - -- in all the other ones, as well as outside of the whole case-expression. This is to check - -- that none of the transformations leak variables outside of the branch they're bound in. - pure . referenceOutOfScope branchBounds $ - Case NotAName tyScoped aScoped $ map referenceInBranch esScopedPoked + establishScoping (Let _ recy bindingsDup body) = do + bindings <- establishScopingBindings (registerByRecursivity recy) bindingsDup + -- Follows the shape of 'establishScopingBinder', but subtly differs (for example, + -- does not bind a single name, does not have a @sort@ etc), hence we write things out + -- manually. + referenceOutOfScope bindings + . Let NotAName recy bindings + . referenceBound bindings + <$> establishScoping body + establishScoping (LamAbs _ nameDup ty body) = do + name <- freshenName nameDup + establishScopingBinder LamAbs name ty body + establishScoping (TyAbs _ nameDup kind body) = do + name <- freshenTyName nameDup + establishScopingBinder TyAbs name kind body + establishScoping (IWrap _ pat arg term) = + IWrap NotAName <$> establishScoping pat <*> establishScoping arg <*> establishScoping term + establishScoping (Apply _ fun arg) = + Apply NotAName <$> establishScoping fun <*> establishScoping arg + establishScoping (Unwrap _ term) = Unwrap NotAName <$> establishScoping term + establishScoping (Error _ ty) = Error NotAName <$> establishScoping ty + establishScoping (TyInst _ term ty) = + TyInst NotAName <$> establishScoping term <*> establishScoping ty + establishScoping (Var _ nameDup) = do + name <- freshenName nameDup + pure $ Var (registerFree name) name + establishScoping (Constant _ con) = pure $ Constant NotAName con + establishScoping (Builtin _ bi) = pure $ Builtin NotAName bi + establishScoping (Constr _ ty i es) = Constr NotAName <$> establishScoping ty <*> pure i <*> traverse establishScoping es + establishScoping (Case _ ty a es) = do + esScoped <- traverse establishScoping es + let esScopedPoked = addTheRest $ map (\e -> (e, firstBound e)) esScoped + branchBounds = map (snd . fst) esScopedPoked + referenceInBranch ((branch, _), others) = referenceOutOfScope (map snd others) branch + tyScoped <- establishScoping ty + aScoped <- establishScoping a + -- For each of the branches reference (as out-of-scope) the variables bound in that branch + -- in all the other ones, as well as outside of the whole case-expression. This is to check + -- that none of the transformations leak variables outside of the branch they're bound in. + pure . referenceOutOfScope branchBounds $ + Case NotAName tyScoped aScoped $ + map referenceInBranch esScopedPoked instance (tyname ~ TyName, name ~ Name) => EstablishScoping (Program tyname name uni fun) where - establishScoping (Program _ v term) = Program NotAName v <$> establishScoping term + establishScoping (Program _ v term) = Program NotAName v <$> establishScoping term instance tyname ~ TyName => CollectScopeInfo (TyVarDecl tyname) where - collectScopeInfo (TyVarDecl ann tyname kind) = handleSname ann tyname <> collectScopeInfo kind + collectScopeInfo (TyVarDecl ann tyname kind) = handleSname ann tyname <> collectScopeInfo kind instance (tyname ~ TyName, name ~ Name) => CollectScopeInfo (VarDecl tyname name uni) where - collectScopeInfo (VarDecl ann name ty) = handleSname ann name <> collectScopeInfo ty + collectScopeInfo (VarDecl ann name ty) = handleSname ann name <> collectScopeInfo ty instance (tyname ~ TyName, name ~ Name) => CollectScopeInfo (Datatype tyname name uni) where - collectScopeInfo (Datatype matchAnn dataDecl params matchName constrs) = fold - [ collectScopeInfo dataDecl - , foldMap collectScopeInfo params - , handleSname matchAnn matchName - , foldMap collectScopeInfo constrs - ] + collectScopeInfo (Datatype matchAnn dataDecl params matchName constrs) = + fold + [ collectScopeInfo dataDecl + , foldMap collectScopeInfo params + , handleSname matchAnn matchName + , foldMap collectScopeInfo constrs + ] instance (tyname ~ TyName, name ~ Name) => CollectScopeInfo (Binding tyname name uni fun) where - collectScopeInfo (TermBind _ _ varDecl term) = collectScopeInfo varDecl <> collectScopeInfo term - collectScopeInfo (TypeBind _ tyVarDecl ty) = collectScopeInfo tyVarDecl <> collectScopeInfo ty - collectScopeInfo (DatatypeBind _ datatype) = collectScopeInfo datatype + collectScopeInfo (TermBind _ _ varDecl term) = collectScopeInfo varDecl <> collectScopeInfo term + collectScopeInfo (TypeBind _ tyVarDecl ty) = collectScopeInfo tyVarDecl <> collectScopeInfo ty + collectScopeInfo (DatatypeBind _ datatype) = collectScopeInfo datatype instance (tyname ~ TyName, name ~ Name) => CollectScopeInfo (Term tyname name uni fun) where - collectScopeInfo (Let _ _ bindings body) = - foldMap collectScopeInfo bindings <> collectScopeInfo body - collectScopeInfo (LamAbs ann name ty body) = - handleSname ann name <> collectScopeInfo ty <> collectScopeInfo body - collectScopeInfo (TyAbs ann name kind body) = - handleSname ann name <> collectScopeInfo kind <> collectScopeInfo body - collectScopeInfo (IWrap _ pat arg term) = - collectScopeInfo pat <> collectScopeInfo arg <> collectScopeInfo term - collectScopeInfo (Apply _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg - collectScopeInfo (Unwrap _ term) = collectScopeInfo term - collectScopeInfo (Error _ ty) = collectScopeInfo ty - collectScopeInfo (TyInst _ term ty) = collectScopeInfo term <> collectScopeInfo ty - collectScopeInfo (Var ann name) = handleSname ann name - collectScopeInfo (Constant _ _) = mempty - collectScopeInfo (Builtin _ _) = mempty - collectScopeInfo (Constr _ ty _ es) = collectScopeInfo ty <> foldMap collectScopeInfo es - collectScopeInfo (Case _ ty arg cs) = collectScopeInfo ty <> collectScopeInfo arg <> foldMap collectScopeInfo cs + collectScopeInfo (Let _ _ bindings body) = + foldMap collectScopeInfo bindings <> collectScopeInfo body + collectScopeInfo (LamAbs ann name ty body) = + handleSname ann name <> collectScopeInfo ty <> collectScopeInfo body + collectScopeInfo (TyAbs ann name kind body) = + handleSname ann name <> collectScopeInfo kind <> collectScopeInfo body + collectScopeInfo (IWrap _ pat arg term) = + collectScopeInfo pat <> collectScopeInfo arg <> collectScopeInfo term + collectScopeInfo (Apply _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg + collectScopeInfo (Unwrap _ term) = collectScopeInfo term + collectScopeInfo (Error _ ty) = collectScopeInfo ty + collectScopeInfo (TyInst _ term ty) = collectScopeInfo term <> collectScopeInfo ty + collectScopeInfo (Var ann name) = handleSname ann name + collectScopeInfo (Constant _ _) = mempty + collectScopeInfo (Builtin _ _) = mempty + collectScopeInfo (Constr _ ty _ es) = collectScopeInfo ty <> foldMap collectScopeInfo es + collectScopeInfo (Case _ ty arg cs) = collectScopeInfo ty <> collectScopeInfo arg <> foldMap collectScopeInfo cs instance (tyname ~ TyName, name ~ Name) => CollectScopeInfo (Program tyname name uni fun) where - collectScopeInfo (Program _ _ term) = collectScopeInfo term + collectScopeInfo (Program _ _ term) = collectScopeInfo term diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs index 0c741f9fb7e..010c91006d7 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs @@ -1,42 +1,50 @@ -- editorconfig-checker-disable-file {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -module PlutusIR.Core.Plated - ( termSubterms - , termSubtermsDeep - , termSubtypes - , termSubtypesDeep - , termSubkinds - , termBindings - , termVars - , termConstants - , termConstantsDeep - , typeSubtypes - , typeSubtypesDeep - , typeSubkinds - , typeUniques - , typeUniquesDeep - , datatypeSubtypes - , datatypeSubkinds - , datatypeTyNames - , bindingSubterms - , bindingSubtypes - , bindingSubkinds - , bindingNames - , bindingTyNames - , bindingIds - , termUniques - , termUniquesDeep - , varDeclSubtypes - , underBinders - , _Constant - ) where +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +module PlutusIR.Core.Plated ( + termSubterms, + termSubtermsDeep, + termSubtypes, + termSubtypesDeep, + termSubkinds, + termBindings, + termVars, + termConstants, + termConstantsDeep, + typeSubtypes, + typeSubtypesDeep, + typeSubkinds, + typeUniques, + typeUniquesDeep, + datatypeSubtypes, + datatypeSubkinds, + datatypeTyNames, + bindingSubterms, + bindingSubtypes, + bindingSubkinds, + bindingNames, + bindingTyNames, + bindingIds, + termUniques, + termUniquesDeep, + varDeclSubtypes, + underBinders, + _Constant, +) where import PlutusCore qualified as PLC import PlutusCore.Arity -import PlutusCore.Core (tyVarDeclSubkinds, typeSubkinds, typeSubtypes, typeSubtypesDeep, - typeUniques, typeUniquesDeep, varDeclSubtypes) +import PlutusCore.Core ( + tyVarDeclSubkinds, + typeSubkinds, + typeSubtypes, + typeSubtypesDeep, + typeUniques, + typeUniquesDeep, + varDeclSubtypes, + ) import PlutusCore.FlatInstances () import PlutusCore.Name.Unique qualified as PLC @@ -55,14 +63,14 @@ infixr 6 <^> -- | View a term as a constant. _Constant :: Prism' (Term tyname name uni fun a) (a, PLC.Some (PLC.ValueOf uni)) -_Constant = prism' (uncurry Constant) (\case { Constant a v -> Just (a, v); _ -> Nothing }) +_Constant = prism' (uncurry Constant) (\case Constant a v -> Just (a, v); _ -> Nothing) -- | Get all the direct child 'Term's of the given 'Binding'. bindingSubterms :: Traversal' (Binding tyname name uni fun a) (Term tyname name uni fun a) bindingSubterms f = \case - TermBind x s d t -> TermBind x s d <$> f t - b@TypeBind {} -> pure b - d@DatatypeBind {} -> pure d + TermBind x s d t -> TermBind x s d <$> f t + b@TypeBind {} -> pure b + d@DatatypeBind {} -> pure d {-# INLINE bindingSubterms #-} -- | Get all the direct child 'Type's of the given 'Datatype'. @@ -73,102 +81,105 @@ datatypeSubtypes f (Datatype a n vs m cs) = Datatype a n vs m <$> (traverse . va -- | Get all the direct child 'Type's of the given 'Binding'. bindingSubtypes :: Traversal' (Binding tyname name uni fun a) (Type tyname uni a) bindingSubtypes f = \case - TermBind x s d t -> TermBind x s <$> varDeclSubtypes f d <*> pure t - DatatypeBind x d -> DatatypeBind x <$> datatypeSubtypes f d - TypeBind a d ty -> TypeBind a d <$> f ty + TermBind x s d t -> TermBind x s <$> varDeclSubtypes f d <*> pure t + DatatypeBind x d -> DatatypeBind x <$> datatypeSubtypes f d + TypeBind a d ty -> TypeBind a d <$> f ty {-# INLINE bindingSubtypes #-} -- | Get all the direct child 'Kind's of the given 'Datatype'. datatypeSubkinds :: Traversal' (Datatype tyname name uni a) (Kind a) datatypeSubkinds f (Datatype a n vs m cs) = do - n' <- tyVarDeclSubkinds f n - vs' <- traverse (tyVarDeclSubkinds f) vs - pure $ Datatype a n' vs' m cs + n' <- tyVarDeclSubkinds f n + vs' <- traverse (tyVarDeclSubkinds f) vs + pure $ Datatype a n' vs' m cs {-# INLINE datatypeSubkinds #-} -- | Get all the type-names introduces by a datatype datatypeTyNames :: Traversal' (Datatype tyname name uni a) tyname datatypeTyNames f (Datatype a2 tvdecl tvdecls n vdecls) = - Datatype a2 - <$> PLC.tyVarDeclName f tvdecl - <*> traverse (PLC.tyVarDeclName f) tvdecls - <*> pure n - <*> pure vdecls + Datatype a2 + <$> PLC.tyVarDeclName f tvdecl + <*> traverse (PLC.tyVarDeclName f) tvdecls + <*> pure n + <*> pure vdecls {-# INLINE datatypeTyNames #-} -- | Get all the direct child 'Kind's of the given 'Binding'. bindingSubkinds :: Traversal' (Binding tyname name uni fun a) (Kind a) bindingSubkinds f = \case - t@TermBind {} -> pure t - DatatypeBind x d -> DatatypeBind x <$> datatypeSubkinds f d - TypeBind a d ty -> TypeBind a <$> tyVarDeclSubkinds f d <*> pure ty + t@TermBind {} -> pure t + DatatypeBind x d -> DatatypeBind x <$> datatypeSubkinds f d + TypeBind a d ty -> TypeBind a <$> tyVarDeclSubkinds f d <*> pure ty {-# INLINE bindingSubkinds #-} -- | All the identifiers/names introduced by this binding -- In case of a datatype-binding it has multiple identifiers: the type, constructors, match function -bindingIds :: (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) - => Traversal1' (Binding tyname name uni fun a) PLC.Unique +bindingIds :: + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) => + Traversal1' (Binding tyname name uni fun a) PLC.Unique bindingIds f = \case - TermBind x s d t -> flip (TermBind x s) t <$> (PLC.varDeclName . PLC.theUnique) f d - TypeBind a d ty -> flip (TypeBind a) ty <$> (PLC.tyVarDeclName . PLC.theUnique) f d - DatatypeBind a1 (Datatype a2 tvdecl tvdecls n vdecls) -> - DatatypeBind a1 <$> - (Datatype a2 <$> (PLC.tyVarDeclName . PLC.theUnique) f tvdecl - <.*> traverse1Maybe ((PLC.tyVarDeclName . PLC.theUnique) f) tvdecls - <.> PLC.theUnique f n - <.*> traverse1Maybe ((PLC.varDeclName . PLC.theUnique) f) vdecls) + TermBind x s d t -> flip (TermBind x s) t <$> (PLC.varDeclName . PLC.theUnique) f d + TypeBind a d ty -> flip (TypeBind a) ty <$> (PLC.tyVarDeclName . PLC.theUnique) f d + DatatypeBind a1 (Datatype a2 tvdecl tvdecls n vdecls) -> + DatatypeBind a1 + <$> ( Datatype a2 + <$> (PLC.tyVarDeclName . PLC.theUnique) f tvdecl + <.*> traverse1Maybe ((PLC.tyVarDeclName . PLC.theUnique) f) tvdecls + <.> PLC.theUnique f n + <.*> traverse1Maybe ((PLC.varDeclName . PLC.theUnique) f) vdecls + ) -- | Get all the direct constants of the given 'Term' from 'Constant's. termConstants :: Traversal' (Term tyname name uni fun ann) (Some (ValueOf uni)) termConstants f term0 = case term0 of - Constant ann val -> Constant ann <$> f val - Let{} -> pure term0 - Var{} -> pure term0 - TyAbs{} -> pure term0 - LamAbs{} -> pure term0 - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + Constant ann val -> Constant ann <$> f val + Let {} -> pure term0 + Var {} -> pure term0 + TyAbs {} -> pure term0 + LamAbs {} -> pure term0 + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 -- | Get all the direct child 'Kind's of the given 'Term'. termSubkinds :: Traversal' (Term tyname name uni fun ann) (Kind ann) termSubkinds f term0 = case term0 of - Let x r bs t -> Let x r <$> (traverse . bindingSubkinds) f bs <*> pure t - TyAbs ann n k t -> f k <&> \k' -> TyAbs ann n k' t - LamAbs{} -> pure term0 - Var{} -> pure term0 - TyInst{} -> pure term0 - IWrap{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Unwrap{} -> pure term0 - Constant{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + Let x r bs t -> Let x r <$> (traverse . bindingSubkinds) f bs <*> pure t + TyAbs ann n k t -> f k <&> \k' -> TyAbs ann n k' t + LamAbs {} -> pure term0 + Var {} -> pure term0 + TyInst {} -> pure term0 + IWrap {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Unwrap {} -> pure term0 + Constant {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 {-# INLINE termSubkinds #-} -- | Get all the direct child 'Term's of the given 'Term', including those within 'Binding's. termSubterms :: Traversal' (Term tyname name uni fun a) (Term tyname name uni fun a) termSubterms f = \case - Let x r bs t -> Let x r <$> (traverse . bindingSubterms) f bs <*> f t - TyAbs x tn k t -> TyAbs x tn k <$> f t - LamAbs x n ty t -> LamAbs x n ty <$> f t - Apply x t1 t2 -> Apply x <$> f t1 <*> f t2 - TyInst x t ty -> TyInst x <$> f t <*> pure ty - IWrap x ty1 ty2 t -> IWrap x ty1 ty2 <$> f t - Unwrap x t -> Unwrap x <$> f t - Constr x ty i es -> Constr x ty i <$> traverse f es - Case x ty arg cs -> Case x ty <$> f arg <*> traverse f cs - e@Error {} -> pure e - v@Var {} -> pure v - c@Constant {} -> pure c - b@Builtin {} -> pure b + Let x r bs t -> Let x r <$> (traverse . bindingSubterms) f bs <*> f t + TyAbs x tn k t -> TyAbs x tn k <$> f t + LamAbs x n ty t -> LamAbs x n ty <$> f t + Apply x t1 t2 -> Apply x <$> f t1 <*> f t2 + TyInst x t ty -> TyInst x <$> f t <*> pure ty + IWrap x ty1 ty2 t -> IWrap x ty1 ty2 <$> f t + Unwrap x t -> Unwrap x <$> f t + Constr x ty i es -> Constr x ty i <$> traverse f es + Case x ty arg cs -> Case x ty <$> f arg <*> traverse f cs + e@Error {} -> pure e + v@Var {} -> pure v + c@Constant {} -> pure c + b@Builtin {} -> pure b {-# INLINE termSubterms #-} -- | Get all the transitive child 'Term's of the given 'Term'. @@ -178,19 +189,19 @@ termSubtermsDeep = cosmosOf termSubterms -- | Get all the direct child 'Type's of the given 'Term', including those within 'Binding's. termSubtypes :: Traversal' (Term tyname name uni fun a) (Type tyname uni a) termSubtypes f = \case - Let x r bs t -> Let x r <$> (traverse . bindingSubtypes) f bs <*> pure t - LamAbs x n ty t -> LamAbs x n <$> f ty <*> pure t - TyInst x t ty -> TyInst x t <$> f ty - IWrap x ty1 ty2 t -> IWrap x <$> f ty1 <*> f ty2 <*> pure t - Error x ty -> Error x <$> f ty - Constr x ty i es -> Constr x <$> f ty <*> pure i <*> pure es - Case x ty arg cs -> Case x <$> f ty <*> pure arg <*> pure cs - t@TyAbs {} -> pure t - a@Apply {} -> pure a - u@Unwrap {} -> pure u - v@Var {} -> pure v - c@Constant {} -> pure c - b@Builtin {} -> pure b + Let x r bs t -> Let x r <$> (traverse . bindingSubtypes) f bs <*> pure t + LamAbs x n ty t -> LamAbs x n <$> f ty <*> pure t + TyInst x t ty -> TyInst x t <$> f ty + IWrap x ty1 ty2 t -> IWrap x <$> f ty1 <*> f ty2 <*> pure t + Error x ty -> Error x <$> f ty + Constr x ty i es -> Constr x <$> f ty <*> pure i <*> pure es + Case x ty arg cs -> Case x <$> f ty <*> pure arg <*> pure cs + t@TyAbs {} -> pure t + a@Apply {} -> pure a + u@Unwrap {} -> pure u + v@Var {} -> pure v + c@Constant {} -> pure c + b@Builtin {} -> pure b {-# INLINE termSubtypes #-} -- | Get all the transitive child 'Type's of the given 'Term'. @@ -200,67 +211,68 @@ termSubtypesDeep = termSubtermsDeep . termSubtypes . typeSubtypesDeep -- | Get all the direct child 'Binding's of the given 'Term'. termBindings :: Traversal' (Term tyname name uni fun a) (Binding tyname name uni fun a) termBindings f = \case - Let x r bs t -> Let x r <$> traverse f bs <*> pure t - t -> pure t + Let x r bs t -> Let x r <$> traverse f bs <*> pure t + t -> pure t {-# INLINE termBindings #-} -- | Get all the direct child 'Unique's of the given 'Term' (including the type-level ones). -termUniques - :: PLC.HasUniques (Term tyname name uni fun ann) - => Traversal' (Term tyname name uni fun ann) PLC.Unique +termUniques :: + PLC.HasUniques (Term tyname name uni fun ann) => + Traversal' (Term tyname name uni fun ann) PLC.Unique termUniques f = \case - Let ann r bs t -> Let ann r <$> cloneTraversal (traversed.bindingIds) f bs <*> pure t - Var ann n -> PLC.theUnique f n <&> Var ann - TyAbs ann tn k t -> PLC.theUnique f tn <&> \tn' -> TyAbs ann tn' k t - LamAbs ann n ty t -> PLC.theUnique f n <&> \n' -> LamAbs ann n' ty t - a@Apply{} -> pure a - c@Constant{} -> pure c - b@Builtin{} -> pure b - t@TyInst{} -> pure t - e@Error{} -> pure e - i@IWrap{} -> pure i - u@Unwrap{} -> pure u - p@Constr {} -> pure p - p@Case {} -> pure p + Let ann r bs t -> Let ann r <$> cloneTraversal (traversed . bindingIds) f bs <*> pure t + Var ann n -> PLC.theUnique f n <&> Var ann + TyAbs ann tn k t -> PLC.theUnique f tn <&> \tn' -> TyAbs ann tn' k t + LamAbs ann n ty t -> PLC.theUnique f n <&> \n' -> LamAbs ann n' ty t + a@Apply {} -> pure a + c@Constant {} -> pure c + b@Builtin {} -> pure b + t@TyInst {} -> pure t + e@Error {} -> pure e + i@IWrap {} -> pure i + u@Unwrap {} -> pure u + p@Constr {} -> pure p + p@Case {} -> pure p -- | Get all the direct child 'name a's of the given 'Term' from 'Var's. termVars :: Traversal' (Term tyname name uni fun ann) name termVars f term0 = case term0 of - Var ann n -> Var ann <$> f n - t -> pure t + Var ann n -> Var ann <$> f n + t -> pure t -- | Get all the transitive child 'Constant's of the given 'Term'. termConstantsDeep :: Fold (Term tyname name uni fun ann) (Some (ValueOf uni)) termConstantsDeep = termSubtermsDeep . termConstants -- | Get all the transitive child 'Unique's of the given 'Term' (including the type-level ones). -termUniquesDeep - :: PLC.HasUniques (Term tyname name uni fun ann) - => Fold (Term tyname name uni fun ann) PLC.Unique +termUniquesDeep :: + PLC.HasUniques (Term tyname name uni fun ann) => + Fold (Term tyname name uni fun ann) PLC.Unique termUniquesDeep = termSubtermsDeep . (termSubtypes . typeUniquesDeep <^> termUniques) -- | Get all the names introduces by a binding bindingNames :: Traversal' (Binding tyname name uni fun a) name bindingNames f = \case - TermBind x s d t -> TermBind x s <$> PLC.varDeclName f d <*> pure t - DatatypeBind a1 (Datatype a2 tvdecl tvdecls n vdecls) -> - DatatypeBind a1 <$> - (Datatype a2 tvdecl tvdecls - <$> f n - <*> traverse (PLC.varDeclName f) vdecls) - b@TypeBind{} -> pure b + TermBind x s d t -> TermBind x s <$> PLC.varDeclName f d <*> pure t + DatatypeBind a1 (Datatype a2 tvdecl tvdecls n vdecls) -> + DatatypeBind a1 + <$> ( Datatype a2 tvdecl tvdecls + <$> f n + <*> traverse (PLC.varDeclName f) vdecls + ) + b@TypeBind {} -> pure b -- | Get all the type-names introduces by a binding bindingTyNames :: Traversal' (Binding tyname name uni fun a) tyname bindingTyNames f = \case - TypeBind a d ty -> TypeBind a <$> PLC.tyVarDeclName f d <*> pure ty - DatatypeBind a1 d -> DatatypeBind a1 <$> datatypeTyNames f d - b@TermBind{} -> pure b + TypeBind a d ty -> TypeBind a <$> PLC.tyVarDeclName f d <*> pure ty + DatatypeBind a1 d -> DatatypeBind a1 <$> datatypeTyNames f d + b@TermBind {} -> pure b -- | Focus on the term under the binders corresponding to the given arity. -- e.g. for arity @[TermParam, TermParam]@ and term @\x y -> t@ it focusses on @t@. underBinders :: Arity -> Traversal' (Term tyname name uni fun a) (Term tyname name uni fun a) -underBinders [] f t = f t -underBinders (TermParam:arity) f (LamAbs a n ty t) = LamAbs a n ty <$> underBinders arity f t -underBinders (TypeParam:arity) f (TyAbs a ty k t) = TyAbs a ty k <$> underBinders arity f t -underBinders _ _ t = pure t +underBinders [] f t = f t +underBinders (TermParam : arity) f (LamAbs a n ty t) = LamAbs a n ty <$> underBinders arity f t +underBinders (TypeParam : arity) f (TyAbs a ty k t) = TyAbs a ty k <$> underBinders arity f t +underBinders _ _ t = pure t diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs index 34b4b98087a..64005bf7841 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs @@ -1,35 +1,35 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusIR.Core.Type - ( TyName (..) - , Name (..) - , VarDecl (..) - , TyVarDecl (..) - , varDeclNameString - , tyVarDeclNameString - , Kind (..) - , Type (..) - , Datatype (..) - , datatypeNameString - , Recursivity (..) - , Strictness (..) - , Binding (..) - , Term (..) - , Program (..) - , Version (..) - , applyProgram - , termAnn - , bindingAnn - , progAnn - , progVer - , progTerm - ) where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module PlutusIR.Core.Type ( + TyName (..), + Name (..), + VarDecl (..), + TyVarDecl (..), + varDeclNameString, + tyVarDeclNameString, + Kind (..), + Type (..), + Datatype (..), + datatypeNameString, + Recursivity (..), + Strictness (..), + Binding (..), + Term (..), + Program (..), + Version (..), + applyProgram, + termAnn, + bindingAnn, + progAnn, + progVer, + progTerm, +) where import PlutusCore (Kind, Name, TyName, Type (..), Version (..)) import PlutusCore qualified as PLC @@ -67,24 +67,22 @@ datatypeNameString (Datatype _ tn _ _ _) = tyVarDeclNameString tn -- Bindings -{- | Each multi-let-group has to be marked with its scoping: -* 'NonRec': the identifiers introduced by this multi-let are only linearly-scoped, - i.e. an identifier cannot refer to itself or later-introduced identifiers of the group. -* 'Rec': an identifiers introduced by this multi-let group can use all other multi-lets - of the same group (including itself), thus permitting (mutual) recursion. --} +-- | Each multi-let-group has to be marked with its scoping: +-- * 'NonRec': the identifiers introduced by this multi-let are only linearly-scoped, +-- i.e. an identifier cannot refer to itself or later-introduced identifiers of the group. +-- * 'Rec': an identifiers introduced by this multi-let group can use all other multi-lets +-- of the same group (including itself), thus permitting (mutual) recursion. data Recursivity = NonRec | Rec deriving stock (Show, Eq, Generic, Ord) deriving anyclass (Hashable) -{- | Recursivity can form a 'Semigroup' / lattice, where 'NonRec' < 'Rec'. -The lattice is ordered by "power": a non-recursive binding group can be made recursive -and it will still work, but not vice versa. -The semigroup operation is the "join" of the lattice. --} +-- | Recursivity can form a 'Semigroup' / lattice, where 'NonRec' < 'Rec'. +-- The lattice is ordered by "power": a non-recursive binding group can be made recursive +-- and it will still work, but not vice versa. +-- The semigroup operation is the "join" of the lattice. instance Semigroup Recursivity where NonRec <> x = x - Rec <> _ = Rec + Rec <> _ = Rec data Strictness = NonStrict | Strict deriving stock (Show, Eq, Generic) @@ -103,8 +101,8 @@ deriving stock instance , GShow uni , Everywhere uni Show , Closed uni - ) - => Show (Binding tyname name uni fun a) + ) => + Show (Binding tyname name uni fun a) -- Terms @@ -160,8 +158,8 @@ deriving stock instance , Show fun , Show a , Closed uni - ) - => Show (Term tyname name uni fun a) + ) => + Show (Term tyname name uni fun a) -- See Note [ExMemoryUsage instances for non-constants]. instance ExMemoryUsage (Term tyname name uni fun ann) where @@ -172,7 +170,7 @@ type instance UniOf (Term tyname name uni fun ann) = uni instance HasConstant (Term tyname name uni fun ()) where asConstant (Constant _ val) = pure val - asConstant _ = throwError notAConstant + asConstant _ = throwError notAConstant fromConstant = Constant () @@ -194,8 +192,8 @@ instance TermLike (Term tyname name uni fun) tyname name uni fun where typeLet x (Def vd bind) = Let x NonRec (pure $ TypeBind x vd bind) data Program tyname name uni fun ann = Program - { _progAnn :: ann - , _progVer :: Version + { _progAnn :: ann + , _progVer :: Version -- ^ The version of the program. This corresponds to the underlying Plutus Core version. , _progTerm :: Term tyname name uni fun ann } @@ -210,8 +208,8 @@ deriving stock instance , Show fun , Show ann , Closed uni - ) - => Show (Program tyname name uni fun ann) + ) => + Show (Program tyname name uni fun ann) type instance PLC.HasUniques (Term tyname name uni fun ann) = @@ -221,14 +219,13 @@ type instance PLC.HasUniques (Program tyname name uni fun ann) = PLC.HasUniques (Term tyname name uni fun ann) -{- | Applies one program to another. Fails if the versions do not match -and tries to merge annotations. --} -applyProgram - :: (MonadError ApplyProgramError m, Semigroup a) - => Program tyname name uni fun a - -> Program tyname name uni fun a - -> m (Program tyname name uni fun a) +-- | Applies one program to another. Fails if the versions do not match +-- and tries to merge annotations. +applyProgram :: + (MonadError ApplyProgramError m, Semigroup a) => + Program tyname name uni fun a -> + Program tyname name uni fun a -> + m (Program tyname name uni fun a) applyProgram (Program a1 v1 t1) (Program a2 v2 t2) | v1 == v2 = pure $ Program (a1 <> a2) v1 (Apply (termAnn t1 <> termAnn t2) t1 t2) @@ -237,22 +234,22 @@ applyProgram (Program _a1 v1 _t1) (Program _a2 v2 _t2) = termAnn :: Term tyname name uni fun a -> a termAnn = \case - Let a _ _ _ -> a - Var a _ -> a - TyAbs a _ _ _ -> a + Let a _ _ _ -> a + Var a _ -> a + TyAbs a _ _ _ -> a LamAbs a _ _ _ -> a - Apply a _ _ -> a - Constant a _ -> a - Builtin a _ -> a - TyInst a _ _ -> a - Error a _ -> a - IWrap a _ _ _ -> a - Unwrap a _ -> a + Apply a _ _ -> a + Constant a _ -> a + Builtin a _ -> a + TyInst a _ _ -> a + Error a _ -> a + IWrap a _ _ _ -> a + Unwrap a _ -> a Constr a _ _ _ -> a - Case a _ _ _ -> a + Case a _ _ _ -> a bindingAnn :: Binding tyname name uni fun a -> a bindingAnn = \case TermBind a _ _ _ -> a - TypeBind a _ _ -> a + TypeBind a _ _ -> a DatatypeBind a _ -> a diff --git a/plutus-core/plutus-ir/src/PlutusIR/Error.hs b/plutus-core/plutus-ir/src/PlutusIR/Error.hs index 893c38390c4..c30c8434c84 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Error.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Error.hs @@ -1,19 +1,20 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module PlutusIR.Error - ( Error (..) - , PLC.TypeError - , TypeErrorExt (..) - , PLC.Normalized (..) - ) where +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module PlutusIR.Error ( + Error (..), + PLC.TypeError, + TypeErrorExt (..), + PLC.Normalized (..), +) where import PlutusCore qualified as PLC import PlutusCore.Pretty qualified as PLC @@ -23,50 +24,60 @@ import PlutusPrelude import Data.Text qualified as T import Prettyprinter as PP -data TypeErrorExt uni ann = - MalformedDataConstrResType - !ann - -- the expected constructor's type - !(PLC.Type PLC.TyName uni ann) - deriving stock (Show, Eq, Generic, Functor) - deriving anyclass (NFData) +data TypeErrorExt uni ann + = MalformedDataConstrResType + !ann + -- the expected constructor's type + !(PLC.Type PLC.TyName uni ann) + deriving stock (Show, Eq, Generic, Functor) + deriving anyclass (NFData) -data Error uni fun a = CompilationError !a !T.Text -- ^ A generic compilation error. - | UnsupportedError !a !T.Text -- ^ An error relating specifically to an unsupported feature. - | OptionsError !T.Text -- ^ An error relating to compilation options. - | PLCError !(PLC.Error uni fun a) -- ^ An error from running some PLC function, lifted into this error type for convenience. - | PLCTypeError !(PLC.TypeError (PIR.Term PIR.TyName PIR.Name uni fun ()) uni fun a) - | PIRTypeError !(TypeErrorExt uni a) - deriving stock (Functor) +data Error uni fun a + = -- | A generic compilation error. + CompilationError !a !T.Text + | -- | An error relating specifically to an unsupported feature. + UnsupportedError !a !T.Text + | -- | An error relating to compilation options. + OptionsError !T.Text + | -- | An error from running some PLC function, lifted into this error type for convenience. + PLCError !(PLC.Error uni fun a) + | PLCTypeError !(PLC.TypeError (PIR.Term PIR.TyName PIR.Name uni fun ()) uni fun a) + | PIRTypeError !(TypeErrorExt uni a) + deriving stock (Functor) -- Pretty-printing ------------------ -instance (PLC.PrettyUni uni, Pretty ann) => - PrettyBy PLC.PrettyConfigPlc (TypeErrorExt uni ann) where - prettyBy config (MalformedDataConstrResType ann expType) = - vsep ["The result-type of a dataconstructor is malformed at location" <+> PP.pretty ann - , "The expected result-type is:" <+> prettyBy config expType] +instance + (PLC.PrettyUni uni, Pretty ann) => + PrettyBy PLC.PrettyConfigPlc (TypeErrorExt uni ann) + where + prettyBy config (MalformedDataConstrResType ann expType) = + vsep + [ "The result-type of a dataconstructor is malformed at location" <+> PP.pretty ann + , "The expected result-type is:" <+> prettyBy config expType + ] -- show via pretty, for printing as SomeExceptions instance (PLC.PrettyUni uni, Pretty fun, Pretty ann) => Show (Error uni fun ann) where - show = show . PP.pretty + show = show . PP.pretty -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1732): we get rid of this -- when our TestLib stops using rethrow deriving anyclass instance - (PLC.ThrowableBuiltins uni fun, PP.Pretty ann, Typeable ann) => Exception (Error uni fun ann) + (PLC.ThrowableBuiltins uni fun, PP.Pretty ann, Typeable ann) => Exception (Error uni fun ann) instance (PLC.PrettyUni uni, Pretty fun, Pretty ann) => Pretty (Error uni fun ann) where - pretty = PLC.prettyPlcClassic - + pretty = PLC.prettyPlcClassic -instance (PLC.PrettyUni uni, Pretty fun, Pretty ann) => - PrettyBy PLC.PrettyConfigPlc (Error uni fun ann) where - prettyBy config = \case - CompilationError x e -> "Error during compilation:" <+> PP.pretty e <> "(" <> PP.pretty x <> ")" - UnsupportedError x e -> "Unsupported construct:" <+> PP.pretty e <+> "(" <> PP.pretty x <> ")" - OptionsError e -> "Compiler options error:" <+> PP.pretty e - PLCError e -> PP.vsep [ "Error from the PLC compiler:", PLC.prettyBy config e ] - PLCTypeError e -> PP.vsep ["Error during PIR typechecking:" , PLC.prettyBy config e ] - PIRTypeError e -> PP.vsep ["Error during PIR typechecking:" , PLC.prettyBy config e ] +instance + (PLC.PrettyUni uni, Pretty fun, Pretty ann) => + PrettyBy PLC.PrettyConfigPlc (Error uni fun ann) + where + prettyBy config = \case + CompilationError x e -> "Error during compilation:" <+> PP.pretty e <> "(" <> PP.pretty x <> ")" + UnsupportedError x e -> "Unsupported construct:" <+> PP.pretty e <+> "(" <> PP.pretty x <> ")" + OptionsError e -> "Compiler options error:" <+> PP.pretty e + PLCError e -> PP.vsep ["Error from the PLC compiler:", PLC.prettyBy config e] + PLCTypeError e -> PP.vsep ["Error during PIR typechecking:", PLC.prettyBy config e] + PIRTypeError e -> PP.vsep ["Error during PIR typechecking:", PLC.prettyBy config e] diff --git a/plutus-core/plutus-ir/src/PlutusIR/Mark.hs b/plutus-core/plutus-ir/src/PlutusIR/Mark.hs index 915e87f19ef..e58d15c8682 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Mark.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Mark.hs @@ -12,27 +12,24 @@ import PlutusCore.Quote import Data.Set.Lens (setOf) import PlutusIR.Core -{- | Marks all the 'Unique's in a term as used, so they will not be generated in future. -Useful if you have a term which was not generated in 'Quote'. --} +-- | Marks all the 'Unique's in a term as used, so they will not be generated in future. +-- Useful if you have a term which was not generated in 'Quote'. markNonFreshTerm :: (PLC.HasUniques (Term tyname name uni fun ann), MonadQuote m) => Term tyname name uni fun ann -> m () markNonFreshTerm = markNonFreshMax . setOf termUniquesDeep -{- | Marks all the 'Unique's in a type as used, so they will not be generated in future. -Useful if you have a type which was not generated in 'Quote'. --} +-- | Marks all the 'Unique's in a type as used, so they will not be generated in future. +-- Useful if you have a type which was not generated in 'Quote'. markNonFreshType :: (PLC.HasUniques (Type tyname uni ann), MonadQuote m) => Type tyname uni ann -> m () markNonFreshType = markNonFreshMax . setOf typeUniquesDeep -{- | Marks all the 'Unique's in a program as used, so they will not be generated in future. -Useful if you have a program which was not generated in 'Quote'. --} +-- | Marks all the 'Unique's in a program as used, so they will not be generated in future. +-- Useful if you have a program which was not generated in 'Quote'. markNonFreshProgram :: (PLC.HasUniques (Program tyname name uni fun ann), MonadQuote m) => Program tyname name uni fun ann -> diff --git a/plutus-core/plutus-ir/src/PlutusIR/MkPir.hs b/plutus-core/plutus-ir/src/PlutusIR/MkPir.hs index ffc3995b718..2ed2d9fc444 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/MkPir.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/MkPir.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module PlutusIR.MkPir ( module MkPlc - , DatatypeDef - , mkLet - ) where +module PlutusIR.MkPir ( + module MkPlc, + DatatypeDef, + mkLet, +) where import PlutusIR @@ -13,18 +14,17 @@ import PlutusCore.MkPlc as MkPlc import Data.List.NonEmpty qualified as NE - -- | A datatype definition as a type variable. type DatatypeDef tyname name uni a = Def (TyVarDecl tyname a) (Datatype tyname name uni a) -- | Make a let binding, unless the list of bindings is empty, in which case just -- return the underlying term. -mkLet - :: a - -> Recursivity - -> [Binding tyname name uni fun a] - -> Term tyname name uni fun a - -> Term tyname name uni fun a -mkLet x r bs t = case NE.nonEmpty bs of - Nothing -> t +mkLet :: + a -> + Recursivity -> + [Binding tyname name uni fun a] -> + Term tyname name uni fun a -> + Term tyname name uni fun a +mkLet x r bs t = case NE.nonEmpty bs of + Nothing -> t Just bs' -> Let x r bs' t diff --git a/plutus-core/plutus-ir/src/PlutusIR/Normalize.hs b/plutus-core/plutus-ir/src/PlutusIR/Normalize.hs index 499a626d22e..122884d6db0 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Normalize.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Normalize.hs @@ -1,11 +1,12 @@ -- editorconfig-checker-disable-file {-# LANGUAGE FlexibleContexts #-} + -- | PlutusIR versions of the functions in PlutusCore.Normalize -module PlutusIR.Normalize - ( Export.normalizeType - , normalizeTypesIn - , normalizeTypesInProgram - ) where +module PlutusIR.Normalize ( + Export.normalizeType, + normalizeTypesIn, + normalizeTypesInProgram, +) where import PlutusCore.Core as PLC (Normalized (..)) import PlutusCore.Name.Unique @@ -21,21 +22,22 @@ import Control.Monad ((>=>)) import Universe (HasUniApply) -- | Normalize every 'Type' in a 'Term'. -normalizeTypesIn - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadQuote m, HasUniApply uni) - => Term tyname name uni fun ann -> m (Term tyname name uni fun ann) +normalizeTypesIn :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadQuote m, HasUniApply uni) => + Term tyname name uni fun ann -> m (Term tyname name uni fun ann) normalizeTypesIn = rename >=> runNormalizeTypeT . normalizeTypesInM -- | Normalize every 'Type' in a 'Program'. -normalizeTypesInProgram - :: (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadQuote m, HasUniApply uni) - => Program tyname name uni fun ann -> m (Program tyname name uni fun ann) +normalizeTypesInProgram :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique, MonadQuote m, HasUniApply uni) => + Program tyname name uni fun ann -> m (Program tyname name uni fun ann) normalizeTypesInProgram (Program x v t) = Program x v <$> normalizeTypesIn t -- | Normalize every 'Type' in a 'Term'. -- Mirrors the `normalizeTypesInM` of 'PlutusCore.Normalize.Internal', working on PIR.Term instead -normalizeTypesInM - :: (HasUnique tyname TypeUnique, MonadQuote m, HasUniApply uni) - => Term tyname name uni fun ann -> NormalizeTypeT m tyname uni ann (Term tyname name uni fun ann) -normalizeTypesInM = transformMOf termSubterms normalizeChildTypes where +normalizeTypesInM :: + (HasUnique tyname TypeUnique, MonadQuote m, HasUniApply uni) => + Term tyname name uni fun ann -> NormalizeTypeT m tyname uni ann (Term tyname name uni fun ann) +normalizeTypesInM = transformMOf termSubterms normalizeChildTypes + where normalizeChildTypes = termSubtypes (fmap unNormalized . normalizeTypeM) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Parser.hs b/plutus-core/plutus-ir/src/PlutusIR/Parser.hs index 155eb7d5f2b..bbd0df1bbf7 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Parser.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Parser.hs @@ -1,17 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} -- | Parsers for PIR terms in DefaultUni. - -module PlutusIR.Parser - ( parse - , program - , pType - , pTerm - , parseProgram - , Parser - , SourcePos - ) where +module PlutusIR.Parser ( + parse, + program, + pType, + pTerm, + parseProgram, + Parser, + SourcePos, +) where import PlutusCore.Annotation import PlutusCore.Default qualified as PLC (DefaultFun, DefaultUni) @@ -36,140 +35,145 @@ import Text.Megaparsec.Char.Lexer qualified as Lex type PTerm = PIR.Term TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan recursivity :: Parser Recursivity -recursivity = trailingWhitespace . inParens $ +recursivity = + trailingWhitespace . inParens $ (symbol "rec" $> Rec) <|> (symbol "nonrec" $> NonRec) strictness :: Parser Strictness -strictness = trailingWhitespace . inParens $ +strictness = + trailingWhitespace . inParens $ (symbol "strict" $> Strict) <|> (symbol "nonstrict" $> NonStrict) varDecl :: Parser (VarDecl TyName Name PLC.DefaultUni SrcSpan) varDecl = withSpan $ \sp -> - inParens $ VarDecl sp <$> (symbol "vardecl" *> trailingWhitespace name) <*> pType + inParens $ VarDecl sp <$> (symbol "vardecl" *> trailingWhitespace name) <*> pType tyVarDecl :: Parser (TyVarDecl TyName SrcSpan) tyVarDecl = withSpan $ \sp -> - inParens $ TyVarDecl sp <$> (symbol "tyvardecl" *> trailingWhitespace tyName) <*> kind + inParens $ TyVarDecl sp <$> (symbol "tyvardecl" *> trailingWhitespace tyName) <*> kind datatype :: Parser (Datatype TyName Name PLC.DefaultUni SrcSpan) datatype = withSpan $ \sp -> - inParens $ - Datatype sp - <$> (symbol "datatype" *> tyVarDecl) - <*> many tyVarDecl - <*> trailingWhitespace name - <*> many varDecl + inParens $ + Datatype sp + <$> (symbol "datatype" *> tyVarDecl) + <*> many tyVarDecl + <*> trailingWhitespace name + <*> many varDecl binding :: Parser (Binding TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) binding = withSpan $ \sp -> - inParens . choice $ try <$> - [ TermBind sp <$> (symbol "termbind" *> strictness) <*> varDecl <*> pTerm - , TypeBind sp <$> (symbol "typebind" *> tyVarDecl) <*> pType - , DatatypeBind sp <$> (symbol "datatypebind" *> datatype) - ] + inParens . choice $ + try + <$> [ TermBind sp <$> (symbol "termbind" *> strictness) <*> varDecl <*> pTerm + , TypeBind sp <$> (symbol "typebind" *> tyVarDecl) <*> pType + , DatatypeBind sp <$> (symbol "datatypebind" *> datatype) + ] varTerm :: Parser PTerm varTerm = withSpan $ \sp -> - PIR.Var sp <$> name + PIR.Var sp <$> name -- A small type wrapper for parsers that are parametric in the type of term they parse -type Parametric - = Parser PTerm -> Parser PTerm +type Parametric = + Parser PTerm -> Parser PTerm absTerm :: Parametric absTerm tm = withSpan $ \sp -> - inParens $ PIR.tyAbs sp <$> (symbol "abs" *> trailingWhitespace tyName) <*> kind <*> tm + inParens $ PIR.tyAbs sp <$> (symbol "abs" *> trailingWhitespace tyName) <*> kind <*> tm lamTerm :: Parametric lamTerm tm = withSpan $ \sp -> - inParens $ PIR.lamAbs sp <$> (symbol "lam" *> trailingWhitespace name) <*> pType <*> tm + inParens $ PIR.lamAbs sp <$> (symbol "lam" *> trailingWhitespace name) <*> pType <*> tm conTerm :: Parametric conTerm _tm = withSpan $ \sp -> - inParens $ PIR.constant sp <$> (symbol "con" *> constant) + inParens $ PIR.constant sp <$> (symbol "con" *> constant) iwrapTerm :: Parametric iwrapTerm tm = withSpan $ \sp -> - inParens $ PIR.iWrap sp <$> (symbol "iwrap" *> pType) <*> pType <*> tm + inParens $ PIR.iWrap sp <$> (symbol "iwrap" *> pType) <*> pType <*> tm builtinTerm :: Parametric builtinTerm _tm = withSpan $ \sp -> - inParens $ PIR.builtin sp <$> (symbol "builtin" *> builtinFunction) + inParens $ PIR.builtin sp <$> (symbol "builtin" *> builtinFunction) unwrapTerm :: Parametric unwrapTerm tm = withSpan $ \sp -> - inParens $ PIR.unwrap sp <$> (symbol "unwrap" *> tm) + inParens $ PIR.unwrap sp <$> (symbol "unwrap" *> tm) errorTerm :: Parametric errorTerm _tm = withSpan $ \sp -> - inParens $ PIR.error sp <$> (symbol "error" *> pType) + inParens $ PIR.error sp <$> (symbol "error" *> pType) constrTerm :: Parametric constrTerm tm = withSpan $ \sp -> - inParens $ do - let maxTag = fromIntegral (maxBound :: Word64) - ty <- symbol "constr" *> pType - tag :: Integer <- lexeme Lex.decimal - args <- many tm - whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0" - when (tag > maxTag) $ fail "constr tag too large: must be a legal Word64 value" - pure $ PIR.constr sp ty (fromIntegral tag) args + inParens $ do + let maxTag = fromIntegral (maxBound :: Word64) + ty <- symbol "constr" *> pType + tag :: Integer <- lexeme Lex.decimal + args <- many tm + whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0" + when (tag > maxTag) $ fail "constr tag too large: must be a legal Word64 value" + pure $ PIR.constr sp ty (fromIntegral tag) args caseTerm :: Parametric caseTerm tm = withSpan $ \sp -> inParens $ do - res <- PIR.kase sp <$> (symbol "case" *> pType) <*> tm <*> many tm - whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" - pure res + res <- PIR.kase sp <$> (symbol "case" *> pType) <*> tm <*> many tm + whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" + pure res letTerm :: Parser PTerm letTerm = withSpan $ \sp -> - inParens $ Let sp <$> (symbol "let" *> recursivity) <*> NE.some (try binding) <*> pTerm + inParens $ Let sp <$> (symbol "let" *> recursivity) <*> NE.some (try binding) <*> pTerm appTerm :: Parametric appTerm tm = withSpan $ \sp -> - -- TODO: should not use the same `sp` for all arguments. - inBrackets $ PIR.mkIterApp <$> tm <*> (fmap (sp,) <$> some tm) + -- TODO: should not use the same `sp` for all arguments. + inBrackets $ PIR.mkIterApp <$> tm <*> (fmap (sp,) <$> some tm) tyInstTerm :: Parametric tyInstTerm tm = withSpan $ \sp -> - -- TODO: should not use the same `sp` for all arguments. - inBraces $ PIR.mkIterInst <$> tm <*> (fmap (sp,) <$> some pType) + -- TODO: should not use the same `sp` for all arguments. + inBraces $ PIR.mkIterInst <$> tm <*> (fmap (sp,) <$> some pType) pTerm :: Parser PTerm pTerm = leadingWhitespace go where - go = choice $ try <$> - [ varTerm - , letTerm - , absTerm go - , lamTerm go - , conTerm go - , iwrapTerm go - , builtinTerm go - , unwrapTerm go - , errorTerm go - , tyInstTerm go - , appTerm go - , constrTerm go - , caseTerm go - ] + go = + choice $ + try + <$> [ varTerm + , letTerm + , absTerm go + , lamTerm go + , conTerm go + , iwrapTerm go + , builtinTerm go + , unwrapTerm go + , errorTerm go + , tyInstTerm go + , appTerm go + , constrTerm go + , caseTerm go + ] program :: Parser (Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) program = leadingWhitespace go where go = do - prog <- withSpan $ \sp -> inParens $ do - v <- symbol "program" *> version - withVersion v $ Program sp v <$> pTerm - notFollowedBy anySingle - pure prog + prog <- withSpan $ \sp -> inParens $ do + v <- symbol "program" *> version + withVersion v $ Program sp v <$> pTerm + notFollowedBy anySingle + pure prog -- | Parse a PIR program. The resulting program will have fresh names. The -- underlying monad must be capable of handling any parse errors. This passes -- "test" to the parser as the name of the input stream; to supply a name -- explicity, use `parse program `. parseProgram :: - (MonadError ParserErrorBundle m, MonadQuote m) - => Text - -> m (Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) + (MonadError ParserErrorBundle m, MonadQuote m) => + Text -> + m (Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) parseProgram = parseGen program diff --git a/plutus-core/plutus-ir/src/PlutusIR/Pass.hs b/plutus-core/plutus-ir/src/PlutusIR/Pass.hs index 47cf5f0f534..4b7659fcde9 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Pass.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Pass.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module PlutusIR.Pass where @@ -22,15 +22,18 @@ import PlutusCore.Quote -- | A condition on a 'Term'. data Condition tyname name uni fun a where -- | The 'Term' typechecks. - Typechecks :: (PLC.Typecheckable uni fun, PLC.GEq uni) - => TC.PirTCConfig uni fun -> Condition TyName Name uni fun a + Typechecks :: + (PLC.Typecheckable uni fun, PLC.GEq uni) => + TC.PirTCConfig uni fun -> Condition TyName Name uni fun a -- | The 'Term' has globally unique names. - GloballyUniqueNames :: (HasUnique tyname TypeUnique, HasUnique name TermUnique, Ord a) - => Condition tyname name uni fun a + GloballyUniqueNames :: + (HasUnique tyname TypeUnique, HasUnique name TermUnique, Ord a) => + Condition tyname name uni fun a -- | A custom condition. 'Nothing' indicates success, 'Just' indicates a failure at -- a location with a message. - Custom :: (Term tyname name uni fun a -> Maybe (a, Text)) - -> Condition tyname name uni fun a + Custom :: + (Term tyname name uni fun a -> Maybe (a, Text)) -> + Condition tyname name uni fun a -- | A condition on a pair of 'Term's. data BiCondition tyname name uni fun a where @@ -38,47 +41,49 @@ data BiCondition tyname name uni fun a where ConstCondition :: Condition tyname name uni fun a -> BiCondition tyname name uni fun a -- | A custom condition. 'Nothing' indicates success, 'Just' indicates a failure at -- a location with a message. - CustomBi :: (Term tyname name uni fun a -> Term tyname name uni fun a -> Maybe (a, Text)) - -> BiCondition tyname name uni fun a - -checkCondition - :: (MonadError (Error uni fun a) m, AnnotateCaseBuiltin uni) - => Condition tyname name uni fun a - -> Term tyname name uni fun a - -> m () + CustomBi :: + (Term tyname name uni fun a -> Term tyname name uni fun a -> Maybe (a, Text)) -> + BiCondition tyname name uni fun a + +checkCondition :: + (MonadError (Error uni fun a) m, AnnotateCaseBuiltin uni) => + Condition tyname name uni fun a -> + Term tyname name uni fun a -> + m () checkCondition c t = case c of Typechecks tcconfig -> void $ runQuoteT $ do -- Typechecking requires globally unique names renamed <- PLC.rename t TC.inferType tcconfig renamed GloballyUniqueNames -> - void $ modifyError (PLCError . PLC.UniqueCoherencyErrorE) $ - Uniques.checkTerm (const True) t + void $ + modifyError (PLCError . PLC.UniqueCoherencyErrorE) $ + Uniques.checkTerm (const True) t Custom f -> case f t of Just (a, e) -> throwError $ CompilationError a e - Nothing -> pure () - -checkBiCondition - :: (MonadError (Error uni fun a) m, AnnotateCaseBuiltin uni) - => BiCondition tyname name uni fun a - -> Term tyname name uni fun a - -> Term tyname name uni fun a - -> m () + Nothing -> pure () + +checkBiCondition :: + (MonadError (Error uni fun a) m, AnnotateCaseBuiltin uni) => + BiCondition tyname name uni fun a -> + Term tyname name uni fun a -> + Term tyname name uni fun a -> + m () checkBiCondition c t1 t2 = case c of ConstCondition c' -> checkCondition c' t2 CustomBi f -> case f t1 t2 of Just (a, e) -> throwError $ CompilationError a e - Nothing -> pure () + Nothing -> pure () -- | A pass over a term, with pre- and post-conditions. -data Pass m tyname name uni fun a = - -- | A basic pass. Has a function, which is the pass itself, a set of pre-conditions - -- which are run on the input term, and a set of post-conditions which are run on the - -- input and output terms (so can compare them). - Pass - (Term tyname name uni fun a -> m (Term tyname name uni fun a)) - [Condition tyname name uni fun a] - [BiCondition tyname name uni fun a] +data Pass m tyname name uni fun a + = -- | A basic pass. Has a function, which is the pass itself, a set of pre-conditions + -- which are run on the input term, and a set of post-conditions which are run on the + -- input and output terms (so can compare them). + Pass + (Term tyname name uni fun a -> m (Term tyname name uni fun a)) + [Condition tyname name uni fun a] + [BiCondition tyname name uni fun a] | CompoundPass (Pass m tyname name uni fun a) (Pass m tyname name uni fun a) | NoOpPass | NamedPass String (Pass m tyname name uni fun a) @@ -89,20 +94,20 @@ instance Semigroup (Pass m tyname name uni fun a) where instance Monoid (Pass m tyname name uni fun a) where mempty = NoOpPass -hoistPass :: (forall v . m v -> n v) -> Pass m tyname name uni fun a -> Pass n tyname name uni fun a +hoistPass :: (forall v. m v -> n v) -> Pass m tyname name uni fun a -> Pass n tyname name uni fun a hoistPass f p = case p of Pass mainPass pre post -> Pass (f . mainPass) pre post - CompoundPass p1 p2 -> CompoundPass (hoistPass f p1) (hoistPass f p2) - NamedPass n pass -> NamedPass n (hoistPass f pass) - NoOpPass -> NoOpPass - -runPass - :: (Monad m, AnnotateCaseBuiltin uni) - => (String -> m ()) - -> Bool - -> Pass m tyname name uni fun a - -> Term tyname name uni fun a - -> ExceptT (Error uni fun a) m (Term tyname name uni fun a) + CompoundPass p1 p2 -> CompoundPass (hoistPass f p1) (hoistPass f p2) + NamedPass n pass -> NamedPass n (hoistPass f pass) + NoOpPass -> NoOpPass + +runPass :: + (Monad m, AnnotateCaseBuiltin uni) => + (String -> m ()) -> + Bool -> + Pass m tyname name uni fun a -> + Term tyname name uni fun a -> + ExceptT (Error uni fun a) m (Term tyname name uni fun a) runPass logger checkConditions (Pass mainPass pre post) t = do when checkConditions $ do lift $ logger "checking preconditions" @@ -123,30 +128,30 @@ runPass logger checkConditions (NamedPass n pass) t = do runPass _ _ NoOpPass t = pure t -- | A simple, non-monadic pass that should typecheck. -simplePass - :: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) - => String - -> TC.PirTCConfig uni fun - -> (Term TyName Name uni fun a -> Term TyName Name uni fun a) - -> Pass m TyName Name uni fun a +simplePass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => + String -> + TC.PirTCConfig uni fun -> + (Term TyName Name uni fun a -> Term TyName Name uni fun a) -> + Pass m TyName Name uni fun a simplePass name tcConfig f = NamedPass name $ Pass (pure . f) [Typechecks tcConfig] [ConstCondition (Typechecks tcConfig)] -- | A pass that does renaming. -renamePass - :: (HasUnique name TermUnique, HasUnique tyname TypeUnique, MonadQuote m, Ord a) - => Pass m tyname name uni fun a +renamePass :: + (HasUnique name TermUnique, HasUnique tyname TypeUnique, MonadQuote m, Ord a) => + Pass m tyname name uni fun a renamePass = NamedPass "renaming" $ Pass PLC.rename [] [ConstCondition GloballyUniqueNames] -- | A pass that does typechecking, useful when you want to do it explicitly -- and not as part of a precondition check. -typecheckPass - :: (TC.MonadTypeCheckPir uni fun a m, Ord a) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a +typecheckPass :: + (TC.MonadTypeCheckPir uni fun a m, Ord a) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a typecheckPass tcconfig = NamedPass "typechecking" $ Pass run [GloballyUniqueNames] [] where run t = do diff --git a/plutus-core/plutus-ir/src/PlutusIR/Purity.hs b/plutus-core/plutus-ir/src/PlutusIR/Purity.hs index f189bb97ba6..791c59607a9 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Purity.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Purity.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -module PlutusIR.Purity - ( isPure - , isSaturated - , isWorkFree - , EvalOrder - , unEvalOrder - , EvalTerm (..) - , Purity (..) - , termEvaluationOrder - ) where +module PlutusIR.Purity ( + isPure, + isSaturated, + isWorkFree, + EvalOrder, + unEvalOrder, + EvalTerm (..), + Purity (..), + termEvaluationOrder, +) where import Control.Lens ((^.)) import Data.DList qualified as DList @@ -25,38 +25,53 @@ import Data.List.NonEmpty qualified as NE import PlutusCore.Builtin (BuiltinMeaning (..), ToBuiltinMeaning (..), TypeScheme (..)) import PlutusCore.Name.Unique qualified as PLC import PlutusCore.Pretty (Pretty (pretty), PrettyBy (prettyBy)) -import PlutusIR (Binding (TermBind), Name, Recursivity (NonRec, Rec), - Strictness (NonStrict, Strict), Term (..), TyName) +import PlutusIR ( + Binding (TermBind), + Name, + Recursivity (NonRec, Rec), + Strictness (NonStrict, Strict), + Term (..), + TyName, + ) import PlutusIR.Analysis.Builtins (BuiltinsInfo, biSemanticsVariant, builtinArityInfo) -import PlutusIR.Analysis.VarInfo (VarInfo (DatatypeConstructor), VarsInfo, lookupVarInfo, - varInfoStrictness) -import PlutusIR.Contexts (AppContext (..), Saturation (Oversaturated, Saturated, Undersaturated), - fillAppContext, saturates, splitApplication) +import PlutusIR.Analysis.VarInfo ( + VarInfo (DatatypeConstructor), + VarsInfo, + lookupVarInfo, + varInfoStrictness, + ) +import PlutusIR.Contexts ( + AppContext (..), + Saturation (Oversaturated, Saturated, Undersaturated), + fillAppContext, + saturates, + splitApplication, + ) import Prettyprinter (vsep, (<+>)) saturatesScheme :: AppContext tyname name uni fun a -> TypeScheme val args res -> Maybe Bool -- We've passed enough arguments that the builtin will reduce. -- Note that this also accepts over-applied builtins. -saturatesScheme _ TypeSchemeResult{} = Just True +saturatesScheme _ TypeSchemeResult {} = Just True -- Consume one argument saturatesScheme (TermAppContext _ _ args) (TypeSchemeArrow sch) = saturatesScheme args sch saturatesScheme (TypeAppContext _ _ args) (TypeSchemeAll _ sch) = saturatesScheme args sch -- Under-applied, not saturated -saturatesScheme AppContextEnd TypeSchemeArrow{} = Just False -saturatesScheme AppContextEnd TypeSchemeAll{} = Just False +saturatesScheme AppContextEnd TypeSchemeArrow {} = Just False +saturatesScheme AppContextEnd TypeSchemeAll {} = Just False -- These cases are only possible in case we have an ill-typed builtin application, -- so we can't give an answer. -saturatesScheme TypeAppContext{} TypeSchemeArrow{} = Nothing -saturatesScheme TermAppContext{} TypeSchemeAll{} = Nothing +saturatesScheme TypeAppContext {} TypeSchemeArrow {} = Nothing +saturatesScheme TermAppContext {} TypeSchemeAll {} = Nothing -- | Is the given application saturated? Returns 'Nothing' if we can't tell. -isSaturated - :: forall tyname name uni fun a - . (ToBuiltinMeaning uni fun) - => BuiltinsInfo uni fun - -> fun - -> AppContext tyname name uni fun a - -> Maybe Bool +isSaturated :: + forall tyname name uni fun a. + ToBuiltinMeaning uni fun => + BuiltinsInfo uni fun -> + fun -> + AppContext tyname name uni fun a -> + Maybe Bool isSaturated binfo fun args = let semvar = binfo ^. biSemanticsVariant in case toBuiltinMeaning @uni @fun @(Term TyName Name uni fun ()) semvar fun of @@ -67,260 +82,254 @@ data Purity = MaybeImpure | Pure instance Pretty Purity where pretty MaybeImpure = "impure?" - pretty Pure = "pure" + pretty Pure = "pure" -- | Is this term essentially work-free? Either yes, or maybe not. data WorkFreedom = MaybeWork | WorkFree instance Pretty WorkFreedom where pretty MaybeWork = "maybe work?" - pretty WorkFree = "work-free" + pretty WorkFree = "work-free" -{- | Either the "next" term to be evaluated, along with its 'Purity' and 'WorkFreedom', -or we don't know what comes next. --} +-- | Either the "next" term to be evaluated, along with its 'Purity' and 'WorkFreedom', +-- or we don't know what comes next. data EvalTerm tyname name uni fun a = Unknown | EvalTerm Purity WorkFreedom (Term tyname name uni fun a) instance - (PrettyBy config (Term tyname name uni fun a)) - => PrettyBy config (EvalTerm tyname name uni fun a) + PrettyBy config (Term tyname name uni fun a) => + PrettyBy config (EvalTerm tyname name uni fun a) where - prettyBy _ Unknown = "" + prettyBy _ Unknown = "" prettyBy config (EvalTerm eff work t) = pretty eff <+> pretty work <> ":" <+> prettyBy config t -{- | The order in which terms get evaluated, along with their purities. -We use a DList here for efficient and lazy concatenation --} +-- | The order in which terms get evaluated, along with their purities. +-- We use a DList here for efficient and lazy concatenation newtype EvalOrder tyname name uni fun a = EvalOrder (DList.DList (EvalTerm tyname name uni fun a)) deriving newtype (Semigroup, Monoid) -{- | Get the evaluation order as a list of 'EvalTerm's. Either terminates in a single -'Unknown', which means that we got to a point where evaluation continues but we don't -know where; or terminates normally, in which case we actually got to the end of the -evaluation order for the term. --} +-- | Get the evaluation order as a list of 'EvalTerm's. Either terminates in a single +-- 'Unknown', which means that we got to a point where evaluation continues but we don't +-- know where; or terminates normally, in which case we actually got to the end of the +-- evaluation order for the term. unEvalOrder :: EvalOrder tyname name uni fun a -> [EvalTerm tyname name uni fun a] unEvalOrder (EvalOrder ts) = -- This is where we avoid traversing the whole program beyond the first Unknown, -- since DList is lazy and we convert to a lazy list and then filter it. takeWhileInclusive (\case Unknown -> False; _ -> True) (DList.toList ts) - where - takeWhileInclusive :: (a -> Bool) -> [a] -> [a] - takeWhileInclusive p = foldr (\x ys -> if p x then x : ys else [x]) [] + where + takeWhileInclusive :: (a -> Bool) -> [a] -> [a] + takeWhileInclusive p = foldr (\x ys -> if p x then x : ys else [x]) [] evalThis :: EvalTerm tyname name uni fun a -> EvalOrder tyname name uni fun a evalThis tm = EvalOrder (DList.singleton tm) instance - (PrettyBy config (Term tyname name uni fun a)) - => PrettyBy config (EvalOrder tyname name uni fun a) + PrettyBy config (Term tyname name uni fun a) => + PrettyBy config (EvalOrder tyname name uni fun a) where prettyBy config eo = vsep $ fmap (prettyBy config) (unEvalOrder eo) -{- | Given a term, return the order in which it and its sub-terms will be evaluated. - -This aims to be a sound under-approximation: if we don't know, we just say 'Unknown'. -Typically there will be a sequence of terms that we do know, which will terminate -in 'Unknown' once we do something like call a function. - -This makes some assumptions about the evaluator, in particular about the order in -which we evaluate sub-terms, but these match the current evaluator and we are not -planning on changing it. --} -termEvaluationOrder - :: forall tyname name uni fun a - . (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Term tyname name uni fun a - -> EvalOrder tyname name uni fun a +-- | Given a term, return the order in which it and its sub-terms will be evaluated. +-- +-- This aims to be a sound under-approximation: if we don't know, we just say 'Unknown'. +-- Typically there will be a sequence of terms that we do know, which will terminate +-- in 'Unknown' once we do something like call a function. +-- +-- This makes some assumptions about the evaluator, in particular about the order in +-- which we evaluate sub-terms, but these match the current evaluator and we are not +-- planning on changing it. +termEvaluationOrder :: + forall tyname name uni fun a. + (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + EvalOrder tyname name uni fun a termEvaluationOrder binfo vinfo = goTerm - where - goTerm :: Term tyname name uni fun a -> EvalOrder tyname name uni fun a - goTerm = \case - t@(Let _ NonRec bs b) -> - -- first the bindings, in order - goBindings (NE.toList bs) - -- then the body - <> goTerm b - -- then the whole term, which will lead to applications (so work) - <> evalThis (EvalTerm Pure MaybeWork t) - Let _ Rec _ _ -> - -- Hard to know what gets evaluated first in a recursive let-binding, - -- just give up - evalThis Unknown - -- If we can view as a builtin application, then handle that specially - (splitApplication -> (Builtin a fun, args)) -> goBuiltinApp a fun args - -- If we can view as a constructor application, then handle that specially. - -- Constructor applications are always pure: if under-applied they don't - -- reduce; if fully-applied they are pure; if over-applied it's going to be - -- a type error since they never return a function. So we can ignore the arity - -- in this case! - t@(splitApplication -> (h@(Var _ n), args)) - | Just (DatatypeConstructor{}) <- lookupVarInfo n vinfo -> - evalThis (EvalTerm Pure MaybeWork h) - <> appContextEvalOrder args - <> evalThis (EvalTerm Pure MaybeWork t) - -- No Unknown: we go to a known pure place, but we can't show it, - -- so we just skip it here. This has the effect of making constructor - -- applications pure + where + goTerm :: Term tyname name uni fun a -> EvalOrder tyname name uni fun a + goTerm = \case + t@(Let _ NonRec bs b) -> + -- first the bindings, in order + goBindings (NE.toList bs) + -- then the body + <> goTerm b + -- then the whole term, which will lead to applications (so work) + <> evalThis (EvalTerm Pure MaybeWork t) + Let _ Rec _ _ -> + -- Hard to know what gets evaluated first in a recursive let-binding, + -- just give up + evalThis Unknown + -- If we can view as a builtin application, then handle that specially + (splitApplication -> (Builtin a fun, args)) -> goBuiltinApp a fun args + -- If we can view as a constructor application, then handle that specially. + -- Constructor applications are always pure: if under-applied they don't + -- reduce; if fully-applied they are pure; if over-applied it's going to be + -- a type error since they never return a function. So we can ignore the arity + -- in this case! + t@(splitApplication -> (h@(Var _ n), args)) + | Just (DatatypeConstructor {}) <- lookupVarInfo n vinfo -> + evalThis (EvalTerm Pure MaybeWork h) + <> appContextEvalOrder args + <> evalThis (EvalTerm Pure MaybeWork t) + -- No Unknown: we go to a known pure place, but we can't show it, + -- so we just skip it here. This has the effect of making constructor + -- applications pure - -- We could handle functions and type abstractions with *known* bodies - -- here. But there's not much point: beta reduction will immediately - -- turn those into let-bindings, which we do see through already. - t@(Apply _ fun arg) -> - -- first the function - goTerm fun - -- then the arg - <> goTerm arg - -- then the whole term, which means environment manipulation, so work - <> evalThis (EvalTerm Pure MaybeWork t) - -- then we go to the unknown function body - <> evalThis Unknown - t@(TyInst _ ta _) -> - -- first the type abstraction - goTerm ta - -- then the whole term, which will mean forcing, so work - <> evalThis (EvalTerm Pure MaybeWork t) - -- then we go to the unknown body of the type abstraction - <> evalThis Unknown - t@(IWrap _ _ _ b) -> - -- first the body - goTerm b - <> evalThis (EvalTerm Pure WorkFree t) - t@(Unwrap _ b) -> - -- first the body - goTerm b - -- then the whole term, but this is erased so it is work-free - <> evalThis (EvalTerm Pure WorkFree t) - t@(Constr _ _ _ ts) -> - -- first the arguments, in left-to-right order - foldMap goTerm ts - -- then the whole term, which means constructing the value, so work - <> evalThis (EvalTerm Pure MaybeWork t) - t@(Case _ _ scrut _) -> - -- first the scrutinee - goTerm scrut - -- then the whole term, which means finding the case so work - <> evalThis (EvalTerm Pure MaybeWork t) - -- then we go to an unknown scrutinee - <> evalThis Unknown - -- Leaf terms - t@(Var _ name) -> - -- See Note [Purity, strictness, and variables] - let purity = case varInfoStrictness <$> lookupVarInfo name vinfo of - Just Strict -> Pure - Just NonStrict -> MaybeImpure - _ -> MaybeImpure - in -- looking up the variable is work - evalThis (EvalTerm purity MaybeWork t) - t@Error{} -> - -- definitely effectful! but not relevant from a work perspective - evalThis (EvalTerm MaybeImpure WorkFree t) - -- program terminates - <> evalThis Unknown - t@Builtin{} -> - evalThis (EvalTerm Pure WorkFree t) - t@TyAbs{} -> - evalThis (EvalTerm Pure WorkFree t) - t@LamAbs{} -> - evalThis (EvalTerm Pure WorkFree t) - t@Constant{} -> - evalThis (EvalTerm Pure WorkFree t) + -- We could handle functions and type abstractions with *known* bodies + -- here. But there's not much point: beta reduction will immediately + -- turn those into let-bindings, which we do see through already. + t@(Apply _ fun arg) -> + -- first the function + goTerm fun + -- then the arg + <> goTerm arg + -- then the whole term, which means environment manipulation, so work + <> evalThis (EvalTerm Pure MaybeWork t) + -- then we go to the unknown function body + <> evalThis Unknown + t@(TyInst _ ta _) -> + -- first the type abstraction + goTerm ta + -- then the whole term, which will mean forcing, so work + <> evalThis (EvalTerm Pure MaybeWork t) + -- then we go to the unknown body of the type abstraction + <> evalThis Unknown + t@(IWrap _ _ _ b) -> + -- first the body + goTerm b + <> evalThis (EvalTerm Pure WorkFree t) + t@(Unwrap _ b) -> + -- first the body + goTerm b + -- then the whole term, but this is erased so it is work-free + <> evalThis (EvalTerm Pure WorkFree t) + t@(Constr _ _ _ ts) -> + -- first the arguments, in left-to-right order + foldMap goTerm ts + -- then the whole term, which means constructing the value, so work + <> evalThis (EvalTerm Pure MaybeWork t) + t@(Case _ _ scrut _) -> + -- first the scrutinee + goTerm scrut + -- then the whole term, which means finding the case so work + <> evalThis (EvalTerm Pure MaybeWork t) + -- then we go to an unknown scrutinee + <> evalThis Unknown + -- Leaf terms + t@(Var _ name) -> + -- See Note [Purity, strictness, and variables] + let purity = case varInfoStrictness <$> lookupVarInfo name vinfo of + Just Strict -> Pure + Just NonStrict -> MaybeImpure + _ -> MaybeImpure + in -- looking up the variable is work + evalThis (EvalTerm purity MaybeWork t) + t@Error {} -> + -- definitely effectful! but not relevant from a work perspective + evalThis (EvalTerm MaybeImpure WorkFree t) + -- program terminates + <> evalThis Unknown + t@Builtin {} -> + evalThis (EvalTerm Pure WorkFree t) + t@TyAbs {} -> + evalThis (EvalTerm Pure WorkFree t) + t@LamAbs {} -> + evalThis (EvalTerm Pure WorkFree t) + t@Constant {} -> + evalThis (EvalTerm Pure WorkFree t) - goBindings :: [Binding tyname name uni fun a] -> EvalOrder tyname name uni fun a - goBindings [] = mempty - goBindings (b : bs) = case b of - -- Only strict term bindings get evaluated at this point - TermBind _ Strict _ rhs -> goTerm rhs - _ -> goBindings bs + goBindings :: [Binding tyname name uni fun a] -> EvalOrder tyname name uni fun a + goBindings [] = mempty + goBindings (b : bs) = case b of + -- Only strict term bindings get evaluated at this point + TermBind _ Strict _ rhs -> goTerm rhs + _ -> goBindings bs - goBuiltinApp :: a -> fun -> AppContext tyname name uni fun a -> EvalOrder tyname name uni fun a - goBuiltinApp a fun appContext = appContextEvalOrder appContext <> evalOrder - where - evalOrder :: EvalOrder tyname name uni fun a - evalOrder = case saturates appContext (builtinArityInfo binfo fun) of - -- If it's saturated or oversaturated, we might have an effect here - Just Saturated -> maybeImpureWork - Just Oversaturated -> maybeImpureWork - -- TODO: previous definition of work-free included this, it's slightly - -- unclear if we should do since we do update partial builtin meanings - -- etc. - -- If it's unsaturated, we definitely don't do any work - Just Undersaturated -> pureWorkFree - -- Don't know, be conservative - Nothing -> maybeImpureWork + goBuiltinApp :: a -> fun -> AppContext tyname name uni fun a -> EvalOrder tyname name uni fun a + goBuiltinApp a fun appContext = appContextEvalOrder appContext <> evalOrder + where + evalOrder :: EvalOrder tyname name uni fun a + evalOrder = case saturates appContext (builtinArityInfo binfo fun) of + -- If it's saturated or oversaturated, we might have an effect here + Just Saturated -> maybeImpureWork + Just Oversaturated -> maybeImpureWork + -- TODO: previous definition of work-free included this, it's slightly + -- unclear if we should do since we do update partial builtin meanings + -- etc. + -- If it's unsaturated, we definitely don't do any work + Just Undersaturated -> pureWorkFree + -- Don't know, be conservative + Nothing -> maybeImpureWork - maybeImpureWork :: EvalOrder tyname name uni fun a - maybeImpureWork = evalThis (EvalTerm MaybeImpure MaybeWork reconstructed) + maybeImpureWork :: EvalOrder tyname name uni fun a + maybeImpureWork = evalThis (EvalTerm MaybeImpure MaybeWork reconstructed) - pureWorkFree :: EvalOrder tyname name uni fun a - pureWorkFree = evalThis (EvalTerm Pure WorkFree reconstructed) + pureWorkFree :: EvalOrder tyname name uni fun a + pureWorkFree = evalThis (EvalTerm Pure WorkFree reconstructed) - reconstructed :: Term tyname name uni fun a - reconstructed = fillAppContext (Builtin a fun) appContext + reconstructed :: Term tyname name uni fun a + reconstructed = fillAppContext (Builtin a fun) appContext - appContextEvalOrder :: AppContext tyname name uni fun a -> EvalOrder tyname name uni fun a - appContextEvalOrder = \case - AppContextEnd -> mempty - TermAppContext t _ rest -> goTerm t <> appContextEvalOrder rest - TypeAppContext _ _ rest -> appContextEvalOrder rest + appContextEvalOrder :: AppContext tyname name uni fun a -> EvalOrder tyname name uni fun a + appContextEvalOrder = \case + AppContextEnd -> mempty + TermAppContext t _ rest -> goTerm t <> appContextEvalOrder rest + TypeAppContext _ _ rest -> appContextEvalOrder rest -{- | Will evaluating this term have side effects (looping or error)? -This is slightly wider than the definition of a value, as -it includes applications that are known to be pure, as well as -things that can't be returned from the machine (as they'd be ill-scoped). --} -isPure - :: (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Term tyname name uni fun a - -> Bool +-- | Will evaluating this term have side effects (looping or error)? +-- This is slightly wider than the definition of a value, as +-- it includes applications that are known to be pure, as well as +-- things that can't be returned from the machine (as they'd be ill-scoped). +isPure :: + (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + Bool isPure binfo vinfo t = -- to work out if the term is pure, we see if we can look through -- the whole evaluation order without hitting something that might be -- effectful go $ unEvalOrder (termEvaluationOrder binfo vinfo t) - where - go :: [EvalTerm tyname name uni fun a] -> Bool - go [] = True - go (et : rest) = case et of - -- Might be an effect here! - EvalTerm MaybeImpure _ _ -> False - -- This term is fine, what about the rest? - EvalTerm Pure _ _ -> go rest - -- We don't know what will happen, so be conservative - Unknown -> False - -{- | Is the given term 'work-free'? + where + go :: [EvalTerm tyname name uni fun a] -> Bool + go [] = True + go (et : rest) = case et of + -- Might be an effect here! + EvalTerm MaybeImpure _ _ -> False + -- This term is fine, what about the rest? + EvalTerm Pure _ _ -> go rest + -- We don't know what will happen, so be conservative + Unknown -> False -Note: The definition of 'work-free' is a little unclear, but the idea is that -evaluating this term should do very a trivial amount of work. --} -isWorkFree - :: (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Term tyname name uni fun a - -> Bool +-- | Is the given term 'work-free'? +-- +-- Note: The definition of 'work-free' is a little unclear, but the idea is that +-- evaluating this term should do very a trivial amount of work. +isWorkFree :: + (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + Bool isWorkFree binfo vinfo t = -- to work out if the term is pure, we see if we can look through -- the whole evaluation order without hitting something that might be -- effectful go $ unEvalOrder (termEvaluationOrder binfo vinfo t) - where - go :: [EvalTerm tyname name uni fun a] -> Bool - go [] = True - go (et : rest) = case et of - -- Might be an effect here! - EvalTerm _ MaybeWork _ -> False - -- This term is fine, what about the rest? - EvalTerm _ WorkFree _ -> go rest - -- We don't know what will happen, so be conservative - Unknown -> False + where + go :: [EvalTerm tyname name uni fun a] -> Bool + go [] = True + go (et : rest) = case et of + -- Might be an effect here! + EvalTerm _ MaybeWork _ -> False + -- This term is fine, what about the rest? + EvalTerm _ WorkFree _ -> go rest + -- We don't know what will happen, so be conservative + Unknown -> False {- Note [Purity, strictness, and variables] Variables in PLC won't have effects: they can have something else substituted for them, diff --git a/plutus-core/plutus-ir/src/PlutusIR/Strictness.hs b/plutus-core/plutus-ir/src/PlutusIR/Strictness.hs index 799b6388846..529e2c5a384 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Strictness.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Strictness.hs @@ -6,29 +6,29 @@ module PlutusIR.Strictness (isStrictIn) where import PlutusIR (Binding (TermBind), Strictness (Strict), Term (..)) -- | Whether the given name is strict in the given term. -isStrictIn - :: forall tyname name uni fun a - . (Eq name) - => name - -> Term tyname name uni fun a - -> Bool +isStrictIn :: + forall tyname name uni fun a. + Eq name => + name -> + Term tyname name uni fun a -> + Bool isStrictIn n = go - where - go = \case - Var _ n' -> n == n' - Let _ _ bs body -> any goBinding bs || go body - Apply _ fun arg -> go fun || go arg - TyInst _ body _ -> go body - IWrap _ _ _ body -> go body - Unwrap _ body -> go body - Constr _ _ _ args -> any go args - Case _ _ scrut _ -> go scrut - TyAbs{} -> False - LamAbs{} -> False - Constant{} -> False - Builtin{} -> False - Error{} -> False + where + go = \case + Var _ n' -> n == n' + Let _ _ bs body -> any goBinding bs || go body + Apply _ fun arg -> go fun || go arg + TyInst _ body _ -> go body + IWrap _ _ _ body -> go body + Unwrap _ body -> go body + Constr _ _ _ args -> any go args + Case _ _ scrut _ -> go scrut + TyAbs {} -> False + LamAbs {} -> False + Constant {} -> False + Builtin {} -> False + Error {} -> False - goBinding = \case - TermBind _ Strict _ rhs -> go rhs - _ -> False + goBinding = \case + TermBind _ Strict _ rhs -> go rhs + _ -> False diff --git a/plutus-core/plutus-ir/src/PlutusIR/Subst.hs b/plutus-core/plutus-ir/src/PlutusIR/Subst.hs index 08be90d84b7..4b35c7662f4 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Subst.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Subst.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} module PlutusIR.Subst ( substVarA, @@ -45,22 +45,22 @@ import Universe -- | Applicatively replace a variable using the given function. substVarA :: - (Applicative f) => + Applicative f => (name -> f (Maybe (Term tyname name uni fun ann))) -> Term tyname name uni fun ann -> f (Term tyname name uni fun ann) substVarA nameF t@(Var _ name) = fromMaybe t <$> nameF name -substVarA _ t = pure t +substVarA _ t = pure t {-# INLINE substVarA #-} -- | Applicatively replace a type variable using the given function. substTyVarA :: - (Applicative f) => + Applicative f => (tyname -> f (Maybe (Type tyname uni ann))) -> Type tyname uni ann -> f (Type tyname uni ann) substTyVarA tynameF ty@(TyVar _ tyname) = fromMaybe ty <$> tynameF tyname -substTyVarA _ ty = pure ty +substTyVarA _ ty = pure ty {-# INLINE substTyVarA #-} -- | Naively substitute names using the given functions (i.e. do not substitute binders). @@ -72,7 +72,7 @@ termSubstNames = purely termSubstNamesM -- | Naively monadically substitute names using the given function (i.e. do not substitute binders). termSubstNamesM :: - (Monad m) => + Monad m => (name -> m (Maybe (Term tyname name uni fun ann))) -> Term tyname name uni fun ann -> m (Term tyname name uni fun ann) @@ -85,11 +85,10 @@ termSubstTyNames :: Term tyname name uni fun a termSubstTyNames = purely termSubstTyNamesM -{- | Naively monadically substitute type names using the given function -(i.e. do not substitute binders). --} +-- | Naively monadically substitute type names using the given function +-- (i.e. do not substitute binders). termSubstTyNamesM :: - (Monad m) => + Monad m => (tyname -> m (Maybe (Type tyname uni ann))) -> Term tyname name uni fun ann -> m (Term tyname name uni fun ann) @@ -113,12 +112,12 @@ bindingSubstTyNames tynameF = . over bindingSubtypes (typeSubstTyNames tynameF) -- | Get all the free term variables in a PIR term. -fvTerm :: (HasUnique name TermUnique) => Traversal' (Term tyname name uni fun ann) name +fvTerm :: HasUnique name TermUnique => Traversal' (Term tyname name uni fun ann) name fvTerm = fvTermCtx mempty -fvTermCtx - :: forall tyname name uni fun ann . - (HasUnique name TermUnique) => +fvTermCtx :: + forall tyname name uni fun ann. + HasUnique name TermUnique => UniqueSet TermUnique -> Traversal' (Term tyname name uni fun ann) name fvTermCtx bound f = \case @@ -135,11 +134,11 @@ fvTermCtx bound f = \case t -> (termSubterms . fvTermCtx bound) f t -- | Get all the free type variables in a PIR term. -ftvTerm :: (HasUnique tyname TypeUnique) => Traversal' (Term tyname name uni fun ann) tyname +ftvTerm :: HasUnique tyname TypeUnique => Traversal' (Term tyname name uni fun ann) tyname ftvTerm = ftvTermCtx mempty ftvTermCtx :: - (HasUnique tyname TypeUnique) => + HasUnique tyname TypeUnique => UniqueSet TypeUnique -> Traversal' (Term tyname name uni fun ann) tyname ftvTermCtx bound f = \case @@ -156,24 +155,24 @@ ftvTermCtx bound f = \case t -> ((termSubterms . ftvTermCtx bound) `Unsound.adjoin` (termSubtypes . ftvTyCtx bound)) f t -- | Get all the free variables in a PIR single let-binding. -fvBinding :: (HasUnique name TermUnique) => Traversal' (Binding tyname name uni fun ann) name +fvBinding :: HasUnique name TermUnique => Traversal' (Binding tyname name uni fun ann) name fvBinding = fvBindingCtx mempty fvBindingCtx :: - (HasUnique name TermUnique) => + HasUnique name TermUnique => UniqueSet TermUnique -> Traversal' (Binding tyname name uni fun ann) name fvBindingCtx bound = bindingSubterms . fvTermCtx bound -- | Get all the free type variables in a PIR single let-binding. ftvBinding :: - (HasUnique tyname TypeUnique) => + HasUnique tyname TypeUnique => Recursivity -> Traversal' (Binding tyname name uni fun ann) tyname ftvBinding r = ftvBindingCtx r mempty ftvBindingCtx :: - (HasUnique tyname TypeUnique) => + HasUnique tyname TypeUnique => Recursivity -> UniqueSet TypeUnique -> Traversal' (Binding tyname name uni fun ann) tyname @@ -188,7 +187,7 @@ ftvBindingCtx r bound f = \case b ftvDatatypeCtx :: - (HasUnique tyname TypeUnique) => + HasUnique tyname TypeUnique => Recursivity -> UniqueSet TypeUnique -> Traversal' (Datatype tyname name uni ann) tyname @@ -219,17 +218,18 @@ ftvDatatypeCtx r bound f d@(Datatype a tyconstr tyvars destr constrs) = -- | Traverse the arguments of a function type (nothing if the type is not a function type). funArgs :: Traversal' (Type tyname uni a) (Type tyname uni a) funArgs f = \case - TyFun a dom cod@TyFun{} -> TyFun a <$> f dom <*> funArgs f cod - TyFun a dom res -> TyFun a <$> f dom <*> pure res - t -> pure t + TyFun a dom cod@TyFun {} -> TyFun a <$> f dom <*> funArgs f cod + TyFun a dom res -> TyFun a <$> f dom <*> pure res + t -> pure t -- | Traverse the result type of a function type (the type itself if it is not a function type). funRes :: Lens' (Type tyname uni a) (Type tyname uni a) funRes f = \case TyFun a dom cod -> TyFun a dom <$> funRes f cod - t -> f t + t -> f t -- TODO: these could be Traversals + -- | Get all the term variables in a term. vTerm :: Fold (Term tyname name uni fun ann) name vTerm = termSubtermsDeep . termVars @@ -239,32 +239,32 @@ tvTerm :: Fold (Term tyname name uni fun ann) tyname tvTerm = termSubtypesDeep . typeTyVars -- | Applicatively replace a constant using the given function. -substConstantA - :: Applicative f - => (ann -> Some (ValueOf uni) -> f (Maybe (Term tyname name uni fun ann))) - -> Term tyname name uni fun ann - -> f (Term tyname name uni fun ann) +substConstantA :: + Applicative f => + (ann -> Some (ValueOf uni) -> f (Maybe (Term tyname name uni fun ann))) -> + Term tyname name uni fun ann -> + f (Term tyname name uni fun ann) substConstantA valF t@(Constant ann val) = fromMaybe t <$> valF ann val -substConstantA _ t = pure t +substConstantA _ t = pure t -- | Replace a constant using the given function. -substConstant - :: (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann +substConstant :: + (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann substConstant = purely (substConstantA . curry) . uncurry -- | Monadically substitute constants using the given function. -termSubstConstantsM - :: Monad m - => (ann -> Some (ValueOf uni) -> m (Maybe (Term tyname name uni fun ann))) - -> Term tyname name uni fun ann - -> m (Term tyname name uni fun ann) +termSubstConstantsM :: + Monad m => + (ann -> Some (ValueOf uni) -> m (Maybe (Term tyname name uni fun ann))) -> + Term tyname name uni fun ann -> + m (Term tyname name uni fun ann) termSubstConstantsM = transformMOf termSubterms . substConstantA -- | Substitute constants using the given function. -termSubstConstants - :: (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) - -> Term tyname name uni fun ann - -> Term tyname name uni fun ann +termSubstConstants :: + (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann)) -> + Term tyname name uni fun ann -> + Term tyname name uni fun ann termSubstConstants = purely (termSubstConstantsM . curry) . uncurry diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Beta.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Beta.hs index a0335a5cad7..c28cf870aeb 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Beta.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Beta.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} -{-| -A simple beta-reduction pass. --} + +-- | +-- A simple beta-reduction pass. module PlutusIR.Transform.Beta ( beta, betaPass, - betaPassSC - ) where + betaPassSC, +) where import Control.Lens (over) import Data.List.NonEmpty qualified as NE @@ -78,53 +78,50 @@ because in order to check that `b` and `y` have the same type, we need to know t but we don't - type-lets are opaque inside their bodies. -} -{-| Extract the list of bindings from a term, a bit like a "multi-beta" reduction. - -Some examples will help: - -[(\x . t) a] -> Just ([x |-> a], t) - -[[[(\x . (\y . (\z . t))) a] b] c] -> Just ([x |-> a, y |-> b, z |-> c]) t) - -[[(\x . t) a] b] -> Nothing --} +-- | Extract the list of bindings from a term, a bit like a "multi-beta" reduction. +-- +-- Some examples will help: +-- +-- [(\x . t) a] -> Just ([x |-> a], t) +-- +-- [[[(\x . (\y . (\z . t))) a] b] c] -> Just ([x |-> a, y |-> b, z |-> c]) t) +-- +-- [[(\x . t) a] b] -> Nothing extractBindings :: - Term tyname name uni fun a - -> Maybe (NE.NonEmpty (Binding tyname name uni fun a), Term tyname name uni fun a) + Term tyname name uni fun a -> + Maybe (NE.NonEmpty (Binding tyname name uni fun a), Term tyname name uni fun a) extractBindings = collectArgs [] where - collectArgs argStack (Apply _ f arg) = collectArgs (arg:argStack) f - collectArgs argStack t = matchArgs argStack [] t - matchArgs (arg:rest) acc (LamAbs a n ty body) = - matchArgs rest (TermBind a Strict (VarDecl a n ty) arg:acc) body - matchArgs [] acc t = - case NE.nonEmpty (reverse acc) of - Nothing -> Nothing - Just acc' -> Just (acc', t) - matchArgs (_:_) _ _ = Nothing - -{-| -Recursively apply the beta transformation on the code, both for the terms - -@ - (\ (x : A). M) N - ==> - let x : A = N in M -@ - -and types - -@ - (/\ a. \(x : a) . x) {A} - ==> - let a : * = A in - (\ (x : A). x) -@ - --} -beta - :: Term tyname name uni fun a - -> Term tyname name uni fun a + collectArgs argStack (Apply _ f arg) = collectArgs (arg : argStack) f + collectArgs argStack t = matchArgs argStack [] t + matchArgs (arg : rest) acc (LamAbs a n ty body) = + matchArgs rest (TermBind a Strict (VarDecl a n ty) arg : acc) body + matchArgs [] acc t = + case NE.nonEmpty (reverse acc) of + Nothing -> Nothing + Just acc' -> Just (acc', t) + matchArgs (_ : _) _ _ = Nothing + +-- | +-- Recursively apply the beta transformation on the code, both for the terms +-- +-- @ +-- (\ (x : A). M) N +-- ==> +-- let x : A = N in M +-- @ +-- +-- and types +-- +-- @ +-- (/\ a. \(x : a) . x) {A} +-- ==> +-- let a : * = A in +-- (\ (x : A). x) +-- @ +beta :: + Term tyname name uni fun a -> + Term tyname name uni fun a beta = over termSubterms beta . localTransform where localTransform = \case @@ -133,20 +130,20 @@ beta = over termSubterms beta . localTransform (extractBindings -> Just (bs, t)) -> Let (termAnn t) NonRec bs t -- See Note [Multi-beta] for why we don't perform multi-beta on `TyInst`. TyInst _ (TyAbs a n k body) tyArg -> - let b = TypeBind a (TyVarDecl a n k) tyArg - in Let (termAnn body) NonRec (pure b) body + let b = TypeBind a (TyVarDecl a n k) tyArg + in Let (termAnn body) NonRec (pure b) body t -> t -betaPassSC - :: (PLC.Typecheckable uni fun, PLC.GEq uni, PLC.MonadQuote m, Ord a) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a +betaPassSC :: + (PLC.Typecheckable uni fun, PLC.GEq uni, PLC.MonadQuote m, Ord a) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a betaPassSC tcconfig = renamePass <> betaPass tcconfig -betaPass - :: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m, Ord a) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a +betaPass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m, Ord a) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a betaPass tcconfig = NamedPass "beta" $ Pass diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseOfCase.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseOfCase.hs index 26cfb712ce2..58742063152 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseOfCase.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseOfCase.hs @@ -1,8 +1,9 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} + module PlutusIR.Transform.CaseOfCase (caseOfCase, caseOfCasePass, caseOfCasePassSC) where import Control.Lens hiding (Strict, cons) @@ -15,8 +16,13 @@ import PlutusCore.Name.Unique qualified as PLC import PlutusCore.Quote import PlutusIR import PlutusIR.Analysis.Builtins -import PlutusIR.Analysis.VarInfo (VarInfo (DatatypeConstructor, DatatypeMatcher), VarsInfo, - getConstructorArities, lookupVarInfo, termVarInfo) +import PlutusIR.Analysis.VarInfo ( + VarInfo (DatatypeConstructor, DatatypeMatcher), + VarsInfo, + getConstructorArities, + lookupVarInfo, + termVarInfo, + ) import PlutusIR.Contexts import PlutusIR.Core import PlutusIR.MkPir @@ -26,24 +32,24 @@ import PlutusIR.TypeCheck qualified as TC import PlutusPrelude caseOfCasePassSC :: - forall m uni fun a. - (PLC.Typecheckable uni fun, PLC.GEq uni, PLC.MonadQuote m, Ord a) => - TC.PirTCConfig uni fun -> - BuiltinsInfo uni fun -> - Bool -> - a -> - Pass m TyName Name uni fun a + forall m uni fun a. + (PLC.Typecheckable uni fun, PLC.GEq uni, PLC.MonadQuote m, Ord a) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Bool -> + a -> + Pass m TyName Name uni fun a caseOfCasePassSC tcconfig binfo conservative newAnn = renamePass <> caseOfCasePass tcconfig binfo conservative newAnn caseOfCasePass :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, MonadQuote m, Ord a) => - TC.PirTCConfig uni fun -> - BuiltinsInfo uni fun -> - Bool -> - a -> - Pass m TyName Name uni fun a + forall m uni fun a. + (PLC.Typecheckable uni fun, PLC.GEq uni, MonadQuote m, Ord a) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Bool -> + a -> + Pass m TyName Name uni fun a caseOfCasePass tcconfig binfo conservative newAnn = NamedPass "case-of-case" $ Pass @@ -51,68 +57,68 @@ caseOfCasePass tcconfig binfo conservative newAnn = [Typechecks tcconfig, GloballyUniqueNames] [ConstCondition (Typechecks tcconfig)] -{-| -Perform the case-of-case transformation. This pushes -case expressions into the case branches of other case -expressions, which can often yield optimization opportunities. - -Example: -@ - case (case s of { C1 a -> x; C2 b -> y; }) of - D1 -> w - D2 -> z - - --> - - case s of - C1 a -> case x of { D1 -> w; D2 -> z; } - C2 b -> case y of { D1 -> w; D2 -> z; } -@ --} +-- | +-- Perform the case-of-case transformation. This pushes +-- case expressions into the case branches of other case +-- expressions, which can often yield optimization opportunities. +-- +-- Example: +-- @ +-- case (case s of { C1 a -> x; C2 b -> y; }) of +-- D1 -> w +-- D2 -> z +-- +-- --> +-- +-- case s of +-- C1 a -> case x of { D1 -> w; D2 -> z; } +-- C2 b -> case y of { D1 -> w; D2 -> z; } +-- @ caseOfCase :: - forall m tyname uni fun a. - ( Ord fun, PLC.HasUnique tyname PLC.TypeUnique - , PLC.MonadQuote m -- we need this because we do generate new names - ) => - BuiltinsInfo uni fun -> - Bool -> - a -> - Term tyname Name uni fun a -> - m (Term tyname Name uni fun a) + forall m tyname uni fun a. + ( Ord fun + , PLC.HasUnique tyname PLC.TypeUnique + , PLC.MonadQuote m -- we need this because we do generate new names + ) => + BuiltinsInfo uni fun -> + Bool -> + a -> + Term tyname Name uni fun a -> + m (Term tyname Name uni fun a) -- See Note [Case-of-case and conapps] caseOfCase binfo conservative newAnn t = do - let vinfo = termVarInfo t - liftQuote $ transformMOf termSubterms (processTerm binfo vinfo conservative newAnn) t + let vinfo = termVarInfo t + liftQuote $ transformMOf termSubterms (processTerm binfo vinfo conservative newAnn) t processTerm :: - forall tyname uni fun a . - (Ord fun, PLC.HasUnique tyname PLC.TypeUnique) => - BuiltinsInfo uni fun -> - VarsInfo tyname Name uni a -> - Bool -> - a -> - Term tyname Name uni fun a -> - Quote (Term tyname Name uni fun a) + forall tyname uni fun a. + (Ord fun, PLC.HasUnique tyname PLC.TypeUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname Name uni a -> + Bool -> + a -> + Term tyname Name uni fun a -> + Quote (Term tyname Name uni fun a) processTerm binfo vinfo conservative newAnn t - -- We have a saturated datatype matcher application - | Just (smcO@(SplitMatchContext _ (outerScrut, _, _) _ _), reconstructOuter, _) <- splitMatch binfo vinfo t - -- The scrutinee is itself an application - , Just (smcI, reconstructInner, innerBranchArities) <- splitMatch binfo vinfo outerScrut - = do + -- We have a saturated datatype matcher application + | Just (smcO@(SplitMatchContext _ (outerScrut, _, _) _ _), reconstructOuter, _) <- splitMatch binfo vinfo t + , -- The scrutinee is itself an application + Just (smcI, reconstructInner, innerBranchArities) <- splitMatch binfo vinfo outerScrut = + do nt <- runMaybeT $ tryDoCaseOfCase vinfo conservative newAnn (smcO, reconstructOuter) (smcI, reconstructInner) innerBranchArities case nt of Just newTerm -> pure newTerm - Nothing -> pure t - | otherwise = pure t + Nothing -> pure t + | otherwise = pure t tryDoCaseOfCase :: - VarsInfo tyname Name uni a - -> Bool - -> a - -> (SplitMatchContext tyname Name uni fun a, SplitMatchContext tyname Name uni fun a -> Term tyname Name uni fun a) - -> (SplitMatchContext tyname Name uni fun a, SplitMatchContext tyname Name uni fun a -> Term tyname Name uni fun a) - -> [Arity] - -> MaybeT Quote (Term tyname Name uni fun a) + VarsInfo tyname Name uni a -> + Bool -> + a -> + (SplitMatchContext tyname Name uni fun a, SplitMatchContext tyname Name uni fun a -> Term tyname Name uni fun a) -> + (SplitMatchContext tyname Name uni fun a, SplitMatchContext tyname Name uni fun a -> Term tyname Name uni fun a) -> + [Arity] -> + MaybeT Quote (Term tyname Name uni fun a) tryDoCaseOfCase vinfo conservative @@ -120,67 +126,68 @@ tryDoCaseOfCase (SplitMatchContext outerVars (_, outerScrutTy, outerScrutAnn) (outerResTy, outerResTyAnn) outerBranches, reconstructOuter) -- Note: we don't use the inner result type, we're going to replace it (SplitMatchContext innerVars (innerScrut, innerScrutTy, innerScrutAnn) _ innerBranches, reconstructInner) - innerBranchArities - = do - kName <- lift $ freshName "k_caseOfCase" - sName <- lift $ freshName "scrutinee" - let - -- If a term is a constructor application, returns the name of the constructor - conAppHead (splitApplication -> (Var _ n, _)) | Just (DatatypeConstructor{}) <- lookupVarInfo n vinfo = Just n - conAppHead _ = Nothing - -- Gets all the constructor application heads from inside the branches of the inner match - innerBranchConAppHeads = mapMaybe conAppHead $ innerBranches ^.. underBranches innerBranchArities - -- Check whether a) all the branches are conapps, and b) all the conapps are distinct. - -- See Note [Case-of-case and conapps] - allDistinctBranchConApps = + innerBranchArities = + do + kName <- lift $ freshName "k_caseOfCase" + sName <- lift $ freshName "scrutinee" let - -- Otherwise we've lost something when we did the traversal and we don't know what's going on - lengthsMatch = length innerBranchConAppHeads == length innerBranchArities - distinctCons = distinct innerBranchConAppHeads - in lengthsMatch && distinctCons - -- If we're being conservative (so trying to avoid code growth), and we don't know that the inlined - -- version will reduce, then bind the outer case to a function to avoid code growth - bindOuterCase = conservative && not allDistinctBranchConApps - - let - mkNewOuterMatch newScrut = - reconstructOuter $ SplitMatchContext outerVars (newScrut, outerScrutTy, outerScrutAnn) (outerResTy, outerResTyAnn) outerBranches - -- \(x :: scrutTy) -> case x of ... - newOuterMatchFn = LamAbs newAnn sName (newAnn <$ outerScrutTy) $ mkNewOuterMatch (Var newAnn sName) - -- k_caseOfCase :: scrutTy -> outerResTy = ... - newOuterMatchFnBinding = - TermBind newAnn Strict (VarDecl newAnn kName (TyFun newAnn (newAnn <$ outerScrutTy) outerResTy)) newOuterMatchFn - mkNewInnerBranchBody scrut = - if bindOuterCase - -- k_caseOfCase scrut - then Apply newAnn (Var newAnn kName) scrut - -- case scrut of ... - else mkNewOuterMatch scrut - - newInnerBranches <- MaybeT $ pure $ mapBranches mkNewInnerBranchBody innerBranches innerBranchArities - - let - newInnerMatch = - reconstructInner $ SplitMatchContext innerVars (innerScrut, innerScrutTy, innerScrutAnn) (outerResTy, outerResTyAnn) newInnerBranches - - pure $ - if bindOuterCase - then mkLet newAnn NonRec [newOuterMatchFnBinding] newInnerMatch - else newInnerMatch + -- If a term is a constructor application, returns the name of the constructor + conAppHead (splitApplication -> (Var _ n, _)) | Just (DatatypeConstructor {}) <- lookupVarInfo n vinfo = Just n + conAppHead _ = Nothing + -- Gets all the constructor application heads from inside the branches of the inner match + innerBranchConAppHeads = mapMaybe conAppHead $ innerBranches ^.. underBranches innerBranchArities + -- Check whether a) all the branches are conapps, and b) all the conapps are distinct. + -- See Note [Case-of-case and conapps] + allDistinctBranchConApps = + let + -- Otherwise we've lost something when we did the traversal and we don't know what's going on + lengthsMatch = length innerBranchConAppHeads == length innerBranchArities + distinctCons = distinct innerBranchConAppHeads + in + lengthsMatch && distinctCons + -- If we're being conservative (so trying to avoid code growth), and we don't know that the inlined + -- version will reduce, then bind the outer case to a function to avoid code growth + bindOuterCase = conservative && not allDistinctBranchConApps + + let + mkNewOuterMatch newScrut = + reconstructOuter $ SplitMatchContext outerVars (newScrut, outerScrutTy, outerScrutAnn) (outerResTy, outerResTyAnn) outerBranches + -- \(x :: scrutTy) -> case x of ... + newOuterMatchFn = LamAbs newAnn sName (newAnn <$ outerScrutTy) $ mkNewOuterMatch (Var newAnn sName) + -- k_caseOfCase :: scrutTy -> outerResTy = ... + newOuterMatchFnBinding = + TermBind newAnn Strict (VarDecl newAnn kName (TyFun newAnn (newAnn <$ outerScrutTy) outerResTy)) newOuterMatchFn + mkNewInnerBranchBody scrut = + if bindOuterCase + -- k_caseOfCase scrut + then Apply newAnn (Var newAnn kName) scrut + -- case scrut of ... + else mkNewOuterMatch scrut + + newInnerBranches <- MaybeT $ pure $ mapBranches mkNewInnerBranchBody innerBranches innerBranchArities + + let + newInnerMatch = + reconstructInner $ SplitMatchContext innerVars (innerScrut, innerScrutTy, innerScrutAnn) (outerResTy, outerResTyAnn) newInnerBranches + + pure $ + if bindOuterCase + then mkLet newAnn NonRec [newOuterMatchFnBinding] newInnerMatch + else newInnerMatch -- | Apply the given function to the term "inside" the case branches in the given 'AppContext'. -- Must be given an arity for each branch so it knows how many binders to go under. mapBranches :: - forall tyname name uni fun a - . (Term tyname name uni fun a -> Term tyname name uni fun a) - -> AppContext tyname name uni fun a - -> [Arity] - -> Maybe (AppContext tyname name uni fun a) + forall tyname name uni fun a. + (Term tyname name uni fun a -> Term tyname name uni fun a) -> + AppContext tyname name uni fun a -> + [Arity] -> + Maybe (AppContext tyname name uni fun a) mapBranches f = go - where + where go :: AppContext tyname name uni fun a -> [Arity] -> Maybe (AppContext tyname name uni fun a) go AppContextEnd [] = Just AppContextEnd - go (TermAppContext branch ann ctx) (arity:arities) = + go (TermAppContext branch ann ctx) (arity : arities) = -- This makes the whole thing return Nothing if the traversal has no targets, i.e. if the -- arity doesn't match the term we're looking at. I can't see a way to do this with a more -- general traversal, so there's some duplication between this and the simpler 'underBranches'. @@ -190,27 +197,29 @@ mapBranches f = go -- | Traverses under the branches in the application context. underBranches :: [Arity] -> Traversal' (AppContext tyname name uni fun a) (Term tyname name uni fun a) underBranches as f = go as - where + where go [] AppContextEnd = pure AppContextEnd - go (arity:arities) (TermAppContext branch ann ctx) = + go (arity : arities) (TermAppContext branch ann ctx) = TermAppContext <$> underBinders arity f branch <*> pure ann <*> go arities ctx go _ ctx = pure ctx -- | Split a match, either a normal datatype match or a builtin 'match'. -splitMatch :: forall tyname name uni fun a . (Ord fun, PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => - BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Term tyname name uni fun a - -> Maybe (SplitMatchContext tyname name uni fun a, SplitMatchContext tyname name uni fun a -> Term tyname name uni fun a, [Arity]) +splitMatch :: + forall tyname name uni fun a. + (Ord fun, PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + Maybe (SplitMatchContext tyname name uni fun a, SplitMatchContext tyname name uni fun a -> Term tyname name uni fun a, [Arity]) splitMatch binfo vinfo t = do let (hd, args) = splitApplication t (p, arities) <- case hd of - (Var _ matcherName) -> do + (Var _ matcherName) -> do let p = asNormalDatatypeMatch vinfo matcherName info <- lookupVarInfo matcherName vinfo constrArities <- case info of DatatypeMatcher parentTyName -> getConstructorArities parentTyName vinfo - _ -> Nothing + _ -> Nothing -- The branch arities don't include the type arguments for the constructor let branchArities = fmap (dropWhile ((==) TypeParam)) constrArities pure (p, branchArities) @@ -218,7 +227,7 @@ splitMatch binfo vinfo t = do p <- asBuiltinDatatypeMatch binfo matcherName branchArities <- builtinDatatypeMatchBranchArities binfo matcherName pure (p, branchArities) - _ -> Nothing + _ -> Nothing withPrism p $ \reconstruct match -> case match args of Right sm -> diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseReduce.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseReduce.hs index 900ee2248de..3a952cdbc63 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseReduce.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/CaseReduce.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} -module PlutusIR.Transform.CaseReduce - ( caseReduce - , caseReducePass - ) where +module PlutusIR.Transform.CaseReduce ( + caseReduce, + caseReducePass, +) where import PlutusCore.Builtin (CaseBuiltin (..)) import PlutusCore.MkPlc @@ -18,27 +18,30 @@ import PlutusCore qualified as PLC import PlutusIR.Pass import PlutusIR.TypeCheck qualified as TC -caseReducePass - :: ( PLC.Typecheckable uni fun, CaseBuiltin uni - , PLC.GEq uni, Applicative m - ) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a +caseReducePass :: + ( PLC.Typecheckable uni fun + , CaseBuiltin uni + , PLC.GEq uni + , Applicative m + ) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a caseReducePass tcconfig = simplePass "case reduce" tcconfig caseReduce -caseReduce - :: CaseBuiltin uni - => Term tyname name uni fun a -> Term tyname name uni fun a +caseReduce :: + CaseBuiltin uni => + Term tyname name uni fun a -> Term tyname name uni fun a caseReduce = transformOf termSubterms processTerm -processTerm - :: CaseBuiltin uni - => Term tyname name uni fun a -> Term tyname name uni fun a +processTerm :: + CaseBuiltin uni => + Term tyname name uni fun a -> Term tyname name uni fun a processTerm = \case - -- We could've rewritten those patterns as 'Error' in the 'Nothing' cases, but that would turn a - -- structural error into an operational one, which would be unfortunate, so instead we decided - -- not to fully optimize such scripts, since they aren't valid anyway. - Case ann _ (Constr _ _ i args) cs | Just c <- cs ^? wix i -> mkIterApp c ((ann,) <$> args) - Case ann _ (Constant _ con) cs | Right fXs <- caseBuiltin con (fromList cs) -> - headSpineToTerm ann (second (Constant ann) fXs) - t -> t + -- We could've rewritten those patterns as 'Error' in the 'Nothing' cases, but that would turn a + -- structural error into an operational one, which would be unfortunate, so instead we decided + -- not to fully optimize such scripts, since they aren't valid anyway. + Case ann _ (Constr _ _ i args) cs | Just c <- cs ^? wix i -> mkIterApp c ((ann,) <$> args) + Case ann _ (Constant _ con) cs + | Right fXs <- caseBuiltin con (fromList cs) -> + headSpineToTerm ann (second (Constant ann) fXs) + t -> t diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/DeadCode.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/DeadCode.hs index 7ce91ea1aa2..7697a4142f9 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/DeadCode.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/DeadCode.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Optimization passes for removing dead code, mainly dead let bindings. -module PlutusIR.Transform.DeadCode - ( removeDeadBindings - , removeDeadBindingsPass - , removeDeadBindingsPassSC - ) where +module PlutusIR.Transform.DeadCode ( + removeDeadBindings, + removeDeadBindingsPass, + removeDeadBindingsPassSC, +) where import PlutusIR import PlutusIR.Analysis.Dependencies qualified as Deps @@ -37,18 +37,18 @@ import PlutusIR.TypeCheck qualified as TC import Witherable (Witherable (wither)) removeDeadBindingsPassSC :: - (PLC.Typecheckable uni fun, PLC.GEq uni, Ord a, MonadQuote m) - => TC.PirTCConfig uni fun - -> BuiltinsInfo uni fun - -> Pass m TyName Name uni fun a + (PLC.Typecheckable uni fun, PLC.GEq uni, Ord a, MonadQuote m) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun a removeDeadBindingsPassSC tcconfig binfo = renamePass <> removeDeadBindingsPass tcconfig binfo removeDeadBindingsPass :: - (PLC.Typecheckable uni fun, PLC.GEq uni, Ord a, MonadQuote m) - => TC.PirTCConfig uni fun - -> BuiltinsInfo uni fun - -> Pass m TyName Name uni fun a + (PLC.Typecheckable uni fun, PLC.GEq uni, Ord a, MonadQuote m) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun a removeDeadBindingsPass tcconfig binfo = NamedPass "dead code elimination" $ Pass @@ -57,84 +57,92 @@ removeDeadBindingsPass tcconfig binfo = [ConstCondition (Typechecks tcconfig)] -- We only need MonadQuote to make new types for bindings + -- | Remove all the dead let bindings in a term. -removeDeadBindings - :: (PLC.HasUnique name PLC.TermUnique, - PLC.ToBuiltinMeaning uni fun, PLC.MonadQuote m) - => BuiltinsInfo uni fun - -> Term TyName name uni fun a - -> m (Term TyName name uni fun a) +removeDeadBindings :: + ( PLC.HasUnique name PLC.TermUnique + , PLC.ToBuiltinMeaning uni fun + , PLC.MonadQuote m + ) => + BuiltinsInfo uni fun -> + Term TyName name uni fun a -> + m (Term TyName name uni fun a) removeDeadBindings binfo t = do - let vinfo = termVarInfo t - runReaderT (transformMOf termSubterms processTerm t) (calculateLiveness binfo vinfo t) + let vinfo = termVarInfo t + runReaderT (transformMOf termSubterms processTerm t) (calculateLiveness binfo vinfo t) type Liveness = Set.Set Deps.Node -calculateLiveness - :: (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique, - PLC.ToBuiltinMeaning uni fun) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Term tyname name uni fun a - -> Liveness +calculateLiveness :: + ( PLC.HasUnique name PLC.TermUnique + , PLC.HasUnique tyname PLC.TypeUnique + , PLC.ToBuiltinMeaning uni fun + ) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + Liveness calculateLiveness binfo vinfo t = - let - depGraph :: G.Graph Deps.Node - depGraph = Deps.runTermDeps binfo vinfo t - in Set.fromList $ T.reachable depGraph Deps.Root + let + depGraph :: G.Graph Deps.Node + depGraph = Deps.runTermDeps binfo vinfo t + in + Set.fromList $ T.reachable depGraph Deps.Root live :: (MonadReader Liveness m, PLC.HasUnique n unique) => n -> m Bool live n = - let - u = coerce $ n ^. PLC.unique - in asks $ Set.member (Deps.Variable u) - -liveBinding - :: (MonadReader Liveness m, PLC.HasUnique name PLC.TermUnique, MonadQuote m) - => Binding TyName name uni fun a - -> m (Maybe (Binding TyName name uni fun a)) + let + u = coerce $ n ^. PLC.unique + in + asks $ Set.member (Deps.Variable u) + +liveBinding :: + (MonadReader Liveness m, PLC.HasUnique name PLC.TermUnique, MonadQuote m) => + Binding TyName name uni fun a -> + m (Maybe (Binding TyName name uni fun a)) liveBinding = - let - -- TODO: HasUnique instances for VarDecl and TyVarDecl? - liveVarDecl (VarDecl _ n _) = live n - liveTyVarDecl (TyVarDecl _ n _) = live n - in \case - b@(TermBind _ _ d _) -> do - l <- liveVarDecl d - pure $ if l then Just b else Nothing - b@(TypeBind _ d _) -> do - l <- liveTyVarDecl d - pure $ if l then Just b else Nothing - b@(DatatypeBind x (Datatype _ d _ destr constrs)) -> do - dtypeLive <- liveTyVarDecl d - destrLive <- live destr - constrsLive <- traverse liveVarDecl constrs - let termLive = or (destrLive : constrsLive) - case (dtypeLive, termLive) of - -- At least one term-level part is live, keep the whole thing - (_, True) -> pure $ Just b - -- Nothing is live, remove the whole thing - (False, False) -> pure Nothing - -- See Note [Dependencies for datatype bindings, and pruning them] - -- Datatype is live but no term-level parts are, replace with a trivial type binding - (True, False) -> Just . TypeBind x d <$> mkTypeOfKind (_tyVarDeclKind d) + let + -- TODO: HasUnique instances for VarDecl and TyVarDecl? + liveVarDecl (VarDecl _ n _) = live n + liveTyVarDecl (TyVarDecl _ n _) = live n + in + \case + b@(TermBind _ _ d _) -> do + l <- liveVarDecl d + pure $ if l then Just b else Nothing + b@(TypeBind _ d _) -> do + l <- liveTyVarDecl d + pure $ if l then Just b else Nothing + b@(DatatypeBind x (Datatype _ d _ destr constrs)) -> do + dtypeLive <- liveTyVarDecl d + destrLive <- live destr + constrsLive <- traverse liveVarDecl constrs + let termLive = or (destrLive : constrsLive) + case (dtypeLive, termLive) of + -- At least one term-level part is live, keep the whole thing + (_, True) -> pure $ Just b + -- Nothing is live, remove the whole thing + (False, False) -> pure Nothing + -- See Note [Dependencies for datatype bindings, and pruning them] + -- Datatype is live but no term-level parts are, replace with a trivial type binding + (True, False) -> Just . TypeBind x d <$> mkTypeOfKind (_tyVarDeclKind d) -- | Given a kind, make a type (any type!) of that kind. -- Generates things of the form 'unit -> unit -> ... -> unit' mkTypeOfKind :: MonadQuote m => Kind a -> m (Type TyName uni a) mkTypeOfKind = \case - -- The scott-encoded unit here is a little bulky but it continues to be the easiest - -- way to get a type of kind Type without relying on builtins. - Type a -> pure $ a <$ Unit.unit - KindArrow a ki ki' -> do - n <- freshTyName "a" - TyLam a n ki <$> mkTypeOfKind ki' - -processTerm - :: (MonadReader Liveness m, PLC.HasUnique name PLC.TermUnique, MonadQuote m) - => Term TyName name uni fun a - -> m (Term TyName name uni fun a) + -- The scott-encoded unit here is a little bulky but it continues to be the easiest + -- way to get a type of kind Type without relying on builtins. + Type a -> pure $ a <$ Unit.unit + KindArrow a ki ki' -> do + n <- freshTyName "a" + TyLam a n ki <$> mkTypeOfKind ki' + +processTerm :: + (MonadReader Liveness m, PLC.HasUnique name PLC.TermUnique, MonadQuote m) => + Term TyName name uni fun a -> + m (Term TyName name uni fun a) processTerm = \case - -- throw away dead bindings - Let x r bs t -> mkLet x r <$> wither liveBinding (NE.toList bs) <*> pure t - x -> pure x + -- throw away dead bindings + Let x r bs t -> mkLet x r <$> wither liveBinding (NE.toList bs) <*> pure t + x -> pure x diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs index 478cad51542..89e0b0f87f1 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} + -- | A pass that tries to evaluate builtin applications in the program. -- -- This functions as a generic constant-folding pass, but which handles -- arbitrary builtins. -module PlutusIR.Transform.EvaluateBuiltins - ( evaluateBuiltins - , evaluateBuiltinsPass - ) where +module PlutusIR.Transform.EvaluateBuiltins ( + evaluateBuiltins, + evaluateBuiltinsPass, +) where import PlutusCore.Builtin import PlutusIR.Contexts @@ -21,13 +22,14 @@ import PlutusIR.Analysis.Builtins import PlutusIR.Pass import PlutusIR.TypeCheck qualified as TC -evaluateBuiltinsPass :: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) - => TC.PirTCConfig uni fun - -> Bool - -- ^ Whether to be conservative and try to retain logging behaviour. - -> BuiltinsInfo uni fun - -> CostingPart uni fun - -> Pass m TyName Name uni fun a +evaluateBuiltinsPass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => + TC.PirTCConfig uni fun -> + -- | Whether to be conservative and try to retain logging behaviour. + Bool -> + BuiltinsInfo uni fun -> + CostingPart uni fun -> + Pass m TyName Name uni fun a evaluateBuiltinsPass tcconfig preserveLogging binfo costModel = NamedPass "evaluate builtins" $ Pass @@ -35,44 +37,45 @@ evaluateBuiltinsPass tcconfig preserveLogging binfo costModel = [Typechecks tcconfig] [ConstCondition (Typechecks tcconfig)] -evaluateBuiltins - :: forall tyname name uni fun a - . (ToBuiltinMeaning uni fun +evaluateBuiltins :: + forall tyname name uni fun a. + ( ToBuiltinMeaning uni fun , Typeable tyname - , Typeable name) - => Bool - -- ^ Whether to be conservative and try to retain logging behaviour. - -> BuiltinsInfo uni fun - -> CostingPart uni fun - -> Term tyname name uni fun a - -> Term tyname name uni fun a + , Typeable name + ) => + -- | Whether to be conservative and try to retain logging behaviour. + Bool -> + BuiltinsInfo uni fun -> + CostingPart uni fun -> + Term tyname name uni fun a -> + Term tyname name uni fun a evaluateBuiltins preserveLogging binfo costModel = transformOf termSubterms processTerm where -- Nothing means "leave the original term as it was" - eval - :: BuiltinRuntime (Term tyname name uni fun ()) - -> AppContext tyname name uni fun a - -> Maybe (Term tyname name uni fun ()) + eval :: + BuiltinRuntime (Term tyname name uni fun ()) -> + AppContext tyname name uni fun a -> + Maybe (Term tyname name uni fun ()) eval (BuiltinCostedResult _ getFXs) AppContextEnd = - case getFXs of - BuiltinSuccess y -> Just y - -- Evaluates successfully, but does logging. If we're being conservative - -- then we should leave these in, so we don't remove people's logging! - -- Otherwise `trace "hello" x` is a prime candidate for evaluation! - BuiltinSuccessWithLogs _ y -> if preserveLogging then Nothing else Just y - -- Evaluation failure. This can mean that the evaluation legitimately - -- failed (e.g. `divideInteger 1 0`), or that it failed because the - -- argument terms are not currently in the right form (because they're - -- not evaluated, we're in the middle of a term here!). Since we can't - -- distinguish these, we have to assume it's the latter case and just leave - -- things alone. - BuiltinFailure{} -> Nothing + case getFXs of + BuiltinSuccess y -> Just y + -- Evaluates successfully, but does logging. If we're being conservative + -- then we should leave these in, so we don't remove people's logging! + -- Otherwise `trace "hello" x` is a prime candidate for evaluation! + BuiltinSuccessWithLogs _ y -> if preserveLogging then Nothing else Just y + -- Evaluation failure. This can mean that the evaluation legitimately + -- failed (e.g. `divideInteger 1 0`), or that it failed because the + -- argument terms are not currently in the right form (because they're + -- not evaluated, we're in the middle of a term here!). Since we can't + -- distinguish these, we have to assume it's the latter case and just leave + -- things alone. + BuiltinFailure {} -> Nothing eval (BuiltinExpectArgument toRuntime) (TermAppContext arg _ ctx) = - -- Builtin evaluation does not work with annotations, so we have to throw - -- the argument annotation away here - eval (toRuntime $ void arg) ctx + -- Builtin evaluation does not work with annotations, so we have to throw + -- the argument annotation away here + eval (toRuntime $ void arg) ctx eval (BuiltinExpectForce runtime) (TypeAppContext _ _ ctx) = - eval runtime ctx + eval runtime ctx -- arg mismatch, including under-application, just leave it alone eval _ _ = Nothing @@ -80,13 +83,13 @@ evaluateBuiltins preserveLogging binfo costModel = transformOf termSubterms proc -- See Note [Context splitting in a recursive pass] processTerm t@(splitApplication -> (Builtin x bn, argCtx)) = let runtime = toBuiltinRuntime costModel (toBuiltinMeaning (binfo ^. biSemanticsVariant) bn) - in case eval runtime argCtx of - -- Builtin evaluation gives us a fresh term with no annotation. - -- Use the annotation of the builtin node, arbitrarily. This is slightly - -- suboptimal, e.g. in `ifThenElse True x y`, we will get back `x`, but - -- with the annotation that was on the `ifThenElse` node. But we can't - -- easily do better. - -- See Note [Unserializable constants] - Just t' | termIsSerializable binfo t' -> x <$ t' - _ -> t + in case eval runtime argCtx of + -- Builtin evaluation gives us a fresh term with no annotation. + -- Use the annotation of the builtin node, arbitrarily. This is slightly + -- suboptimal, e.g. in `ifThenElse True x y`, we will get back `x`, but + -- with the annotation that was on the `ifThenElse` node. But we can't + -- easily do better. + -- See Note [Unserializable constants] + Just t' | termIsSerializable binfo t' -> x <$ t' + _ -> t processTerm t = t diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs index 781ae131445..6c4f4b989e0 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} -{- | -Call site inlining machinery. We inline if the size of the inlined result is not larger. -See Note [Inlining and beta reduction of functions]. --} +-- | +-- Call site inlining machinery. We inline if the size of the inlined result is not larger. +-- See Note [Inlining and beta reduction of functions]. module PlutusIR.Transform.Inline.CallSiteInline where import PlutusCore qualified as PLC @@ -56,12 +55,11 @@ perform beta reduction. -} -{- | Apply the RHS of the given variable to the given arguments, and beta-reduce -the application, if possible. --} +-- | Apply the RHS of the given variable to the given arguments, and beta-reduce +-- the application, if possible. applyAndBetaReduce :: forall tyname name uni fun ann. - (InliningConstraints tyname name uni fun) => + InliningConstraints tyname name uni fun => -- | The rhs of the variable, should have been renamed already Term tyname name uni fun ann -> -- | The arguments, already processed @@ -79,8 +77,8 @@ applyAndBetaReduce rhs args0 = do then do acc' <- do termSubstNamesM -- substitute the term param with the arg in the function body - -- rename before substitution to ensure global uniqueness (may not be needed but - -- no harm in renaming just to be sure) + -- rename before substitution to ensure global uniqueness (may not be needed but + -- no harm in renaming just to be sure) (\tmName -> if tmName == n then Just <$> PLC.rename arg else pure Nothing) tm -- drop the beta reduced term lambda go acc' args' @@ -93,8 +91,8 @@ applyAndBetaReduce rhs args0 = do tm -- drop the beta reduced type lambda go acc' args' -- term/type argument mismatch, don't inline - (LamAbs{}, TypeAppContext{}) -> pure Nothing - (TyAbs{}, TermAppContext{}) -> pure Nothing + (LamAbs {}, TypeAppContext {}) -> pure Nothing + (TyAbs {}, TermAppContext {}) -> pure Nothing -- no more lambda abstraction, just return the processed application (_, _) -> pure . Just $ fillAppContext acc args @@ -115,7 +113,7 @@ applyAndBetaReduce rhs args0 = do -- | Consider inlining a variable. For applications, consider whether to apply and beta reduce. callSiteInline :: forall tyname name uni fun ann. - (InliningConstraints tyname name uni fun) => + InliningConstraints tyname name uni fun => -- | The term size if it were not inlined. AstSize -> -- | The `Utils.VarInfo` of the variable (the head of the term). @@ -126,34 +124,37 @@ callSiteInline :: callSiteInline processedTSize = go where go varInfo args = do - let - defAsInlineTerm = varRhs varInfo - inlineTermToTerm :: InlineTerm tyname name uni fun ann - -> Term tyname name uni fun ann - inlineTermToTerm (Done (Dupable var)) = var - -- extract out the rhs without renaming, we only rename - -- when we know there's substitution - headRhs = inlineTermToTerm defAsInlineTerm - -- The definition itself will be inlined, so we need to check that the cost - -- of that is acceptable. Note that we do _not_ check the cost of the _body_. - -- We would have paid that regardless. - -- Consider e.g. `let y = \x. f x`. We pay the cost of the `f x` at - -- every call site regardless. The work that is being duplicated is - -- the work for the lambda. - costIsOk = costIsAcceptable headRhs - -- check if binding is pure to avoid duplicated effects. - -- For strict bindings we can't accidentally make any effects happen less often - -- than it would have before, but we can make it happen more often. - -- We could potentially do this safely in non-conservative mode. - rhsPure <- isTermBindingPure (varStrictness varInfo) headRhs - thresh <- view iiInlineCallsiteGrowth - if costIsOk && rhsPure then do + let + defAsInlineTerm = varRhs varInfo + inlineTermToTerm :: + InlineTerm tyname name uni fun ann -> + Term tyname name uni fun ann + inlineTermToTerm (Done (Dupable var)) = var + -- extract out the rhs without renaming, we only rename + -- when we know there's substitution + headRhs = inlineTermToTerm defAsInlineTerm + -- The definition itself will be inlined, so we need to check that the cost + -- of that is acceptable. Note that we do _not_ check the cost of the _body_. + -- We would have paid that regardless. + -- Consider e.g. `let y = \x. f x`. We pay the cost of the `f x` at + -- every call site regardless. The work that is being duplicated is + -- the work for the lambda. + costIsOk = costIsAcceptable headRhs + -- check if binding is pure to avoid duplicated effects. + -- For strict bindings we can't accidentally make any effects happen less often + -- than it would have before, but we can make it happen more often. + -- We could potentially do this safely in non-conservative mode. + rhsPure <- isTermBindingPure (varStrictness varInfo) headRhs + thresh <- view iiInlineCallsiteGrowth + if costIsOk && rhsPure + then do -- rename the rhs of the variable before any substitution renamedRhs <- rename headRhs applyAndBetaReduce renamedRhs args >>= \case Just inlined -> do - let -- Inline only if the size is no bigger than not inlining plus threshold. - sizeIsOk = termAstSize inlined <= processedTSize + max 0 thresh + let + -- Inline only if the size is no bigger than not inlining plus threshold. + sizeIsOk = termAstSize inlined <= processedTSize + max 0 thresh pure $ if sizeIsOk then Just inlined else Nothing Nothing -> pure Nothing else pure Nothing diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs index 68a0ad4f438..901fa72e126 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs @@ -1,16 +1,15 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} - -{- | An inlining pass of *non-recursive* bindings. It includes -(1) unconditional inlining: similar to `PreInlineUnconditionally` and `PostInlineUnconditionally` -in the paper 'Secrets of the GHC Inliner'. -(2) call site inlining of fully applied functions. See `Inline.CallSiteInline.hs` --} - +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +-- | An inlining pass of *non-recursive* bindings. It includes +-- (1) unconditional inlining: similar to `PreInlineUnconditionally` and `PostInlineUnconditionally` +-- in the paper 'Secrets of the GHC Inliner'. +-- (2) call site inlining of fully applied functions. See `Inline.CallSiteInline.hs` module PlutusIR.Transform.Inline.Inline (inline, inlinePass, inlinePassSC, InlineHints (..)) where + import PlutusCore qualified as PLC import PlutusCore.Annotation import PlutusCore.Name.Unique @@ -18,9 +17,9 @@ import PlutusCore.Quote import PlutusCore.Rename (dupable) import PlutusIR import PlutusIR.Analysis.Builtins -import PlutusIR.AstSize (AstSize, termAstSize) import PlutusIR.Analysis.Usages qualified as Usages import PlutusIR.Analysis.VarInfo qualified as VarInfo +import PlutusIR.AstSize (AstSize, termAstSize) import PlutusIR.Contexts (AppContext (..), fillAppContext, splitApplication) import PlutusIR.MkPir (mkLet) import PlutusIR.Pass @@ -103,7 +102,7 @@ look like this (see Note [Abstract data types]). Here's an example with Maybe: The definitions of the constructors/destructor don't look like let-bindings because there is a type abstraction in between the lambdas and their arguments! And this abstraction is important: the bodies of the constructors/destructor only typecheck if they are -*outside* the type abstraction, because they fundamentally rely on knowing what the +\*outside* the type abstraction, because they fundamentally rely on knowing what the type actually *is* in order to be able to construct/destruct it. e.g. for a Scott-encoded type we actually need to know that the datatype is encoded as a matching function, not just an abstract type. So we can't just put the definitions of the @@ -156,58 +155,60 @@ But we don't really care about the costs listed there: it's easy for us to get a supply, and the performance cost does not currently seem relevant. So it's fine. -} -inlinePassSC - :: forall uni fun ann m - . (PLC.Typecheckable uni fun, PLC.GEq uni, Ord ann, ExternalConstraints TyName Name uni fun m) - => AstSize - -- ^ inline threshold - -> Bool - -- ^ should we inline constants? - -> TC.PirTCConfig uni fun - -> InlineHints Name ann - -> BuiltinsInfo uni fun - -> Pass m TyName Name uni fun ann +inlinePassSC :: + forall uni fun ann m. + (PLC.Typecheckable uni fun, PLC.GEq uni, Ord ann, ExternalConstraints TyName Name uni fun m) => + -- | inline threshold + AstSize -> + -- | should we inline constants? + Bool -> + TC.PirTCConfig uni fun -> + InlineHints Name ann -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun ann inlinePassSC thresh ic tcconfig hints binfo = - renamePass <> inlinePass thresh ic tcconfig hints binfo - -inlinePass - :: forall uni fun ann m - . (PLC.Typecheckable uni fun, PLC.GEq uni, Ord ann, ExternalConstraints TyName Name uni fun m) - => AstSize - -- ^ inline threshold - -> Bool - -- ^ should we inline constants? - -> TC.PirTCConfig uni fun - -> InlineHints Name ann - -> BuiltinsInfo uni fun - -> Pass m TyName Name uni fun ann + renamePass <> inlinePass thresh ic tcconfig hints binfo + +inlinePass :: + forall uni fun ann m. + (PLC.Typecheckable uni fun, PLC.GEq uni, Ord ann, ExternalConstraints TyName Name uni fun m) => + -- | inline threshold + AstSize -> + -- | should we inline constants? + Bool -> + TC.PirTCConfig uni fun -> + InlineHints Name ann -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun ann inlinePass thresh ic tcconfig hints binfo = NamedPass "inline" $ Pass - (inline thresh ic hints binfo ) + (inline thresh ic hints binfo) [GloballyUniqueNames, Typechecks tcconfig] [ConstCondition GloballyUniqueNames, ConstCondition (Typechecks tcconfig)] -- | Inline non-recursive bindings. Relies on global uniqueness, and preserves it. -- See Note [Inlining and global uniqueness] -inline - :: forall tyname name uni fun ann m - . ExternalConstraints tyname name uni fun m - => AstSize - -- ^ inline threshold - -> Bool - -- ^ should we inline constants? - -> InlineHints name ann - -> BuiltinsInfo uni fun - -> Term tyname name uni fun ann - -> m (Term tyname name uni fun ann) -inline thresh ic hints binfo t = let - inlineInfo :: InlineInfo tyname name uni fun ann - inlineInfo = InlineInfo vinfo usgs hints binfo ic thresh - vinfo = VarInfo.termVarInfo t - usgs :: Usages.Usages - usgs = Usages.termUsages t - in liftQuote $ flip evalStateT mempty $ flip runReaderT inlineInfo $ processTerm t +inline :: + forall tyname name uni fun ann m. + ExternalConstraints tyname name uni fun m => + -- | inline threshold + AstSize -> + -- | should we inline constants? + Bool -> + InlineHints name ann -> + BuiltinsInfo uni fun -> + Term tyname name uni fun ann -> + m (Term tyname name uni fun ann) +inline thresh ic hints binfo t = + let + inlineInfo :: InlineInfo tyname name uni fun ann + inlineInfo = InlineInfo vinfo usgs hints binfo ic thresh + vinfo = VarInfo.termVarInfo t + usgs :: Usages.Usages + usgs = Usages.termUsages t + in + liftQuote $ flip evalStateT mempty $ flip runReaderT inlineInfo $ processTerm t {- Note [Removing inlined bindings] We *do* remove bindings that we inline *unconditionally*. We *could* @@ -236,66 +237,69 @@ much easier when they are just separate terms. -} -- | Run the inliner on a `Core.Type.Term`. -processTerm - :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => Term tyname name uni fun ann -- ^ Term to be processed. - -> InlineM tyname name uni fun ann (Term tyname name uni fun ann) -processTerm = handleTerm <=< traverseOf termSubtypes applyTypeSubstitution where +processTerm :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + -- | Term to be processed. + Term tyname name uni fun ann -> + InlineM tyname name uni fun ann (Term tyname name uni fun ann) +processTerm = handleTerm <=< traverseOf termSubtypes applyTypeSubstitution + where handleTerm :: - Term tyname name uni fun ann - -> InlineM tyname name uni fun ann (Term tyname name uni fun ann) + Term tyname name uni fun ann -> + InlineM tyname name uni fun ann (Term tyname name uni fun ann) handleTerm = \case - v@(Var _ n) -> fromMaybe v <$> substName n - Let ann NonRec bs t -> case bs of - b :| [] -> do - -- Process the binding, eliminating it if it will be inlined unconditionally, - -- and accumulating the new substitutions. - -- See Note [Removing inlined bindings] - -- Note that we don't *remove* the binding or scope the state, so the state will - -- carry over into "sibling" terms. This is fine because we have global uniqueness - -- (see Note [Inlining and global uniqueness]), if somewhat wasteful. - b' <- processSingleBinding t b - t' <- processTerm t - -- Use 'mkLet': which takes a possibly empty list of bindings (rather than - -- a non-empty list) - pure $ mkLet ann NonRec (maybeToList b') t' - -- See Note [Processing multi-lets] - b :| rest -> handleTerm (Let ann NonRec (pure b) (mkLet ann NonRec rest t)) - -- This includes recursive let terms, we don't even consider inlining them at the moment - t -> do - -- See Note [Processing order of call site inlining] - let (hd, args) = splitApplication t - processArgs :: - AppContext tyname name uni fun ann -> - InlineM tyname name uni fun ann (AppContext tyname name uni fun ann) - processArgs (TermAppContext arg ann ctx) = do - processedArg <- processTerm arg - processedArgs <- processArgs ctx - pure $ TermAppContext processedArg ann processedArgs - processArgs (TypeAppContext ty ann ctx) = do - processedArgs <- processArgs ctx - ty' <- applyTypeSubstitution ty - pure $ TypeAppContext ty' ann processedArgs - processArgs AppContextEnd = pure AppContextEnd - case args of - -- not really an application, so hd is the term itself. Processing it will loop. - AppContextEnd -> forMOf termSubterms t processTerm - _ -> do - hd' <- processTerm hd - args' <- processArgs args - let reconstructed = fillAppContext hd' args' - case hd' of - Var _ name -> do - gets (lookupVarInfo name) >>= \case - Just varInfo -> do - maybeInlined <- - callSiteInline - (termAstSize reconstructed) - varInfo - args' - pure $ fromMaybe reconstructed maybeInlined - Nothing -> pure reconstructed - _ -> pure reconstructed + v@(Var _ n) -> fromMaybe v <$> substName n + Let ann NonRec bs t -> case bs of + b :| [] -> do + -- Process the binding, eliminating it if it will be inlined unconditionally, + -- and accumulating the new substitutions. + -- See Note [Removing inlined bindings] + -- Note that we don't *remove* the binding or scope the state, so the state will + -- carry over into "sibling" terms. This is fine because we have global uniqueness + -- (see Note [Inlining and global uniqueness]), if somewhat wasteful. + b' <- processSingleBinding t b + t' <- processTerm t + -- Use 'mkLet': which takes a possibly empty list of bindings (rather than + -- a non-empty list) + pure $ mkLet ann NonRec (maybeToList b') t' + -- See Note [Processing multi-lets] + b :| rest -> handleTerm (Let ann NonRec (pure b) (mkLet ann NonRec rest t)) + -- This includes recursive let terms, we don't even consider inlining them at the moment + t -> do + -- See Note [Processing order of call site inlining] + let (hd, args) = splitApplication t + processArgs :: + AppContext tyname name uni fun ann -> + InlineM tyname name uni fun ann (AppContext tyname name uni fun ann) + processArgs (TermAppContext arg ann ctx) = do + processedArg <- processTerm arg + processedArgs <- processArgs ctx + pure $ TermAppContext processedArg ann processedArgs + processArgs (TypeAppContext ty ann ctx) = do + processedArgs <- processArgs ctx + ty' <- applyTypeSubstitution ty + pure $ TypeAppContext ty' ann processedArgs + processArgs AppContextEnd = pure AppContextEnd + case args of + -- not really an application, so hd is the term itself. Processing it will loop. + AppContextEnd -> forMOf termSubterms t processTerm + _ -> do + hd' <- processTerm hd + args' <- processArgs args + let reconstructed = fillAppContext hd' args' + case hd' of + Var _ name -> do + gets (lookupVarInfo name) >>= \case + Just varInfo -> do + maybeInlined <- + callSiteInline + (termAstSize reconstructed) + varInfo + args' + pure $ fromMaybe reconstructed maybeInlined + Nothing -> pure reconstructed + _ -> pure reconstructed {- Note [Processing order of call site inlining] We have two options on how we process terms for the call site inliner: @@ -377,87 +381,96 @@ term, but with the head (the rhs of the variable) and the arguments already proc -} -- | Run the inliner on a single non-recursive let binding. -processSingleBinding - :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => Term tyname name uni fun ann -- ^ The body of the let binding. - -> Binding tyname name uni fun ann -- ^ The binding. - -> InlineM tyname name uni fun ann (Maybe (Binding tyname name uni fun ann)) +processSingleBinding :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + -- | The body of the let binding. + Term tyname name uni fun ann -> + -- | The binding. + Binding tyname name uni fun ann -> + InlineM tyname name uni fun ann (Maybe (Binding tyname name uni fun ann)) processSingleBinding body = \case - (TermBind _ s v@(VarDecl ann n _) rhs0) -> do - -- we want to do unconditional inline if possible - maybeAddSubst body ann s n rhs0 >>= \case - -- this binding is going to be unconditionally inlined - Nothing -> pure Nothing - Just rhs -> do - -- when we encounter a binding, we add it to - -- the global map `Utils.NonRecInScopeSet`. - -- The `varRhs` added to the map has been unconditionally inlined. - -- When we check the body of the let binding we look in this map for - -- call site inlining. - -- We don't remove the binding because we decide *at the call site* - -- whether we want to inline, and it may be called more than once. - modify' $ - extendVarInfo - n - -- no need to rename here when we enter the rhs into the map. Renaming needs - -- to be done at each call site, because each substituted instance has to - -- have unique names - (MkVarInfo s (Done (dupable rhs))) - pure $ Just $ TermBind ann s v rhs - (TypeBind _ v@(TyVarDecl ann n _) rhs) -> do - maybeRhs' <- maybeAddTySubst n rhs - pure $ TypeBind ann v <$> maybeRhs' - b -> -- Just process all the subterms - Just <$> forMOf bindingSubterms b processTerm + (TermBind _ s v@(VarDecl ann n _) rhs0) -> do + -- we want to do unconditional inline if possible + maybeAddSubst body ann s n rhs0 >>= \case + -- this binding is going to be unconditionally inlined + Nothing -> pure Nothing + Just rhs -> do + -- when we encounter a binding, we add it to + -- the global map `Utils.NonRecInScopeSet`. + -- The `varRhs` added to the map has been unconditionally inlined. + -- When we check the body of the let binding we look in this map for + -- call site inlining. + -- We don't remove the binding because we decide *at the call site* + -- whether we want to inline, and it may be called more than once. + modify' $ + extendVarInfo + n + -- no need to rename here when we enter the rhs into the map. Renaming needs + -- to be done at each call site, because each substituted instance has to + -- have unique names + (MkVarInfo s (Done (dupable rhs))) + pure $ Just $ TermBind ann s v rhs + (TypeBind _ v@(TyVarDecl ann n _) rhs) -> do + maybeRhs' <- maybeAddTySubst n rhs + pure $ TypeBind ann v <$> maybeRhs' + b -> + -- Just process all the subterms + Just <$> forMOf bindingSubterms b processTerm -- | Check against the heuristics we have for inlining and either inline the term binding or not. -- The arguments to this function are the fields of the `TermBinding` being processed. -- Nothing means that we are inlining the term: -- * we have extended the substitution, and -- * we are removing the binding (hence we return Nothing). -maybeAddSubst - :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => Term tyname name uni fun ann - -> ann - -> Strictness - -> name - -> Term tyname name uni fun ann - -> InlineM tyname name uni fun ann (Maybe (Term tyname name uni fun ann)) +maybeAddSubst :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + Term tyname name uni fun ann -> + ann -> + Strictness -> + name -> + Term tyname name uni fun ann -> + InlineM tyname name uni fun ann (Maybe (Term tyname name uni fun ann)) maybeAddSubst body ann s n rhs0 = do - rhs <- processTerm rhs0 - - -- Check whether we've been told specifically to inline this - hints <- view iiHints - case shouldInline hints ann n of - AlwaysInline -> - -- if we've been told specifically, then do it right away - extendAndDrop (Done $ dupable rhs) - hint -> - let safeToInline = hint == SafeToInline - in ifM - (shouldUnconditionallyInline safeToInline s n rhs body) - (extendAndDrop (Done $ dupable rhs)) - (pure $ Just rhs) - where - extendAndDrop :: - forall b . InlineTerm tyname name uni fun ann - -> InlineM tyname name uni fun ann (Maybe b) - extendAndDrop t = modify' (extendTerm n t) >> pure Nothing + rhs <- processTerm rhs0 + + -- Check whether we've been told specifically to inline this + hints <- view iiHints + case shouldInline hints ann n of + AlwaysInline -> + -- if we've been told specifically, then do it right away + extendAndDrop (Done $ dupable rhs) + hint -> + let safeToInline = hint == SafeToInline + in ifM + (shouldUnconditionallyInline safeToInline s n rhs body) + (extendAndDrop (Done $ dupable rhs)) + (pure $ Just rhs) + where + extendAndDrop :: + forall b. + InlineTerm tyname name uni fun ann -> + InlineM tyname name uni fun ann (Maybe b) + extendAndDrop t = modify' (extendTerm n t) >> pure Nothing -- | Check against the inlining heuristics for types and either inline it, returning Nothing, or -- just return the type without inlining. -- We only inline if (1) the type is used at most once OR (2) it's a `trivialType`. -maybeAddTySubst - :: forall tyname name uni fun ann . InliningConstraints tyname name uni fun - => tyname -- ^ The type variable - -> Type tyname uni ann -- ^ The value of the type variable. - -> InlineM tyname name uni fun ann (Maybe (Type tyname uni ann)) +maybeAddTySubst :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + -- | The type variable + tyname -> + -- | The value of the type variable. + Type tyname uni ann -> + InlineM tyname name uni fun ann (Maybe (Type tyname uni ann)) maybeAddTySubst tn rhs = do - usgs <- view iiUsages - -- No need for multiple phases here - let typeUsedAtMostOnce = Usages.getUsageCount tn usgs <= 1 - if typeUsedAtMostOnce || trivialType rhs + usgs <- view iiUsages + -- No need for multiple phases here + let typeUsedAtMostOnce = Usages.getUsageCount tn usgs <= 1 + if typeUsedAtMostOnce || trivialType rhs then do - modify' (extendType tn rhs) - pure Nothing + modify' (extendType tn rhs) + pure Nothing else pure $ Just rhs diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs index 6d75b0bcf10..a0a5657db11 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs @@ -1,22 +1,21 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{- | Types and their functions, and general utility (including heuristics) for inlining. -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types and their functions, and general utility (including heuristics) for inlining. module PlutusIR.Transform.Inline.Utils where import PlutusCore.Annotation +import PlutusCore.AstSize import PlutusCore.Builtin qualified as PLC import PlutusCore.Name.Unique import PlutusCore.Name.UniqueMap (UniqueMap) import PlutusCore.Name.UniqueMap qualified as UMap import PlutusCore.Quote import PlutusCore.Rename -import PlutusCore.AstSize import PlutusCore.Subst (typeSubstTyNamesM) import PlutusIR import PlutusIR.Analysis.Builtins @@ -35,21 +34,21 @@ import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) -- General infra: type ExternalConstraints tyname name uni fun m = - ( HasUnique name TermUnique - , HasUnique tyname TypeUnique - , Eq name - , Eq tyname - , PLC.ToBuiltinMeaning uni fun - , MonadQuote m - ) + ( HasUnique name TermUnique + , HasUnique tyname TypeUnique + , Eq name + , Eq tyname + , PLC.ToBuiltinMeaning uni fun + , MonadQuote m + ) type InliningConstraints tyname name uni fun = - ( HasUnique name TermUnique - , HasUnique tyname TypeUnique - , Eq name - , Eq tyname - , PLC.ToBuiltinMeaning uni fun - ) + ( HasUnique name TermUnique + , HasUnique tyname TypeUnique + , Eq name + , Eq tyname + , PLC.ToBuiltinMeaning uni fun + ) -- | Information used by the inliner that is constant across its operation. -- This includes some contextual and configuration information, and also some @@ -57,74 +56,79 @@ type InliningConstraints tyname name uni fun = -- -- See [Inlining and global uniqueness] for caveats about this information. data InlineInfo tyname name uni fun ann = InlineInfo - { _iiVarInfo :: VarInfo.VarsInfo tyname name uni ann - -- ^ Is it strict? Only needed for PIR, not UPLC - , _iiUsages :: Usages.Usages - -- ^ how many times is it used? - , _iiHints :: InlineHints name ann - -- ^ have we explicitly been told to inline? - , _iiBuiltinsInfo :: BuiltinsInfo uni fun - -- ^ the semantics variant. - , _iiInlineConstants :: Bool - -- ^ should we inline constants? - , _iiInlineCallsiteGrowth :: AstSize - -- ^ inline threshold for callsite inlining - } + { _iiVarInfo :: VarInfo.VarsInfo tyname name uni ann + -- ^ Is it strict? Only needed for PIR, not UPLC + , _iiUsages :: Usages.Usages + -- ^ how many times is it used? + , _iiHints :: InlineHints name ann + -- ^ have we explicitly been told to inline? + , _iiBuiltinsInfo :: BuiltinsInfo uni fun + -- ^ the semantics variant. + , _iiInlineConstants :: Bool + -- ^ should we inline constants? + , _iiInlineCallsiteGrowth :: AstSize + -- ^ inline threshold for callsite inlining + } + makeLenses ''InlineInfo -- Using a concrete monad makes a very large difference to the performance of this module -- (determined from profiling) + -- | The monad the inliner runs in. type InlineM tyname name uni fun ann = - ReaderT - (InlineInfo tyname name uni fun ann) - (StateT (InlinerState tyname name uni fun ann) Quote) + ReaderT + (InlineInfo tyname name uni fun ann) + (StateT (InlinerState tyname name uni fun ann) Quote) + -- For unconditional inlining: -- | Substitution range, 'SubstRng' in the paper but no 'Susp' case. -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] -newtype InlineTerm tyname name uni fun ann = - Done (Dupable (Term tyname name uni fun ann)) --out expressions +newtype InlineTerm tyname name uni fun ann + = Done (Dupable (Term tyname name uni fun ann)) -- out expressions -- | Term substitution, 'Subst' in the paper. -- A map of unprocessed variable and its substitution range. -newtype TermSubst tyname name uni fun ann = - TermSubst { _unTermSubst :: UniqueMap TermUnique (InlineTerm tyname name uni fun ann) } - deriving newtype (Semigroup, Monoid) +newtype TermSubst tyname name uni fun ann + = TermSubst {_unTermSubst :: UniqueMap TermUnique (InlineTerm tyname name uni fun ann)} + deriving newtype (Semigroup, Monoid) -- | Type substitution, similar to `TermSubst` but for types. -- A map of unprocessed type variable and its substitution range. -newtype TypeSubst tyname uni ann = - TypeSubst { _unTypeSubst :: UniqueMap TypeUnique (Dupable (Type tyname uni ann)) } - deriving newtype (Semigroup, Monoid) +newtype TypeSubst tyname uni ann + = TypeSubst {_unTypeSubst :: UniqueMap TypeUnique (Dupable (Type tyname uni ann))} + deriving newtype (Semigroup, Monoid) -- For call site inlining: -- | A mapping including all non-recursive in scope variables. -newtype NonRecInScopeSet tyname name uni fun ann = - NonRecInScopeSet - { _unNonRecInScopeSet :: UniqueMap TermUnique (InlineVarInfo tyname name uni fun ann)} - deriving newtype (Semigroup, Monoid) +newtype NonRecInScopeSet tyname name uni fun ann + = NonRecInScopeSet + {_unNonRecInScopeSet :: UniqueMap TermUnique (InlineVarInfo tyname name uni fun ann)} + deriving newtype (Semigroup, Monoid) -- | Info attached to a let-binding needed for call site inlining. data InlineVarInfo tyname name uni fun ann = MkVarInfo - { varStrictness :: Strictness - , varRhs :: InlineTerm tyname name uni fun ann - -- ^ its definition, which has been processed, as an `InlineTerm`. To preserve - -- global uniqueness, we rename before substituting in. - } + { varStrictness :: Strictness + , varRhs :: InlineTerm tyname name uni fun ann + -- ^ its definition, which has been processed, as an `InlineTerm`. To preserve + -- global uniqueness, we rename before substituting in. + } -- | Inliner context for both unconditional inlining and call site inlining. -- It includes substitution for both terms and types, which is similar to 'Subst' in the paper. -- It also includes the non recursive in-scope set for call site inlining. -data InlinerState tyname name uni fun ann = - InlinerState { _termSubst :: TermSubst tyname name uni fun ann - , _typeSubst :: TypeSubst tyname uni ann - , _nonRecInScopeSet :: NonRecInScopeSet tyname name uni fun ann - } - deriving stock (Generic) - deriving (Semigroup, Monoid) via - (GenericSemigroupMonoid (InlinerState tyname name uni fun ann)) +data InlinerState tyname name uni fun ann + = InlinerState + { _termSubst :: TermSubst tyname name uni fun ann + , _typeSubst :: TypeSubst tyname uni ann + , _nonRecInScopeSet :: NonRecInScopeSet tyname name uni fun ann + } + deriving stock (Generic) + deriving + (Semigroup, Monoid) + via (GenericSemigroupMonoid (InlinerState tyname name uni fun ann)) makeLenses ''TermSubst makeLenses ''TypeSubst @@ -134,28 +138,31 @@ makeLenses ''InlinerState -- Helper functions: -- | Look up the unprocessed variable in the term substitution. -lookupTerm - :: (HasUnique name TermUnique) - => name -- ^ The name of the variable. - -> InlinerState tyname name uni fun ann - -> Maybe (InlineTerm tyname name uni fun ann) +lookupTerm :: + HasUnique name TermUnique => + -- | The name of the variable. + name -> + InlinerState tyname name uni fun ann -> + Maybe (InlineTerm tyname name uni fun ann) lookupTerm n s = UMap.lookupName n $ s ^. termSubst . unTermSubst -- | Insert the unprocessed variable into the term substitution. -extendTerm - :: (HasUnique name TermUnique) - => name -- ^ The name of the variable. - -> InlineTerm tyname name uni fun ann -- ^ The substitution range. - -> InlinerState tyname name uni fun ann - -> InlinerState tyname name uni fun ann +extendTerm :: + HasUnique name TermUnique => + -- | The name of the variable. + name -> + -- | The substitution range. + InlineTerm tyname name uni fun ann -> + InlinerState tyname name uni fun ann -> + InlinerState tyname name uni fun ann extendTerm n clos s = s & termSubst . unTermSubst %~ UMap.insertByName n clos -- | Look up the unprocessed type variable in the type substitution. -lookupType - :: (HasUnique tyname TypeUnique) - => tyname - -> InlinerState tyname name uni fun ann - -> Maybe (Dupable (Type tyname uni ann)) +lookupType :: + HasUnique tyname TypeUnique => + tyname -> + InlinerState tyname name uni fun ann -> + Maybe (Dupable (Type tyname uni ann)) lookupType tn s = UMap.lookupName tn $ s ^. typeSubst . unTypeSubst -- | Check if the type substitution is empty. @@ -163,58 +170,71 @@ isTypeSubstEmpty :: InlinerState tyname name uni fun ann -> Bool isTypeSubstEmpty (InlinerState _ (TypeSubst tyEnv) _) = null tyEnv -- | Insert the unprocessed type variable into the type substitution. -extendType - :: (HasUnique tyname TypeUnique) - => tyname -- ^ The name of the type variable. - -> Type tyname uni ann -- ^ Its type. - -> InlinerState tyname name uni fun ann - -> InlinerState tyname name uni fun ann -extendType tn ty s = s & typeSubst . unTypeSubst %~ UMap.insertByName tn (dupable ty) +extendType :: + HasUnique tyname TypeUnique => + -- | The name of the type variable. + tyname -> + -- | Its type. + Type tyname uni ann -> + InlinerState tyname name uni fun ann -> + InlinerState tyname name uni fun ann +extendType tn ty s = s & typeSubst . unTypeSubst %~ UMap.insertByName tn (dupable ty) -- | Look up a variable in the in scope set. -lookupVarInfo - :: (HasUnique name TermUnique) - => name -- ^ The name of the variable. - -> InlinerState tyname name uni fun ann - -> Maybe (InlineVarInfo tyname name uni fun ann) +lookupVarInfo :: + HasUnique name TermUnique => + -- | The name of the variable. + name -> + InlinerState tyname name uni fun ann -> + Maybe (InlineVarInfo tyname name uni fun ann) lookupVarInfo n s = UMap.lookupName n $ s ^. nonRecInScopeSet . unNonRecInScopeSet -- | Insert a variable into the substitution. -extendVarInfo - :: (HasUnique name TermUnique) - => name -- ^ The name of the variable. - -> InlineVarInfo tyname name uni fun ann -- ^ The variable's info. - -> InlinerState tyname name uni fun ann - -> InlinerState tyname name uni fun ann +extendVarInfo :: + HasUnique name TermUnique => + -- | The name of the variable. + name -> + -- | The variable's info. + InlineVarInfo tyname name uni fun ann -> + InlinerState tyname name uni fun ann -> + InlinerState tyname name uni fun ann extendVarInfo n info s = s & nonRecInScopeSet . unNonRecInScopeSet %~ UMap.insertByName n info - -applyTypeSubstitution :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => Type tyname uni ann - -> InlineM tyname name uni fun ann (Type tyname uni ann) -applyTypeSubstitution t = gets isTypeSubstEmpty >>= \case +applyTypeSubstitution :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + Type tyname uni ann -> + InlineM tyname name uni fun ann (Type tyname uni ann) +applyTypeSubstitution t = + gets isTypeSubstEmpty >>= \case -- The type substitution is very often empty, and there are lots of types in the program, -- so this saves a lot of work (determined from profiling) True -> pure t - _ -> typeSubstTyNamesM substTyName t + _ -> typeSubstTyNamesM substTyName t -- See Note [Inlining and global uniqueness] -substTyName :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => tyname - -> InlineM tyname name uni fun ann (Maybe (Type tyname uni ann)) +substTyName :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + tyname -> + InlineM tyname name uni fun ann (Maybe (Type tyname uni ann)) substTyName tyname = gets (lookupType tyname) >>= traverse liftDupable -- See Note [Inlining and global uniqueness] -substName :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => name - -> InlineM tyname name uni fun ann (Maybe (Term tyname name uni fun ann)) +substName :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + name -> + InlineM tyname name uni fun ann (Maybe (Term tyname name uni fun ann)) substName name = gets (lookupTerm name) >>= traverse renameTerm -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] -- Already processed term, just rename and put it in, don't do any further optimization here. -renameTerm :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => InlineTerm tyname name uni fun ann - -> InlineM tyname name uni fun ann (Term tyname name uni fun ann) +renameTerm :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + InlineTerm tyname name uni fun ann -> + InlineM tyname name uni fun ann (Term tyname name uni fun ann) renameTerm (Done t) = liftDupable t {- Note [Renaming strategy] @@ -229,46 +249,49 @@ We rename both terms and types as both may have binders in them. -- Heuristics: -- | Check if term is pure. See Note [Inlining and purity] -checkPurity - :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => Term tyname name uni fun ann -> InlineM tyname name uni fun ann Bool +checkPurity :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + Term tyname name uni fun ann -> InlineM tyname name uni fun ann Bool checkPurity t = do - varInfo <- view iiVarInfo - binfo <- view iiBuiltinsInfo - pure $ isPure binfo varInfo t - -isFirstVarBeforeEffects - :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => name -> Term tyname name uni fun ann -> InlineM tyname name uni fun ann Bool + varInfo <- view iiVarInfo + binfo <- view iiBuiltinsInfo + pure $ isPure binfo varInfo t + +isFirstVarBeforeEffects :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + name -> Term tyname name uni fun ann -> InlineM tyname name uni fun ann Bool isFirstVarBeforeEffects n t = do - varInfo <- view iiVarInfo - binfo <- view iiBuiltinsInfo - -- This can in the worst case traverse a lot of the term, which could lead to us - -- doing ~quadratic work as we process the program. However in practice most terms - -- have a relatively short evaluation order before we hit Unknown, so it's not too bad. - pure $ go (unEvalOrder (termEvaluationOrder binfo varInfo t)) - where - -- Found the variable we're looking for! - go ((EvalTerm _ _ (Var _ n')):_) | n == n' = True - -- Found a pure term, ignore it and continue - go ((EvalTerm Pure _ _):rest) = go rest - -- Found a possibly impure term, our variable is definitely not first - go ((EvalTerm MaybeImpure _ _):_) = False - -- Don't know, be conservative - go (Unknown:_) = False - go [] = False - + varInfo <- view iiVarInfo + binfo <- view iiBuiltinsInfo + -- This can in the worst case traverse a lot of the term, which could lead to us + -- doing ~quadratic work as we process the program. However in practice most terms + -- have a relatively short evaluation order before we hit Unknown, so it's not too bad. + pure $ go (unEvalOrder (termEvaluationOrder binfo varInfo t)) + where + -- Found the variable we're looking for! + go ((EvalTerm _ _ (Var _ n')) : _) | n == n' = True + -- Found a pure term, ignore it and continue + go ((EvalTerm Pure _ _) : rest) = go rest + -- Found a possibly impure term, our variable is definitely not first + go ((EvalTerm MaybeImpure _ _) : _) = False + -- Don't know, be conservative + go (Unknown : _) = False + go [] = False -- | Checks if a binding is pure, i.e. will evaluating it have effects -isTermBindingPure :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => Strictness - -> Term tyname name uni fun ann - -> InlineM tyname name uni fun ann Bool +isTermBindingPure :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + Strictness -> + Term tyname name uni fun ann -> + InlineM tyname name uni fun ann Bool isTermBindingPure s tm = - case s of - -- For non-strict bindings, the effects would have occurred at the call sites anyway. - NonStrict -> pure True - Strict -> checkPurity tm + case s of + -- For non-strict bindings, the effects would have occurred at the call sites anyway. + NonStrict -> pure True + Strict -> checkPurity tm {- Note [Inlining and purity] When can we inline something that might have effects? We must remember that we often also @@ -286,27 +309,32 @@ unconditionally. If we are not in conservative optimization mode and we're allowed to move/duplicate effects, then we could relax these criteria (e.g. say that the binding must be evaluted -*somewhere*, but not necessarily before any other effects). +\*somewhere*, but not necessarily before any other effects). One instance of this is when logging preservation is disabled then we inline variables that are dertermined to get eventually evaluated anyway: such that have at least one occurrence outside of a 'delay', lambda or a case branch. -} -nameUsedAtMostOnce :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => name - -> InlineM tyname name uni fun ann Bool +nameUsedAtMostOnce :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + name -> + InlineM tyname name uni fun ann Bool nameUsedAtMostOnce n = do - usgs <- view iiUsages - -- 'inlining' terms used 0 times is a cheap way to remove dead code while we're here - pure $ Usages.getUsageCount n usgs <= 1 - -effectSafe :: forall tyname name uni fun ann. InliningConstraints tyname name uni fun - => Term tyname name uni fun ann - -> Strictness - -> name - -> Bool -- ^ is it pure? - -> InlineM tyname name uni fun ann Bool + usgs <- view iiUsages + -- 'inlining' terms used 0 times is a cheap way to remove dead code while we're here + pure $ Usages.getUsageCount n usgs <= 1 + +effectSafe :: + forall tyname name uni fun ann. + InliningConstraints tyname name uni fun => + Term tyname name uni fun ann -> + Strictness -> + name -> + -- | is it pure? + Bool -> + InlineM tyname name uni fun ann Bool effectSafe body Strict n purity = do -- See Note [Inlining and purity] immediatelyEvaluated <- isFirstVarBeforeEffects n body @@ -338,74 +366,71 @@ Hence we inline constants by default, but refrain from doing so if we are trying -} -- See Note [Inlining criteria] + -- | Is the cost increase (in terms of evaluation work) of inlining a variable whose RHS is -- the given term acceptable? costIsAcceptable :: Term tyname name uni fun ann -> Bool costIsAcceptable = \case - Builtin{} -> True - Var{} -> True - Constant{} -> True - Error{} -> True + Builtin {} -> True + Var {} -> True + Constant {} -> True + Error {} -> True -- This will mean that we create closures at each use site instead of -- once, but that's a very low cost which we're okay rounding to 0. - LamAbs{} -> True - TyAbs{} -> True - + LamAbs {} -> True + TyAbs {} -> True -- Inlining constructors of size 1 or 0 seems okay, but does result in doing -- the work for the elements at each use site. - Constr _ _ _ es -> case es of - [] -> True - [e] -> costIsAcceptable e - _ -> False + Constr _ _ _ es -> case es of + [] -> True + [e] -> costIsAcceptable e + _ -> False -- Inlining a case means redoing the match at each use site - Case{} -> False - + Case {} -> False -- Arguably we could allow these two, but they're uncommon anyway - IWrap{} -> False - Unwrap{} -> False - - Apply{} -> False - TyInst{} -> False - Let{} -> False + IWrap {} -> False + Unwrap {} -> False + Apply {} -> False + TyInst {} -> False + Let {} -> False -- See Note [Inlining criteria] + -- | Is the size increase (in the AST) of inlining a variable whose RHS is -- the given term acceptable? sizeIsAcceptable :: Bool -> Term tyname name uni fun ann -> Bool sizeIsAcceptable inlineConstants = \case - Builtin{} -> True - Var{} -> True - Error{} -> True - LamAbs {} -> False - TyAbs {} -> False - + Builtin {} -> True + Var {} -> True + Error {} -> True + LamAbs {} -> False + TyAbs {} -> False -- Inlining constructors of size 1 or 0 seems okay - Constr _ _ _ es -> case es of - [] -> True - [e] -> sizeIsAcceptable inlineConstants e - _ -> False + Constr _ _ _ es -> case es of + [] -> True + [e] -> sizeIsAcceptable inlineConstants e + _ -> False -- Cases are pretty big, due to the case branches - Case{} -> False - + Case {} -> False -- Arguably we could allow these two, but they're uncommon anyway - IWrap{} -> False - Unwrap{} -> False + IWrap {} -> False + Unwrap {} -> False -- Inlining constants is deemed acceptable if the 'inlineConstants' -- flag is turned on, see Note [Inlining constants]. - Constant{} -> inlineConstants - Apply{} -> False - TyInst{} -> False - Let{} -> False + Constant {} -> inlineConstants + Apply {} -> False + TyInst {} -> False + Let {} -> False -- | Is this an utterly trivial type which might as well be inlined? trivialType :: Type tyname uni ann -> Bool trivialType = \case - TyBuiltin{} -> True - TyVar{} -> True - _ -> False + TyBuiltin {} -> True + TyVar {} -> True + _ -> False shouldUnconditionallyInline :: - (InliningConstraints tyname name uni fun) => + InliningConstraints tyname name uni fun => -- | Whether we know that the binding is safe to inline. If so, bypass the purity check. Bool -> Strictness -> diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/KnownCon.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/KnownCon.hs index e966d89ff58..23e84da6f86 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/KnownCon.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/KnownCon.hs @@ -15,20 +15,25 @@ import PlutusIR.Pass import PlutusIR.TypeCheck qualified as TC knownConPassSC :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , PLC.MonadQuote m - ) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , PLC.MonadQuote m + ) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a knownConPassSC tcconfig = renamePass <> knownConPass tcconfig knownConPass :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , Applicative m) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , Applicative m + ) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a knownConPass tcconfig = NamedPass "case of known constructor" $ Pass @@ -36,68 +41,68 @@ knownConPass tcconfig = [Typechecks tcconfig, GloballyUniqueNames] [ConstCondition (Typechecks tcconfig)] -{- | Simplify destructor applications, if the scrutinee is a constructor application. - -As an example, given - -@ - Maybe_match - {x_type} - (Just {x_type} x) - {result_type} - (\a -> ) - () - additional_args -@ - -`knownCon` turns it into - -@ - (\a -> ) x additional_args -@ --} +-- | Simplify destructor applications, if the scrutinee is a constructor application. +-- +-- As an example, given +-- +-- @ +-- Maybe_match +-- {x_type} +-- (Just {x_type} x) +-- {result_type} +-- (\a -> ) +-- () +-- additional_args +-- @ +-- +-- `knownCon` turns it into +-- +-- @ +-- (\a -> ) x additional_args +-- @ knownCon :: - forall tyname name uni fun a. - ( PLC.HasUnique name PLC.TermUnique - , PLC.HasUnique tyname PLC.TypeUnique - , Eq name - ) => - Term tyname name uni fun a -> - Term tyname name uni fun a + forall tyname name uni fun a. + ( PLC.HasUnique name PLC.TermUnique + , PLC.HasUnique tyname PLC.TypeUnique + , Eq name + ) => + Term tyname name uni fun a -> + Term tyname name uni fun a knownCon t = - let vinfo = termVarInfo t - in transformOf termSubterms (processTerm vinfo) t + let vinfo = termVarInfo t + in transformOf termSubterms (processTerm vinfo) t processTerm :: - forall tyname name uni fun a . - (Eq name - , PLC.HasUnique name PLC.TermUnique - , PLC.HasUnique tyname PLC.TypeUnique) => - VarsInfo tyname name uni a -> - Term tyname name uni fun a -> - Term tyname name uni fun a + forall tyname name uni fun a. + ( Eq name + , PLC.HasUnique name PLC.TermUnique + , PLC.HasUnique tyname PLC.TypeUnique + ) => + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + Term tyname name uni fun a processTerm vinfo t - | (Var _ n, args) <- splitApplication t - , Just (DatatypeMatcher parentName) <- lookupVarInfo n vinfo - , Just (DatatypeTyVar (Datatype _ _ tvs _ constructors) ) <- lookupTyVarInfo parentName vinfo - , (TermAppContext scrut _ (TypeAppContext _resTy _ branchArgs)) <- - -- The datatype may have some type arguments, we - -- aren't interested in them, so we drop them. - dropAppContext (length tvs) args - , -- The scrutinee is itself an application - (Var _ con, conArgs) <- splitApplication scrut - , -- ... of one of the constructors from the same datatype as the destructor - Just i <- List.findIndex (== con) (fmap _varDeclName constructors) - , -- ... and there is a branch for that constructor in the destructor application - (TermAppContext branch _ _) <- dropAppContext i branchArgs - , -- This condition ensures the destructor is fully-applied - -- (which should always be the case in programs that come from Plutus Tx, - -- but not necessarily in arbitrary PIR programs). - lengthContext branchArgs == length constructors = - fillAppContext - branch - -- The arguments to the selected branch consists of the arguments - -- to the constructor, without the leading type arguments - e.g., - -- if the scrutinee is `Just {integer} 1`, we only need the `1`). - (dropAppContext (length tvs) conArgs) - | otherwise = t + | (Var _ n, args) <- splitApplication t + , Just (DatatypeMatcher parentName) <- lookupVarInfo n vinfo + , Just (DatatypeTyVar (Datatype _ _ tvs _ constructors)) <- lookupTyVarInfo parentName vinfo + , (TermAppContext scrut _ (TypeAppContext _resTy _ branchArgs)) <- + -- The datatype may have some type arguments, we + -- aren't interested in them, so we drop them. + dropAppContext (length tvs) args + , -- The scrutinee is itself an application + (Var _ con, conArgs) <- splitApplication scrut + , -- ... of one of the constructors from the same datatype as the destructor + Just i <- List.findIndex (== con) (fmap _varDeclName constructors) + , -- ... and there is a branch for that constructor in the destructor application + (TermAppContext branch _ _) <- dropAppContext i branchArgs + , -- This condition ensures the destructor is fully-applied + -- (which should always be the case in programs that come from Plutus Tx, + -- but not necessarily in arbitrary PIR programs). + lengthContext branchArgs == length constructors = + fillAppContext + branch + -- The arguments to the selected branch consists of the arguments + -- to the constructor, without the leading type arguments - e.g., + -- if the scrutinee is `Just {integer} 1`, we only need the `1`). + (dropAppContext (length tvs) conArgs) + | otherwise = t diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatIn.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatIn.hs index 6c46a4ee323..3b627da5123 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatIn.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatIn.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- | Float bindings inwards. module PlutusIR.Transform.LetFloatIn (floatTerm, floatTermPass, floatTermPassSC) where @@ -174,35 +174,39 @@ data FloatInContext = FloatInContext { _ctxtInManyOccRhs :: Bool -- ^ Whether we are in the RHS of a binding whose LHS is used more than once. -- See Note [Float-in] #5 - , _ctxtUsages :: Usages.Usages - , _ctxtRelaxed :: Bool + , _ctxtUsages :: Usages.Usages + , _ctxtRelaxed :: Bool -- ^ Whether to float-in more aggressively. See Note [Float-in] #6 } makeLenses ''FloatInContext floatTermPassSC :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , PLC.MonadQuote m - ) => - TC.PirTCConfig uni fun -> - BuiltinsInfo uni fun -> - Bool -> - Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , PLC.MonadQuote m + ) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Bool -> + Pass m TyName Name uni fun a floatTermPassSC tcconfig binfo relaxed = - renamePass <> floatTermPass tcconfig binfo relaxed + renamePass <> floatTermPass tcconfig binfo relaxed floatTermPass :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , Applicative m - ) => - TC.PirTCConfig uni fun -> - BuiltinsInfo uni fun -> - -- | Whether to float-in more aggressively. See Note [Float-in] #6 - Bool -> - Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , Applicative m + ) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + -- | Whether to float-in more aggressively. See Note [Float-in] #6 + Bool -> + Pass m TyName Name uni fun a floatTermPass tcconfig binfo relaxed = NamedPass "let float-in" $ Pass @@ -301,8 +305,8 @@ floatTerm binfo relaxed t0 = us = typeUniqs ty <> termUniqs arg <> foldMap termUniqs cs in Case (a, us) ty arg cs - Constant{} -> noUniq t - Builtin{} -> noUniq t + Constant {} -> noUniq t + Builtin {} -> noUniq t -- Float bindings in the given `Binding` inwards, and calculate the set of -- `Unique`s of used variables in the result `Binding`. @@ -382,31 +386,30 @@ bindingUniqs = snd . bindingAnn varDeclUniqs :: VarDecl tyname name uni (a, Uniques) -> Uniques varDeclUniqs = snd . view PLC.varDeclAnn -noUniq :: (Functor f) => f a -> f (a, Uniques) +noUniq :: Functor f => f a -> f (a, Uniques) noUniq = fmap (,mempty) -- See Note [Float-in] #1 -floatable - :: (PLC.ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Binding tyname name uni fun a - -> Bool +floatable :: + (PLC.ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Binding tyname name uni fun a -> + Bool floatable binfo vinfo = \case -- See Note [Float-in] #1 - TermBind _a Strict _var rhs -> isWorkFree binfo vinfo rhs + TermBind _a Strict _var rhs -> isWorkFree binfo vinfo rhs TermBind _a NonStrict _var _rhs -> True -- See Note [Float-in] #2 - TypeBind{} -> True + TypeBind {} -> True -- See Note [Float-in] #2 - DatatypeBind{} -> True + DatatypeBind {} -> True -{- | Given a `Term` and a `Binding`, determine whether the `Binding` can be - placed somewhere inside the `Term`. - - If yes, return the result `Term`. Otherwise, return a `Let` constructed from - the given `Binding` and `Term`. --} +-- | Given a `Term` and a `Binding`, determine whether the `Binding` can be +-- placed somewhere inside the `Term`. +-- +-- If yes, return the result `Term`. Otherwise, return a `Let` constructed from +-- the given `Binding` and `Term`. floatInBinding :: forall tyname name uni fun a. ( PLC.HasUnique name PLC.TermUnique @@ -441,7 +444,7 @@ floatInBinding binfo vinfo letAnn = \b -> let inManyOccRhs = case fun of LamAbs _ name _ _ -> Usages.getUsageCount name usgs > 1 - Builtin{} -> False + Builtin {} -> False -- We need to be conservative here, this could be something -- that computes to a function that uses its argument repeatedly. _ -> True @@ -544,13 +547,12 @@ floatInBinding binfo vinfo letAnn = \b -> declaredUniqs = Set.fromList $ b ^.. bindingIds usBind = bindingUniqs b -{- | -Search the given list of elements for the unique one whose 'Uniques' are non-disjoint -with the given 'Uniques'. Then, split the list at that point. --} +-- | +-- Search the given list of elements for the unique one whose 'Uniques' are non-disjoint +-- with the given 'Uniques'. Then, split the list at that point. findNonDisjoint :: Uniques -> [t] -> (t -> Uniques) -> Maybe ([t], t, [t]) findNonDisjoint us bs getUniques = case is of [(t, i)] -> Just (take i bs, t, drop (i + 1) bs) - _ -> Nothing + _ -> Nothing where is = List.filter (\(t, _) -> not $ getUniques t `Set.disjoint` us) (bs `zip` [0 ..]) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs index 74f42fff6bc..3bee3f25eab 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs @@ -1,11 +1,12 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + module PlutusIR.Transform.LetFloatOut (floatTerm, floatTermPass, floatTermPassSC) where import PlutusCore qualified as PLC @@ -92,34 +93,36 @@ both on entering any of its rhs'es *and* inside its inTerm. -} newtype Depth = Depth Int - deriving newtype (Eq, Ord, Show, Num) - -{-| Position of an anchor (lam,Lam,unfloatable-let or Top). -The original paper's algorithm relies just on using the depth as the anchor's position; -for us this is no enough, because we act mark/remove/float globally and the depth is not globally-unique. -To fix this, we use an extra "representative" identifier (PLC.Unique) of the anchor. -Since (unfloatable) lets can also be anchors, we also use an extra 'PosType' to differentiate -between two cases of a let-anchor, see 'PosType'. --} + deriving newtype (Eq, Ord, Show, Num) + +-- | Position of an anchor (lam,Lam,unfloatable-let or Top). +-- The original paper's algorithm relies just on using the depth as the anchor's position; +-- for us this is no enough, because we act mark/remove/float globally and the depth is not globally-unique. +-- To fix this, we use an extra "representative" identifier (PLC.Unique) of the anchor. +-- Since (unfloatable) lets can also be anchors, we also use an extra 'PosType' to differentiate +-- between two cases of a let-anchor, see 'PosType'. data Pos = Pos - { _posDepth :: Depth - , _posUnique :: PLC.Unique -- ^ The lam name or Lam tyname or Let's representative unique - , _posType :: PosType - } - deriving stock (Eq, Ord, Show) - -{-| The type of the anchor's position. We only need this because -we need to differentiate between two cases of a 'let-anchor' position: - -A floatable let-binding can (maximally) depend on an (unfloatable, effectful) let anchor, -which means that it will either float in two different places, depending upon the floatable let's original location: - -a) floated *next to* the let-anchor it depends upon (inside its let-group), if it originated from the rhs of the let-anchor -b) floated directly under the `in` of the let-anchor it depends upon, if it originated from the inTerm of the let-anchor. --} -data PosType = LamBody -- ^ lam, Lam, let body, or Top - | LetRhs -- ^ let rhs - deriving stock (Eq, Ord, Show) + { _posDepth :: Depth + , _posUnique :: PLC.Unique + -- ^ The lam name or Lam tyname or Let's representative unique + , _posType :: PosType + } + deriving stock (Eq, Ord, Show) + +-- | The type of the anchor's position. We only need this because +-- we need to differentiate between two cases of a 'let-anchor' position: +-- +-- A floatable let-binding can (maximally) depend on an (unfloatable, effectful) let anchor, +-- which means that it will either float in two different places, depending upon the floatable let's original location: +-- +-- a) floated *next to* the let-anchor it depends upon (inside its let-group), if it originated from the rhs of the let-anchor +-- b) floated directly under the `in` of the let-anchor it depends upon, if it originated from the inTerm of the let-anchor. +data PosType + = -- | lam, Lam, let body, or Top + LamBody + | -- | let rhs + LetRhs + deriving stock (Eq, Ord, Show) topPos :: Pos topPos = Pos topDepth topUnique topType @@ -138,12 +141,12 @@ topType :: PosType topType = LamBody -- | Arbitrary: return a single unique among all the introduced uniques of the given letgroup. -representativeBindingUnique - :: (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) - => NE.NonEmpty (Binding tyname name uni fun a) -> PLC.Unique +representativeBindingUnique :: + (PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => + NE.NonEmpty (Binding tyname name uni fun a) -> PLC.Unique representativeBindingUnique = - -- Arbitrary: select the first unique from the representative binding - first1Of bindingIds . representativeBinding + -- Arbitrary: select the first unique from the representative binding + first1Of bindingIds . representativeBinding where -- Arbitrary: a binding to be used as representative binding in MARKING the group of bindings. representativeBinding :: NE.NonEmpty (Binding tyname name uni fun a) -> Binding tyname name uni fun a @@ -155,149 +158,158 @@ type Scope = PLC.UniqueMap PLC.Unique Pos -- | The first pass has a reader context of current depth, and (term&type)variables in scope. data MarkCtx tyname name uni fun a = MarkCtx - { _markCtxDepth :: Depth - , _markCtxScope :: Scope - , _markBuiltinsInfo :: BuiltinsInfo uni fun - , _markVarsInfo :: VarsInfo tyname name uni a - } + { _markCtxDepth :: Depth + , _markCtxScope :: Scope + , _markBuiltinsInfo :: BuiltinsInfo uni fun + , _markVarsInfo :: VarsInfo tyname name uni a + } + makeLenses ''MarkCtx -- | The result of the first pass is a subset(union of all computed scopes). -- This subset contains only the marks of the floatable lets. type Marks = Scope -{-| -A 'BindingGrp' is a group of bindings and a *minimum* recursivity for the group. -We use this intermediate structure when tracking groups of bindings to be floated or re-inserted. +-- | +-- A 'BindingGrp' is a group of bindings and a *minimum* recursivity for the group. +-- We use this intermediate structure when tracking groups of bindings to be floated or re-inserted. +-- +-- It's convenient when doing this work to be able to combine binding groups (with the 'Semigroup') instance. +-- However, appending 'BindingGrp's does not account for the possibility that binding groups may *share* +-- variables. This means that the combination of multiple non-recursive binding groups may be recursive. +-- As such, if you have reason to believe that the variables used by the combined binding groups may not be disjoint, +-- you should manually require the term to be recursive when you convert back to a let term with 'bindingGrpToLet'. +data BindingGrp tyname name uni fun a = BindingGrp + { _bgAnn :: a + , _bgRec :: Recursivity + , _bgBindings :: NE.NonEmpty (Binding tyname name uni fun a) + } + deriving stock (Generic) + deriving (Semigroup) via (GenericSemigroupMonoid (BindingGrp tyname name uni fun a)) -It's convenient when doing this work to be able to combine binding groups (with the 'Semigroup') instance. -However, appending 'BindingGrp's does not account for the possibility that binding groups may *share* -variables. This means that the combination of multiple non-recursive binding groups may be recursive. -As such, if you have reason to believe that the variables used by the combined binding groups may not be disjoint, -you should manually require the term to be recursive when you convert back to a let term with 'bindingGrpToLet'. --} -data BindingGrp tyname name uni fun a = BindingGrp { - _bgAnn :: a, - _bgRec :: Recursivity, - _bgBindings :: NE.NonEmpty (Binding tyname name uni fun a) - } - deriving stock Generic - deriving Semigroup via (GenericSemigroupMonoid (BindingGrp tyname name uni fun a)) -- Note on Semigroup: appending bindingGroups will not try to fix the well-scopedness by -- rearranging any bindings or promoting to a Rec if bindings in case some bindinings refer to each other. makeLenses ''BindingGrp -- | Turn a 'BindingGrp' into a let, when given a minimum recursivity and let body. -bindingGrpToLet :: Recursivity - -> BindingGrp tyname name uni fun a - -> (Term tyname name uni fun a -> Term tyname name uni fun a) -bindingGrpToLet r (BindingGrp a r' bs) = Let a (r<>r') bs +bindingGrpToLet :: + Recursivity -> + BindingGrp tyname name uni fun a -> + (Term tyname name uni fun a -> Term tyname name uni fun a) +bindingGrpToLet r (BindingGrp a r' bs) = Let a (r <> r') bs -- | A store of lets to be floated at their new position type FloatTable tyname name uni fun a = MM.MonoidalMap Pos (NE.NonEmpty (BindingGrp tyname name uni fun a)) -- | The 1st pass of marking floatable lets -mark :: forall tyname name uni fun a. - (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique, PLC.ToBuiltinMeaning uni fun) - => BuiltinsInfo uni fun - -> Term tyname name uni fun a - -> Marks +mark :: + forall tyname name uni fun a. + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique, PLC.ToBuiltinMeaning uni fun) => + BuiltinsInfo uni fun -> + Term tyname name uni fun a -> + Marks mark binfo tm = snd $ runWriter $ flip runReaderT (MarkCtx topDepth mempty binfo (termVarInfo tm)) $ go tm where go :: Term tyname name uni fun a -> ReaderT (MarkCtx tyname name uni fun a) (Writer Marks) () - go = breakNonRec >>> \case + go = + breakNonRec >>> \case -- lam/Lam are treated the same. - LamAbs _ n _ tBody -> withLam n $ go tBody - TyAbs _ n _ tBody -> withAbs n $ go tBody - + LamAbs _ n _ tBody -> withLam n $ go tBody + TyAbs _ n _ tBody -> withAbs n $ go tBody -- main operation: for letrec or single letnonrec Let ann r bs@(representativeBindingUnique -> letU) tIn -> - let letN = BindingGrp ann r bs in - ifM (floatable letN) - -- then - (do - scope <- view markCtxScope - let freeVars = - -- if Rec, remove the here-bindings from free - ifRec r (USet.\\ USet.setOfByUnique (traversed.bindingIds) bs) $ - calcFreeVars letN - - -- The "heart" of the algorithm: the future position to float this let to - -- is determined as the maximum among its dependencies (free vars). - let floatPos@(Pos floatDepth _ _) = maxPos $ scope `UMap.restrictKeys` freeVars - - -- visit the rhs'es - -- IMPORTANT: inside the rhs, act like the current depth - -- is the future floated depth of this rhs. - withDepth (const floatDepth) $ - -- if rec, then its bindings are in scope in the rhs'es - ifRec r (withBs bs floatPos) $ - traverseOf_ (traversed . bindingSubterms) go bs - - -- visit the inTerm - -- bindings are inscope in the InTerm for both rec&nonrec - withBs bs floatPos $ go tIn - - -- collect here the new mark and propagate all - tell $ UMap.fromUniques [(letU, floatPos)] - ) - -- else - $ do - -- since it is unfloatable (effectful), this let is a new anchor - -- acts as anchor both in rhs'es and inTerm - withDepth (+1) $ do - depth <- view markCtxDepth - let toPos = Pos depth letU - -- visit the rhs'es - -- if rec, then its bindings are in scope in the rhs'es - ifRec r (withBs bs $ toPos LetRhs) $ traverseOf_ (traversed . bindingSubterms) go bs - - -- bindings are inscope in the InTerm for both rec&nonrec - withBs bs (toPos LamBody) $ go tIn + let letN = BindingGrp ann r bs + in ifM + (floatable letN) + -- then + ( do + scope <- view markCtxScope + let freeVars = + -- if Rec, remove the here-bindings from free + ifRec r (USet.\\ USet.setOfByUnique (traversed . bindingIds) bs) $ + calcFreeVars letN + + -- The "heart" of the algorithm: the future position to float this let to + -- is determined as the maximum among its dependencies (free vars). + let floatPos@(Pos floatDepth _ _) = maxPos $ scope `UMap.restrictKeys` freeVars + + -- visit the rhs'es + -- IMPORTANT: inside the rhs, act like the current depth + -- is the future floated depth of this rhs. + withDepth (const floatDepth) $ + -- if rec, then its bindings are in scope in the rhs'es + ifRec r (withBs bs floatPos) $ + traverseOf_ (traversed . bindingSubterms) go bs + + -- visit the inTerm + -- bindings are inscope in the InTerm for both rec&nonrec + withBs bs floatPos $ go tIn + + -- collect here the new mark and propagate all + tell $ UMap.fromUniques [(letU, floatPos)] + ) + -- else + $ do + -- since it is unfloatable (effectful), this let is a new anchor + -- acts as anchor both in rhs'es and inTerm + withDepth (+ 1) $ do + depth <- view markCtxDepth + let toPos = Pos depth letU + -- visit the rhs'es + -- if rec, then its bindings are in scope in the rhs'es + ifRec r (withBs bs $ toPos LetRhs) $ traverseOf_ (traversed . bindingSubterms) go bs + + -- bindings are inscope in the InTerm for both rec&nonrec + withBs bs (toPos LamBody) $ go tIn -- descend and collect t -> traverseOf_ termSubterms go t -- | Given a 'BindingGrp', calculate its free vars and free tyvars and collect them in a set. -calcFreeVars :: forall tyname name uni fun a. - (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) - => BindingGrp tyname name uni fun a - -> PLC.UniqueSet PLC.Unique +calcFreeVars :: + forall tyname name uni fun a. + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) => + BindingGrp tyname name uni fun a -> + PLC.UniqueSet PLC.Unique calcFreeVars (BindingGrp _ r bs) = foldMap1 calcBinding bs where -- given a binding return all its free term *AND* free type variables calcBinding :: Binding tyname name uni fun a -> PLC.UniqueSet PLC.Unique calcBinding b = - USet.setOfByUnique (fvBinding . PLC.theUnique) b + USet.setOfByUnique (fvBinding . PLC.theUnique) b <> USet.setOfByUnique (ftvBinding r . PLC.theUnique) b -- | The second pass of cleaning the term of the floatable lets, and placing them in a separate map -- OPTIMIZE: use State for building the FloatTable, and for reducing the Marks -removeLets :: forall tyname name uni fun a term. - (term~Term tyname name uni fun a - ,PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) - => Marks - -> term - -> (term, FloatTable tyname name uni fun a) +removeLets :: + forall tyname name uni fun a term. + ( term ~ Term tyname name uni fun a + , PLC.HasUnique tyname PLC.TypeUnique + , PLC.HasUnique name PLC.TermUnique + ) => + Marks -> + term -> + (term, FloatTable tyname name uni fun a) removeLets marks term = runWriter $ go term where -- TODO: use State for the Marks to safeguard against any bugs where floatable lets are not removed as they should to. go :: term -> Writer (FloatTable tyname name uni fun a) term - go = breakNonRec >>> \case + go = + breakNonRec >>> \case -- main operation: for letrec or single letnonrec Let a r bs@(representativeBindingUnique -> letU) tIn -> do - -- go to rhs'es and collect their floattable + cleanedterm - bs' <- bs & (traversed . bindingSubterms) go - -- go to inTerm and collect its floattable + cleanedterm - tIn' <- go tIn - case UMap.lookupUnique letU marks of - -- this is not a floatable let - Nothing -> pure $ Let a r bs' tIn' - -- floatable let found. - -- move this let to the floattable, and just return the body - Just pos -> do - tell (MM.singleton pos (pure $ BindingGrp a r bs')) - pure tIn' + -- go to rhs'es and collect their floattable + cleanedterm + bs' <- bs & (traversed . bindingSubterms) go + -- go to inTerm and collect its floattable + cleanedterm + tIn' <- go tIn + case UMap.lookupUnique letU marks of + -- this is not a floatable let + Nothing -> pure $ Let a r bs' tIn' + -- floatable let found. + -- move this let to the floattable, and just return the body + Just pos -> do + tell (MM.singleton pos (pure $ BindingGrp a r bs')) + pure tIn' -- descend and collect Apply a t1 t2 -> Apply a <$> go t1 <*> go t2 @@ -308,26 +320,31 @@ removeLets marks term = runWriter $ go term Unwrap a t -> Unwrap a <$> go t Constr a ty i es -> Constr a ty i <$> traverse go es Case a ty arg cs -> Case a ty <$> go arg <*> traverse go cs - -- no term inside here, nothing to do - t@Var{} -> pure t - t@Constant{} -> pure t - t@Builtin{} -> pure t - t@Error{} -> pure t + t@Var {} -> pure t + t@Constant {} -> pure t + t@Builtin {} -> pure t + t@Error {} -> pure t -- | The 3rd and last pass that, given the result of 'removeLets', places the lets back (floats) at the right marked positions. -floatBackLets :: forall tyname name uni fun a term m. - ( term~Term tyname name uni fun a - , m~Reader Depth - , PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique, Semigroup a) - => term -- ^ the cleanedup, reducted term - -> FloatTable tyname name uni fun a -- ^ the lets to be floated - -> term -- ^ the final, floated, and correctly-scoped term +floatBackLets :: + forall tyname name uni fun a term m. + ( term ~ Term tyname name uni fun a + , m ~ Reader Depth + , PLC.HasUnique tyname PLC.TypeUnique + , PLC.HasUnique name PLC.TermUnique + , Semigroup a + ) => + -- | the cleanedup, reducted term + term -> + -- | the lets to be floated + FloatTable tyname name uni fun a -> + -- | the final, floated, and correctly-scoped term + term floatBackLets term fTable = - -- our reader context is only the depth this time. - flip runReader topDepth $ goTop term + -- our reader context is only the depth this time. + flip runReader topDepth $ goTop term where - -- TODO: use State for FloatTable to safeguard against any bugs where floatable-lets were not floated as they should to. goTop, go :: term -> m term @@ -335,82 +352,98 @@ floatBackLets term fTable = goTop = floatLam topUnique <=< go go = \case - -- lam anchor, increase depth & try to float inside the lam's body - LamAbs a n ty tBody -> local (+1) $ - LamAbs a n ty <$> (floatLam (n^.PLC.theUnique) =<< go tBody) - -- Lam anchor, increase depth & try to float inside the Lam's body - TyAbs a n k tBody -> local (+1) $ - TyAbs a n k <$> (floatLam (n^.PLC.theUnique) =<< go tBody) - -- Unfloatable-let anchor, increase depth - Let a r bs@(representativeBindingUnique -> letU) tIn -> local (+1) $ do - -- note that we do not touch the original recursivity of the unfloatable-let - unfloatableGrp <- BindingGrp a r <$> traverseOf (traversed.bindingSubterms) go bs - -- rebuild the let-group (we take the minimum bound, i.e. NonRec) - bindingGrpToLet NonRec - <$> -- float inside the rhs of the unfloatable group, and merge the bindings - floatRhs letU unfloatableGrp - -- float right inside the inTerm (similar to lam/Lam) - <*> (floatLam letU =<< go tIn) - - -- descend - t -> t & termSubterms go + -- lam anchor, increase depth & try to float inside the lam's body + LamAbs a n ty tBody -> + local (+ 1) $ + LamAbs a n ty <$> (floatLam (n ^. PLC.theUnique) =<< go tBody) + -- Lam anchor, increase depth & try to float inside the Lam's body + TyAbs a n k tBody -> + local (+ 1) $ + TyAbs a n k <$> (floatLam (n ^. PLC.theUnique) =<< go tBody) + -- Unfloatable-let anchor, increase depth + Let a r bs@(representativeBindingUnique -> letU) tIn -> local (+ 1) $ do + -- note that we do not touch the original recursivity of the unfloatable-let + unfloatableGrp <- BindingGrp a r <$> traverseOf (traversed . bindingSubterms) go bs + -- rebuild the let-group (we take the minimum bound, i.e. NonRec) + bindingGrpToLet NonRec + <$> floatRhs letU unfloatableGrp -- float inside the rhs of the unfloatable group, and merge the bindings + + -- float right inside the inTerm (similar to lam/Lam) + <*> (floatLam letU =<< go tIn) + + -- descend + t -> t & termSubterms go -- Make a brand new let-group comprised of all the floatable lets just inside the lam-body/Lam-body/let-InTerm floatLam :: PLC.Unique -> term -> m term floatLam lamU t = do - herePos <- asks $ \d -> Pos d lamU LamBody - -- We need to force to Rec because we might merge lets which depend on each other, - -- but we can't tell because we don't do dependency resolution at this pass. - -- So we have to be conservative. See Note [LetRec splitting pass] - floatAt herePos (bindingGrpToLet Rec) t - - floatRhs :: (grp ~ BindingGrp tyname name uni fun a) - => PLC.Unique - -> grp -- ^ the unfloatable group - -> m grp -- ^ the result group extended with the floatable rhs'es (size(result_group) >= size(unfloatable_group)) + herePos <- asks $ \d -> Pos d lamU LamBody + -- We need to force to Rec because we might merge lets which depend on each other, + -- but we can't tell because we don't do dependency resolution at this pass. + -- So we have to be conservative. See Note [LetRec splitting pass] + floatAt herePos (bindingGrpToLet Rec) t + + floatRhs :: + grp ~ BindingGrp tyname name uni fun a => + PLC.Unique -> + grp -> + -- \^ the unfloatable group + m grp + -- \^ the result group extended with the floatable rhs'es (size(result_group) >= size(unfloatable_group)) floatRhs letU bs = do - herePos <- asks $ \d -> Pos d letU LetRhs - -- we don't know from which rhs the floatable-let(s) came from originally, - -- so we instead are going to semigroup-append the floatable-let bindings together with the unfloatable let-group's bindings - floatAt herePos (<>) bs - - floatAt :: Pos -- ^ floating position - -> (BindingGrp tyname name uni fun a -> c -> c) -- ^ how to place the unfloatable-group into the PIR result - -> c -- ^ term or bindings to float AROUND - -> m c -- ^ the combined PIR result (terms or bindings) + herePos <- asks $ \d -> Pos d letU LetRhs + -- we don't know from which rhs the floatable-let(s) came from originally, + -- so we instead are going to semigroup-append the floatable-let bindings together with the unfloatable let-group's bindings + floatAt herePos (<>) bs + + floatAt :: + Pos -> + -- \^ floating position + (BindingGrp tyname name uni fun a -> c -> c) -> + -- \^ how to place the unfloatable-group into the PIR result + c -> + -- \^ term or bindings to float AROUND + m c + -- \^ the combined PIR result (terms or bindings) floatAt herePos placeIntoFn termOrBindings = do - -- is there something to be floated here? - case MM.lookup herePos fTable of - -- nothing to float, just descend - Nothing -> pure termOrBindings - -- all the naked-lets to be floated here - Just floatableGrps -> do - -- visit the rhs'es of these floated lets for any potential floatings as well - -- NOTE: we do not directly run `go(bgGroup)` because that would increase the depth, - -- and the floated lets are not anchors themselves; instead we run go on the floated-let bindings' subterms. - floatableGrps' <- floatableGrps & (traversed.bgBindings.traversed.bindingSubterms) go - -- fold the floatable groups into a *single* floatablegroup and combine that with some pir (term or bindings). - pure $ fold1 floatableGrps' `placeIntoFn` termOrBindings + -- is there something to be floated here? + case MM.lookup herePos fTable of + -- nothing to float, just descend + Nothing -> pure termOrBindings + -- all the naked-lets to be floated here + Just floatableGrps -> do + -- visit the rhs'es of these floated lets for any potential floatings as well + -- NOTE: we do not directly run `go(bgGroup)` because that would increase the depth, + -- and the floated lets are not anchors themselves; instead we run go on the floated-let bindings' subterms. + floatableGrps' <- floatableGrps & (traversed . bgBindings . traversed . bindingSubterms) go + -- fold the floatable groups into a *single* floatablegroup and combine that with some pir (term or bindings). + pure $ fold1 floatableGrps' `placeIntoFn` termOrBindings floatTermPassSC :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , Semigroup a, PLC.MonadQuote m - ) => - TC.PirTCConfig uni fun -> - BuiltinsInfo uni fun -> - Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , Semigroup a + , PLC.MonadQuote m + ) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun a floatTermPassSC tcconfig binfo = - renamePass <> floatTermPass tcconfig binfo + renamePass <> floatTermPass tcconfig binfo floatTermPass :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , Semigroup a, Applicative m - ) => - TC.PirTCConfig uni fun -> - BuiltinsInfo uni fun -> - Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , Semigroup a + , Applicative m + ) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun a floatTermPass tcconfig binfo = NamedPass "let float-out" $ Pass @@ -420,14 +453,14 @@ floatTermPass tcconfig binfo = -- | The compiler pass of the algorithm (comprised of 3 connected passes). floatTerm :: - (PLC.ToBuiltinMeaning uni fun, - PLC.HasUnique tyname PLC.TypeUnique, - PLC.HasUnique name PLC.TermUnique, - Semigroup a - ) - => BuiltinsInfo uni fun -> Term tyname name uni fun a -> Term tyname name uni fun a + ( PLC.ToBuiltinMeaning uni fun + , PLC.HasUnique tyname PLC.TypeUnique + , PLC.HasUnique name PLC.TermUnique + , Semigroup a + ) => + BuiltinsInfo uni fun -> Term tyname name uni fun a -> Term tyname name uni fun a floatTerm binfo t = - mark binfo t + mark binfo t & flip removeLets t & uncurry floatBackLets @@ -436,78 +469,86 @@ floatTerm binfo t = maxPos :: PLC.UniqueMap k Pos -> Pos maxPos = foldr max topPos -withDepth :: (r ~ MarkCtx tyname name uni fun a2, MonadReader r m) - => (Depth -> Depth) -> m a -> m a +withDepth :: + (r ~ MarkCtx tyname name uni fun a2, MonadReader r m) => + (Depth -> Depth) -> m a -> m a withDepth = local . over markCtxDepth -withLam :: (r ~ MarkCtx tyname name uni fun a2, MonadReader r m, PLC.HasUnique name unique) - => name - -> m a -> m a -withLam (view PLC.theUnique -> u) = local $ \ (MarkCtx d scope binfo vinfo) -> - let d' = d+1 - pos' = Pos d' u LamBody - in MarkCtx d' (UMap.insertByUnique u pos' scope) binfo vinfo - -withAbs :: (r ~ MarkCtx tyname name uni fun a2, MonadReader r m, PLC.HasUnique tyname unique) - => tyname - -> m a -> m a -withAbs (view PLC.theUnique -> u) = local $ \ (MarkCtx d scope binfo vinfo) -> - let d' = d+1 - pos' = Pos d' u LamBody - in MarkCtx d' (UMap.insertByUnique u pos' scope) binfo vinfo - -withBs :: (r ~ MarkCtx tyname name uni fun a2, MonadReader r m, PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) - => NE.NonEmpty (Binding tyname name uni fun a3) - -> Pos - -> m a -> m a +withLam :: + (r ~ MarkCtx tyname name uni fun a2, MonadReader r m, PLC.HasUnique name unique) => + name -> + m a -> + m a +withLam (view PLC.theUnique -> u) = local $ \(MarkCtx d scope binfo vinfo) -> + let d' = d + 1 + pos' = Pos d' u LamBody + in MarkCtx d' (UMap.insertByUnique u pos' scope) binfo vinfo + +withAbs :: + (r ~ MarkCtx tyname name uni fun a2, MonadReader r m, PLC.HasUnique tyname unique) => + tyname -> + m a -> + m a +withAbs (view PLC.theUnique -> u) = local $ \(MarkCtx d scope binfo vinfo) -> + let d' = d + 1 + pos' = Pos d' u LamBody + in MarkCtx d' (UMap.insertByUnique u pos' scope) binfo vinfo + +withBs :: + (r ~ MarkCtx tyname name uni fun a2, MonadReader r m, PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => + NE.NonEmpty (Binding tyname name uni fun a3) -> + Pos -> + m a -> + m a withBs bs pos = local . over markCtxScope $ \scope -> - UMap.fromUniques [(bid, pos) | bid <- bs^..traversed.bindingIds] <> scope + UMap.fromUniques [(bid, pos) | bid <- bs ^.. traversed . bindingIds] <> scope -- A helper to apply a function iff recursive ifRec :: Recursivity -> (a -> a) -> a -> a ifRec r f a = case r of - Rec -> f a - NonRec -> a + Rec -> f a + NonRec -> a -floatable - :: (MonadReader (MarkCtx tyname name uni fun a) m, PLC.ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) - => BindingGrp tyname name uni fun a - -> m Bool +floatable :: + (MonadReader (MarkCtx tyname name uni fun a) m, PLC.ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) => + BindingGrp tyname name uni fun a -> + m Bool floatable (BindingGrp _ _ bs) = do - binfo <- view markBuiltinsInfo - vinfo <- view markVarsInfo - pure $ all (hasNoEffects binfo vinfo) bs - && - -- See Note [Floating type-lets] - none isTypeBind bs - -{-| Returns if a binding has absolutely no effects (see Value.hs) -See Note [Purity, strictness, and variables] -An extreme alternative implementation is to treat *all strict* bindings as unfloatable, e.g.: -`hasNoEffects = \case {TermBind _ Strict _ _ -> False; _ -> True}` --} -hasNoEffects - :: (PLC.ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Binding tyname name uni fun a -> Bool + binfo <- view markBuiltinsInfo + vinfo <- view markVarsInfo + pure $ + all (hasNoEffects binfo vinfo) bs + && + -- See Note [Floating type-lets] + none isTypeBind bs + +-- | Returns if a binding has absolutely no effects (see Value.hs) +-- See Note [Purity, strictness, and variables] +-- An extreme alternative implementation is to treat *all strict* bindings as unfloatable, e.g.: +-- `hasNoEffects = \case {TermBind _ Strict _ _ -> False; _ -> True}` +hasNoEffects :: + (PLC.ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Binding tyname name uni fun a -> + Bool hasNoEffects binfo vinfo = \case - TypeBind{} -> True - DatatypeBind{} -> True - TermBind _ NonStrict _ _ -> True - -- have to check for purity - TermBind _ Strict _ t -> isPure binfo vinfo t + TypeBind {} -> True + DatatypeBind {} -> True + TermBind _ NonStrict _ _ -> True + -- have to check for purity + TermBind _ Strict _ t -> isPure binfo vinfo t isTypeBind :: Binding tyname name uni fun a -> Bool -isTypeBind = \case TypeBind{} -> True; _ -> False +isTypeBind = \case TypeBind {} -> True; _ -> False -- | Breaks down linear let nonrecs by -- the rule: {let nonrec (b:bs) in t} === {let nonrec b in let nonrec bs in t} breakNonRec :: Term tyname name uni fun a -> Term tyname name uni fun a breakNonRec = \case - Let a NonRec (NE.uncons -> (b, Just bs)) tIn -> - (Let a NonRec (pure b) $ Let a NonRec bs tIn) - t -> t + Let a NonRec (NE.uncons -> (b, Just bs)) tIn -> + (Let a NonRec (pure b) $ Let a NonRec bs tIn) + t -> t {- Note [Floating rhs-nested lets] @@ -532,7 +573,7 @@ Note about squeezing order: The end result is that no nested, floatable let will appear anymore inside another let's rhs at the algorithm's output, (e.g. invalid output: let x=1+(let y=3 in y) in ...) -*EXCEPT* if the nested let is intercepted by a lam/Lam anchor (depends on a lam/Lam that is located inside the parent-let's rhs) +\*EXCEPT* if the nested let is intercepted by a lam/Lam anchor (depends on a lam/Lam that is located inside the parent-let's rhs) e.g. valid output: let x= \z -> (let y = 3+z in y) in ... -} diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetMerge.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetMerge.hs index 054b329f9e4..05858cea961 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetMerge.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetMerge.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} -{-| -A trivial simplification that merges adjacent non-recursive let terms. --} + +-- | +-- A trivial simplification that merges adjacent non-recursive let terms. module PlutusIR.Transform.LetMerge ( - letMerge - , letMergePass - ) where + letMerge, + letMergePass, +) where import PlutusIR @@ -14,26 +14,24 @@ import PlutusCore qualified as PLC import PlutusIR.Pass import PlutusIR.TypeCheck qualified as TC -{-| -A single non-recursive application of let-merging cancellation. --} -letMergeStep - :: Term tyname name uni fun a - -> Term tyname name uni fun a +-- | +-- A single non-recursive application of let-merging cancellation. +letMergeStep :: + Term tyname name uni fun a -> + Term tyname name uni fun a letMergeStep = \case - Let a NonRec bs (Let _ NonRec bs' t) -> Let a NonRec (bs <> bs') t - t -> t + Let a NonRec bs (Let _ NonRec bs' t) -> Let a NonRec (bs <> bs') t + t -> t -{-| -Recursively apply let merging cancellation. --} -letMerge - :: Term tyname name uni fun a - -> Term tyname name uni fun a +-- | +-- Recursively apply let merging cancellation. +letMerge :: + Term tyname name uni fun a -> + Term tyname name uni fun a letMerge = transformOf termSubterms letMergeStep -letMergePass - :: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a +letMergePass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a letMergePass tcconfig = simplePass "let merge" tcconfig letMerge diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/NonStrict.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/NonStrict.hs index 8e288dab0e0..8af00e048b9 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/NonStrict.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/NonStrict.hs @@ -1,7 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + -- | Compile non-strict bindings into strict bindings. module PlutusIR.Transform.NonStrict (compileNonStrictBindings, compileNonStrictBindingsPass, compileNonStrictBindingsPassSC) where @@ -44,72 +45,73 @@ function type but `() -> x` is! type Substs uni fun a = Map.Map Name (Term TyName Name uni fun a) -compileNonStrictBindingsPassSC - :: (PLC.Typecheckable uni fun, PLC.GEq uni, MonadQuote m, Ord a) - => TC.PirTCConfig uni fun - -> Bool - -> Pass m TyName Name uni fun a +compileNonStrictBindingsPassSC :: + (PLC.Typecheckable uni fun, PLC.GEq uni, MonadQuote m, Ord a) => + TC.PirTCConfig uni fun -> + Bool -> + Pass m TyName Name uni fun a compileNonStrictBindingsPassSC tcConfig useUnit = - renamePass <> compileNonStrictBindingsPass tcConfig useUnit + renamePass <> compileNonStrictBindingsPass tcConfig useUnit -compileNonStrictBindingsPass - :: (PLC.Typecheckable uni fun, PLC.GEq uni, MonadQuote m) - => TC.PirTCConfig uni fun - -> Bool - -> Pass m TyName Name uni fun a +compileNonStrictBindingsPass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, MonadQuote m) => + TC.PirTCConfig uni fun -> + Bool -> + Pass m TyName Name uni fun a compileNonStrictBindingsPass tcConfig useUnit = NamedPass "compile non-strict bindings" $ Pass (compileNonStrictBindings useUnit) - [Typechecks tcConfig] [ConstCondition (Typechecks tcConfig)] + [Typechecks tcConfig] + [ConstCondition (Typechecks tcConfig)] -- | Compile all the non-strict bindings in a term into strict bindings. Note: requires globally -- unique names. compileNonStrictBindings :: MonadQuote m => Bool -> Term TyName Name uni fun a -> m (Term TyName Name uni fun a) compileNonStrictBindings useUnit t = do - (t', substs) <- liftQuote $ flip runStateT mempty $ strictifyTerm useUnit t - -- See Note [Compiling non-strict bindings] - pure $ termSubstNames (\n -> Map.lookup n substs) t' + (t', substs) <- liftQuote $ flip runStateT mempty $ strictifyTerm useUnit t + -- See Note [Compiling non-strict bindings] + pure $ termSubstNames (\n -> Map.lookup n substs) t' -strictifyTerm - :: (MonadState (Substs uni fun a) m, MonadQuote m) - => Bool -> Term TyName Name uni fun a -> m (Term TyName Name uni fun a) +strictifyTerm :: + (MonadState (Substs uni fun a) m, MonadQuote m) => + Bool -> Term TyName Name uni fun a -> m (Term TyName Name uni fun a) strictifyTerm useUnit = - -- See Note [Using unit versus force/delay] - let transformation = if useUnit then strictifyBindingWithUnit else strictifyBinding - in transformMOf termSubterms (traverseOf termBindings transformation) + -- See Note [Using unit versus force/delay] + let transformation = if useUnit then strictifyBindingWithUnit else strictifyBinding + in transformMOf termSubterms (traverseOf termBindings transformation) -strictifyBinding - :: (MonadState (Substs uni fun a) m, MonadQuote m) - => Binding TyName Name uni fun a -> m (Binding TyName Name uni fun a) +strictifyBinding :: + (MonadState (Substs uni fun a) m, MonadQuote m) => + Binding TyName Name uni fun a -> m (Binding TyName Name uni fun a) strictifyBinding = \case - TermBind x NonStrict (VarDecl x' name ty) rhs -> do - -- The annotation to use for new synthetic nodes - let ann = x' + TermBind x NonStrict (VarDecl x' name ty) rhs -> do + -- The annotation to use for new synthetic nodes + let ann = x' - a <- freshTyName "dead" - -- See Note [Compiling non-strict bindings] - modify $ Map.insert name $ TyInst ann (Var ann name) (TyForall ann a (Type ann) (TyVar ann a)) + a <- freshTyName "dead" + -- See Note [Compiling non-strict bindings] + modify $ Map.insert name $ TyInst ann (Var ann name) (TyForall ann a (Type ann) (TyVar ann a)) - pure $ TermBind x Strict (VarDecl x' name (TyForall ann a (Type ann) ty)) (TyAbs ann a (Type ann) rhs) - x -> pure x + pure $ TermBind x Strict (VarDecl x' name (TyForall ann a (Type ann) ty)) (TyAbs ann a (Type ann) rhs) + x -> pure x -strictifyBindingWithUnit - :: (MonadState (Substs uni fun a) m, MonadQuote m) - => Binding TyName Name uni fun a -> m (Binding TyName Name uni fun a) +strictifyBindingWithUnit :: + (MonadState (Substs uni fun a) m, MonadQuote m) => + Binding TyName Name uni fun a -> m (Binding TyName Name uni fun a) strictifyBindingWithUnit = \case - TermBind x NonStrict (VarDecl x' name ty) rhs -> do - -- The annotation to use for new synthetic nodes - let ann = x' + TermBind x NonStrict (VarDecl x' name ty) rhs -> do + -- The annotation to use for new synthetic nodes + let ann = x' - argName <- liftQuote $ freshName "arg" - -- TODO: These are created at every use site, we should bind them globally - let unit = ann <$ Unit.unit - unitval = ann <$ Unit.unitval - forced = Apply ann (Var ann name) unitval + argName <- liftQuote $ freshName "arg" + -- TODO: These are created at every use site, we should bind them globally + let unit = ann <$ Unit.unit + unitval = ann <$ Unit.unitval + forced = Apply ann (Var ann name) unitval - -- See Note [Compiling non-strict bindings] - modify $ Map.insert name forced + -- See Note [Compiling non-strict bindings] + modify $ Map.insert name forced - pure $ TermBind x Strict (VarDecl x' name (TyFun ann unit ty)) (LamAbs ann argName unit rhs) - x -> pure x + pure $ TermBind x Strict (VarDecl x' name (TyFun ann unit ty)) (LamAbs ann argName unit rhs) + x -> pure x diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RecSplit.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RecSplit.hs index fb31d16307d..e6fa987d7a0 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RecSplit.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RecSplit.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -module PlutusIR.Transform.RecSplit - (recSplit, recSplitPass) where +{-# LANGUAGE TupleSections #-} + +module PlutusIR.Transform.RecSplit (recSplit, recSplitPass) where import PlutusCore.Name.Unique qualified as PLC import PlutusIR @@ -69,97 +69,103 @@ and the 'principal' function arbitrarily chooses between one of these introduced to represent the "principal" id of the whole datatype binding so it can be used as "the key". -} -recSplitPass - :: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a +recSplitPass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a recSplitPass tcconfig = simplePass "recursive let split" tcconfig recSplit -{-| -Apply letrec splitting, recursively in bottom-up fashion. --} -recSplit :: forall uni fun a name tyname. - (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) - => Term tyname name uni fun a - -> Term tyname name uni fun a +-- | +-- Apply letrec splitting, recursively in bottom-up fashion. +recSplit :: + forall uni fun a name tyname. + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) => + Term tyname name uni fun a -> + Term tyname name uni fun a recSplit = transformOf termSubterms recSplitStep -{-| -Apply splitting for a single letrec group. --} -recSplitStep :: forall uni fun a name tyname. - (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) - => Term tyname name uni fun a -> Term tyname name uni fun a +-- | +-- Apply splitting for a single letrec group. +recSplitStep :: + forall uni fun a name tyname. + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) => + Term tyname name uni fun a -> Term tyname name uni fun a recSplitStep = \case - -- See Note [LetRec splitting pass] - Let a Rec bs t -> - let -- a table from principal id to the its corresponding 'Binding' - bindingsTable :: M.Map PLC.Unique (Binding tyname name uni fun a) - bindingsTable = M.fromList . NE.toList $ fmap (\ b -> (principal b, b)) bs - hereSccs = - fromRight (error "Cycle detected in the scc-graph. This shouldn't happen in the first place.") - -- we take the topological sort (for the correct order) - -- from the SCCs (for the correct grouping) of the local dep-graph - . AM.topSort . AM.scc $ buildLocalDepGraph bs - - genLetFromScc acc scc = mkLet a - (if isAcyclic scc then NonRec else Rec) - (M.elems . M.restrictKeys bindingsTable $ AMN.vertexSet scc) - acc - in Foldable.foldl' genLetFromScc t hereSccs - t -> t - -{-| -It constructs a dependency graph for the currently-examined let-group. - -The vertices of this graph are the bindings of this let-group, and the edges, -dependencies between those bindings. - -This local graph may contain loops: -- A "self-edge" indicates a self-recursive binding. -- Any other loop indicates mutual-recursive bindings. --} -buildLocalDepGraph :: forall uni fun a name tyname. - (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) - => NE.NonEmpty (Binding tyname name uni fun a) -> AM.AdjacencyMap PLC.Unique + -- See Note [LetRec splitting pass] + Let a Rec bs t -> + let + -- a table from principal id to the its corresponding 'Binding' + bindingsTable :: M.Map PLC.Unique (Binding tyname name uni fun a) + bindingsTable = M.fromList . NE.toList $ fmap (\b -> (principal b, b)) bs + hereSccs = + fromRight (error "Cycle detected in the scc-graph. This shouldn't happen in the first place.") + -- we take the topological sort (for the correct order) + -- from the SCCs (for the correct grouping) of the local dep-graph + . AM.topSort + . AM.scc + $ buildLocalDepGraph bs + + genLetFromScc acc scc = + mkLet + a + (if isAcyclic scc then NonRec else Rec) + (M.elems . M.restrictKeys bindingsTable $ AMN.vertexSet scc) + acc + in + Foldable.foldl' genLetFromScc t hereSccs + t -> t + +-- | +-- It constructs a dependency graph for the currently-examined let-group. +-- +-- The vertices of this graph are the bindings of this let-group, and the edges, +-- dependencies between those bindings. +-- +-- This local graph may contain loops: +-- - A "self-edge" indicates a self-recursive binding. +-- - Any other loop indicates mutual-recursive bindings. +buildLocalDepGraph :: + forall uni fun a name tyname. + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) => + NE.NonEmpty (Binding tyname name uni fun a) -> AM.AdjacencyMap PLC.Unique buildLocalDepGraph bs = - -- join together - AM.overlays . NE.toList $ fmap bindingSubGraph bs - where - -- a map of a all introduced binding ids of this letgroup to their belonging principal id - idTable :: M.Map PLC.Unique PLC.Unique - idTable = foldMap1 (\ b -> M.fromList (fmap (,principal b) $ b^..bindingIds)) bs - - -- Given a binding, it intersects the free uniques of the binding, - -- with the introduced uniques of the current let group (all bindings). - -- The result of this intersection is the "local" dependencies of the binding to other - -- "sibling" bindings of this let group or to itself (if self-recursive). - -- It returns a graph which connects this binding to all of its calculated "local" dependencies. - bindingSubGraph :: Binding tyname name uni fun a -> AM.AdjacencyMap PLC.Unique - bindingSubGraph b = - -- the free uniques (variables or tyvariables) that occur inside this binding - -- Special case for datatype bindings: - -- To find out if the binding is self-recursive, - -- we treat it like it was originally belonging to a let-nonrec (`ftvBinding NonRec`). - -- Then, if it the datatype is indeed self-recursive, the call to `ftvBinding NonRec` will return - -- its typeconstructor as free. - let freeUniques = setOf (fvBinding . PLC.theUnique <^> ftvBinding NonRec . PLC.theUnique) b - -- the "local" dependencies - occursIds = M.keysSet idTable `S.intersection` freeUniques - -- maps the ids of the "local" dependencies to their principal uniques. - -- See Note [Principal id] - occursPrincipals = nub $ M.elems $ idTable `M.restrictKeys` occursIds - in AM.connect (AM.vertex $ principal b) (AM.vertices occursPrincipals) - - -{-| -A function that returns a single 'Unique' for a particular binding. -See Note [Principal id] --} -principal :: (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) - => Binding tyname name uni fun a - -> PLC.Unique -principal = \case TermBind _ _ (VarDecl _ n _) _ -> n^. PLC.theUnique - TypeBind _ (TyVarDecl _ n _) _ -> n ^. PLC.theUnique - -- arbitrary: uses the type constructor's unique as the principal unique of this data binding group - DatatypeBind _ (Datatype _ (TyVarDecl _ tyConstr _) _ _ _) -> tyConstr ^. PLC.theUnique + -- join together + AM.overlays . NE.toList $ fmap bindingSubGraph bs + where + -- a map of a all introduced binding ids of this letgroup to their belonging principal id + idTable :: M.Map PLC.Unique PLC.Unique + idTable = foldMap1 (\b -> M.fromList (fmap (,principal b) $ b ^.. bindingIds)) bs + + -- Given a binding, it intersects the free uniques of the binding, + -- with the introduced uniques of the current let group (all bindings). + -- The result of this intersection is the "local" dependencies of the binding to other + -- "sibling" bindings of this let group or to itself (if self-recursive). + -- It returns a graph which connects this binding to all of its calculated "local" dependencies. + bindingSubGraph :: Binding tyname name uni fun a -> AM.AdjacencyMap PLC.Unique + bindingSubGraph b = + -- the free uniques (variables or tyvariables) that occur inside this binding + -- Special case for datatype bindings: + -- To find out if the binding is self-recursive, + -- we treat it like it was originally belonging to a let-nonrec (`ftvBinding NonRec`). + -- Then, if it the datatype is indeed self-recursive, the call to `ftvBinding NonRec` will return + -- its typeconstructor as free. + let freeUniques = setOf (fvBinding . PLC.theUnique <^> ftvBinding NonRec . PLC.theUnique) b + -- the "local" dependencies + occursIds = M.keysSet idTable `S.intersection` freeUniques + -- maps the ids of the "local" dependencies to their principal uniques. + -- See Note [Principal id] + occursPrincipals = nub $ M.elems $ idTable `M.restrictKeys` occursIds + in AM.connect (AM.vertex $ principal b) (AM.vertices occursPrincipals) + +-- | +-- A function that returns a single 'Unique' for a particular binding. +-- See Note [Principal id] +principal :: + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) => + Binding tyname name uni fun a -> + PLC.Unique +principal = \case + TermBind _ _ (VarDecl _ n _) _ -> n ^. PLC.theUnique + TypeBind _ (TyVarDecl _ n _) _ -> n ^. PLC.theUnique + -- arbitrary: uses the type constructor's unique as the principal unique of this data binding group + DatatypeBind _ (Datatype _ (TyVarDecl _ tyConstr _) _ _ _) -> tyConstr ^. PLC.theUnique diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Rename.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Rename.hs index e6b396773ed..6663ad8f901 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Rename.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Rename.hs @@ -1,21 +1,20 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Renaming of PIR terms. Import this module to bring the @PLC.Rename (Term tyname name uni fun ann)@ -- instance in scope. -module PlutusIR.Transform.Rename - ( renameTermM - , renameProgramM - ) where +module PlutusIR.Transform.Rename ( + renameTermM, + renameProgramM, +) where import PlutusPrelude @@ -197,86 +196,89 @@ recursive and non-recursive data types with a single function. -} instance PLC.HasUniques (Term tyname name uni fun ann) => PLC.Rename (Term tyname name uni fun ann) where - -- See Note [Marking] - rename = through markNonFreshTerm >=> PLC.runRenameT . renameTermM + -- See Note [Marking] + rename = through markNonFreshTerm >=> PLC.runRenameT . renameTermM instance PLC.HasUniques (Term tyname name uni fun ann) => PLC.Rename (Program tyname name uni fun ann) where - rename (Program ann v term) = Program ann v <$> PLC.rename term + rename (Program ann v term) = Program ann v <$> PLC.rename term -- See Note [Renaming of constructors]. + -- | A wrapper around a function restoring some old context of the renamer. newtype Restorer m = Restorer - { unRestorer :: forall a. m a -> m a - } + { unRestorer :: forall a. m a -> m a + } -- | Capture the current context in a 'Restorer'. captureContext :: MonadReader ren m => ContT c m (Restorer m) captureContext = ContT $ \k -> do - env <- ask - k $ Restorer $ local $ const env + env <- ask + k $ Restorer $ local $ const env type MonadRename m = (PLC.MonadQuote m, MonadReader PLC.ScopedRenaming m) -- | Rename the type of a constructor given a restorer dropping all variables bound after the -- name of the data type. -renameConstrTypeM - :: (MonadRename m, PLC.HasUniques (Type tyname uni ann)) - => Restorer m -> Type tyname uni ann -> m (Type tyname uni ann) -renameConstrTypeM (Restorer restoreAfterData) = renameSpineM where +renameConstrTypeM :: + (MonadRename m, PLC.HasUniques (Type tyname uni ann)) => + Restorer m -> Type tyname uni ann -> m (Type tyname uni ann) +renameConstrTypeM (Restorer restoreAfterData) = renameSpineM + where renameSpineM (TyForall ann name kind ty) = - PLC.withFreshenedName name $ \nameFr -> TyForall ann nameFr kind <$> renameSpineM ty + PLC.withFreshenedName name $ \nameFr -> TyForall ann nameFr kind <$> renameSpineM ty renameSpineM (TyFun ann dom cod) = TyFun ann <$> PLC.renameTypeM dom <*> renameSpineM cod renameSpineM ty = renameResultM ty renameResultM (TyApp ann fun arg) = TyApp ann <$> renameResultM fun <*> PLC.renameTypeM arg renameResultM (TyVar ann name) = TyVar ann <$> restoreAfterData (PLC.renameNameM name) renameResultM _ = - error "Panic: a constructor returns something that is not an iterated application of a type variable" + error "Panic: a constructor returns something that is not an iterated application of a type variable" -- | Rename the name of a constructor immediately and defer renaming of its type until the second -- stage where all mutually recursive data types (if any) are bound. -renameConstrCM - :: (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) - => Restorer m - -> VarDecl tyname name uni ann - -> ContT c m (m (VarDecl tyname name uni ann)) +renameConstrCM :: + (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) => + Restorer m -> + VarDecl tyname name uni ann -> + ContT c m (m (VarDecl tyname name uni ann)) renameConstrCM restorerAfterData (VarDecl ann name ty) = do - nameFr <- ContT $ PLC.withFreshenedName name - pure $ VarDecl ann nameFr <$> renameConstrTypeM restorerAfterData ty + nameFr <- ContT $ PLC.withFreshenedName name + pure $ VarDecl ann nameFr <$> renameConstrTypeM restorerAfterData ty -- | Apply a function to a value in the non-recursive case and return the value unchanged otherwise. onNonRec :: Recursivity -> (a -> a) -> a -> a onNonRec NonRec f x = f x -onNonRec Rec _ x = x +onNonRec Rec _ x = x -- See Note [Weird IR data types] -- See Note [Renaming of constructors] (and make sure you understand all the intricacies in it -- before toucing this function). + -- | Rename a 'Datatype' in the CPS-transformed 'ScopedRenameM' monad. -renameDatatypeCM - :: (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) - => Recursivity - -> Datatype tyname name uni ann - -> ContT c m (m (Datatype tyname name uni ann)) +renameDatatypeCM :: + (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) => + Recursivity -> + Datatype tyname name uni ann -> + ContT c m (m (Datatype tyname name uni ann)) renameDatatypeCM recy (Datatype x dataDecl params matchName constrs) = do - -- The first stage (the data type itself, its constructors and its matcher get renamed). - -- Note that all of these are visible downstream. - restorerBeforeData <- captureContext - dataDeclFr <- ContT $ PLC.withFreshenedTyVarDecl dataDecl - restorerAfterData <- captureContext - constrsRen <- traverse (renameConstrCM restorerAfterData) constrs - matchNameFr <- ContT $ PLC.withFreshenedName matchName - -- The second stage (the type parameters and types of constructors get renamed). - -- Note that parameters are only visible in the types of constructors and not downstream. - pure . onNonRec recy (unRestorer restorerBeforeData) $ - runContT (traverse (ContT . PLC.withFreshenedTyVarDecl) params) $ \paramsFr -> - Datatype x dataDeclFr paramsFr matchNameFr <$> sequence constrsRen + -- The first stage (the data type itself, its constructors and its matcher get renamed). + -- Note that all of these are visible downstream. + restorerBeforeData <- captureContext + dataDeclFr <- ContT $ PLC.withFreshenedTyVarDecl dataDecl + restorerAfterData <- captureContext + constrsRen <- traverse (renameConstrCM restorerAfterData) constrs + matchNameFr <- ContT $ PLC.withFreshenedName matchName + -- The second stage (the type parameters and types of constructors get renamed). + -- Note that parameters are only visible in the types of constructors and not downstream. + pure . onNonRec recy (unRestorer restorerBeforeData) $ + runContT (traverse (ContT . PLC.withFreshenedTyVarDecl) params) $ \paramsFr -> + Datatype x dataDeclFr paramsFr matchNameFr <$> sequence constrsRen -- | Rename a 'Binding' from a non-recursive family in the CPS-transformed 'ScopedRenameM' monad. -renameBindingNonRecC - :: (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) - => Binding tyname name uni fun ann - -> ContT c m (Binding tyname name uni fun ann) +renameBindingNonRecC :: + (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) => + Binding tyname name uni fun ann -> + ContT c m (Binding tyname name uni fun ann) -- Unlike in the recursive case we don't have any stage separation here. -- -- 'TypeBind' is the simplest case: the body of the binding gets renamed first, then the name of @@ -294,93 +296,93 @@ renameBindingNonRecC -- 'renameDatatypeCM' and here we just unwrap from 'ContT' and perform all the renaming saved for -- stage two immediately just like in the 'TermBind' case and for the same reason. renameBindingNonRecC binding = ContT $ \cont -> case binding of - TermBind x s var term -> do - termFr <- renameTermM term - PLC.withFreshenedVarDecl var $ \varRen -> do - varFr <- varRen - cont $ TermBind x s varFr termFr - TypeBind x var ty -> do - tyFr <- PLC.renameTypeM ty - PLC.withFreshenedTyVarDecl var $ \varFr -> - cont $ TypeBind x varFr tyFr - DatatypeBind x datatype -> do - runContT (renameDatatypeCM NonRec datatype) $ \datatypeRen -> - datatypeRen >>= cont . DatatypeBind x + TermBind x s var term -> do + termFr <- renameTermM term + PLC.withFreshenedVarDecl var $ \varRen -> do + varFr <- varRen + cont $ TermBind x s varFr termFr + TypeBind x var ty -> do + tyFr <- PLC.renameTypeM ty + PLC.withFreshenedTyVarDecl var $ \varFr -> + cont $ TypeBind x varFr tyFr + DatatypeBind x datatype -> do + runContT (renameDatatypeCM NonRec datatype) $ \datatypeRen -> + datatypeRen >>= cont . DatatypeBind x -- | Rename a 'Binding' from a recursive family in the CPS-transformed 'ScopedRenameM' monad. -renameBindingRecCM - :: (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) - => Binding tyname name uni fun ann - -> ContT c m (m (Binding tyname name uni fun ann)) +renameBindingRecCM :: + (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) => + Binding tyname name uni fun ann -> + ContT c m (m (Binding tyname name uni fun ann)) renameBindingRecCM = \case - TermBind x s var term -> do - -- The first stage (the variable gets renamed). - varRen <- ContT $ PLC.withFreshenedVarDecl var - -- The second stage (the type of the variable and the RHS get renamed). - pure $ TermBind x s <$> varRen <*> renameTermM term - TypeBind x var ty -> do - -- The first stage (the variable gets renamed). - varFr <- ContT $ PLC.withFreshenedTyVarDecl var - -- The second stage (the RHS gets renamed). - pure $ TypeBind x varFr <$> PLC.renameTypeM ty - DatatypeBind x datatype -> do - -- The first stage. - datatypeRen <- renameDatatypeCM Rec datatype - -- The second stage. - pure $ DatatypeBind x <$> datatypeRen + TermBind x s var term -> do + -- The first stage (the variable gets renamed). + varRen <- ContT $ PLC.withFreshenedVarDecl var + -- The second stage (the type of the variable and the RHS get renamed). + pure $ TermBind x s <$> varRen <*> renameTermM term + TypeBind x var ty -> do + -- The first stage (the variable gets renamed). + varFr <- ContT $ PLC.withFreshenedTyVarDecl var + -- The second stage (the RHS gets renamed). + pure $ TypeBind x varFr <$> PLC.renameTypeM ty + DatatypeBind x datatype -> do + -- The first stage. + datatypeRen <- renameDatatypeCM Rec datatype + -- The second stage. + pure $ DatatypeBind x <$> datatypeRen -- | Replace the uniques in the names stored in a bunch of bindings by new uniques, -- save the mapping from the old uniques to the new ones, rename the RHSs and -- supply the updated bindings to a continuation. -withFreshenedBindings - :: (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) - => Recursivity - -> NonEmpty (Binding tyname name uni fun ann) - -> (NonEmpty (Binding tyname name uni fun ann) -> m c) - -> m c +withFreshenedBindings :: + (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) => + Recursivity -> + NonEmpty (Binding tyname name uni fun ann) -> + (NonEmpty (Binding tyname name uni fun ann) -> m c) -> + m c withFreshenedBindings recy binds cont = case recy of - -- Bring each binding in scope, rename its RHS straight away, collect all the results and - -- supply them to the continuation. - NonRec -> runContT (traverse renameBindingNonRecC binds) cont - -- First bring all bindinds in scope and only then rename their RHSs and - -- supply the results to the continuation. - Rec -> runContT (traverse renameBindingRecCM binds) $ sequence >=> cont + -- Bring each binding in scope, rename its RHS straight away, collect all the results and + -- supply them to the continuation. + NonRec -> runContT (traverse renameBindingNonRecC binds) cont + -- First bring all bindinds in scope and only then rename their RHSs and + -- supply the results to the continuation. + Rec -> runContT (traverse renameBindingRecCM binds) $ sequence >=> cont -- | Rename a 'Term' in the 'ScopedRenameM' monad. -renameTermM - :: (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) - => Term tyname name uni fun ann -> m (Term tyname name uni fun ann) +renameTermM :: + (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) => + Term tyname name uni fun ann -> m (Term tyname name uni fun ann) renameTermM = \case - Let x r binds term -> - withFreshenedBindings r binds $ \bindsFr -> - Let x r bindsFr <$> renameTermM term - Var x name -> - Var x <$> PLC.renameNameM name - TyAbs x name kind body -> - PLC.withFreshenedName name $ \nameFr -> - TyAbs x nameFr kind <$> renameTermM body - LamAbs x name ty body -> - PLC.withFreshenedName name $ \nameFr -> - LamAbs x nameFr <$> PLC.renameTypeM ty <*> renameTermM body - Apply x fun arg -> - Apply x <$> renameTermM fun <*> renameTermM arg - Constant x con -> - pure $ Constant x con - Builtin x bi -> - pure $ Builtin x bi - TyInst x term ty -> - TyInst x <$> renameTermM term <*> PLC.renameTypeM ty - Error x ty -> - Error x <$> PLC.renameTypeM ty - IWrap x pat arg term -> - IWrap x <$> PLC.renameTypeM pat <*> PLC.renameTypeM arg <*> renameTermM term - Unwrap x term -> - Unwrap x <$> renameTermM term - Constr x ty i es -> Constr x <$> PLC.renameTypeM ty <*> pure i <*> traverse renameTermM es - Case x ty arg cs -> Case x <$> PLC.renameTypeM ty <*> renameTermM arg <*> traverse renameTermM cs + Let x r binds term -> + withFreshenedBindings r binds $ \bindsFr -> + Let x r bindsFr <$> renameTermM term + Var x name -> + Var x <$> PLC.renameNameM name + TyAbs x name kind body -> + PLC.withFreshenedName name $ \nameFr -> + TyAbs x nameFr kind <$> renameTermM body + LamAbs x name ty body -> + PLC.withFreshenedName name $ \nameFr -> + LamAbs x nameFr <$> PLC.renameTypeM ty <*> renameTermM body + Apply x fun arg -> + Apply x <$> renameTermM fun <*> renameTermM arg + Constant x con -> + pure $ Constant x con + Builtin x bi -> + pure $ Builtin x bi + TyInst x term ty -> + TyInst x <$> renameTermM term <*> PLC.renameTypeM ty + Error x ty -> + Error x <$> PLC.renameTypeM ty + IWrap x pat arg term -> + IWrap x <$> PLC.renameTypeM pat <*> PLC.renameTypeM arg <*> renameTermM term + Unwrap x term -> + Unwrap x <$> renameTermM term + Constr x ty i es -> Constr x <$> PLC.renameTypeM ty <*> pure i <*> traverse renameTermM es + Case x ty arg cs -> Case x <$> PLC.renameTypeM ty <*> renameTermM arg <*> traverse renameTermM cs -- | Rename a 'Term' in the 'ScopedRenameM' monad. -renameProgramM - :: (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) - => Program tyname name uni fun ann -> m (Program tyname name uni fun ann) +renameProgramM :: + (MonadRename m, PLC.HasUniques (Term tyname name uni fun ann)) => + Program tyname name uni fun ann -> m (Program tyname name uni fun ann) renameProgramM (Program ann v term) = Program ann v <$> renameTermM term diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs index 94e05b8ba7c..fc5fd5ef507 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs @@ -1,15 +1,16 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -module PlutusIR.Transform.RewriteRules - ( rewriteWith - , rewritePass - , rewritePassSC - , RewriteRules - , unRewriteRules - , defaultUniRewriteRules - ) where +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module PlutusIR.Transform.RewriteRules ( + rewriteWith, + rewritePass, + rewritePassSC, + RewriteRules, + unRewriteRules, + defaultUniRewriteRules, +) where import PlutusCore qualified as PLC import PlutusCore.Core (HasUniques) @@ -24,24 +25,30 @@ import PlutusIR.Pass import PlutusIR.TypeCheck qualified as TC rewritePassSC :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , PLC.MonadQuote m, Monoid a - ) => - TC.PirTCConfig uni fun -> - RewriteRules uni fun -> - Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , PLC.MonadQuote m + , Monoid a + ) => + TC.PirTCConfig uni fun -> + RewriteRules uni fun -> + Pass m TyName Name uni fun a rewritePassSC tcconfig rules = - renamePass <> rewritePass tcconfig rules + renamePass <> rewritePass tcconfig rules rewritePass :: - forall m uni fun a. - ( PLC.Typecheckable uni fun, PLC.GEq uni, Ord a - , PLC.MonadQuote m, Monoid a - ) => - TC.PirTCConfig uni fun -> - RewriteRules uni fun -> - Pass m TyName Name uni fun a + forall m uni fun a. + ( PLC.Typecheckable uni fun + , PLC.GEq uni + , Ord a + , PLC.MonadQuote m + , Monoid a + ) => + TC.PirTCConfig uni fun -> + RewriteRules uni fun -> + Pass m TyName Name uni fun a rewritePass tcconfig rules = NamedPass "rewrite rules" $ Pass @@ -49,24 +56,24 @@ rewritePass tcconfig rules = [Typechecks tcconfig, GloballyUniqueNames] [ConstCondition (Typechecks tcconfig)] -{- | Rewrite a `Term` using the given `RewriteRules` (similar to functions of Term -> Term) -Normally the rewrite rules are configured at entrypoint time of the compiler. - -It goes without saying that the supplied rewrite rules must be type-preserving. -MAYBE: enforce this with a `through typeCheckTerm`? --} -rewriteWith :: ( Monoid a, t ~ Term tyname Name uni fun a - , HasUniques t - , MonadQuote m - ) - => RewriteRules uni fun - -> t - -> m t +-- | Rewrite a `Term` using the given `RewriteRules` (similar to functions of Term -> Term) +-- Normally the rewrite rules are configured at entrypoint time of the compiler. +-- +-- It goes without saying that the supplied rewrite rules must be type-preserving. +-- MAYBE: enforce this with a `through typeCheckTerm`? +rewriteWith :: + ( Monoid a + , t ~ Term tyname Name uni fun a + , HasUniques t + , MonadQuote m + ) => + RewriteRules uni fun -> + t -> + m t rewriteWith rules t = - -- We collect `VarsInfo` on the whole program term and pass it on as arg to each RewriteRule. - -- This has the limitation that any variables newly-introduced by the rules would - -- not be accounted in `VarsInfo`. This is currently fine, because we only rely on VarsInfo - -- for isPure; isPure is safe w.r.t "open" terms. - let vinfo = termVarInfo t - in transformMOf termSubterms (unRewriteRules rules vinfo) t - + -- We collect `VarsInfo` on the whole program term and pass it on as arg to each RewriteRule. + -- This has the limitation that any variables newly-introduced by the rules would + -- not be accounted in `VarsInfo`. This is currently fine, because we only rely on VarsInfo + -- for isPure; isPure is safe w.r.t "open" terms. + let vinfo = termVarInfo t + in transformMOf termSubterms (unRewriteRules rules vinfo) t diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Common.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Common.hs index 0694f3be1bc..7d269adc207 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Common.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Common.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeOperators #-} -module PlutusIR.Transform.RewriteRules.Common - ( seqA - , seqP - , mkFreshTermLet -- from MkPlc - , pattern A - , pattern B - , pattern I - ) where +{-# LANGUAGE TypeOperators #-} + +module PlutusIR.Transform.RewriteRules.Common ( + seqA, + seqP, + mkFreshTermLet, -- from MkPlc + pattern A, + pattern B, + pattern I, +) where import PlutusCore.Builtin import PlutusCore.Quote @@ -18,64 +19,71 @@ import PlutusIR.Analysis.VarInfo import PlutusIR.MkPir import PlutusIR.Purity -{- | A wrapper that can be more easily turned into an infix operator. - -e.g. `infixr 5 (***) = seqA binfo vInfo` --} -seqA :: (MonadQuote m, Monoid a, ToBuiltinMeaning uni fun) - => BuiltinsInfo uni fun - -> VarsInfo tyname Name uni a - -> (Type tyname uni a, Term tyname Name uni fun a) - -> m (Term tyname Name uni fun a) - -> m (Term tyname Name uni fun a) -seqA binfo vinfo (a,aT) y = seqOpt binfo vinfo a aT <*> y - +-- | A wrapper that can be more easily turned into an infix operator. +-- +-- e.g. `infixr 5 (***) = seqA binfo vInfo` +seqA :: + (MonadQuote m, Monoid a, ToBuiltinMeaning uni fun) => + BuiltinsInfo uni fun -> + VarsInfo tyname Name uni a -> + (Type tyname uni a, Term tyname Name uni fun a) -> + m (Term tyname Name uni fun a) -> + m (Term tyname Name uni fun a) +seqA binfo vinfo (a, aT) y = seqOpt binfo vinfo a aT <*> y -{- | Another "infix" wrapper where second operand is a Haskell pure value. - -e.g. `infixr 5 (***) = seqP binfo vInfo` --} -seqP :: (MonadQuote m, Monoid a, ToBuiltinMeaning uni fun) - => BuiltinsInfo uni fun - -> VarsInfo tyname Name uni a - -> (Type tyname uni a, Term tyname Name uni fun a) - -> Term tyname Name uni fun a - -> m (Term tyname Name uni fun a) +-- | Another "infix" wrapper where second operand is a Haskell pure value. +-- +-- e.g. `infixr 5 (***) = seqP binfo vInfo` +seqP :: + (MonadQuote m, Monoid a, ToBuiltinMeaning uni fun) => + BuiltinsInfo uni fun -> + VarsInfo tyname Name uni a -> + (Type tyname uni a, Term tyname Name uni fun a) -> + Term tyname Name uni fun a -> + m (Term tyname Name uni fun a) seqP binfo vinfo p y = seqA binfo vinfo p (pure y) -- | An optimized version to omit call to `seq` if left operand `isPure`. -seqOpt :: ( MonadQuote m - , Monoid a - , ToBuiltinMeaning uni fun - , t ~ Term tyname Name uni fun a - ) - => BuiltinsInfo uni fun - -> VarsInfo tyname Name uni a - -> Type tyname uni a -- ^ the type of left operand a - -> t -- ^ left operand a - -> m (t -> t) -- ^ how to modify right operand b -seqOpt binfo vinfo aT a | isPure binfo vinfo a = pure id - | otherwise = seqUnOpt aT a - -{- | Takes as input a term `a` with its type `aT`, -and constructs a function that expects another term `b`. -When the returned function is applied to a term, the execution of the applied term -would strictly evaluate the first term `a` only for its effects (i.e. ignoring its result) -while returning the result of the second term `b`. - -The name is intentionally taken from Haskell's `GHC.Prim.seq`. -Currently, the need for this `seq` "combinator" is in `RewriteRules`, -to trying to retain the effects, that would otherwise be lost if that code was instead considered -completely dead. +seqOpt :: + ( MonadQuote m + , Monoid a + , ToBuiltinMeaning uni fun + , t ~ Term tyname Name uni fun a + ) => + BuiltinsInfo uni fun -> + VarsInfo tyname Name uni a -> + -- | the type of left operand a + Type tyname uni a -> + -- | left operand a + t -> + -- | how to modify right operand b + m (t -> t) +seqOpt binfo vinfo aT a + | isPure binfo vinfo a = pure id + | otherwise = seqUnOpt aT a -Unfortunately, unlike Haskell's `seq`, we need the pass the correct `Type` of `a`, -so as to apply this `seq` combinator. This is usually not a problem because we are generating -code and we should have the type of `a` somewhere available. --} -seqUnOpt :: (MonadQuote m, Monoid a, t ~ Term tyname Name uni fun a) - => Type tyname uni a -- ^ the type of left operand a - -> t -- ^ left operand a - -> m (t -> t) -- ^ how to modify right operand b +-- | Takes as input a term `a` with its type `aT`, +-- and constructs a function that expects another term `b`. +-- When the returned function is applied to a term, the execution of the applied term +-- would strictly evaluate the first term `a` only for its effects (i.e. ignoring its result) +-- while returning the result of the second term `b`. +-- +-- The name is intentionally taken from Haskell's `GHC.Prim.seq`. +-- Currently, the need for this `seq` "combinator" is in `RewriteRules`, +-- to trying to retain the effects, that would otherwise be lost if that code was instead considered +-- completely dead. +-- +-- Unfortunately, unlike Haskell's `seq`, we need the pass the correct `Type` of `a`, +-- so as to apply this `seq` combinator. This is usually not a problem because we are generating +-- code and we should have the type of `a` somewhere available. +seqUnOpt :: + (MonadQuote m, Monoid a, t ~ Term tyname Name uni fun a) => + -- | the type of left operand a + Type tyname uni a -> + -- | left operand a + t -> + -- | how to modify right operand b + m (t -> t) seqUnOpt aT a = snd <$> mkFreshTermLet aT a -- Some shorthands for easier pattern-matching when creating rewrite rules diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs index ffd06e9bc2b..12a93125825 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs @@ -1,159 +1,157 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeOperators #-} -{- | Commute such that constants are the first arguments. Consider: - -(1) equalsInteger 1 x - -(2) equalsInteger x 1 - -We have unary application, so these are two partial applications: - -(1) (equalsInteger 1) x - -(2) (equalsInteger x) 1 - -With (1), we can share the `equalsInteger 1` node, and it will be the same across any place where -we do this. - -With (2), both the nodes here include x, which is a variable that will likely be different in other -invocations of `equalsInteger`. So the second one is harder to share, which is worse for CSE. - -So commuting `equalsInteger` so that it has the constant first both a) makes various occurrences of -`equalsInteger` more likely to look similar, and b) gives us a maximally-shareable node for CSE. - -This applies to any commutative builtin function that takes constants as arguments, although we -might expect that `equalsInteger` is the one that will benefit the most. -Plutonomy only commutes `EqualsInteger` in their `commEquals`. --} - -module PlutusIR.Transform.RewriteRules.CommuteFnWithConst - ( commuteFnWithConst - ) where +-- | Commute such that constants are the first arguments. Consider: +-- +-- (1) equalsInteger 1 x +-- +-- (2) equalsInteger x 1 +-- +-- We have unary application, so these are two partial applications: +-- +-- (1) (equalsInteger 1) x +-- +-- (2) (equalsInteger x) 1 +-- +-- With (1), we can share the `equalsInteger 1` node, and it will be the same across any place where +-- we do this. +-- +-- With (2), both the nodes here include x, which is a variable that will likely be different in other +-- invocations of `equalsInteger`. So the second one is harder to share, which is worse for CSE. +-- +-- So commuting `equalsInteger` so that it has the constant first both a) makes various occurrences of +-- `equalsInteger` more likely to look similar, and b) gives us a maximally-shareable node for CSE. +-- +-- This applies to any commutative builtin function that takes constants as arguments, although we +-- might expect that `equalsInteger` is the one that will benefit the most. +-- Plutonomy only commutes `EqualsInteger` in their `commEquals`. +module PlutusIR.Transform.RewriteRules.CommuteFnWithConst ( + commuteFnWithConst, +) where import PlutusCore.Default import PlutusIR.Core.Type (Term (Apply, Builtin, Constant)) isConstant :: Term tyname name uni fun a -> Bool isConstant = \case - Constant{} -> True - _ -> False + Constant {} -> True + _ -> False -commuteFnWithConst :: (t ~ Term tyname name uni DefaultFun a) => t -> t +commuteFnWithConst :: t ~ Term tyname name uni DefaultFun a => t -> t commuteFnWithConst = \case - Apply ann1 (Apply ann2 (Builtin ann3 fun) arg1) arg2 - | isCommutative fun - , not (isConstant arg1) - , isConstant arg2 - -> Apply ann1 (Apply ann2 (Builtin ann3 fun) arg2) arg1 - t -> t + Apply ann1 (Apply ann2 (Builtin ann3 fun) arg1) arg2 + | isCommutative fun + , not (isConstant arg1) + , isConstant arg2 -> + Apply ann1 (Apply ann2 (Builtin ann3 fun) arg2) arg1 + t -> t -- | Returns whether a `DefaultFun` is commutative. Not using -- catchall to make sure that this function catches newly added `DefaultFun`. isCommutative :: DefaultFun -> Bool isCommutative = \case - AddInteger -> True - MultiplyInteger -> True - EqualsInteger -> True - EqualsByteString -> True - EqualsString -> True - EqualsData -> True + AddInteger -> True + MultiplyInteger -> True + EqualsInteger -> True + EqualsByteString -> True + EqualsString -> True + EqualsData -> True -- verbose laid down, to revisit this function if a new builtin is added - SubtractInteger -> False - DivideInteger -> False - QuotientInteger -> False - RemainderInteger -> False - ModInteger -> False - LessThanInteger -> False - LessThanEqualsInteger -> False - AppendByteString -> False - ConsByteString -> False - SliceByteString -> False - LengthOfByteString -> False - IndexByteString -> False - LessThanByteString -> False - LessThanEqualsByteString -> False - Sha2_256 -> False - Sha3_256 -> False - Blake2b_224 -> False - Blake2b_256 -> False - Keccak_256 -> False - Ripemd_160 -> False - VerifyEd25519Signature -> False - VerifyEcdsaSecp256k1Signature -> False + SubtractInteger -> False + DivideInteger -> False + QuotientInteger -> False + RemainderInteger -> False + ModInteger -> False + LessThanInteger -> False + LessThanEqualsInteger -> False + AppendByteString -> False + ConsByteString -> False + SliceByteString -> False + LengthOfByteString -> False + IndexByteString -> False + LessThanByteString -> False + LessThanEqualsByteString -> False + Sha2_256 -> False + Sha3_256 -> False + Blake2b_224 -> False + Blake2b_256 -> False + Keccak_256 -> False + Ripemd_160 -> False + VerifyEd25519Signature -> False + VerifyEcdsaSecp256k1Signature -> False VerifySchnorrSecp256k1Signature -> False - Bls12_381_G1_add -> False - Bls12_381_G1_neg -> False - Bls12_381_G1_scalarMul -> False - Bls12_381_G1_multiScalarMul -> False - Bls12_381_G1_equal -> False - Bls12_381_G1_hashToGroup -> False - Bls12_381_G1_compress -> False - Bls12_381_G1_uncompress -> False - Bls12_381_G2_add -> False - Bls12_381_G2_neg -> False - Bls12_381_G2_scalarMul -> False - Bls12_381_G2_multiScalarMul -> False - Bls12_381_G2_equal -> False - Bls12_381_G2_hashToGroup -> False - Bls12_381_G2_compress -> False - Bls12_381_G2_uncompress -> False - Bls12_381_millerLoop -> False - Bls12_381_mulMlResult -> False - Bls12_381_finalVerify -> False - AppendString -> False - EncodeUtf8 -> False - DecodeUtf8 -> False - IfThenElse -> False - ChooseUnit -> False - Trace -> False - FstPair -> False - SndPair -> False - ChooseList -> False - MkCons -> False - HeadList -> False - TailList -> False - NullList -> False - LengthOfArray -> False - ListToArray -> False - IndexArray -> False - ChooseData -> False - ConstrData -> False - MapData -> False - ListData -> False - IData -> False - BData -> False - UnConstrData -> False - UnMapData -> False - UnListData -> False - UnIData -> False - UnBData -> False - SerialiseData -> False - MkPairData -> False - MkNilData -> False - MkNilPairData -> False - IntegerToByteString -> False - ByteStringToInteger -> False + Bls12_381_G1_add -> False + Bls12_381_G1_neg -> False + Bls12_381_G1_scalarMul -> False + Bls12_381_G1_multiScalarMul -> False + Bls12_381_G1_equal -> False + Bls12_381_G1_hashToGroup -> False + Bls12_381_G1_compress -> False + Bls12_381_G1_uncompress -> False + Bls12_381_G2_add -> False + Bls12_381_G2_neg -> False + Bls12_381_G2_scalarMul -> False + Bls12_381_G2_multiScalarMul -> False + Bls12_381_G2_equal -> False + Bls12_381_G2_hashToGroup -> False + Bls12_381_G2_compress -> False + Bls12_381_G2_uncompress -> False + Bls12_381_millerLoop -> False + Bls12_381_mulMlResult -> False + Bls12_381_finalVerify -> False + AppendString -> False + EncodeUtf8 -> False + DecodeUtf8 -> False + IfThenElse -> False + ChooseUnit -> False + Trace -> False + FstPair -> False + SndPair -> False + ChooseList -> False + MkCons -> False + HeadList -> False + TailList -> False + NullList -> False + LengthOfArray -> False + ListToArray -> False + IndexArray -> False + ChooseData -> False + ConstrData -> False + MapData -> False + ListData -> False + IData -> False + BData -> False + UnConstrData -> False + UnMapData -> False + UnListData -> False + UnIData -> False + UnBData -> False + SerialiseData -> False + MkPairData -> False + MkNilData -> False + MkNilPairData -> False + IntegerToByteString -> False + ByteStringToInteger -> False -- Currently, this requires commutativity in all arguments, which the -- logical and bitwise operations are not. - AndByteString -> False - OrByteString -> False - XorByteString -> False - ComplementByteString -> False - ReadBit -> False - WriteBits -> False - ReplicateByte -> False - ShiftByteString -> False - RotateByteString -> False - CountSetBits -> False - FindFirstSetBit -> False - ExpModInteger -> False - DropList -> False - InsertCoin -> False - LookupCoin -> False - UnionValue -> True - ValueContains -> False - ValueData -> False - UnValueData -> False - ScaleValue -> False + AndByteString -> False + OrByteString -> False + XorByteString -> False + ComplementByteString -> False + ReadBit -> False + WriteBits -> False + ReplicateByte -> False + ShiftByteString -> False + RotateByteString -> False + CountSetBits -> False + FindFirstSetBit -> False + ExpModInteger -> False + DropList -> False + InsertCoin -> False + LookupCoin -> False + UnionValue -> True + ValueContains -> False + ValueData -> False + UnValueData -> False + ScaleValue -> False diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Internal.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Internal.hs index 9b57d2d60ab..708253b8e36 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Internal.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Internal.hs @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} -module PlutusIR.Transform.RewriteRules.Internal - ( RewriteRules (..) - , defaultUniRewriteRules - ) where +module PlutusIR.Transform.RewriteRules.Internal ( + RewriteRules (..), + defaultUniRewriteRules, +) where import PlutusCore.Default (DefaultFun, DefaultUni) import PlutusCore.Name.Unique (Name) @@ -18,15 +18,15 @@ import PlutusPrelude (Default (..), (>=>)) -- | A bundle of composed `RewriteRules`, to be passed at entrypoint of the compiler. newtype RewriteRules uni fun where - RewriteRules - :: { unRewriteRules - :: forall tyname m a - . (MonadQuote m, Monoid a) - => VarsInfo tyname Name uni a - -> PIR.Term tyname Name uni fun a - -> m (PIR.Term tyname Name uni fun a) - } - -> RewriteRules uni fun + RewriteRules :: + { unRewriteRules :: + forall tyname m a. + (MonadQuote m, Monoid a) => + VarsInfo tyname Name uni a -> + PIR.Term tyname Name uni fun a -> + m (PIR.Term tyname Name uni fun a) + } -> + RewriteRules uni fun -- | The rules for the Default Universe/Builtin. defaultUniRewriteRules :: RewriteRules DefaultUni DefaultFun diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/RemoveTrace.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/RemoveTrace.hs index 89a12a2000a..89cc6c69d13 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/RemoveTrace.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/RemoveTrace.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} -module PlutusIR.Transform.RewriteRules.RemoveTrace - ( rewriteRuleRemoveTrace - ) where +module PlutusIR.Transform.RewriteRules.RemoveTrace ( + rewriteRuleRemoveTrace, +) where import PlutusCore.Default (DefaultFun) import PlutusCore.Default.Builtins qualified as Builtin diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/UnConstrConstrData.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/UnConstrConstrData.hs index fd570e98702..7fc976d291a 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/UnConstrConstrData.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/UnConstrConstrData.hs @@ -1,9 +1,10 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} -module PlutusIR.Transform.RewriteRules.UnConstrConstrData - ( unConstrConstrData - ) where + +module PlutusIR.Transform.RewriteRules.UnConstrConstrData ( + unConstrConstrData, +) where import PlutusCore.Default import PlutusCore.Quote @@ -12,48 +13,48 @@ import PlutusIR.Analysis.Builtins import PlutusIR.Analysis.VarInfo import PlutusIR.Transform.RewriteRules.Common -{- | This rule rewrites terms of form `BUILTIN(unConstrData(constrData(x,y)))` -, where builtin stands for `FstPair` or `SndPair`, to "x" or "y" respectively. - -This rewrite-rule was originally meant to rewrite `unConstrData(constrData(x,y)) => (x,y)`, -however we do not have a (polymorphic or monomorphic) builtin constructor to create a `BuiltinPair` -"(x,y)". See Note [Representable built-in functions over polymorphic built-in types]. - -So we adapted the original rewrite rule to try to achieve a similar goal. -Unfortunately, the adapted rule is less applicable and will most likely never fire -(at least for PIR code generated by plutus-tx). -The reason is that the TH code in plutus-tx does not create such "tight" code, but uses -way more lets that get in the way preventing the rule from firing. - -Possible solutions: Some more aggressive PIR inlining, rewriting the PlutusTx TH code, or -introducing specialised pattern-matching builtins as last resort. -Plutus Tx TH code responsible: - --} -unConstrConstrData :: (MonadQuote m, t ~ Term tyname Name DefaultUni DefaultFun a, Monoid a) - => BuiltinsInfo DefaultUni DefaultFun - -> VarsInfo tyname Name DefaultUni a - -> t - -> m t +-- | This rule rewrites terms of form `BUILTIN(unConstrData(constrData(x,y)))` +-- , where builtin stands for `FstPair` or `SndPair`, to "x" or "y" respectively. +-- +-- This rewrite-rule was originally meant to rewrite `unConstrData(constrData(x,y)) => (x,y)`, +-- however we do not have a (polymorphic or monomorphic) builtin constructor to create a `BuiltinPair` +-- "(x,y)". See Note [Representable built-in functions over polymorphic built-in types]. +-- +-- So we adapted the original rewrite rule to try to achieve a similar goal. +-- Unfortunately, the adapted rule is less applicable and will most likely never fire +-- (at least for PIR code generated by plutus-tx). +-- The reason is that the TH code in plutus-tx does not create such "tight" code, but uses +-- way more lets that get in the way preventing the rule from firing. +-- +-- Possible solutions: Some more aggressive PIR inlining, rewriting the PlutusTx TH code, or +-- introducing specialised pattern-matching builtins as last resort. +-- Plutus Tx TH code responsible: +-- +unConstrConstrData :: + (MonadQuote m, t ~ Term tyname Name DefaultUni DefaultFun a, Monoid a) => + BuiltinsInfo DefaultUni DefaultFun -> + VarsInfo tyname Name DefaultUni a -> + t -> + m t unConstrConstrData binfo vinfo t = case t of - -- This rule might as well have been split into two separate rules, but kept as one - -- so as to reuse most of the matching pattern. - - -- builtin({t1}, {t2}, unConstr(constrData(i, data))) - (A (I (I (B builtin) tyFst) tySnd) - (A (B UnConstrData) (A (A (B ConstrData) arg1) arg2))) -> - case builtin of - -- sndPair({t1}, {t2}, unConstr(constrData(i, data))) = i `seq` data - SndPair -> (tyFst,arg1) `seQ` arg2 - - -- fstPair({t1}, {t2}, unConstr(constrData(i, data))) = let !gen = i in data `seq` gen - FstPair -> do - (genVar, genLetIn) <- mkFreshTermLet tyFst arg1 - genLetIn <$> - (tySnd, arg2) `seQ` genVar - _ -> pure t - _ -> pure t - + -- This rule might as well have been split into two separate rules, but kept as one + -- so as to reuse most of the matching pattern. + + -- builtin({t1}, {t2}, unConstr(constrData(i, data))) + ( A + (I (I (B builtin) tyFst) tySnd) + (A (B UnConstrData) (A (A (B ConstrData) arg1) arg2)) + ) -> + case builtin of + -- sndPair({t1}, {t2}, unConstr(constrData(i, data))) = i `seq` data + SndPair -> (tyFst, arg1) `seQ` arg2 + -- fstPair({t1}, {t2}, unConstr(constrData(i, data))) = let !gen = i in data `seq` gen + FstPair -> do + (genVar, genLetIn) <- mkFreshTermLet tyFst arg1 + genLetIn + <$> (tySnd, arg2) `seQ` genVar + _ -> pure t + _ -> pure t where - infixr 5 `seQ` -- 5 so it has more precedence than <$> - seQ = seqP binfo vinfo + infixr 5 `seQ` -- 5 so it has more precedence than <$> + seQ = seqP binfo vinfo diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/StrictifyBindings.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/StrictifyBindings.hs index 7ad2af9f1cd..e250ab1741c 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/StrictifyBindings.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/StrictifyBindings.hs @@ -1,14 +1,14 @@ {-# LANGUAGE LambdaCase #-} -{-| -Pass to convert the following non-strict bindings into strict bindings, which have less overhead: - * non-strict bindings whose RHSs are pure - * non-strict bindings that are strict in the body --} +-- | +-- Pass to convert the following non-strict bindings into strict bindings, which have less overhead: +-- +-- * non-strict bindings whose RHSs are pure +-- * non-strict bindings that are strict in the body module PlutusIR.Transform.StrictifyBindings ( strictifyBindings, - strictifyBindingsPass - ) where + strictifyBindingsPass, +) where import PlutusCore.Builtin import PlutusIR @@ -23,27 +23,30 @@ import PlutusIR.Analysis.VarInfo import PlutusIR.Pass import PlutusIR.TypeCheck qualified as TC -strictifyBindingsStep - :: (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique, Eq name) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Term tyname name uni fun a - -> Term tyname name uni fun a +strictifyBindingsStep :: + (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique, Eq name) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + Term tyname name uni fun a strictifyBindingsStep binfo vinfo = \case - Let a s bs t -> Let a s (fmap strictifyBinding bs) t - where - strictifyBinding (TermBind x NonStrict vd rhs) - | isPure binfo vinfo rhs = TermBind x Strict vd rhs - | isStrictIn (vd ^. PLC.varDeclName) t = TermBind x Strict vd rhs - strictifyBinding b = b - t -> t + Let a s bs t -> Let a s (fmap strictifyBinding bs) t + where + strictifyBinding (TermBind x NonStrict vd rhs) + | isPure binfo vinfo rhs = TermBind x Strict vd rhs + | isStrictIn (vd ^. PLC.varDeclName) t = TermBind x Strict vd rhs + strictifyBinding b = b + t -> t -strictifyBindings - :: (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique - , PLC.HasUnique tyname PLC.TypeUnique, Eq name) - => BuiltinsInfo uni fun - -> Term tyname name uni fun a - -> Term tyname name uni fun a +strictifyBindings :: + ( ToBuiltinMeaning uni fun + , PLC.HasUnique name PLC.TermUnique + , PLC.HasUnique tyname PLC.TypeUnique + , Eq name + ) => + BuiltinsInfo uni fun -> + Term tyname name uni fun a -> + Term tyname name uni fun a strictifyBindings binfo term = transformOf termSubterms @@ -51,11 +54,11 @@ strictifyBindings binfo term = term strictifyBindingsPass :: - forall m uni fun a. - (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => - TC.PirTCConfig uni fun -> - BuiltinsInfo uni fun -> - Pass m TyName Name uni fun a + forall m uni fun a. + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun a strictifyBindingsPass tcconfig binfo = NamedPass "strictify bindings" $ Pass diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/ThunkRecursions.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/ThunkRecursions.hs index 9d3e5b16415..5e1b8b7a9c0 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/ThunkRecursions.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/ThunkRecursions.hs @@ -1,6 +1,7 @@ -- editorconfig-checker-disable-file {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} + -- | Implements a PIR-to-PIR transformation that makes all recursive term definitions -- compilable to PLC. See Note [Thunking recursions] for details. module PlutusIR.Transform.ThunkRecursions (thunkRecursions, thunkRecursionsPass) where @@ -109,46 +110,47 @@ any kind of strictness analysis). isTyFun :: Type tyname uni a -> Bool isTyFun = \case - TyFun {} -> True - _ -> False + TyFun {} -> True + _ -> False nonStrictifyB :: Binding tyname name uni fun a -> Binding tyname name uni fun a nonStrictifyB = \case - TermBind x _ d rhs -> TermBind x NonStrict d rhs - b -> b + TermBind x _ d rhs -> TermBind x NonStrict d rhs + b -> b -- Out of a binding `(vardecl x = rhs)`, make a "strictifier" binding: `(strict vardecl x = x)` mkStrictifierB :: Binding tyname name uni fun a -> Binding tyname name uni fun a mkStrictifierB = \case - TermBind x _ d _ -> TermBind x Strict d (mkVar d) - b -> b - -thunkRecursionsStep - :: forall tyname name uni fun a - . (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) - => BuiltinsInfo uni fun - -> VarsInfo tyname name uni a - -> Term tyname name uni fun a - -> Term tyname name uni fun a + TermBind x _ d _ -> TermBind x Strict d (mkVar d) + b -> b + +thunkRecursionsStep :: + forall tyname name uni fun a. + (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique) => + BuiltinsInfo uni fun -> + VarsInfo tyname name uni a -> + Term tyname name uni fun a -> + Term tyname name uni fun a thunkRecursionsStep binfo vinfo = \case - -- only apply the transformation if there is at least 1 problematic binding in a letrec group - Let a Rec bs t | any isProblematic bs -> - -- See Note [Thunking recursions] - let (toNonStrictify, rest) = NE.partition needsNonStrictify bs - -- MAYBE: use some prism/traversal to keep the original arrangement of the let group - -- this is not a semantic problem, but just a stylistic/debugging issue where the original - -- let-group will have reordered the (lazified) bindings - editedLet = mkLet a Rec $ fmap nonStrictifyB toNonStrictify ++ rest - -- We insert strictifiers for all previously thunkified - strictifiers = mkStrictifierB <$> toNonStrictify - extraLet = mkLet a NonRec strictifiers - in editedLet $ extraLet t + -- only apply the transformation if there is at least 1 problematic binding in a letrec group + Let a Rec bs t + | any isProblematic bs -> + -- See Note [Thunking recursions] + let (toNonStrictify, rest) = NE.partition needsNonStrictify bs + -- MAYBE: use some prism/traversal to keep the original arrangement of the let group + -- this is not a semantic problem, but just a stylistic/debugging issue where the original + -- let-group will have reordered the (lazified) bindings + editedLet = mkLet a Rec $ fmap nonStrictifyB toNonStrictify ++ rest + -- We insert strictifiers for all previously thunkified + strictifiers = mkStrictifierB <$> toNonStrictify + extraLet = mkLet a NonRec strictifiers + in editedLet $ extraLet t t -> t where isStrictEffectful :: Binding tyname name uni fun a -> Bool isStrictEffectful = \case - TermBind _ Strict _ rhs -> not $ isPure binfo vinfo rhs - _ -> False + TermBind _ Strict _ rhs -> not $ isPure binfo vinfo rhs + _ -> False needsNonStrictify :: Binding tyname name uni fun a -> Bool needsNonStrictify b = isProblematic b || isStrictEffectful b @@ -156,23 +158,23 @@ thunkRecursionsStep binfo vinfo = \case -- | The problematic bindings are those that are strict and their type is not a TyFun isProblematic :: Binding tyname name uni fun a -> Bool isProblematic = \case - TermBind _ Strict (VarDecl _ _ ty) _ -> not $ isTyFun ty - _ -> False + TermBind _ Strict (VarDecl _ _ ty) _ -> not $ isTyFun ty + _ -> False -- | Thunk recursions to turn recusive values of non-function type into recursive values of function type, -- so we can compile them. -- -- Note: this pass breaks global uniqueness! -thunkRecursions - :: (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) - => BuiltinsInfo uni fun - -> Term tyname name uni fun a - -> Term tyname name uni fun a +thunkRecursions :: + (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique) => + BuiltinsInfo uni fun -> + Term tyname name uni fun a -> + Term tyname name uni fun a thunkRecursions binfo t = transformOf termSubterms (thunkRecursionsStep binfo (termVarInfo t)) t -thunkRecursionsPass - :: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) - => TC.PirTCConfig uni fun - -> BuiltinsInfo uni fun - -> Pass m TyName Name uni fun a +thunkRecursionsPass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => + TC.PirTCConfig uni fun -> + BuiltinsInfo uni fun -> + Pass m TyName Name uni fun a thunkRecursionsPass tcconfig binfo = simplePass "thunk recursions" tcconfig (thunkRecursions binfo) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Unwrap.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Unwrap.hs index 57af11bd623..83edc956f08 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Unwrap.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Unwrap.hs @@ -1,16 +1,16 @@ {-# LANGUAGE LambdaCase #-} -{-| -A trivial simplification that cancels unwrap/wrap pairs. -This can only occur if we've inlined both datatype constructors and destructors -and we're deconstructing something we just constructed. This is probably rare, -and should anyway better be handled by something like case-of-known constructor. -But it's so simple we might as well include it just in case. --} +-- | +-- A trivial simplification that cancels unwrap/wrap pairs. +-- +-- This can only occur if we've inlined both datatype constructors and destructors +-- and we're deconstructing something we just constructed. This is probably rare, +-- and should anyway better be handled by something like case-of-known constructor. +-- But it's so simple we might as well include it just in case. module PlutusIR.Transform.Unwrap ( unwrapCancel, - unwrapCancelPass - ) where + unwrapCancelPass, +) where import PlutusIR @@ -19,26 +19,24 @@ import PlutusCore qualified as PLC import PlutusIR.Pass import PlutusIR.TypeCheck qualified as TC -{-| -A single non-recursive application of wrap/unwrap cancellation. --} -unwrapCancelStep - :: Term tyname name uni fun a - -> Term tyname name uni fun a +-- | +-- A single non-recursive application of wrap/unwrap cancellation. +unwrapCancelStep :: + Term tyname name uni fun a -> + Term tyname name uni fun a unwrapCancelStep = \case - Unwrap _ (IWrap _ _ _ b) -> b - t -> t + Unwrap _ (IWrap _ _ _ b) -> b + t -> t -{-| -Recursively apply wrap/unwrap cancellation. --} -unwrapCancel - :: Term tyname name uni fun a - -> Term tyname name uni fun a +-- | +-- Recursively apply wrap/unwrap cancellation. +unwrapCancel :: + Term tyname name uni fun a -> + Term tyname name uni fun a unwrapCancel = transformOf termSubterms unwrapCancelStep -unwrapCancelPass - :: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) - => TC.PirTCConfig uni fun - -> Pass m TyName Name uni fun a +unwrapCancelPass :: + (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m) => + TC.PirTCConfig uni fun -> + Pass m TyName Name uni fun a unwrapCancelPass tcconfig = simplePass "wrap-unwrap cancel" tcconfig unwrapCancel diff --git a/plutus-core/plutus-ir/src/PlutusIR/TypeCheck.hs b/plutus-core/plutus-ir/src/PlutusIR/TypeCheck.hs index ae888f0869f..94f3a49eda3 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/TypeCheck.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/TypeCheck.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | Kind/type inference/checking, mirroring PlutusCore.TypeCheck @@ -67,25 +67,23 @@ getDefTypeCheckConfig ann = do configPlc <- PLC.getDefTypeCheckConfig ann pure $ PirTCConfig configPlc YesEscape -{- | Infer the type of a term. -Note: The "inferred type" can escape its scope if YesEscape config is passed, see -[PIR vs Paper Escaping Types Difference] --} +-- | Infer the type of a term. +-- Note: The "inferred type" can escape its scope if YesEscape config is passed, see +-- [PIR vs Paper Escaping Types Difference] inferType :: - (MonadTypeCheckPir uni fun ann m) => + MonadTypeCheckPir uni fun ann m => PirTCConfig uni fun -> Term TyName Name uni fun ann -> m (Normalized (Type TyName uni ())) inferType config = rename >=> runTypeCheckM config . inferTypeM -{- | Check a term against a type. -Infers the type of the term and checks that it's equal to the given type -throwing a 'TypeError' (annotated with the value of the @ann@ argument) otherwise. -Note: this may allow witnessing a type that escapes its scope, see -[PIR vs Paper Escaping Types Difference] --} +-- | Check a term against a type. +-- Infers the type of the term and checks that it's equal to the given type +-- throwing a 'TypeError' (annotated with the value of the @ann@ argument) otherwise. +-- Note: this may allow witnessing a type that escapes its scope, see +-- [PIR vs Paper Escaping Types Difference] checkType :: - (MonadTypeCheckPir uni fun ann m) => + MonadTypeCheckPir uni fun ann m => PirTCConfig uni fun -> ann -> Term TyName Name uni fun ann -> @@ -95,25 +93,23 @@ checkType config ann term ty = do termRen <- rename term runTypeCheckM config $ checkTypeM ann termRen ty -{- | Infer the type of a program. -Note: The "inferred type" can escape its scope if YesEscape config is passed, see -[PIR vs Paper Escaping Types Difference] --} +-- | Infer the type of a program. +-- Note: The "inferred type" can escape its scope if YesEscape config is passed, see +-- [PIR vs Paper Escaping Types Difference] inferTypeOfProgram :: - (MonadTypeCheckPir uni fun ann m) => + MonadTypeCheckPir uni fun ann m => PirTCConfig uni fun -> Program TyName Name uni fun ann -> m (Normalized (Type TyName uni ())) inferTypeOfProgram config (Program _ _ term) = inferType config term -{- | Check a program against a type. -Infers the type of the program and checks that it's equal to the given type -throwing a 'TypeError' (annotated with the value of the @ann@ argument) otherwise. -Note: this may allow witnessing a type that escapes its scope, see -[PIR vs Paper Escaping Types Difference] --} +-- | Check a program against a type. +-- Infers the type of the program and checks that it's equal to the given type +-- throwing a 'TypeError' (annotated with the value of the @ann@ argument) otherwise. +-- Note: this may allow witnessing a type that escapes its scope, see +-- [PIR vs Paper Escaping Types Difference] checkTypeOfProgram :: - (MonadTypeCheckPir uni fun ann m) => + MonadTypeCheckPir uni fun ann m => PirTCConfig uni fun -> ann -> Program TyName Name uni fun ann -> diff --git a/plutus-core/plutus-ir/src/PlutusIR/TypeCheck/Internal.hs b/plutus-core/plutus-ir/src/PlutusIR/TypeCheck/Internal.hs index 7be5f85e71d..dcedfba1682 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/TypeCheck/Internal.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/TypeCheck/Internal.hs @@ -1,27 +1,26 @@ -- editorconfig-checker-disable-file --- | The internal module of the type checker that defines the actual algorithms, --- but not the user-facing API. - -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -module PlutusIR.TypeCheck.Internal - ( BuiltinTypes (..) - , TypeCheckConfig (..) - , TypeCheckT - , MonadKindCheck - , MonadTypeCheck - , MonadTypeCheckPir - , tccBuiltinTypes - , PirTCConfig (..) - , AllowEscape (..) - , inferTypeM - , checkTypeM - , runTypeCheckM - ) where +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | The internal module of the type checker that defines the actual algorithms, +-- but not the user-facing API. +module PlutusIR.TypeCheck.Internal ( + BuiltinTypes (..), + TypeCheckConfig (..), + TypeCheckT, + MonadKindCheck, + MonadTypeCheck, + MonadTypeCheckPir, + tccBuiltinTypes, + PirTCConfig (..), + AllowEscape (..), + inferTypeM, + checkTypeM, + runTypeCheckM, +) where import PlutusPrelude @@ -39,12 +38,14 @@ import PlutusCore.Builtin (annotateCaseBuiltin) import PlutusCore.Core qualified as PLC import PlutusCore.Error as PLC import PlutusCore.MkPlc (mkIterTyFun) + -- we mirror inferTypeM, checkTypeM of plc-tc and extend it for plutus-ir terms import PlutusCore.TypeCheck.Internal hiding (checkTypeM, inferTypeM, runTypeCheckM) import Control.Monad (when) import Control.Monad.Except import Data.Text qualified as Text + -- Using @transformers@ rather than @mtl@, because the former doesn't impose the 'Monad' constraint -- on 'local'. import Control.Lens ((^?)) @@ -107,8 +108,7 @@ type PirTCEnv uni fun m = TypeCheckT uni fun (PirTCConfig uni fun) m -- | The constraints that are required for type checking Plutus IR. type MonadTypeCheckPir uni fun ann m = - ( MonadTypeCheck (PIR.Error uni fun ann) (Term TyName Name uni fun ()) uni fun ann m - ) + (MonadTypeCheck (PIR.Error uni fun ann) (Term TyName Name uni fun ()) uni fun ann m) -- ########################### -- ## Port of Type checking ## @@ -117,154 +117,152 @@ type MonadTypeCheckPir uni fun ann m = -- See Note [Global uniqueness in the type checker]. -- See Note [Typing rules]. --- | Check a 'Term' against a 'NormalizedType'. -checkTypeM - :: MonadTypeCheckPir uni fun ann m - => ann - -> Term TyName Name uni fun ann - -> Normalized (Type TyName uni ()) - -> PirTCEnv uni fun m () +-- | Check a 'Term' against a 'NormalizedType'. +checkTypeM :: + MonadTypeCheckPir uni fun ann m => + ann -> + Term TyName Name uni fun ann -> + Normalized (Type TyName uni ()) -> + PirTCEnv uni fun m () -- [infer| G !- term : vTermTy] vTermTy ~ vTy -- --------------------------------------------- -- [check| G !- term : vTy] checkTypeM ann term vTy = do - vTermTy <- inferTypeM term - when (vTermTy /= vTy) $ do - let expectedVTy = ExpectedExact $ unNormalized vTy - throwError $ PLCTypeError $ TypeMismatch ann (void term) expectedVTy vTermTy + vTermTy <- inferTypeM term + when (vTermTy /= vTy) $ do + let expectedVTy = ExpectedExact $ unNormalized vTy + throwError $ PLCTypeError $ TypeMismatch ann (void term) expectedVTy vTermTy -- See Note [Global uniqueness in the type checker]. -- See Note [Typing rules]. + -- | Synthesize the type of a term, returning a normalized type. -inferTypeM - :: forall m uni fun ann. - MonadTypeCheckPir uni fun ann m - => Term TyName Name uni fun ann -> PirTCEnv uni fun m (Normalized (Type TyName uni ())) +inferTypeM :: + forall m uni fun ann. + MonadTypeCheckPir uni fun ann m => + Term TyName Name uni fun ann -> PirTCEnv uni fun m (Normalized (Type TyName uni ())) -- c : vTy -- ------------------------- -- [infer| G !- con c : vTy] inferTypeM (Constant _ (Some (ValueOf uni _))) = - -- See Note [Normalization of built-in types]. - normalizeTypeM $ PIR.mkTyBuiltinOf () uni - + -- See Note [Normalization of built-in types]. + normalizeTypeM $ PIR.mkTyBuiltinOf () uni -- [infer| G !- bi : vTy] -- ------------------------------ -- [infer| G !- builtin bi : vTy] -inferTypeM (Builtin ann bn) = - mapReaderT (modifyError PLCTypeError) $ lookupBuiltinM ann bn - +inferTypeM (Builtin ann bn) = + mapReaderT (modifyError PLCTypeError) $ lookupBuiltinM ann bn -- [infer| G !- v : ty] ty ~> vTy -- --------------------------------- -- [infer| G !- var v : vTy] -inferTypeM (Var ann name) = - mapReaderT (modifyError PLCTypeError) $ lookupVarM ann name - +inferTypeM (Var ann name) = + mapReaderT (modifyError PLCTypeError) $ lookupVarM ann name -- [check| G !- dom :: *] dom ~> vDom [infer| G , n : dom !- body : vCod] -- ---------------------------------------------------------------------------- -- [infer| G !- lam n dom body : vDom -> vCod] -inferTypeM (LamAbs ann n dom body) = do - mapReaderT (modifyError PLCTypeError) $ checkKindM ann dom $ Type () - vDom <- mapReaderT (modifyError PLCTypeError) $ normalizeTypeM $ void dom - TyFun () <<$>> pure vDom <<*>> withVar n vDom (inferTypeM body) +inferTypeM (LamAbs ann n dom body) = do + mapReaderT (modifyError PLCTypeError) $ checkKindM ann dom $ Type () + vDom <- mapReaderT (modifyError PLCTypeError) $ normalizeTypeM $ void dom + TyFun () <<$>> pure vDom <<*>> withVar n vDom (inferTypeM body) -- [infer| G , n :: nK !- body : vBodyTy] -- --------------------------------------------------- -- [infer| G !- abs n nK body : all (n :: nK) vBodyTy] -inferTypeM (TyAbs _ n nK body) = do - let nK_ = void nK - TyForall () n nK_ <<$>> withTyVar n nK_ (inferTypeM body) +inferTypeM (TyAbs _ n nK body) = do + let nK_ = void nK + TyForall () n nK_ <<$>> withTyVar n nK_ (inferTypeM body) -- [infer| G !- fun : vDom -> vCod] [check| G !- arg : vDom] -- ------------------------------------------------------------ -- [infer| G !- fun arg : vCod] -inferTypeM (Apply ann fun arg) = do - vFunTy <- inferTypeM fun - case unNormalized vFunTy of - TyFun _ vDom vCod -> do - -- Subparts of a normalized type, so normalized. - checkTypeM ann arg $ Normalized vDom - pure $ Normalized vCod - _ -> do - let expectedTyFun = ExpectedShape "fun k l" ["k", "l"] - throwError $ PLCTypeError $ TypeMismatch ann (void fun) expectedTyFun vFunTy +inferTypeM (Apply ann fun arg) = do + vFunTy <- inferTypeM fun + case unNormalized vFunTy of + TyFun _ vDom vCod -> do + -- Subparts of a normalized type, so normalized. + checkTypeM ann arg $ Normalized vDom + pure $ Normalized vCod + _ -> do + let expectedTyFun = ExpectedShape "fun k l" ["k", "l"] + throwError $ PLCTypeError $ TypeMismatch ann (void fun) expectedTyFun vFunTy -- [infer| G !- body : all (n :: nK) vCod] [check| G !- ty :: tyK] ty ~> vTy -- ------------------------------------------------------------------------------- -- [infer| G !- body {ty} : NORM ([vTy / n] vCod)] -inferTypeM (TyInst ann body ty) = do - vBodyTy <- inferTypeM body - case unNormalized vBodyTy of - TyForall _ n nK vCod -> do - mapReaderT (modifyError PLCTypeError) $ checkKindM ann ty nK - vTy <- normalizeTypeM $ void ty - substNormalizeTypeM vTy n vCod - _ -> do - let expectedTyForall = ExpectedShape "all a kind body" ["a", "kind", "body"] - throwError $ PLCTypeError (TypeMismatch ann (void body) expectedTyForall vBodyTy) +inferTypeM (TyInst ann body ty) = do + vBodyTy <- inferTypeM body + case unNormalized vBodyTy of + TyForall _ n nK vCod -> do + mapReaderT (modifyError PLCTypeError) $ checkKindM ann ty nK + vTy <- normalizeTypeM $ void ty + substNormalizeTypeM vTy n vCod + _ -> do + let expectedTyForall = ExpectedShape "all a kind body" ["a", "kind", "body"] + throwError $ PLCTypeError (TypeMismatch ann (void body) expectedTyForall vBodyTy) -- [infer| G !- arg :: k] [check| G !- pat :: (k -> *) -> k -> *] pat ~> vPat arg ~> vArg -- [check| G !- term : NORM (vPat (\(a :: k) -> ifix vPat a) vArg)] -- ----------------------------------------------------------------------------------------------- -- [infer| G !- iwrap pat arg term : ifix vPat vArg] inferTypeM (IWrap ann pat arg term) = do - k <- mapReaderT (modifyError PLCTypeError) $ inferKindM arg - mapReaderT (modifyError PLCTypeError) $ checkKindM ann pat $ toPatFuncKind k - vPat <- normalizeTypeM $ void pat - vArg <- normalizeTypeM $ void arg - checkTypeM ann term =<< unfoldIFixOf vPat vArg k - pure $ TyIFix () <$> vPat <*> vArg + k <- mapReaderT (modifyError PLCTypeError) $ inferKindM arg + mapReaderT (modifyError PLCTypeError) $ checkKindM ann pat $ toPatFuncKind k + vPat <- normalizeTypeM $ void pat + vArg <- normalizeTypeM $ void arg + checkTypeM ann term =<< unfoldIFixOf vPat vArg k + pure $ TyIFix () <$> vPat <*> vArg -- [infer| G !- term : ifix vPat vArg] [infer| G !- vArg :: k] -- ----------------------------------------------------------------------- -- [infer| G !- unwrap term : NORM (vPat (\(a :: k) -> ifix vPat a) vArg)] -inferTypeM (Unwrap ann term) = do - vTermTy <- inferTypeM term - case unNormalized vTermTy of - TyIFix _ vPat vArg -> do - k <- mapReaderT (modifyError PLCTypeError) $ inferKindM $ ann <$ vArg - -- Subparts of a normalized type, so normalized. - unfoldIFixOf (Normalized vPat) (Normalized vArg) k - _ -> do - let expectedTyIFix = ExpectedShape "ifix pat arg" ["pat", "arg"] - throwError $ PLCTypeError (TypeMismatch ann (void term) expectedTyIFix vTermTy) +inferTypeM (Unwrap ann term) = do + vTermTy <- inferTypeM term + case unNormalized vTermTy of + TyIFix _ vPat vArg -> do + k <- mapReaderT (modifyError PLCTypeError) $ inferKindM $ ann <$ vArg + -- Subparts of a normalized type, so normalized. + unfoldIFixOf (Normalized vPat) (Normalized vArg) k + _ -> do + let expectedTyIFix = ExpectedShape "ifix pat arg" ["pat", "arg"] + throwError $ PLCTypeError (TypeMismatch ann (void term) expectedTyIFix vTermTy) -- [check| G !- ty :: *] ty ~> vTy -- ---------------------------------- -- [infer| G !- error ty : vTy] -inferTypeM (Error ann ty) = do - mapReaderT (modifyError PLCTypeError) $ checkKindM ann ty $ Type () - normalizeTypeM $ void ty +inferTypeM (Error ann ty) = do + mapReaderT (modifyError PLCTypeError) $ checkKindM ann ty $ Type () + normalizeTypeM $ void ty -- resTy ~> vResTy vResTy = sop s_0 ... s_i ... s_n -- s_i = [p_i_0 ... p_i_m] [check| G !- t_0 : p_i_0] ... [check| G !- t_m : p_i_m] -- --------------------------------------------------------------------------------- -- [infer| G !- constr resTy i t_0 ... t_m : vResTy] inferTypeM t@(Constr ann resTy i args) = do - vResTy <- normalizeTypeM $ void resTy - - -- We don't know exactly what to expect, we only know what the i-th sum should look like, so we - -- assert that we should have some types in the sum up to there, and then the known product type. - let prodPrefix = map (\j -> "prod_" <> Text.pack (show j)) [0 .. i - 1] - fields = map (\k -> "field_" <> Text.pack (show k)) [0 .. length args - 1] - prod_i = "[" <> Text.intercalate " " fields <> "]" - shape = "sop " <> foldMap (<> " ") prodPrefix <> prod_i <> " ... prod_n" - vars = prodPrefix ++ fields ++ ["prod_n"] - expectedSop = ExpectedShape shape vars - case unNormalized vResTy of - TySOP _ vSTys -> case vSTys ^? wix i of - Just pTys -> case zipExact args pTys of - -- pTy is a sub-part of a normalized type, so normalized - Just ps -> for_ ps $ \(arg, pTy) -> checkTypeM ann arg (Normalized pTy) - -- the number of args does not match the number of types in the i'th SOP - -- alternative - Nothing -> throwError $ PLCTypeError (TypeMismatch ann (void t) expectedSop vResTy) - -- result type does not contain an i'th sum alternative - Nothing -> throwError $ PLCTypeError (TypeMismatch ann (void t) expectedSop vResTy) - -- result type is not a SOP type - _ -> throwError $ PLCTypeError (TypeMismatch ann (void t) expectedSop vResTy) - - pure vResTy + vResTy <- normalizeTypeM $ void resTy + + -- We don't know exactly what to expect, we only know what the i-th sum should look like, so we + -- assert that we should have some types in the sum up to there, and then the known product type. + let prodPrefix = map (\j -> "prod_" <> Text.pack (show j)) [0 .. i - 1] + fields = map (\k -> "field_" <> Text.pack (show k)) [0 .. length args - 1] + prod_i = "[" <> Text.intercalate " " fields <> "]" + shape = "sop " <> foldMap (<> " ") prodPrefix <> prod_i <> " ... prod_n" + vars = prodPrefix ++ fields ++ ["prod_n"] + expectedSop = ExpectedShape shape vars + case unNormalized vResTy of + TySOP _ vSTys -> case vSTys ^? wix i of + Just pTys -> case zipExact args pTys of + -- pTy is a sub-part of a normalized type, so normalized + Just ps -> for_ ps $ \(arg, pTy) -> checkTypeM ann arg (Normalized pTy) + -- the number of args does not match the number of types in the i'th SOP + -- alternative + Nothing -> throwError $ PLCTypeError (TypeMismatch ann (void t) expectedSop vResTy) + -- result type does not contain an i'th sum alternative + Nothing -> throwError $ PLCTypeError (TypeMismatch ann (void t) expectedSop vResTy) + -- result type is not a SOP type + _ -> throwError $ PLCTypeError (TypeMismatch ann (void t) expectedSop vResTy) + + pure vResTy -- resTy ~> vResTy [infer| G !- scrut : sop s_0 ... s_n] -- s_0 = [p_0_0 ... p_0_m] [check| G !- c_0 : p_0_0 -> ... -> p_0_m -> vResTy] @@ -273,32 +271,32 @@ inferTypeM t@(Constr ann resTy i args) = do -- ----------------------------------------------------------------------------- -- [infer| G !- case resTy scrut c_0 ... c_n : vResTy] inferTypeM (Case ann resTy scrut branches) = do - vResTy <- normalizeTypeM $ void resTy - vScrutTy <- inferTypeM scrut - - -- We don't know exactly what to expect, we only know that it should - -- be a SOP with the right number of sum alternatives - let prods = map (\j -> "prod_" <> Text.pack (show j)) [0 .. length branches - 1] - expectedSop = ExpectedShape (Text.intercalate " " $ "sop" : prods) prods - case unNormalized vScrutTy of - TySOP _ sTys -> case zipExact branches sTys of - Just branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> - -- made of sub-parts of a normalized type, so normalized - checkTypeM ann c (Normalized $ mkIterTyFun () argTypes (unNormalized vResTy)) - -- scrutinee does not have a SOP type with the right number of alternatives - -- for the number of branches - Nothing -> throwError $ PLCTypeError (TypeMismatch ann (void scrut) expectedSop vScrutTy) - vTy -> case annotateCaseBuiltin vTy branches of - Right branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> do - vArgTypes <- traverse (fmap unNormalized . normalizeTypeM) argTypes - -- made of sub-parts of a normalized type, so normalized - checkTypeM ann c (Normalized $ mkIterTyFun () vArgTypes (unNormalized vResTy)) - Left err -> throwError $ PLCTypeError (UnsupportedCaseBuiltin ann err) - - -- If we got through all that, then every case type is correct, including that - -- they all result in vResTy, so we can safely conclude that that is the type of the - -- whole expression. - pure vResTy + vResTy <- normalizeTypeM $ void resTy + vScrutTy <- inferTypeM scrut + + -- We don't know exactly what to expect, we only know that it should + -- be a SOP with the right number of sum alternatives + let prods = map (\j -> "prod_" <> Text.pack (show j)) [0 .. length branches - 1] + expectedSop = ExpectedShape (Text.intercalate " " $ "sop" : prods) prods + case unNormalized vScrutTy of + TySOP _ sTys -> case zipExact branches sTys of + Just branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> + -- made of sub-parts of a normalized type, so normalized + checkTypeM ann c (Normalized $ mkIterTyFun () argTypes (unNormalized vResTy)) + -- scrutinee does not have a SOP type with the right number of alternatives + -- for the number of branches + Nothing -> throwError $ PLCTypeError (TypeMismatch ann (void scrut) expectedSop vScrutTy) + vTy -> case annotateCaseBuiltin vTy branches of + Right branchesAndArgTypes -> for_ branchesAndArgTypes $ \(c, argTypes) -> do + vArgTypes <- traverse (fmap unNormalized . normalizeTypeM) argTypes + -- made of sub-parts of a normalized type, so normalized + checkTypeM ann c (Normalized $ mkIterTyFun () vArgTypes (unNormalized vResTy)) + Left err -> throwError $ PLCTypeError (UnsupportedCaseBuiltin ann err) + + -- If we got through all that, then every case type is correct, including that + -- they all result in vResTy, so we can safely conclude that that is the type of the + -- whole expression. + pure vResTy -- ############## -- ## Port end ## -- ############## @@ -314,22 +312,22 @@ ty ~> vTy [infer| G !- (let nonrec {b ; bs} in inT) : vTy] -} inferTypeM (Let ann r@NonRec bs inTerm) = do - -- Check each binding individually, then if ok, introduce its new type/vars to the (linearly) next let or inTerm - ty <- substTypeBinds bs =<< foldr checkBindingThenScope (inferTypeM inTerm) bs - -- check the in-term's inferred type has kind * (except at toplevel) - checkStarInferred ann ty - pure ty + -- Check each binding individually, then if ok, introduce its new type/vars to the (linearly) next let or inTerm + ty <- substTypeBinds bs =<< foldr checkBindingThenScope (inferTypeM inTerm) bs + -- check the in-term's inferred type has kind * (except at toplevel) + checkStarInferred ann ty + pure ty where checkBindingThenScope :: Binding TyName Name uni fun ann -> PirTCEnv uni fun m a -> PirTCEnv uni fun m a checkBindingThenScope b acc = do - -- check that the kinds of the declared types are correct - checkKindFromBinding b - -- check that the types of declared terms are correct - checkTypeFromBinding r b - -- add new *normalized* termvariables to env - -- Note that the order of adding typesVSkinds here does not matter - withTyVarsOfBinding b $ - withVarsOfBinding r b acc + -- check that the kinds of the declared types are correct + checkKindFromBinding b + -- check that the types of declared terms are correct + checkTypeFromBinding r b + -- add new *normalized* termvariables to env + -- Note that the order of adding typesVSkinds here does not matter + withTyVarsOfBinding b $ + withVarsOfBinding r b acc {- G'=G,withTyVarsOfBindings(bs) @@ -341,108 +339,108 @@ forall b in bs. checkTypeFromBinding(G'', b) [infer| G !- (let rec bs in inT) : vTy] -} inferTypeM (Let ann r@Rec bs inTerm) = do - ty <- withTyVarsOfBindings bs $ do - -- check that the kinds of the declared types *over all bindings* are correct - -- Note that, compared to NonRec, we need the newtyvars in scope to do kindchecking - for_ bs checkKindFromBinding - ty <- withVarsOfBindings r bs $ do - -- check that the types of declared terms are correct - -- Note that, compared to NonRec, we need the newtyvars+newvars in scope to do typechecking - for_ bs $ checkTypeFromBinding r - inferTypeM inTerm - substTypeBinds bs ty - -- check the in-term's inferred type has kind * (except at toplevel) - checkStarInferred ann ty - pure ty - -{-| This checks that a newly-introduced type variable is correctly kinded. - -(b is ty::K = rhs) => [check| G !- rhs :: K] -(b is term (X::T) => [check| G !- T :: *]) -(b is data (X::K) tyarg1::K1 ... tyargN::KN = _) => [check| G, X::K, tyarg1::K1...tyargN::KN !- [X tyarg1 ... tyargN] :: *] --------------------------------------------------------------------------------------- -checkKindFromBinding(G,b) --} -checkKindFromBinding - :: forall m uni fun ann. - MonadTypeCheckPir uni fun ann m - => Binding TyName Name uni fun ann - -> PirTCEnv uni fun m () -checkKindFromBinding = mapReaderT (modifyError PLCTypeError) . \case + ty <- withTyVarsOfBindings bs $ do + -- check that the kinds of the declared types *over all bindings* are correct + -- Note that, compared to NonRec, we need the newtyvars in scope to do kindchecking + for_ bs checkKindFromBinding + ty <- withVarsOfBindings r bs $ do + -- check that the types of declared terms are correct + -- Note that, compared to NonRec, we need the newtyvars+newvars in scope to do typechecking + for_ bs $ checkTypeFromBinding r + inferTypeM inTerm + substTypeBinds bs ty + -- check the in-term's inferred type has kind * (except at toplevel) + checkStarInferred ann ty + pure ty + +-- | This checks that a newly-introduced type variable is correctly kinded. +-- +-- (b is ty::K = rhs) => [check| G !- rhs :: K] +-- (b is term (X::T) => [check| G !- T :: *]) +-- (b is data (X::K) tyarg1::K1 ... tyargN::KN = _) => [check| G, X::K, tyarg1::K1...tyargN::KN !- [X tyarg1 ... tyargN] :: *] +-- -------------------------------------------------------------------------------------- +-- checkKindFromBinding(G,b) +checkKindFromBinding :: + forall m uni fun ann. + MonadTypeCheckPir uni fun ann m => + Binding TyName Name uni fun ann -> + PirTCEnv uni fun m () +checkKindFromBinding = + mapReaderT (modifyError PLCTypeError) . \case -- For a type binding, correct means that the the RHS is indeed kinded by the declared kind. TypeBind _ (TyVarDecl ann _ k) rhs -> - checkKindM ann rhs $ void k + checkKindM ann rhs $ void k -- For a term binding, correct means that the declared type has kind *. TermBind _ _ (VarDecl _ _ ty) _ -> - checkKindM (typeAnn ty) ty $ Type () + checkKindM (typeAnn ty) ty $ Type () -- For a datatype binding, correct means that the type constructor has kind * when fully-applied to its type arguments. DatatypeBind _ dt@(Datatype ann tycon tyargs _ vdecls) -> - -- tycon+tyargs must be in scope during kindchecking - withTyVarDecls (tycon:tyargs) $ do - -- the fully-applied type-constructor must be *-kinded - checkKindM ann appliedTyCon $ Type () - -- the types of all the data-constructors must be *-kinded - for_ (_varDeclType <$> vdecls) $ - checkKindM ann `flip` Type () - where - appliedTyCon :: Type TyName uni ann = mkDatatypeValueType ann dt - - -{- | This checks that a newly-introduced variable has declared the *right type* for its term -(rhs term in case of termbind or implicit constructor term in case of dataconstructor). - -(b is t:ty = _) => [check| G !- t : nTy] ty ~> vTy ---------------------------------------------------- -checkTypeFromBinding(G,b) --} -checkTypeFromBinding - :: forall m uni fun ann. - MonadTypeCheckPir uni fun ann m - => Recursivity -> Binding TyName Name uni fun ann -> PirTCEnv uni fun m () -checkTypeFromBinding recurs = \case - TypeBind{} -> pure () -- no types to check - TermBind _ _ (VarDecl ann _ ty) rhs -> - -- See Note [PIR vs Paper Escaping Types Difference] - withNoEscapingTypes (checkTypeM ann rhs . fmap void =<< normalizeTypeM ty) - DatatypeBind _ dt@(Datatype ann _ tyargs _ constrs) -> - for_ (_varDeclType <$> constrs) $ - \ ty -> checkConRes ty *> checkNonRecScope ty + -- tycon+tyargs must be in scope during kindchecking + withTyVarDecls (tycon : tyargs) $ do + -- the fully-applied type-constructor must be *-kinded + checkKindM ann appliedTyCon $ Type () + -- the types of all the data-constructors must be *-kinded + for_ (_varDeclType <$> vdecls) $ + checkKindM ann `flip` Type () where - appliedTyCon :: Type TyName uni ann = mkDatatypeValueType ann dt - checkConRes :: Type TyName uni ann -> PirTCEnv uni fun m () - checkConRes ty = - -- We earlier checked that datacons' type is *-kinded (using checkKindBinding), but this is not enough: - -- we must also check that its result type is EXACTLY `[[TypeCon tyarg1] ... tyargn]` (ignoring annotations) - when (void (PLC.funTyResultType ty) /= void appliedTyCon) . - throwError $ PIRTypeError $ MalformedDataConstrResType ann appliedTyCon - - -- if nonrec binding, make sure that type-constructor is not part of the data-constructor's argument types. - checkNonRecScope :: Type TyName uni ann -> PirTCEnv uni fun m () - checkNonRecScope ty = case recurs of - Rec -> pure () - NonRec -> - -- now we make sure that dataconstructor is not self-recursive, i.e. funargs don't contain tycon - withTyVarDecls tyargs $ -- tycon not in scope here - -- OPTIMIZE: we use inferKind for scope-checking, but a simple ADT-traversal would suffice - mapReaderT (modifyError PLCTypeError) $ for_ (PLC.funTyArgs ty) inferKindM + appliedTyCon :: Type TyName uni ann = mkDatatypeValueType ann dt + +-- | This checks that a newly-introduced variable has declared the *right type* for its term +-- (rhs term in case of termbind or implicit constructor term in case of dataconstructor). +-- +-- (b is t:ty = _) => [check| G !- t : nTy] ty ~> vTy +-- --------------------------------------------------- +-- checkTypeFromBinding(G,b) +checkTypeFromBinding :: + forall m uni fun ann. + MonadTypeCheckPir uni fun ann m => + Recursivity -> Binding TyName Name uni fun ann -> PirTCEnv uni fun m () +checkTypeFromBinding recurs = \case + TypeBind {} -> pure () -- no types to check + TermBind _ _ (VarDecl ann _ ty) rhs -> + -- See Note [PIR vs Paper Escaping Types Difference] + withNoEscapingTypes (checkTypeM ann rhs . fmap void =<< normalizeTypeM ty) + DatatypeBind _ dt@(Datatype ann _ tyargs _ constrs) -> + for_ (_varDeclType <$> constrs) $ + \ty -> checkConRes ty *> checkNonRecScope ty + where + appliedTyCon :: Type TyName uni ann = mkDatatypeValueType ann dt + checkConRes :: Type TyName uni ann -> PirTCEnv uni fun m () + checkConRes ty = + -- We earlier checked that datacons' type is *-kinded (using checkKindBinding), but this is not enough: + -- we must also check that its result type is EXACTLY `[[TypeCon tyarg1] ... tyargn]` (ignoring annotations) + when (void (PLC.funTyResultType ty) /= void appliedTyCon) + . throwError + $ PIRTypeError + $ MalformedDataConstrResType ann appliedTyCon + + -- if nonrec binding, make sure that type-constructor is not part of the data-constructor's argument types. + checkNonRecScope :: Type TyName uni ann -> PirTCEnv uni fun m () + checkNonRecScope ty = case recurs of + Rec -> pure () + NonRec -> + -- now we make sure that dataconstructor is not self-recursive, i.e. funargs don't contain tycon + withTyVarDecls tyargs $ -- tycon not in scope here + -- OPTIMIZE: we use inferKind for scope-checking, but a simple ADT-traversal would suffice + mapReaderT (modifyError PLCTypeError) $ + for_ (PLC.funTyArgs ty) inferKindM -- | Check that the in-Term's inferred type of a Let has kind *. -- Skip this check at the top-level, to allow top-level types to escape; see Note [PIR vs Paper Escaping Types Difference]. -checkStarInferred - :: MonadTypeCheckPir uni fun ann m - => ann -> Normalized (Type TyName uni ()) -> PirTCEnv uni fun m () +checkStarInferred :: + MonadTypeCheckPir uni fun ann m => + ann -> Normalized (Type TyName uni ()) -> PirTCEnv uni fun m () checkStarInferred ann t = do - allowEscape <- view $ tceTypeCheckConfig . pirConfigAllowEscape - case allowEscape of - NoEscape -> mapReaderT (modifyError PLCTypeError) $ checkKindM ann (ann <$ unNormalized t) $ Type () - -- NOTE: we completely skip the check in case of toplevel because we would need an *final, extended Gamma environment* - -- to run the kind-check in, but we cannot easily get that since we are using a Reader for environments and not State - YesEscape -> pure () - + allowEscape <- view $ tceTypeCheckConfig . pirConfigAllowEscape + case allowEscape of + NoEscape -> mapReaderT (modifyError PLCTypeError) $ checkKindM ann (ann <$ unNormalized t) $ Type () + -- NOTE: we completely skip the check in case of toplevel because we would need an *final, extended Gamma environment* + -- to run the kind-check in, but we cannot easily get that since we are using a Reader for environments and not State + YesEscape -> pure () -- | Changes the flag in nested-lets so to disallow returning a type outside of the type's scope withNoEscapingTypes :: PirTCEnv uni fun m a -> PirTCEnv uni fun m a -withNoEscapingTypes = local $ set (tceTypeCheckConfig.pirConfigAllowEscape) NoEscape +withNoEscapingTypes = local $ set (tceTypeCheckConfig . pirConfigAllowEscape) NoEscape -- | Run a 'TypeCheckM' computation by supplying a 'TypeCheckConfig' to it. -- Differs from its PLC version in that is passes an extra env flag 'YesEscape'. @@ -457,58 +455,59 @@ runTypeCheckM config a = runReaderT a $ TypeCheckEnv config mempty mempty -- Newly-declared term variables are: variables of termbinds, constructors, destructor -- Note: Assumes that the input is globally-unique and preserves global-uniqueness -- Note to self: actually passing here recursivity is unnecessary, but we do it for sake of compiler/datatype.hs api -withVarsOfBinding - :: forall uni fun cfg ann m a. - MonadNormalizeType uni m - => Recursivity - -> Binding TyName Name uni fun ann - -> TypeCheckT uni fun cfg m a - -> TypeCheckT uni fun cfg m a -withVarsOfBinding _ TypeBind{} k = k +withVarsOfBinding :: + forall uni fun cfg ann m a. + MonadNormalizeType uni m => + Recursivity -> + Binding TyName Name uni fun ann -> + TypeCheckT uni fun cfg m a -> + TypeCheckT uni fun cfg m a +withVarsOfBinding _ TypeBind {} k = k withVarsOfBinding _ (TermBind _ _ vdecl _) k = do - vTy <- normalizeTypeM $ _varDeclType vdecl - -- no need to rename here - withVar (_varDeclName vdecl) (void <$> vTy) k + vTy <- normalizeTypeM $ _varDeclType vdecl + -- no need to rename here + withVar (_varDeclName vdecl) (void <$> vTy) k withVarsOfBinding r (DatatypeBind _ dt) k = do - -- generate all the definitions - -- options don't matter, we're just doing it for the types - (_tyconstrDef, constrDefs, destrDef) <- compileDatatypeDefs defaultDatatypeCompilationOpts r (original dt) - -- ignore the generated rhs terms of constructors/destructor - let structorDecls = PIR.defVar <$> destrDef:constrDefs - foldr normRenameScope k structorDecls - where - -- normalize, then introduce the vardecl to scope - normRenameScope :: VarDecl TyName Name uni (Provenance ann) - -> TypeCheckT uni fun cfg m a -> TypeCheckT uni fun cfg m a - normRenameScope v acc = do - normRenamedTy <- normalizeTypeM $ _varDeclType v - withVar (_varDeclName v) (void <$> normRenamedTy) acc - - -withVarsOfBindings - :: (MonadNormalizeType uni m, Foldable t) - => Recursivity - -> t (Binding TyName Name uni fun ann) - -> TypeCheckT uni fun cfg m a - -> TypeCheckT uni fun cfg m a + -- generate all the definitions + -- options don't matter, we're just doing it for the types + (_tyconstrDef, constrDefs, destrDef) <- compileDatatypeDefs defaultDatatypeCompilationOpts r (original dt) + -- ignore the generated rhs terms of constructors/destructor + let structorDecls = PIR.defVar <$> destrDef : constrDefs + foldr normRenameScope k structorDecls + where + -- normalize, then introduce the vardecl to scope + normRenameScope :: + VarDecl TyName Name uni (Provenance ann) -> + TypeCheckT uni fun cfg m a -> + TypeCheckT uni fun cfg m a + normRenameScope v acc = do + normRenamedTy <- normalizeTypeM $ _varDeclType v + withVar (_varDeclName v) (void <$> normRenamedTy) acc + +withVarsOfBindings :: + (MonadNormalizeType uni m, Foldable t) => + Recursivity -> + t (Binding TyName Name uni fun ann) -> + TypeCheckT uni fun cfg m a -> + TypeCheckT uni fun cfg m a withVarsOfBindings r bs k = foldr (withVarsOfBinding r) k bs -- | Scope a typechecking computation with the given binding's newly-introducing type (if there is one) -withTyVarsOfBinding - :: Binding TyName name uni fun ann - -> TypeCheckT uni fun cfg m a - -> TypeCheckT uni fun cfg m a +withTyVarsOfBinding :: + Binding TyName name uni fun ann -> + TypeCheckT uni fun cfg m a -> + TypeCheckT uni fun cfg m a withTyVarsOfBinding = \case - TypeBind _ tvdecl _ -> withTyVarDecls [tvdecl] - DatatypeBind _ (Datatype _ tvdecl _ _ _) -> withTyVarDecls [tvdecl] - TermBind{} -> id -- no type to introduce + TypeBind _ tvdecl _ -> withTyVarDecls [tvdecl] + DatatypeBind _ (Datatype _ tvdecl _ _ _) -> withTyVarDecls [tvdecl] + TermBind {} -> id -- no type to introduce -- | Extend the typecheck reader environment with the kinds of the newly-introduced type variables of a binding. -withTyVarsOfBindings - :: Foldable f - => f (Binding TyName name uni fun ann) - -> TypeCheckT uni fun cfg m a - -> TypeCheckT uni fun cfg m a +withTyVarsOfBindings :: + Foldable f => + f (Binding TyName name uni fun ann) -> + TypeCheckT uni fun cfg m a -> + TypeCheckT uni fun cfg m a withTyVarsOfBindings = flip $ foldr withTyVarsOfBinding -- | Helper to add type variables into a computation's environment. @@ -518,14 +517,14 @@ withTyVarDecls = flip . foldr $ \(TyVarDecl _ n k) -> withTyVar n $ void k -- | Substitute `TypeBind`s from the given list of `Binding`s in the given `Type`. -- This is so that @let a = (con integer) in \(x : a) -> x@ typechecks. substTypeBinds :: - MonadNormalizeType uni m => - NonEmpty (Binding TyName Name uni fun ann) -> - Normalized (Type TyName uni ()) -> - PirTCEnv uni fun m (Normalized (Type TyName uni ())) + MonadNormalizeType uni m => + NonEmpty (Binding TyName Name uni fun ann) -> + Normalized (Type TyName uni ()) -> + PirTCEnv uni fun m (Normalized (Type TyName uni ())) substTypeBinds = flip . foldrM $ \b ty -> case b of - TypeBind _ tvar rhs -> do - rhs' <- normalizeTypeM (void rhs) - -- See Note [Normalizing substitution] for why `substNormalizeTypeM` - -- doesn't take a normalized type. - substNormalizeTypeM rhs' (tvar ^. tyVarDeclName) (unNormalized ty) - _ -> pure ty + TypeBind _ tvar rhs -> do + rhs' <- normalizeTypeM (void rhs) + -- See Note [Normalizing substitution] for why `substNormalizeTypeM` + -- doesn't take a normalized type. + substNormalizeTypeM rhs' (tvar ^. tyVarDeclName) (unNormalized ty) + _ -> pure ty diff --git a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs index 440c1c042ac..357c46b3ea6 100644 --- a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs +++ b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs @@ -1,4 +1,3 @@ - module PlutusCore.Generators.QuickCheck.BuiltinsTests where import PlutusCore.Data diff --git a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/SubstitutionTests.hs b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/SubstitutionTests.hs index d85f0f0c25e..77c94266c53 100644 --- a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/SubstitutionTests.hs +++ b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/SubstitutionTests.hs @@ -39,47 +39,52 @@ import Test.QuickCheck hiding (choose, vectorOf) -- thousands of (non-filtered) test cases, we do still get some reasonable coverage in the end. prop_unify :: Property prop_unify = withMaxSuccess 500 $ - forAllDoc "n" arbitrary shrink $ \ (NonNegative n) -> - forAllDoc "nSub" (choose (0, n)) shrink $ \ nSub -> - -- See Note [Chaotic Good fresh name generation]. - let xVars = [TyName $ Name (fromString $ "x" ++ show i) (toEnum i) | i <- [1..n]] in - -- Just for displaying @xVars@ in case of error. - letCE "xVars" xVars $ \ _ -> - forAllDoc "kinds" - (vectorOf n arbitrary) - (filter ((== n) . length) . shrink) $ \ kinds -> - letCE "ctx" (Map.fromList $ zip xVars kinds) $ \ ctx -> - forAllDoc "ty1" - (genKindAndTypeWithCtx ctx) - (shrinkKindAndType ctx) $ \ (_, ty1) -> - forAllDoc "ty2" - (genKindAndTypeWithCtx ctx) - (shrinkKindAndType ctx) $ \ (_, ty2) -> - letCE "nty1" (normalizeTy ty1) $ \ nty1 -> - letCE "nty2" (normalizeTy ty2) $ \ nty2 -> - letCE "res" (unifyType ctx (Set.fromList $ take nSub xVars) ty1 ty2) $ \ res -> - isRight res ==> - let sub = fromRight (error "impossible") res - checkSub (x, ty) = - letCE "x,ty" (x, ty) $ \ _ -> - letCE "k" (Map.findWithDefault (error "impossible") x ctx) $ \ k -> - checkKind ctx ty k - in - letCE "sty1" (substType sub ty1) $ \ sty1 -> - letCE "sty2" (substType sub ty2) $ \ sty2 -> - letCE "nsty1" (normalizeTy sty1) $ \ nsty1 -> - letCE "nsty2" (normalizeTy sty2) $ \ nsty2 -> - -- Since unification normalizes both the sides beforehand, we're displaying free variables of - -- normalized types here. - tabulate "sizes" [show $ min (Set.size $ setOf ftvTy nty1) (Set.size $ setOf ftvTy nty2)] $ - foldr (.&&.) (property $ nsty1 == nsty2) (map checkSub (Map.toList sub)) + forAllDoc "n" arbitrary shrink $ \(NonNegative n) -> + forAllDoc "nSub" (choose (0, n)) shrink $ \nSub -> + -- See Note [Chaotic Good fresh name generation]. + let xVars = [TyName $ Name (fromString $ "x" ++ show i) (toEnum i) | i <- [1 .. n]] + in -- Just for displaying @xVars@ in case of error. + letCE "xVars" xVars $ \_ -> + forAllDoc + "kinds" + (vectorOf n arbitrary) + (filter ((== n) . length) . shrink) + $ \kinds -> + letCE "ctx" (Map.fromList $ zip xVars kinds) $ \ctx -> + forAllDoc + "ty1" + (genKindAndTypeWithCtx ctx) + (shrinkKindAndType ctx) + $ \(_, ty1) -> + forAllDoc + "ty2" + (genKindAndTypeWithCtx ctx) + (shrinkKindAndType ctx) + $ \(_, ty2) -> + letCE "nty1" (normalizeTy ty1) $ \nty1 -> + letCE "nty2" (normalizeTy ty2) $ \nty2 -> + letCE "res" (unifyType ctx (Set.fromList $ take nSub xVars) ty1 ty2) $ \res -> + isRight res ==> + let sub = fromRight (error "impossible") res + checkSub (x, ty) = + letCE "x,ty" (x, ty) $ \_ -> + letCE "k" (Map.findWithDefault (error "impossible") x ctx) $ \k -> + checkKind ctx ty k + in letCE "sty1" (substType sub ty1) $ \sty1 -> + letCE "sty2" (substType sub ty2) $ \sty2 -> + letCE "nsty1" (normalizeTy sty1) $ \nsty1 -> + letCE "nsty2" (normalizeTy sty2) $ \nsty2 -> + -- Since unification normalizes both the sides beforehand, we're displaying free variables of + -- normalized types here. + tabulate "sizes" [show $ min (Set.size $ setOf ftvTy nty1) (Set.size $ setOf ftvTy nty2)] $ + foldr (.&&.) (property $ nsty1 == nsty2) (map checkSub (Map.toList sub)) -- | Check that a type unifies with a renaming of itself prop_unifyRename :: Property prop_unifyRename = - forAllDoc "_, ty" genKindAndType (shrinkKindAndType mempty) $ \ (_, ty) -> - letCE "rename ty" (runQuote $ rename ty) $ \ rnty -> - void $ unifyType mempty mempty ty rnty + forAllDoc "_, ty" genKindAndType (shrinkKindAndType mempty) $ \(_, ty) -> + letCE "rename ty" (runQuote $ rename ty) $ \rnty -> + void $ unifyType mempty mempty ty rnty -- | Check that substitution eliminates from the type all free occurrences of variables present in -- the domain of the substitution. @@ -88,17 +93,18 @@ prop_substType = withMaxSuccess 1000 $ -- No shrinking because every nested shrink makes properties harder to shrink (because you'd need -- to regenerate the stuff that depends on the context, meaning you don't have the same -- counterexample as you did before) and context minimality doesn't help readability very much. - forAllDoc "ctx" genCtx (const []) $ \ ctx -> - forAllDoc "ty" (genKindAndTypeWithCtx ctx) (shrinkKindAndType ctx) $ \ (k, ty) -> - forAllDoc "sub" (genSubst ctx) (shrinkSubst ctx) $ \ sub -> - letCE "res" (substType sub ty) $ \ res -> do - let fv1 = fvTypeR sub ty - fv2 = setOf ftvTy res - unless (fv1 == fv2) . Left $ concat - [ "Type variables of the generated type given the generated substitution don't match " - , "those of the resulting type after the substitution is applied: \n\n" - , show fv1 - , "\n\n vs \n\n" - , show fv2 - ] - checkKind ctx res k + forAllDoc "ctx" genCtx (const []) $ \ctx -> + forAllDoc "ty" (genKindAndTypeWithCtx ctx) (shrinkKindAndType ctx) $ \(k, ty) -> + forAllDoc "sub" (genSubst ctx) (shrinkSubst ctx) $ \sub -> + letCE "res" (substType sub ty) $ \res -> do + let fv1 = fvTypeR sub ty + fv2 = setOf ftvTy res + unless (fv1 == fv2) . Left $ + concat + [ "Type variables of the generated type given the generated substitution don't match " + , "those of the resulting type after the substitution is applied: \n\n" + , show fv1 + , "\n\n vs \n\n" + , show fv2 + ] + checkKind ctx res k diff --git a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/TypesTests.hs b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/TypesTests.hs index b6190606cc4..fd9ddd2e261 100644 --- a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/TypesTests.hs +++ b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/TypesTests.hs @@ -23,56 +23,58 @@ prop_genKindCorrect = p_genKindCorrect False p_genKindCorrect :: Bool -> Property p_genKindCorrect debug = withMaxSuccess 1000 $ -- Context minimality doesn't help readability, so no shrinking here - forAllDoc "ctx" genCtx (const []) $ \ ctx -> - -- Note, no shrinking here because shrinking relies on well-kindedness. - forAllDoc "k,ty" (if debug then genKindAndTypeDebug else genKindAndType) (const []) $ \ (k, ty) -> - checkKind ctx ty k + forAllDoc "ctx" genCtx (const []) $ \ctx -> + -- Note, no shrinking here because shrinking relies on well-kindedness. + forAllDoc "k,ty" (if debug then genKindAndTypeDebug else genKindAndType) (const []) $ \(k, ty) -> + checkKind ctx ty k -- | Check that shrinking types maintains kinds. prop_shrinkTypeSound :: Property prop_shrinkTypeSound = withMaxSuccess 500 $ - forAllDoc "ctx" genCtx (const []) $ \ ctx -> - forAllDoc "k,ty" (genKindAndTypeWithCtx ctx) (shrinkKindAndType ctx) $ \ (k, ty) -> - -- See discussion about the same trick in 'prop_shrinkTermSound'. - isRight (checkKind ctx ty k) ==> - assertNoCounterexamples $ lefts - [ first (k', ty', ) $ checkKind ctx ty' k' - | (k', ty') <- shrinkKindAndType ctx (k, ty) - ] + forAllDoc "ctx" genCtx (const []) $ \ctx -> + forAllDoc "k,ty" (genKindAndTypeWithCtx ctx) (shrinkKindAndType ctx) $ \(k, ty) -> + -- See discussion about the same trick in 'prop_shrinkTermSound'. + isRight (checkKind ctx ty k) ==> + assertNoCounterexamples $ + lefts + [ first (k',ty',) $ checkKind ctx ty' k' + | (k', ty') <- shrinkKindAndType ctx (k, ty) + ] -- Utility tests for debugging -- | Test that shrinking a type results in a type of a smaller kind. Useful for debugging shrinking. prop_shrinkTypeSmallerKind :: Property prop_shrinkTypeSmallerKind = withMaxSuccess 3000 $ - forAllDoc "k,ty" genKindAndType (shrinkKindAndType Map.empty) $ \ (k, ty) -> - assertNoCounterexamples - [ (k', ty') - | (k', ty') <- shrinkKindAndType Map.empty (k, ty) - , not $ leKind k' k - ] + forAllDoc "k,ty" genKindAndType (shrinkKindAndType Map.empty) $ \(k, ty) -> + assertNoCounterexamples + [ (k', ty') + | (k', ty') <- shrinkKindAndType Map.empty (k, ty) + , not $ leKind k' k + ] -- | Test that shrinking kinds generates smaller kinds. prop_shrinkKindSmaller :: Property prop_shrinkKindSmaller = withMaxSuccess 30000 $ - forAllDoc "k" arbitrary shrink $ \ k -> - assertNoCounterexamples [k' | k' <- shrink k, not $ leKind k' k] + forAllDoc "k" arbitrary shrink $ \k -> + assertNoCounterexamples [k' | k' <- shrink k, not $ leKind k' k] -- | Test that fixKind actually gives you something of the right kind. prop_fixKind :: Property prop_fixKind = withMaxSuccess 10000 $ - forAllDoc "ctx" genCtx (const []) $ \ ctx -> - forAllDoc "k,ty" genKindAndType (shrinkKindAndType ctx) $ \ (k, ty) -> - -- Note, fixKind only works on smaller kinds, so we use shrink to get a definitely smaller kind - assertNoCounterexamples $ lefts - [ first (ty', k', ) $ checkKind ctx ty' k' - | k' <- shrink k - , let ty' = fixKind ctx ty k' - ] + forAllDoc "ctx" genCtx (const []) $ \ctx -> + forAllDoc "k,ty" genKindAndType (shrinkKindAndType ctx) $ \(k, ty) -> + -- Note, fixKind only works on smaller kinds, so we use shrink to get a definitely smaller kind + assertNoCounterexamples $ + lefts + [ first (ty',k',) $ checkKind ctx ty' k' + | k' <- shrink k + , let ty' = fixKind ctx ty k' + ] -- | Check that 'normalizeType' returns a normal type. prop_normalizedTypeIsNormal :: Property prop_normalizedTypeIsNormal = withMaxSuccess 1000 $ - forAllDoc "k,ty" genKindAndType (shrinkKindAndType Map.empty) $ \ (_, ty) -> + forAllDoc "k,ty" genKindAndType (shrinkKindAndType Map.empty) $ \(_, ty) -> unless (isNormalType . unNormalized . runQuote $ normalizeType ty) $ Left "'normalizeType' returned a non-normal type" diff --git a/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs index d112a7149bf..5dc349299ab 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs @@ -14,33 +14,33 @@ import PlutusPrelude test_retainedSize :: TestTree test_retainedSize = - runTestNested ["plutus-ir", "test", "PlutusIR", "Analysis", "RetainedSize"] $ - map - (goldenPirUnique renameAndAnnotate pTerm) - [ "typeLet" - , "termLet" - , "strictLet" - , "nonstrictLet" - , -- @Maybe@ is referenced, so it retains all of the data type. - "datatypeLiveType" - , -- @Nothing@ is referenced, so it retains all of the data type. - "datatypeLiveConstr" - , -- @match_Maybe@ is referenced, so it retains all of the data type. - "datatypeLiveDestr" - , "datatypeDead" - , "singleBinding" - , "builtinBinding" - , "etaBuiltinBinding" - , "etaBuiltinBindingUsed" - , "nestedBindings" - , "nestedBindingsIndirect" - , "recBindingSimple" - , "recBindingComplex" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Analysis", "RetainedSize"] $ + map + (goldenPirUnique renameAndAnnotate pTerm) + [ "typeLet" + , "termLet" + , "strictLet" + , "nonstrictLet" + , -- @Maybe@ is referenced, so it retains all of the data type. + "datatypeLiveType" + , -- @Nothing@ is referenced, so it retains all of the data type. + "datatypeLiveConstr" + , -- @match_Maybe@ is referenced, so it retains all of the data type. + "datatypeLiveDestr" + , "datatypeDead" + , "singleBinding" + , "builtinBinding" + , "etaBuiltinBinding" + , "etaBuiltinBindingUsed" + , "nestedBindings" + , "nestedBindingsIndirect" + , "recBindingSimple" + , "recBindingComplex" + ] where displayAnnsConfig = PLC.PrettyConfigClassic PLC.prettyConfigNameSimple True renameAndAnnotate = - PLC.AttachPrettyConfig displayAnnsConfig - . RetainedSize.annotateWithRetainedSize def - . runQuote - . PLC.rename + PLC.AttachPrettyConfig displayAnnsConfig + . RetainedSize.annotateWithRetainedSize def + . runQuote + . PLC.rename diff --git a/plutus-core/plutus-ir/test/PlutusIR/Check/Uniques/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Check/Uniques/Tests.hs index b372511d430..3d807a1f9eb 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Check/Uniques/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Check/Uniques/Tests.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -- | This module contains tests that ensure the definition analysis is correct. We may consider -- renaming this module, along with the corresponding PLC module to better reflect the scope. module PlutusIR.Check.Uniques.Tests where - import Control.Monad.Except (MonadError, runExcept) import Data.List.NonEmpty qualified as NE import PlutusCore.Default (DefaultUni) @@ -22,59 +21,70 @@ import Test.Tasty.HUnit (testCase, (@?=)) data Tag = Tag Int | Ignore deriving stock (Show, Eq, Ord) checkTermUniques :: (Ord a, MonadError (UniqueError a) m) => Term TyName Name uni fun a -> m () -checkTermUniques = Uniques.checkTerm (\case MultiplyDefined{} -> True; _ -> False) +checkTermUniques = Uniques.checkTerm (\case MultiplyDefined {} -> True; _ -> False) test_shadowed :: TestTree test_shadowed = - let - u = Unique (-1) - checked = runExcept $ runQuoteT $ do - ty <- freshTyName "ty" - let n = Name "yo" u - let term = - LamAbs (Tag 1) n (TyVar Ignore ty) $ - LamAbs (Tag 2) n (TyVar Ignore ty) $ - Var Ignore n - checkTermUniques term - assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) - in testCase "shadowed" assertion + let + u = Unique (-1) + checked = runExcept $ runQuoteT $ do + ty <- freshTyName "ty" + let n = Name "yo" u + let term = + LamAbs (Tag 1) n (TyVar Ignore ty) $ + LamAbs (Tag 2) n (TyVar Ignore ty) $ + Var Ignore n + checkTermUniques term + assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) + in + testCase "shadowed" assertion test_multiplyDefined :: TestTree test_multiplyDefined = - let - u = Unique (-1) - checked = runExcept $ runQuoteT $ do - ty <- freshTyName "ty" - let n = Name "yo" u - let term = - Apply Ignore - (LamAbs (Tag 1) n (TyVar Ignore ty) (Var Ignore n)) - (LamAbs (Tag 2) n (TyVar Ignore ty) (Var Ignore n)) - checkTermUniques term - assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) - in testCase "multiplyDefined" assertion + let + u = Unique (-1) + checked = runExcept $ runQuoteT $ do + ty <- freshTyName "ty" + let n = Name "yo" u + let term = + Apply + Ignore + (LamAbs (Tag 1) n (TyVar Ignore ty) (Var Ignore n)) + (LamAbs (Tag 2) n (TyVar Ignore ty) (Var Ignore n)) + checkTermUniques term + assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2)) + in + testCase "multiplyDefined" assertion test_shadowedInLet :: TestTree test_shadowedInLet = - let - u = Unique (-1) - checked = runExcept $ runQuoteT $ do - ty <- freshTyName "ty" - let n = Name "yo" u - let term = -- let n = 2 in \n -> n - Let - (Tag 1) - NonRec - (NE.fromList [TermBind - (Tag 2) - Strict - (VarDecl - {_varDeclAnn = Tag 3 - , _varDeclName = n - , _varDeclType = TyVar Ignore ty}) - (mkConstant @Integer @DefaultUni (Tag 5) 2) ]) - (LamAbs (Tag 4) n (TyVar Ignore ty) $ - Var Ignore n) - checkTermUniques term - assertion = checked @?= Left (MultiplyDefined (Unique {unUnique = -1}) (Tag 3) (Tag 4)) - in testCase "shadowedInLet" assertion + let + u = Unique (-1) + checked = runExcept $ runQuoteT $ do + ty <- freshTyName "ty" + let n = Name "yo" u + let term = + -- let n = 2 in \n -> n + Let + (Tag 1) + NonRec + ( NE.fromList + [ TermBind + (Tag 2) + Strict + ( VarDecl + { _varDeclAnn = Tag 3 + , _varDeclName = n + , _varDeclType = TyVar Ignore ty + } + ) + (mkConstant @Integer @DefaultUni (Tag 5) 2) + ] + ) + ( LamAbs (Tag 4) n (TyVar Ignore ty) $ + Var Ignore n + ) + checkTermUniques term + assertion = checked @?= Left (MultiplyDefined (Unique {unUnique = -1}) (Tag 3) (Tag 4)) + in + testCase "shadowedInLet" assertion diff --git a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Datatype/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Datatype/Tests.hs index 8f6239dc040..028cce01eb8 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Datatype/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Datatype/Tests.hs @@ -8,15 +8,17 @@ import Test.Tasty.Extras test_datatypes :: TestTree test_datatypes = - runTestNested ["plutus-ir", "test", "PlutusIR", "Compiler", "Datatype"] - [ goldenPlcFromPir pTermAsProg "maybe" - , goldenPlcFromPir pTermAsProg "listMatch" - , goldenPlcFromPir pTermAsProg "idleAll" - , goldenPlcFromPir pTermAsProg "some" - , goldenEvalPir pTermAsProg "listMatchEval" - , goldenTypeFromPir topSrcSpan pTerm "dataEscape" - , testNested "scott" - [ goldenPlcFromPirScott pTermAsProg "maybe" - , goldenPlcFromPirScott pTermAsProg "listMatch" - ] + runTestNested + ["plutus-ir", "test", "PlutusIR", "Compiler", "Datatype"] + [ goldenPlcFromPir pTermAsProg "maybe" + , goldenPlcFromPir pTermAsProg "listMatch" + , goldenPlcFromPir pTermAsProg "idleAll" + , goldenPlcFromPir pTermAsProg "some" + , goldenEvalPir pTermAsProg "listMatchEval" + , goldenTypeFromPir topSrcSpan pTerm "dataEscape" + , testNested + "scott" + [ goldenPlcFromPirScott pTermAsProg "maybe" + , goldenPlcFromPirScott pTermAsProg "listMatch" ] + ] diff --git a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Error/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Error/Tests.hs index f0029cb077e..b39e3ff465c 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Error/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Error/Tests.hs @@ -7,7 +7,8 @@ import Test.Tasty.Extras test_error :: TestTree test_error = - runTestNested ["plutus-ir", "test", "PlutusIR", "Compiler", "Error"] - [ goldenPlcFromPir pTermAsProg "mutuallyRecursiveTypes" - , goldenPlcFromPir pTermAsProg "recursiveTypeBind" - ] + runTestNested + ["plutus-ir", "test", "PlutusIR", "Compiler", "Error"] + [ goldenPlcFromPir pTermAsProg "mutuallyRecursiveTypes" + , goldenPlcFromPir pTermAsProg "recursiveTypeBind" + ] diff --git a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Let/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Let/Tests.hs index 4ca5c3e02e7..3e3ee1381f1 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Let/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Let/Tests.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} + module PlutusIR.Compiler.Let.Tests where import PlutusPrelude @@ -22,10 +23,11 @@ import Test.Tasty.QuickCheck test_lets :: TestTree test_lets = - runTestNested ["plutus-ir", "test", "PlutusIR", "Compiler", "Let"] - [ goldenPlcFromPir pTermAsProg "letInLet" - , goldenPlcFromPir pTermAsProg "letDep" - ] + runTestNested + ["plutus-ir", "test", "PlutusIR", "Compiler", "Let"] + [ goldenPlcFromPir pTermAsProg "letInLet" + , goldenPlcFromPir pTermAsProg "letDep" + ] -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1876): -- this fails because some of the let passes expect certain things to be @@ -33,29 +35,31 @@ test_lets = -- and b) set up the tests to establish what is needed test_propLets :: TestTree test_propLets = - ignoreTest $ testProperty "lets" $ \letKind -> withMaxSuccess 40000 $ - testPassProp' @_ @_ @_ @(Provenance ()) - (Original ()) - (\t -> fmap Original t) - runCompiling - (\tc -> compileLetsPassSC tc letKind) + ignoreTest $ testProperty "lets" $ \letKind -> + withMaxSuccess 40000 $ + testPassProp' @_ @_ @_ @(Provenance ()) + (Original ()) + (\t -> fmap Original t) + runCompiling + (\tc -> compileLetsPassSC tc letKind) where -- This is rather painful, but it works runCompiling :: - forall e m c . - (e ~ PIR.Error PLC.DefaultUni PLC.DefaultFun (Provenance ()) + forall e m c. + ( e ~ PIR.Error PLC.DefaultUni PLC.DefaultFun (Provenance ()) , c ~ PIR.CompilationCtx PLC.DefaultUni PLC.DefaultFun () , m ~ ExceptT e (ExceptT e (PLC.QuoteT (Reader c))) - ) - => m () -> Either String () + ) => + m () -> Either String () runCompiling v = let res :: Either e () res = do - plcConfig <- modifyError (PIR.PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig (Original ()) - let ctx = PIR.toDefaultCompilationCtx plcConfig - join $ flip runReader ctx $ PLC.runQuoteT $ runExceptT $ runExceptT v - in convertToEitherString $ first void res + plcConfig <- modifyError (PIR.PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig (Original ()) + let ctx = PIR.toDefaultCompilationCtx plcConfig + join $ flip runReader ctx $ PLC.runQuoteT $ runExceptT $ runExceptT v + in + convertToEitherString $ first void res instance Arbitrary LetKind where - arbitrary = elements [ RecTerms , NonRecTerms , Types , DataTypes ] + arbitrary = elements [RecTerms, NonRecTerms, Types, DataTypes] diff --git a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Recursion/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Recursion/Tests.hs index 7d6963954e5..2e5ac7faa54 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Recursion/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Compiler/Recursion/Tests.hs @@ -7,11 +7,12 @@ import Test.Tasty.Extras test_recursion :: TestTree test_recursion = - runTestNested ["plutus-ir", "test", "PlutusIR", "Compiler", "Recursion"] - [ goldenNamedUPlcFromPir pTermAsProg "factorial" - , goldenPlcFromPir pTermAsProg "even3" - , goldenEvalPir pTermAsProg "even3Eval" - , goldenPlcFromPir pTermAsProg "stupidZero" - , goldenPlcFromPir pTermAsProg "mutuallyRecursiveValues" - , goldenEvalPir pTermAsProg "errorBinding" - ] + runTestNested + ["plutus-ir", "test", "PlutusIR", "Compiler", "Recursion"] + [ goldenNamedUPlcFromPir pTermAsProg "factorial" + , goldenPlcFromPir pTermAsProg "even3" + , goldenEvalPir pTermAsProg "even3Eval" + , goldenPlcFromPir pTermAsProg "stupidZero" + , goldenPlcFromPir pTermAsProg "mutuallyRecursiveValues" + , goldenEvalPir pTermAsProg "errorBinding" + ] diff --git a/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs index b7e3e101c4d..7acb0632d1d 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs @@ -14,48 +14,48 @@ import PlutusCore.Flat test_prettyprinting :: TestTree test_prettyprinting = - runTestNested ["plutus-ir", "test", "PlutusIR", "Core", "prettyprinting"] $ - map - (goldenPir id pTerm) - [ "basic" - , "maybe" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Core", "prettyprinting"] $ + map + (goldenPir id pTerm) + [ "basic" + , "maybe" + ] test_prettyprintingReadable :: TestTree test_prettyprintingReadable = - runTestNested ["plutus-ir", "test", "PlutusIR", "Core", "prettyprintingReadable"] $ - map - (goldenPirDoc prettyReadableSimple pTerm) - [ "basic" - , "maybe" - , "letInLet" - , "letDep" - , "listMatch" - , "idleAll" - , "some" - , "even3" - , "stupidZero" - , "mutuallyRecursiveValues" - , "errorBinding" - , "some" - , "stupidZero" - , "recursiveTypeBind" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Core", "prettyprintingReadable"] $ + map + (goldenPirDoc prettyReadableSimple pTerm) + [ "basic" + , "maybe" + , "letInLet" + , "letDep" + , "listMatch" + , "idleAll" + , "some" + , "even3" + , "stupidZero" + , "mutuallyRecursiveValues" + , "errorBinding" + , "some" + , "stupidZero" + , "recursiveTypeBind" + ] test_serialization :: TestTree test_serialization = - runTestNested ["plutus-ir", "test", "PlutusIR", "Core", "serialization"] $ - map - (goldenPir roundTripPirTerm pTerm) - [ "serializeBasic" - , "serializeMaybePirTerm" - , "serializeEvenOdd" - , "serializeListMatch" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Core", "serialization"] $ + map + (goldenPir roundTripPirTerm pTerm) + [ "serializeBasic" + , "serializeMaybePirTerm" + , "serializeEvenOdd" + , "serializeListMatch" + ] -roundTripPirTerm - :: Term TyName Name PLC.DefaultUni PLC.DefaultFun a - -> Term TyName Name PLC.DefaultUni PLC.DefaultFun () +roundTripPirTerm :: + Term TyName Name PLC.DefaultUni PLC.DefaultFun a -> + Term TyName Name PLC.DefaultUni PLC.DefaultFun () roundTripPirTerm = decodeOrError . unflat . flat . void where decodeOrError (Right tm) = tm diff --git a/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs index 1a6c0264c3a..62c18100fc8 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs @@ -1,8 +1,7 @@ -- editorconfig-checker-disable-file {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusIR.Generators.QuickCheck.Tests where @@ -24,16 +23,19 @@ import PlutusCore.Version (latestVersion) import PlutusIR import PlutusIR.Test () import UntypedPlutusCore qualified as UPLC -import UntypedPlutusCore.Evaluation.Machine.Cek (restrictingLarge, runCekNoEmit, - unsafeSplitStructuralOperational) +import UntypedPlutusCore.Evaluation.Machine.Cek ( + restrictingLarge, + runCekNoEmit, + unsafeSplitStructuralOperational, + ) import Control.Exception import Control.Monad.Except import Control.Monad.Reader import Data.Char import Data.Either -import Data.Hashable import Data.HashMap.Strict qualified as HashMap +import Data.Hashable import Data.Map.Strict qualified as Map import Test.QuickCheck @@ -51,9 +53,9 @@ nubHashableOn f = HashMap.elems . HashMap.fromList . map (\x -> (f x, x)) -- place it here, since nothing can depend on a test suite (apart from modules from within this test -- suite), hence no conflicting orphans can occur. instance Eq (Term TyName Name DefaultUni DefaultFun ()) where - -- Quick-and-dirty implementation in terms of 'Show'. - -- We generally consider equality modulo alpha, hence the call to 'rename'. - (==) = (==) `on` showRenameTerm + -- Quick-and-dirty implementation in terms of 'Show'. + -- We generally consider equality modulo alpha, hence the call to 'rename'. + (==) = (==) `on` showRenameTerm -- * Core properties for PIR generators @@ -70,59 +72,61 @@ p_genTypeCorrect debug = withMaxSuccess 200 $ do -- the term we are shrinking is well-typed. If it is not, the counterexample we get -- from shrinking will be nonsene. let gen = if debug then genTypeAndTermDebug_ else genTypeAndTerm_ - forAllDoc "ty,tm" gen (const []) $ \ (ty, tm) -> typeCheckTerm tm ty + forAllDoc "ty,tm" gen (const []) $ \(ty, tm) -> typeCheckTerm tm ty -- | Test that when we generate a fully applied term we end up -- with a well-typed term. prop_genWellTypedFullyApplied :: Property prop_genWellTypedFullyApplied = withMaxSuccess 50 $ - forAllDoc "ty, tm" genTypeAndTerm_ shrinkClosedTypedTerm $ \ (ty, tm) -> - -- No shrinking here because if `genFullyApplied` is wrong then the shrinking - -- will be wrong too. See `prop_genTypeCorrect`. - forAllDoc "ty', tm'" (genFullyApplied ty tm) (const []) $ \ (ty', tm') -> - typeCheckTerm tm' ty' + forAllDoc "ty, tm" genTypeAndTerm_ shrinkClosedTypedTerm $ \(ty, tm) -> + -- No shrinking here because if `genFullyApplied` is wrong then the shrinking + -- will be wrong too. See `prop_genTypeCorrect`. + forAllDoc "ty', tm'" (genFullyApplied ty tm) (const []) $ \(ty', tm') -> + typeCheckTerm tm' ty' -- | Test that shrinking a well-typed term results in a well-typed term prop_shrinkTermSound :: Property -- The test is disabled, because it's exponential and was hanging CI. prop_shrinkTermSound = withMaxSuccess 0 $ - forAllDoc "ty,tm" genTypeAndTerm_ shrinkClosedTypedTerm $ \ (ty, tm) -> - let shrinks = shrinkClosedTypedTerm (ty, tm) in - -- While we generate well-typed terms we still need this check here for - -- shrinking counterexamples to *this* property. If we find a term whose - -- shrinks aren't well-typed we want to find smaller *well-typed* terms - -- whose shrinks aren't well typed. - -- Importantly, this property is only interesting when - -- shrinking itself is broken, so we can only use the - -- parts of shrinking that happen to be OK. - isRight (typeCheckTerm tm ty) ==> - -- We don't want to let the shrinker get away with being empty, so we ignore empty - -- shrinks. QuickCheck will give up and print an error if the shrinker returns the empty list too - -- often. - not (null shrinks) ==> - assertNoCounterexamples $ lefts - [ first ((ty', tm'), ) $ typeCheckTerm tm' ty' - | (ty', tm') <- shrinks - ] + forAllDoc "ty,tm" genTypeAndTerm_ shrinkClosedTypedTerm $ \(ty, tm) -> + let shrinks = shrinkClosedTypedTerm (ty, tm) + in -- While we generate well-typed terms we still need this check here for + -- shrinking counterexamples to *this* property. If we find a term whose + -- shrinks aren't well-typed we want to find smaller *well-typed* terms + -- whose shrinks aren't well typed. + -- Importantly, this property is only interesting when + -- shrinking itself is broken, so we can only use the + -- parts of shrinking that happen to be OK. + isRight (typeCheckTerm tm ty) ==> + -- We don't want to let the shrinker get away with being empty, so we ignore empty + -- shrinks. QuickCheck will give up and print an error if the shrinker returns the empty list too + -- often. + not (null shrinks) ==> + assertNoCounterexamples $ + lefts + [ first ((ty', tm'),) $ typeCheckTerm tm' ty' + | (ty', tm') <- shrinks + ] -- * Utility tests for debugging generators that behave weirdly -- | Test that `findInstantiation` results in a well-typed instantiation. prop_findInstantiation :: Property prop_findInstantiation = withMaxSuccess 1000 $ - forAllDoc "ctx" genCtx (const []) $ \ ctx0 -> - forAllDoc "ty" (genTypeWithCtx ctx0 $ Type ()) (shrinkType ctx0) $ \ ty0 -> - forAllDoc "target" (genTypeWithCtx ctx0 $ Type ()) (shrinkType ctx0) $ \ target -> - assertNoCounterexamples $ lefts - [ first (n ,) $ checkInst ctx0 x0 ty0 insts target - | n <- [0 .. arity ty0 + 3] - , Right insts <- [findInstantiation ctx0 n target ty0] - ] + forAllDoc "ctx" genCtx (const []) $ \ctx0 -> + forAllDoc "ty" (genTypeWithCtx ctx0 $ Type ()) (shrinkType ctx0) $ \ty0 -> + forAllDoc "target" (genTypeWithCtx ctx0 $ Type ()) (shrinkType ctx0) $ \target -> + assertNoCounterexamples $ + lefts + [ first (n,) $ checkInst ctx0 x0 ty0 insts target + | n <- [0 .. arity ty0 + 3] + , Right insts <- [findInstantiation ctx0 n target ty0] + ] where x0 = Name "x" (toEnum 0) arity (TyForall _ _ _ a) = arity a - arity (TyFun _ _ b) = 1 + arity b - arity _ = 0 + arity (TyFun _ _ b) = 1 + arity b + arity _ = 0 -- Check that building a "minimal" term that performs the instantiations in -- `insts` produces a well-typed term. @@ -134,68 +138,80 @@ prop_findInstantiation = withMaxSuccess 1000 $ (tmCtx1, tm1) = go (toEnum 1) (Map.singleton x1 ty1) (Var () x1) insts1 go _ tmCtx tm [] = (tmCtx, tm) go i tmCtx tm (InstApp ty : insts) = go i tmCtx (TyInst () tm ty) insts - go i tmCtx tm (InstArg ty : insts) = go (succ i) (Map.insert y ty tmCtx) - (Apply () tm (Var () y)) insts - where y = Name "y" i + go i tmCtx tm (InstArg ty : insts) = + go + (succ i) + (Map.insert y ty tmCtx) + (Apply () tm (Var () y)) + insts + where + y = Name "y" i -- | Check what's in the leaves of the generated data prop_stats_leaves :: Property prop_stats_leaves = withMaxSuccess 10 $ -- No shrinking here because we are only collecting stats - forAllDoc "_,tm" genTypeAndTerm_ (const []) $ \ (_, tm) -> - tabulate "leaves" (map (filter isAlpha . show . prettyReadable) $ leaves tm) $ property True + forAllDoc "_,tm" genTypeAndTerm_ (const []) $ \(_, tm) -> + tabulate "leaves" (map (filter isAlpha . show . prettyReadable) $ leaves tm) $ property True where -- Figure out what's at the leaves of the AST, -- including variable names, error, and builtins. - leaves (Var _ x) = [x] - leaves (TyInst _ a _) = leaves a - leaves (Let _ _ _ b) = leaves b + leaves (Var _ x) = [x] + leaves (TyInst _ a _) = leaves a + leaves (Let _ _ _ b) = leaves b leaves (LamAbs _ _ _ b) = leaves b - leaves (Apply _ a b) = leaves a ++ leaves b - leaves Error{} = [Name "error" $ toEnum 0] - leaves Builtin{} = [Name "builtin" $ toEnum 0] - leaves _ = [] + leaves (Apply _ a b) = leaves a ++ leaves b + leaves Error {} = [Name "error" $ toEnum 0] + leaves Builtin {} = [Name "builtin" $ toEnum 0] + leaves _ = [] -- | Check the ratio of duplicate shrinks prop_stats_numShrink :: Property -- The test is disabled, because it's exponential and was hanging CI. prop_stats_numShrink = withMaxSuccess 0 $ -- No shrinking here because we are only collecting stats - forAllDoc "ty,tm" genTypeAndTerm_ (const []) $ \ (ty, tm) -> - let shrinks = map snd $ shrinkClosedTypedTerm (ty, tm) - n = length shrinks - u = length $ nubHashableOn showRenameTerm shrinks - r | n > 0 = 5 * ((n - u) * 20 `div` n) - | otherwise = 0 - in tabulate "distribution | duplicates" [" | " ++ show r ++ "%"] True + forAllDoc "ty,tm" genTypeAndTerm_ (const []) $ \(ty, tm) -> + let shrinks = map snd $ shrinkClosedTypedTerm (ty, tm) + n = length shrinks + u = length $ nubHashableOn showRenameTerm shrinks + r + | n > 0 = 5 * ((n - u) * 20 `div` n) + | otherwise = 0 + in tabulate "distribution | duplicates" [" | " ++ show r ++ "%"] True -- | Specific test that `inhabitType` returns well-typed things prop_inhabited :: Property prop_inhabited = withMaxSuccess 50 $ -- No shrinking here because if the generator -- generates nonsense shrinking will be nonsense. - forAllDoc "ty,tm" (genInhab mempty) (const []) $ \ (ty, tm) -> typeCheckTerm tm ty + forAllDoc "ty,tm" (genInhab mempty) (const []) $ + \(ty, tm) -> typeCheckTerm tm ty where -- Generate some datatypes and then immediately call -- `inhabitType` to test `inhabitType` directly instead -- of through the whole term generator. Quick-ish way -- of debugging "clever hacks" in `inhabitType`. - genInhab ctx = runGenTm $ local (\ e -> e { geTypes = ctx }) $ - genDatatypeLets $ \ dats -> do - ty <- genType $ Type () - tm <- inhabitType ty - return (ty, foldr (\ dat -> Let () NonRec (DatatypeBind () dat :| [])) tm dats) + genInhab ctx = runGenTm $ + local (\e -> e {geTypes = ctx}) $ + genDatatypeLets $ \dats -> do + ty <- genType $ Type () + tm <- inhabitType ty + return (ty, foldr (\dat -> Let () NonRec (DatatypeBind () dat :| [])) tm dats) -- | Check that there are no one-step shrink loops prop_noTermShrinkLoops :: Property -- The test is disabled, because it's exponential and was hanging CI. -prop_noTermShrinkLoops = withMaxSuccess 0 $ +prop_noTermShrinkLoops = withMaxSuccess 0 + $ -- Note that we need to remove x from the shrinks of x here because -- a counterexample to this property is otherwise guaranteed to -- go into a shrink loop. - forAllDoc "ty,tm" genTypeAndTerm_ - (\(ty', tm') -> filter ((/= tm') . snd) $ shrinkClosedTypedTerm (ty', tm')) $ \(ty, tm) -> - tm `notElem` map snd (shrinkClosedTypedTerm (ty, tm)) + forAllDoc + "ty,tm" + genTypeAndTerm_ + (\(ty', tm') -> filter ((/= tm') . snd) $ shrinkClosedTypedTerm (ty', tm')) + $ \(ty, tm) -> + tm `notElem` map snd (shrinkClosedTypedTerm (ty, tm)) -- | Check that evaluation of the given term doesn't fail with a structural error. noStructuralErrors :: UPLC.Term Name DefaultUni DefaultFun () -> IO () @@ -212,11 +228,14 @@ noStructuralErrors term = prop_noStructuralErrors :: Property prop_noStructuralErrors = withMaxSuccess 99 $ forAllDoc "ty,tm" genTypeAndTerm_ shrinkClosedTypedTerm $ \(_, termPir) -> ioProperty $ do - termUPlc <- fmap UPLC._progTerm . modifyError (userError . displayException) . toUPlc $ + termUPlc <- + fmap UPLC._progTerm . modifyError (userError . displayException) . toUPlc $ Program () latestVersion termPir noStructuralErrors termUPlc -- | Test that evaluation of an ill-typed terms fails with a structural error. prop_yesStructuralErrors :: Property -prop_yesStructuralErrors = expectFailure . ioProperty $ - noStructuralErrors $ UPLC.Apply () (fromValue True) (fromValue ()) +prop_yesStructuralErrors = + expectFailure . ioProperty $ + noStructuralErrors $ + UPLC.Apply () (fromValue True) (fromValue ()) diff --git a/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs index 38147d7a55a..b401332d630 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PolyKinds #-} -- | Tests for PIR parser. module PlutusIR.Parser.Tests where @@ -27,22 +27,25 @@ import Hedgehog.Range qualified as Range import Test.Tasty import Test.Tasty.Hedgehog -newtype PrettyProg = PrettyProg { prog :: Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan } +newtype PrettyProg = PrettyProg {prog :: Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan} instance Show PrettyProg where - show = display . prog + show = display . prog whitespace :: MonadGen m => m String whitespace = flip replicate ' ' <$> Gen.integral (Range.linear 1 4) lineComment :: MonadGen m => m String -lineComment = (Gen.string (Range.linear 0 20) $ Gen.filterT (/= '\n') Gen.latin1) - >>= (\s -> return $ " --" ++ s ++ "\n") +lineComment = + (Gen.string (Range.linear 0 20) $ Gen.filterT (/= '\n') Gen.latin1) + >>= (\s -> return $ " --" ++ s ++ "\n") blockComment :: MonadGen m => m String -blockComment = (Gen.string (Range.linear 0 20) $ Gen.element notBraces) - >>= (\s -> return $ "{- " ++ s ++ " -}") - where notBraces :: String - notBraces = filter (\c -> c /= '{' && c /= '}') ['\0' .. '\255'] +blockComment = + (Gen.string (Range.linear 0 20) $ Gen.element notBraces) + >>= (\s -> return $ "{- " ++ s ++ " -}") + where + notBraces :: String + notBraces = filter (\c -> c /= '{' && c /= '}') ['\0' .. '\255'] comment :: MonadGen m => m String comment = Gen.choice [Gen.constant "", lineComment, blockComment] @@ -59,29 +62,31 @@ aroundSeparators = go False False -- Quoted names may contain separators, but they are part of the name, so -- we cannot scramble inside quoted names. go inQuotedName inUnique splice = \case - [] -> pure [] - [s] -> (s:) <$> splice - ('`' : '-' : l) | inQuotedName -> do - let (digits, notDigits) = break isDigit l - rest <- go (not inQuotedName) True splice notDigits - pure $ "`-" ++ digits ++ rest - ('`' : l) -> do - s <- splice - rest <- go (not inQuotedName) inUnique splice l - pure $ if inQuotedName - then '`' : s ++ rest - else s ++ '`' : rest - (a : b : l) - | not inQuotedName && separator b -> do - s1 <- splice - s2 <- splice - rest <- go inQuotedName inUnique splice l - pure $ a : s1 ++ b : s2 ++ rest - | otherwise -> (a :) <$> go inQuotedName inUnique splice (b : l) + [] -> pure [] + [s] -> (s :) <$> splice + ('`' : '-' : l) | inQuotedName -> do + let (digits, notDigits) = break isDigit l + rest <- go (not inQuotedName) True splice notDigits + pure $ "`-" ++ digits ++ rest + ('`' : l) -> do + s <- splice + rest <- go (not inQuotedName) inUnique splice l + pure $ + if inQuotedName + then '`' : s ++ rest + else s ++ '`' : rest + (a : b : l) + | not inQuotedName && separator b -> do + s1 <- splice + s2 <- splice + rest <- go inQuotedName inUnique splice l + pure $ a : s1 ++ b : s2 ++ rest + | otherwise -> (a :) <$> go inQuotedName inUnique splice (b : l) -- | Check whether the given constant can be scrambled (in the sense of 'genScrambledWith'). isScramblable :: PLC.Some (PLC.ValueOf PLC.DefaultUni) -> Bool -isScramblable (PLC.Some (PLC.ValueOf uni0 x0)) = go uni0 x0 where +isScramblable (PLC.Some (PLC.ValueOf uni0 x0)) = go uni0 x0 + where go :: PLC.DefaultUni (PLC.Esc a) -> a -> Bool go PLC.DefaultUniInteger _ = True go PLC.DefaultUniByteString _ = True @@ -92,9 +97,9 @@ isScramblable (PLC.Some (PLC.ValueOf uni0 x0)) = go uni0 x0 where go (PLC.DefaultUniProtoList `PLC.DefaultUniApply` uniA) xs = all (go uniA) xs go (PLC.DefaultUniProtoArray `PLC.DefaultUniApply` uniA) xs = all (go uniA) xs go (PLC.DefaultUniProtoPair `PLC.DefaultUniApply` uniA `PLC.DefaultUniApply` uniB) (x, y) = - go uniA x && go uniB y - go (f `PLC.DefaultUniApply` _ `PLC.DefaultUniApply` _ `PLC.DefaultUniApply` _) _ = - noMoreTypeFunctions f + go uniA x && go uniB y + go (f `PLC.DefaultUniApply` _ `PLC.DefaultUniApply` _ `PLC.DefaultUniApply` _) _ = + noMoreTypeFunctions f go PLC.DefaultUniData _ = True go PLC.DefaultUniValue _ = True go PLC.DefaultUniBLS12_381_G1_Element _ = False @@ -103,58 +108,62 @@ isScramblable (PLC.Some (PLC.ValueOf uni0 x0)) = go uni0 x0 where genScrambledWith :: MonadGen m => m String -> m (String, String) genScrambledWith splice = do - original <- display <$> runAstGen (regenConstantsUntil isScramblable =<< genProgram) - scrambled <- aroundSeparators splice original - return (original, scrambled) + original <- display <$> runAstGen (regenConstantsUntil isScramblable =<< genProgram) + scrambled <- aroundSeparators splice original + return (original, scrambled) propRoundTrip :: Property propRoundTrip = property $ do - code <- display <$> - forAllWith display (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) - let backward = fmap (display . prog) - forward = fmap PrettyProg . parseProg - tripping code forward backward + code <- + display + <$> forAllWith display (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) + let backward = fmap (display . prog) + forward = fmap PrettyProg . parseProg + tripping code forward backward -- | The `SrcSpan` of a parsed `Term` should not including trailing whitespaces. propTermSrcSpan :: Property propTermSrcSpan = property $ do - code <- display . _progTerm <$> - forAllWith display (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) - let (endingLine, endingCol) = length &&& T.length . last $ T.lines code - trailingSpaces <- forAll $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n']) - case parseTerm (code <> trailingSpaces) of - Right term -> - let sp = termAnn term - in (srcSpanELine sp, srcSpanECol sp) === (endingLine, endingCol + 1) - Left err -> annotate (display err) >> failure + code <- + display . _progTerm + <$> forAllWith display (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) + let (endingLine, endingCol) = length &&& T.length . last $ T.lines code + trailingSpaces <- forAll $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n']) + case parseTerm (code <> trailingSpaces) of + Right term -> + let sp = termAnn term + in (srcSpanELine sp, srcSpanECol sp) === (endingLine, endingCol + 1) + Left err -> annotate (display err) >> failure parseProg :: - T.Text -> - Either - ParserErrorBundle - (Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) + T.Text -> + Either + ParserErrorBundle + (Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) parseProg p = - PLC.runQuoteT $ parse program "test" p + PLC.runQuoteT $ parse program "test" p parseTerm :: - T.Text -> - Either - ParserErrorBundle - (Term TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) + T.Text -> + Either + ParserErrorBundle + (Term TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan) parseTerm p = - PLC.runQuoteT $ parse pTerm "test" p + PLC.runQuoteT $ parse pTerm "test" p propIgnores :: Gen String -> Property propIgnores splice = property $ do - (original, scrambled) <- forAll (genScrambledWith splice) - let displayProgram :: Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan -> String - displayProgram = display - parse1 = displayProgram <$> parseProg (T.pack original) - parse2 = displayProgram <$> parseProg (T.pack scrambled) - parse1 === parse2 + (original, scrambled) <- forAll (genScrambledWith splice) + let displayProgram :: Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan -> String + displayProgram = display + parse1 = displayProgram <$> parseProg (T.pack original) + parse2 = displayProgram <$> parseProg (T.pack scrambled) + parse1 === parse2 test_parsing :: TestTree -test_parsing = testGroup "parsing" +test_parsing = + testGroup + "parsing" [ testPropertyNamed "parser round-trip" "propRoundTrip" diff --git a/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs index 4b80f6e1c4a..a9729427d62 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + module PlutusIR.Purity.Tests where import Test.Tasty.Extras @@ -16,15 +17,15 @@ import PlutusPrelude (def) import Test.Tasty import Test.Tasty.HUnit -computeEvalOrder - :: Term TyName Name PLC.DefaultUni PLC.DefaultFun a - -> EvalOrder TyName Name PLC.DefaultUni PLC.DefaultFun a +computeEvalOrder :: + Term TyName Name PLC.DefaultUni PLC.DefaultFun a -> + EvalOrder TyName Name PLC.DefaultUni PLC.DefaultFun a computeEvalOrder tm = termEvaluationOrder def (termVarInfo tm) tm -- Avoids traversing the term to compute the var info -computeEvalOrderCoarse - :: Term TyName Name PLC.DefaultUni PLC.DefaultFun a - -> EvalOrder TyName Name PLC.DefaultUni PLC.DefaultFun a +computeEvalOrderCoarse :: + Term TyName Name PLC.DefaultUni PLC.DefaultFun a -> + EvalOrder TyName Name PLC.DefaultUni PLC.DefaultFun a computeEvalOrderCoarse = termEvaluationOrder def mempty goldenEvalOrder :: String -> TestNested @@ -41,13 +42,15 @@ dangerTerm = runQuote $ do test_evalOrder :: TestTree test_evalOrder = - runTestNested ["plutus-ir", "test", "PlutusIR", "Purity"] - [ goldenEvalOrder "letFun" - , goldenEvalOrder "builtinAppUnsaturated" - , goldenEvalOrder "builtinAppSaturated" - , goldenEvalOrder "pureLet" - , goldenEvalOrder "nestedLets1" - , goldenEvalOrder "ifThenElse" - , embed $ testCase "evalOrderLazy" $ - 4 @=? length (unEvalOrder $ computeEvalOrderCoarse dangerTerm) - ] + runTestNested + ["plutus-ir", "test", "PlutusIR", "Purity"] + [ goldenEvalOrder "letFun" + , goldenEvalOrder "builtinAppUnsaturated" + , goldenEvalOrder "builtinAppSaturated" + , goldenEvalOrder "pureLet" + , goldenEvalOrder "nestedLets1" + , goldenEvalOrder "ifThenElse" + , embed $ + testCase "evalOrderLazy" $ + 4 @=? length (unEvalOrder $ computeEvalOrderCoarse dangerTerm) + ] diff --git a/plutus-core/plutus-ir/test/PlutusIR/Scoping/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Scoping/Tests.hs index 1933befea49..35d9861bbeb 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Scoping/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Scoping/Tests.hs @@ -27,7 +27,9 @@ import Test.Tasty -- See Note [Scoping tests API]. test_names :: TestTree -test_names = testGroup "names" +test_names = + testGroup + "names" [ T.test_scopingGood "beta-reduction" genTerm T.BindingRemovalNotOk T.PrerenameYes $ pure . beta , T.test_scopingGood "case-of-known-constructor" genTerm T.BindingRemovalOk T.PrerenameYes $ @@ -51,34 +53,36 @@ test_names = testGroup "names" "match-against-known-constructor" genTerm T.BindingRemovalNotOk - T.PrerenameYes $ - (pure . knownCon) + T.PrerenameYes + $ (pure . knownCon) , T.test_scopingGood "floating bindings inwards" genTerm T.BindingRemovalNotOk T.PrerenameYes $ (pure . In.floatTerm def True) - -- Can't test 'Out.floatTerm', because it requires the type of annotations to implement - -- 'Semigroup' and it's not clear what that means for 'NameAnn'. - , T.test_scopingGood "merging lets" genTerm T.BindingRemovalNotOk T.PrerenameYes $ + , -- Can't test 'Out.floatTerm', because it requires the type of annotations to implement + -- 'Semigroup' and it's not clear what that means for 'NameAnn'. + T.test_scopingGood "merging lets" genTerm T.BindingRemovalNotOk T.PrerenameYes $ pure . letMerge , -- The pass breaks global uniqueness, but it's not clear whether this is by design or not. T.test_scopingBad "compilation of non-strict bindings" genTerm T.BindingRemovalOk - T.PrerenameYes $ - compileNonStrictBindings True + T.PrerenameYes + $ compileNonStrictBindings True , T.test_scopingGood "match-against-known-constructor" genTerm T.BindingRemovalNotOk - T.PrerenameYes $ - pure . recSplit + T.PrerenameYes + $ pure . recSplit , T.test_scopingGood "renaming" genProgram T.BindingRemovalNotOk T.PrerenameNo $ rename - , T.test_scopingSpoilRenamer genProgram markNonFreshProgram + , T.test_scopingSpoilRenamer + genProgram + markNonFreshProgram renameProgramM - -- Can't test substitution procedures at the moment, because that requires generating - -- functions. - , -- The pass breals global uniqueness by design. + , -- Can't test substitution procedures at the moment, because that requires generating + -- functions. + -- The pass breals global uniqueness by design. T.test_scopingBad "thunking recursions" genTerm T.BindingRemovalOk T.PrerenameYes $ pure . thunkRecursions def , T.test_scopingGood "unwrap-wrap cancelling" genTerm T.BindingRemovalNotOk T.PrerenameYes $ diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/Beta/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/Beta/Tests.hs index c19a221d010..97dea6ef0ff 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/Beta/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/Beta/Tests.hs @@ -11,15 +11,15 @@ import Test.Tasty.Extras test_beta :: TestTree test_beta = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Beta"] $ - map - (goldenPir (runQuote . runTestPass betaPassSC) pTerm) - [ "lamapp" - , "lamapp2" - , "absapp" - , "multiapp" - , "multilet" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Beta"] $ + map + (goldenPir (runQuote . runTestPass betaPassSC) pTerm) + [ "lamapp" + , "lamapp2" + , "absapp" + , "multiapp" + , "multilet" + ] prop_beta :: Property prop_beta = withMaxSuccess numTestsForPassProp $ testPassProp runQuote betaPassSC diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs index 221f02c5cbb..97d5ae7a28f 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs @@ -13,18 +13,24 @@ import Test.QuickCheck.Property (Property, withMaxSuccess) test_caseOfCase :: TestTree test_caseOfCase = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "CaseOfCase"] $ - map - (goldenPir (runQuote . runTestPass - (\tc -> CaseOfCase.caseOfCasePassSC tc def True mempty)) pTerm) - [ "basic" - , "builtinBool" - , "largeExpr" - , "exponential" - , "twoTyArgs" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "CaseOfCase"] $ + map + ( goldenPir + ( runQuote + . runTestPass + (\tc -> CaseOfCase.caseOfCasePassSC tc def True mempty) + ) + pTerm + ) + [ "basic" + , "builtinBool" + , "largeExpr" + , "exponential" + , "twoTyArgs" + ] prop_caseOfCase :: Property prop_caseOfCase = withMaxSuccess numTestsForPassProp $ - testPassProp runQuote $ \tc -> CaseOfCase.caseOfCasePassSC tc def True mempty + testPassProp runQuote $ + \tc -> CaseOfCase.caseOfCasePassSC tc def True mempty diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/DeadCode/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/DeadCode/Tests.hs index 5ce5c3e8498..9920a7cbcdb 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/DeadCode/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/DeadCode/Tests.hs @@ -14,38 +14,37 @@ import PlutusPrelude import Test.Tasty.ExpectedFailure (ignoreTest) import Test.Tasty.QuickCheck - test_deadCode :: TestTree test_deadCode = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "DeadCode"] $ - map - (goldenPir (runQuote . runTestPass (\tc -> removeDeadBindingsPassSC tc def)) pTerm) - [ "typeLet" - , "termLet" - , "strictLet" - , "nonstrictLet" - , "datatypeLiveType" - , "datatypeLiveConstr" - , "datatypeLiveDestr" - , "datatypeDead" - , "singleBinding" - , "builtinBinding" - , "etaBuiltinBinding" - , "nestedBindings" - , "nestedBindingsIndirect" - , "recBindingSimple" - , "recBindingComplex" - , "pruneDatatype" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "DeadCode"] $ + map + (goldenPir (runQuote . runTestPass (\tc -> removeDeadBindingsPassSC tc def)) pTerm) + [ "typeLet" + , "termLet" + , "strictLet" + , "nonstrictLet" + , "datatypeLiveType" + , "datatypeLiveConstr" + , "datatypeLiveDestr" + , "datatypeDead" + , "singleBinding" + , "builtinBinding" + , "etaBuiltinBinding" + , "nestedBindings" + , "nestedBindingsIndirect" + , "recBindingSimple" + , "recBindingComplex" + , "pruneDatatype" + ] -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1877): -- this test sometimes fails so ignoring it to make CI pass. typecheckRemoveDeadBindingsProp :: BuiltinSemanticsVariant DefaultFun -> Property typecheckRemoveDeadBindingsProp biVariant = - withMaxSuccess (3 * numTestsForPassProp) $ - testPassProp + withMaxSuccess (3 * numTestsForPassProp) + $ testPassProp runQuote - $ \tc -> removeDeadBindingsPassSC tc (def {_biSemanticsVariant = biVariant}) + $ \tc -> removeDeadBindingsPassSC tc (def {_biSemanticsVariant = biVariant}) test_deadCodeP :: TestTree test_deadCodeP = ignoreTest $ testProperty "deadCode" typecheckRemoveDeadBindingsProp diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs index e2d3aa316d4..1595e1d3c3d 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs @@ -15,35 +15,36 @@ import Test.QuickCheck.Property (Property, withMaxSuccess) test_evaluateBuiltins :: TestTree test_evaluateBuiltins = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "EvaluateBuiltins"] $ - conservative ++ nonConservative - where - conservative = - map - (goldenPir - (runIdentity . runTestPass (\tc -> evaluateBuiltinsPass tc True def def)) - pTerm) - [ "addInteger" - , "ifThenElse" - , "traceConservative" - , "failingBuiltin" - , "nonConstantArg" - , "overApplication" - , "underApplication" - , "uncompressBlsConservative" - ] - nonConservative = - map - (goldenPir (evaluateBuiltins False def def) pTerm) - -- We want to test the case where this would reduce, i.e. - [ "traceNonConservative" - , "uncompressBlsNonConservative" - , "uncompressAndEqualBlsNonConservative" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "EvaluateBuiltins"] $ + conservative ++ nonConservative + where + conservative = + map + ( goldenPir + (runIdentity . runTestPass (\tc -> evaluateBuiltinsPass tc True def def)) + pTerm + ) + [ "addInteger" + , "ifThenElse" + , "traceConservative" + , "failingBuiltin" + , "nonConstantArg" + , "overApplication" + , "underApplication" + , "uncompressBlsConservative" + ] + nonConservative = + map + (goldenPir (evaluateBuiltins False def def) pTerm) + -- We want to test the case where this would reduce, i.e. + [ "traceNonConservative" + , "uncompressBlsNonConservative" + , "uncompressAndEqualBlsNonConservative" + ] prop_evaluateBuiltins :: Bool -> BuiltinSemanticsVariant DefaultFun -> Property prop_evaluateBuiltins conservative biVariant = - withMaxSuccess numTestsForPassProp $ - testPassProp + withMaxSuccess numTestsForPassProp + $ testPassProp runIdentity - $ \tc -> evaluateBuiltinsPass tc conservative (def {_biSemanticsVariant = biVariant}) def + $ \tc -> evaluateBuiltinsPass tc conservative (def {_biSemanticsVariant = biVariant}) def diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/Inline/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/Inline/Tests.hs index 3c5e2b6ce1e..8f8dad44398 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/Inline/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/Inline/Tests.hs @@ -16,54 +16,54 @@ import Test.Tasty (TestTree) -- | Tests of the inliner, include global uniqueness test. test_inline :: TestTree test_inline = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Inline"] $ - map - (runTest withConstantInlining) - [ "var" - , "builtin" - , "callsite-6970" - , "callsite-non-trivial-body" - , "constant" - , "transitive" - , "tyvar" - , "single" - , "immediateVar" - , "immediateApp" - , "firstEffectfulTerm1" - , "firstEffectfulTerm2" - -- these tests are all let bindings of functions - , "letFunConstInt" -- const fn fully applied (integer) - , "letFunConstBool" -- const fn fully applied (bool) - , "letFunConstMulti" -- multiple occurrences of a let binding of the const fn. - , "letFunInFun" -- fully applied fn inside another let, single occurrence. - , "letFunInFunMulti" -- fully applied fn inside another let, multiple occurrences. - -- similar to "letFunInFunMulti" but all fns are fully applied. - , "letTypeAppMulti" - -- singe occurrence of a polymorphic id function that is fully applied - , "letTypeApp" - , "letTypeApp2" -- multiple occurrences of a function with type application - -- multiple occurrences of a polymorphic id function that IS fully applied - , "letTypeAppMultiSat" - -- multiple occurrences of a polymorphic id function that is NOT fully applied - , "letTypeAppMultiNotSat" - , "letApp" -- single occurrence of a function application in rhs - -- multiple occurrences of a function application in rhs with not acceptable body - , "letAppMultiNotAcceptable" - , "letOverApp" -- over-application of a function, single occurrence - , "letOverAppMulti" -- multiple occurrences of an over-application of a function - -- multiple occurrences of an over-application of a function with type arguments - , "letOverAppType" - , "letNonPure" -- multiple occurrences of a non-pure binding - , "letNonPureMulti" - , "letNonPureMultiStrict" - , "multilet" - , "rhs-modified" - , "partiallyApp" - , "effectfulBuiltinArg" - , "nameCapture" - , "inlineConstantsOn" - ] - <> [runTest withoutConstantInlining "inlineConstantsOff"] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Inline"] $ + map + (runTest withConstantInlining) + [ "var" + , "builtin" + , "callsite-6970" + , "callsite-non-trivial-body" + , "constant" + , "transitive" + , "tyvar" + , "single" + , "immediateVar" + , "immediateApp" + , "firstEffectfulTerm1" + , "firstEffectfulTerm2" + , -- these tests are all let bindings of functions + "letFunConstInt" -- const fn fully applied (integer) + , "letFunConstBool" -- const fn fully applied (bool) + , "letFunConstMulti" -- multiple occurrences of a let binding of the const fn. + , "letFunInFun" -- fully applied fn inside another let, single occurrence. + , "letFunInFunMulti" -- fully applied fn inside another let, multiple occurrences. + -- similar to "letFunInFunMulti" but all fns are fully applied. + , "letTypeAppMulti" + , -- singe occurrence of a polymorphic id function that is fully applied + "letTypeApp" + , "letTypeApp2" -- multiple occurrences of a function with type application + -- multiple occurrences of a polymorphic id function that IS fully applied + , "letTypeAppMultiSat" + , -- multiple occurrences of a polymorphic id function that is NOT fully applied + "letTypeAppMultiNotSat" + , "letApp" -- single occurrence of a function application in rhs + -- multiple occurrences of a function application in rhs with not acceptable body + , "letAppMultiNotAcceptable" + , "letOverApp" -- over-application of a function, single occurrence + , "letOverAppMulti" -- multiple occurrences of an over-application of a function + -- multiple occurrences of an over-application of a function with type arguments + , "letOverAppType" + , "letNonPure" -- multiple occurrences of a non-pure binding + , "letNonPureMulti" + , "letNonPureMultiStrict" + , "multilet" + , "rhs-modified" + , "partiallyApp" + , "effectfulBuiltinArg" + , "nameCapture" + , "inlineConstantsOn" + ] + <> [runTest withoutConstantInlining "inlineConstantsOff"] where runTest constantInlining = goldenPir (runQuote . runTestPass (\tc -> inlinePassSC 0 constantInlining tc def def)) pTerm @@ -71,9 +71,9 @@ test_inline = withoutConstantInlining = False prop_inline :: - BuiltinSemanticsVariant DefaultFun -> Property + BuiltinSemanticsVariant DefaultFun -> Property prop_inline biVariant = - withMaxSuccess numTestsForPassProp $ - testPassProp + withMaxSuccess numTestsForPassProp + $ testPassProp runQuote - $ \tc -> inlinePassSC 0 True tc def (def {_biSemanticsVariant = biVariant}) + $ \tc -> inlinePassSC 0 True tc def (def {_biSemanticsVariant = biVariant}) diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/KnownCon/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/KnownCon/Tests.hs index 7eb7f7ac053..afac656be64 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/KnownCon/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/KnownCon/Tests.hs @@ -12,17 +12,17 @@ import Test.QuickCheck test_knownCon :: TestTree test_knownCon = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "KnownCon"] $ - map - (goldenPir (runQuote . runTestPass KnownCon.knownConPassSC) pTerm) - [ "applicative" - , "bool" - , "list" - , "maybe-just" - , "maybe-just-unsaturated" - , "maybe-nothing" - , "pair" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "KnownCon"] $ + map + (goldenPir (runQuote . runTestPass KnownCon.knownConPassSC) pTerm) + [ "applicative" + , "bool" + , "list" + , "maybe-just" + , "maybe-just-unsaturated" + , "maybe-nothing" + , "pair" + ] prop_knownCon :: Property prop_knownCon = withMaxSuccess numTestsForPassProp $ testPassProp runQuote KnownCon.knownConPassSC diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatIn/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatIn/Tests.hs index e14e1341296..c3b292cf273 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatIn/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatIn/Tests.hs @@ -18,43 +18,43 @@ import Test.QuickCheck.Property (Property, withMaxSuccess) test_letFloatInConservative :: TestTree test_letFloatInConservative = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "LetFloatIn", "conservative"] $ - map - (goldenPir (runQuote . runTestPass testPass) pTerm) - [ "avoid-floating-into-lam" - , "avoid-floating-into-tyabs" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "LetFloatIn", "conservative"] $ + map + (goldenPir (runQuote . runTestPass testPass) pTerm) + [ "avoid-floating-into-lam" + , "avoid-floating-into-tyabs" + ] where testPass tcconfig = LetFloatIn.floatTermPassSC tcconfig def False - <> LetMerge.letMergePass tcconfig + <> LetMerge.letMergePass tcconfig test_letFloatInRelaxed :: TestTree test_letFloatInRelaxed = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "LetFloatIn", "relaxed"] $ - map - (goldenPir (runQuote . runTestPass testPass) pTerm) - [ "avoid-floating-into-RHS" - , "avoid-moving-strict-nonvalue-bindings" - , "cannot-float-into-app" - , "datatype1" - , "datatype2" - , "float-into-fun-and-arg-1" - , "float-into-fun-and-arg-2" - , "float-into-lam1" - , "float-into-lam2" - , "float-into-RHS" - , "float-into-tyabs1" - , "float-into-tyabs2" - , "float-into-constr" - , "float-into-case-arg" - , "float-into-case-branch" - , "type" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "LetFloatIn", "relaxed"] $ + map + (goldenPir (runQuote . runTestPass testPass) pTerm) + [ "avoid-floating-into-RHS" + , "avoid-moving-strict-nonvalue-bindings" + , "cannot-float-into-app" + , "datatype1" + , "datatype2" + , "float-into-fun-and-arg-1" + , "float-into-fun-and-arg-2" + , "float-into-lam1" + , "float-into-lam2" + , "float-into-RHS" + , "float-into-tyabs1" + , "float-into-tyabs2" + , "float-into-constr" + , "float-into-case-arg" + , "float-into-case-branch" + , "type" + ] where testPass tcconfig = LetFloatIn.floatTermPassSC tcconfig def True - <> LetMerge.letMergePass tcconfig + <> LetMerge.letMergePass tcconfig prop_floatIn :: BuiltinSemanticsVariant PLC.DefaultFun -> Bool -> Property @@ -64,5 +64,5 @@ prop_floatIn biVariant conservative = testPass tcconfig = LetFloatIn.floatTermPassSC tcconfig - (def { _biSemanticsVariant = biVariant }) + (def {_biSemanticsVariant = biVariant}) conservative diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatOut/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatOut/Tests.hs index 7c6e07538ed..c140b19639b 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatOut/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/LetFloatOut/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-} + module PlutusIR.Transform.LetFloatOut.Tests where import Test.Tasty @@ -20,49 +21,49 @@ import Test.QuickCheck.Property (Property, withMaxSuccess) test_letFloatOut :: TestTree test_letFloatOut = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "LetFloatOut"] $ - map - (goldenPir (runQuote . runTestPass testPass) pTerm) - [ "letInLet" - , "listMatch" - , "maybe" - , "ifError" - , "mutuallyRecursiveTypes" - , "mutuallyRecursiveValues" - , "nonrec1" - , "nonrec2" - , "nonrec3" - , "nonrec4" - , "nonrec6" - , "nonrec7" - , "nonrec8" - , "nonrec9" - , "rec1" - , "rec2" - , "rec3" - , "rec4" - , "nonrecToRec" - , "nonrecToNonrec" - , "oldLength" - , "strictValue" - , "strictNonValue" - , "strictNonValue2" - , "strictNonValue3" - , "strictValueNonValue" - , "strictValueValue" - , "even3Eval" - , "strictNonValueDeep" - , "oldFloatBug" - , "outRhs" - , "outLam" - , "inLam" - , "rhsSqueezeVsNest" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "LetFloatOut"] $ + map + (goldenPir (runQuote . runTestPass testPass) pTerm) + [ "letInLet" + , "listMatch" + , "maybe" + , "ifError" + , "mutuallyRecursiveTypes" + , "mutuallyRecursiveValues" + , "nonrec1" + , "nonrec2" + , "nonrec3" + , "nonrec4" + , "nonrec6" + , "nonrec7" + , "nonrec8" + , "nonrec9" + , "rec1" + , "rec2" + , "rec3" + , "rec4" + , "nonrecToRec" + , "nonrecToNonrec" + , "oldLength" + , "strictValue" + , "strictNonValue" + , "strictNonValue2" + , "strictNonValue3" + , "strictValueNonValue" + , "strictValueValue" + , "even3Eval" + , "strictNonValueDeep" + , "oldFloatBug" + , "outRhs" + , "outLam" + , "inLam" + , "rhsSqueezeVsNest" + ] where testPass tcconfig = LetFloatOut.floatTermPassSC tcconfig def - <> RecSplit.recSplitPass tcconfig - <> LetMerge.letMergePass tcconfig + <> RecSplit.recSplitPass tcconfig + <> LetMerge.letMergePass tcconfig prop_floatOut :: BuiltinSemanticsVariant PLC.DefaultFun -> Property prop_floatOut biVariant = withMaxSuccess numTestsForPassProp $ testPassProp runQuote testPass @@ -70,4 +71,4 @@ prop_floatOut biVariant = withMaxSuccess numTestsForPassProp $ testPassProp runQ testPass tcconfig = LetFloatOut.floatTermPassSC tcconfig - (def { _biSemanticsVariant = biVariant }) + (def {_biSemanticsVariant = biVariant}) diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/NonStrict/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/NonStrict/Tests.hs index e78dd512a5a..ae3dba0cbc8 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/NonStrict/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/NonStrict/Tests.hs @@ -13,13 +13,19 @@ import Test.QuickCheck test_nonStrict :: TestTree test_nonStrict = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "NonStrict"] $ - map - (goldenPir (runQuote . runTestPass - (\tc -> NonStrict.compileNonStrictBindingsPassSC tc False)) pTerm) - [ "nonStrict1" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "NonStrict"] $ + map + ( goldenPir + ( runQuote + . runTestPass + (\tc -> NonStrict.compileNonStrictBindingsPassSC tc False) + ) + pTerm + ) + [ "nonStrict1" + ] prop_nonStrict :: Bool -> Property prop_nonStrict useUnit = withMaxSuccess numTestsForPassProp $ - testPassProp runQuote $ \tc -> NonStrict.compileNonStrictBindingsPassSC tc useUnit + testPassProp runQuote $ + \tc -> NonStrict.compileNonStrictBindingsPassSC tc useUnit diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RecSplit/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/RecSplit/Tests.hs index 57d46d0fd77..0cd1a40234f 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/RecSplit/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RecSplit/Tests.hs @@ -13,16 +13,16 @@ import Test.Tasty.QuickCheck test_recSplit :: TestTree test_recSplit = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "RecSplit"] $ - map - (goldenPir (runQuote . runTestPass recSplitPass) pTerm) - [ "truenonrec" - , "mutuallyRecursiveTypes" - , "mutuallyRecursiveValues" - , "selfrecursive" - , "small" - , "big" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "RecSplit"] $ + map + (goldenPir (runQuote . runTestPass recSplitPass) pTerm) + [ "truenonrec" + , "mutuallyRecursiveTypes" + , "mutuallyRecursiveValues" + , "selfrecursive" + , "small" + , "big" + ] prop_recSplit :: Property prop_recSplit = diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs index baa43be5eb7..810277a078d 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs @@ -13,14 +13,13 @@ import Test.Tasty.QuickCheck test_rename :: TestTree test_rename = - - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Rename"] $ - runGoldenPir <$> - [ "allShadowedDataNonRec" - , "allShadowedDataRec" - , "paramShadowedDataNonRec" - , "paramShadowedDataRec" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Rename"] $ + runGoldenPir + <$> [ "allShadowedDataNonRec" + , "allShadowedDataRec" + , "paramShadowedDataNonRec" + , "paramShadowedDataRec" + ] where runGoldenPir = goldenPir (runQuote . runTestPass (const renamePass)) pTerm diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests.hs index 7c627737d51..f7ec82ec27c 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} module PlutusIR.Transform.StrictLetRec.Tests where @@ -16,10 +16,14 @@ import PlutusIR.Core qualified as PIR import PlutusIR.Parser (pTerm) import PlutusIR.Pass.Test (runTestPass) import PlutusIR.Test (goldenPirM) -import PlutusIR.Transform.StrictLetRec.Tests.Lib (compilePirProgramOrFail, compileTplcProgramOrFail, - defaultCompilationCtx, - evalPirProgramWithTracesOrFail, pirTermAsProgram, - pirTermFromFile) +import PlutusIR.Transform.StrictLetRec.Tests.Lib ( + compilePirProgramOrFail, + compileTplcProgramOrFail, + defaultCompilationCtx, + evalPirProgramWithTracesOrFail, + pirTermAsProgram, + pirTermFromFile, + ) import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek (EvaluationResult (..)) @@ -34,26 +38,32 @@ path :: [FilePath] path = ["plutus-ir", "test", "PlutusIR", "Transform"] test_letRec :: TestTree -test_letRec = runTestNested path . pure $ testNested "StrictLetRec" - [ let - runCompilationM m = either (fail . show) pure do - ctx <- defaultCompilationCtx - runExcept . runQuoteT $ runReaderT m ctx - dumpUplc pirTermBefore = do - pirTermAfter <- runCompilationM $ - fmap void . runTestPass (`compileLetsPassSC` RecTerms) $ noProvenance <$ pirTermBefore - tplcProg <- compilePirProgramOrFail $ PIR.Program () latestVersion pirTermAfter - uplcProg <- compileTplcProgramOrFail tplcProg - pure . AsReadable $ UPLC._progTerm uplcProg - in goldenPirM dumpUplc pTerm "strictLetRec" - , embed $ testCase "traces" do - (result, traces) <- do - pirTerm <- pirTermFromFile (joinPath path "StrictLetRec" "strictLetRec") - evalPirProgramWithTracesOrFail (pirTermAsProgram (void pirTerm)) - case result of - EvaluationFailure -> - fail $ "Evaluation failed, available traces: " <> show traces - EvaluationSuccess term -> do - term @?= constant () (someValue (1 :: Integer)) - traces @?= ["hello"] - ] +test_letRec = + runTestNested path . pure $ + testNested + "StrictLetRec" + [ let + runCompilationM m = either (fail . show) pure do + ctx <- defaultCompilationCtx + runExcept . runQuoteT $ runReaderT m ctx + dumpUplc pirTermBefore = do + pirTermAfter <- + runCompilationM $ + fmap void . runTestPass (`compileLetsPassSC` RecTerms) $ + noProvenance <$ pirTermBefore + tplcProg <- compilePirProgramOrFail $ PIR.Program () latestVersion pirTermAfter + uplcProg <- compileTplcProgramOrFail tplcProg + pure . AsReadable $ UPLC._progTerm uplcProg + in + goldenPirM dumpUplc pTerm "strictLetRec" + , embed $ testCase "traces" do + (result, traces) <- do + pirTerm <- pirTermFromFile (joinPath path "StrictLetRec" "strictLetRec") + evalPirProgramWithTracesOrFail (pirTermAsProgram (void pirTerm)) + case result of + EvaluationFailure -> + fail $ "Evaluation failed, available traces: " <> show traces + EvaluationSuccess term -> do + term @?= constant () (someValue (1 :: Integer)) + traces @?= ["hello"] + ] diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs index 66d94927990..cf9d9bfcf0c 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module PlutusIR.Transform.StrictLetRec.Tests.Lib where @@ -17,49 +17,64 @@ import PlutusCore.Core qualified as TPLC import PlutusCore.Default (DefaultFun, DefaultUni) import PlutusCore.Error qualified as PLC import PlutusCore.Evaluation.Machine.BuiltinCostModel (BuiltinCostModel) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModelForTesting, - defaultCekMachineCostsForTesting) -import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..), MachineParameters (..), - mkMachineVariantParameters) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults ( + defaultBuiltinCostModelForTesting, + defaultCekMachineCostsForTesting, + ) +import PlutusCore.Evaluation.Machine.MachineParameters ( + CostModel (..), + MachineParameters (..), + mkMachineVariantParameters, + ) import PlutusCore.Evaluation.Machine.MachineParameters.Default (DefaultMachineParameters) import PlutusCore.Parser qualified as PC import PlutusCore.Quote (runQuoteT) import PlutusCore.TypeCheck qualified as PLC -import PlutusIR.Compiler (Provenance (..), ccOpts, coPreserveLogging, noProvenance, - toDefaultCompilationCtx) +import PlutusIR.Compiler ( + Provenance (..), + ccOpts, + coPreserveLogging, + noProvenance, + toDefaultCompilationCtx, + ) import PlutusIR.Compiler qualified as PIR import PlutusIR.Core qualified as PIR import PlutusIR.Parser (pTerm) import UntypedPlutusCore.Core qualified as UPLC -import UntypedPlutusCore.Evaluation.Machine.Cek (EvaluationResult (..), evaluateCek, logEmitter, - unsafeSplitStructuralOperational) +import UntypedPlutusCore.Evaluation.Machine.Cek ( + EvaluationResult (..), + evaluateCek, + logEmitter, + unsafeSplitStructuralOperational, + ) import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts) -pirTermFromFile - :: (MonadIO m, MonadFail m) - => FilePath - -> m (PIR.Term PIR.TyName PIR.Name DefaultUni DefaultFun SrcSpan) +pirTermFromFile :: + (MonadIO m, MonadFail m) => + FilePath -> + m (PIR.Term PIR.TyName PIR.Name DefaultUni DefaultFun SrcSpan) pirTermFromFile file = do contents <- liftIO $ Text.readFile file PC.parseGen pTerm contents & runQuoteT - & handlePirErrorByFailing @SrcSpan . modifyError (PIR.PLCError . PLC.ParseErrorE) + & handlePirErrorByFailing @SrcSpan + . modifyError (PIR.PLCError . PLC.ParseErrorE) pirTermAsProgram :: PIR.Term tyname name uni fun () -> PIR.Program tyname name uni fun () pirTermAsProgram = PIR.Program () latestVersion -evalPirProgramWithTracesOrFail - :: (MonadFail m) - => PIR.Program PIR.TyName PIR.Name DefaultUni DefaultFun () - -> m (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()), [Text]) +evalPirProgramWithTracesOrFail :: + MonadFail m => + PIR.Program PIR.TyName PIR.Name DefaultUni DefaultFun () -> + m (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()), [Text]) evalPirProgramWithTracesOrFail pirProgram = do plcProgram <- compilePirProgramOrFail pirProgram evaluateUplcProgramWithTraces <$> compileTplcProgramOrFail plcProgram -compilePirProgramOrFail - :: (MonadFail m) - => PIR.Program PIR.TyName Name DefaultUni DefaultFun () - -> m (TPLC.Program PIR.TyName Name DefaultUni DefaultFun ()) +compilePirProgramOrFail :: + MonadFail m => + PIR.Program PIR.TyName Name DefaultUni DefaultFun () -> + m (TPLC.Program PIR.TyName Name DefaultUni DefaultFun ()) compilePirProgramOrFail pirProgram = do ctx <- defaultCompilationCtx & handlePirErrorByFailing PIR.compileReadableToPlc (noProvenance <$ pirProgram) @@ -68,12 +83,12 @@ compilePirProgramOrFail pirProgram = do & runExceptT >>= \case Left (er :: PIR.Error DefaultUni DefaultFun (Provenance ())) -> fail $ show er - Right p -> pure (void p) + Right p -> pure (void p) -compileTplcProgramOrFail - :: (MonadFail m) - => TPLC.Program PIR.TyName PIR.Name DefaultUni DefaultFun () - -> m (UPLC.Program Name DefaultUni DefaultFun ()) +compileTplcProgramOrFail :: + MonadFail m => + TPLC.Program PIR.TyName PIR.Name DefaultUni DefaultFun () -> + m (UPLC.Program Name DefaultUni DefaultFun ()) compileTplcProgramOrFail plcProgram = handlePirErrorByFailing @SrcSpan =<< do TPLC.compileProgram plcProgram @@ -81,31 +96,31 @@ compileTplcProgramOrFail plcProgram = & runQuoteT & runExceptT -evaluateUplcProgramWithTraces - :: UPLC.Program Name DefaultUni DefaultFun () - -> (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()), [Text]) +evaluateUplcProgramWithTraces :: + UPLC.Program Name DefaultUni DefaultFun () -> + (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()), [Text]) evaluateUplcProgramWithTraces uplcProg = first unsafeSplitStructuralOperational $ evaluateCek logEmitter machineParameters (uplcProg ^. UPLC.progTerm) - where - costModel :: CostModel CekMachineCosts BuiltinCostModel - costModel = + where + costModel :: CostModel CekMachineCosts BuiltinCostModel + costModel = CostModel defaultCekMachineCostsForTesting defaultBuiltinCostModelForTesting - machineParameters :: DefaultMachineParameters - machineParameters = + machineParameters :: DefaultMachineParameters + machineParameters = MachineParameters def $ mkMachineVariantParameters def costModel -defaultCompilationCtx - :: Either - (PIR.Error DefaultUni DefaultFun (Provenance ())) - (PIR.CompilationCtx DefaultUni DefaultFun a) +defaultCompilationCtx :: + Either + (PIR.Error DefaultUni DefaultFun (Provenance ())) + (PIR.CompilationCtx DefaultUni DefaultFun a) defaultCompilationCtx = do pirTcConfig <- modifyError (PIR.PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig noProvenance pure $ toDefaultCompilationCtx pirTcConfig -handlePirErrorByFailing - :: (Pretty ann, MonadFail m) => Either (PIR.Error DefaultUni DefaultFun ann) a -> m a +handlePirErrorByFailing :: + (Pretty ann, MonadFail m) => Either (PIR.Error DefaultUni DefaultFun ann) a -> m a handlePirErrorByFailing = \case - Left e -> fail $ show e + Left e -> fail $ show e Right x -> pure x diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictifyBindings/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictifyBindings/Tests.hs index 25a56d76708..ba175d2945f 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictifyBindings/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictifyBindings/Tests.hs @@ -15,21 +15,21 @@ import Test.QuickCheck.Property (Property, withMaxSuccess) test_strictifyBindings :: TestTree test_strictifyBindings = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "StrictifyBindings"] $ - map - (goldenPir (runIdentity . runTestPass (\tc -> strictifyBindingsPass tc def)) pTerm) - [ "pure1" - , "impure1" - , "unused" - , "conapp" - , "strict" - , "nonstrict1" - , "nonstrict2" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "StrictifyBindings"] $ + map + (goldenPir (runIdentity . runTestPass (\tc -> strictifyBindingsPass tc def)) pTerm) + [ "pure1" + , "impure1" + , "unused" + , "conapp" + , "strict" + , "nonstrict1" + , "nonstrict2" + ] prop_strictifyBindings :: BuiltinSemanticsVariant DefaultFun -> Property prop_strictifyBindings biVariant = - withMaxSuccess numTestsForPassProp $ - testPassProp + withMaxSuccess numTestsForPassProp + $ testPassProp runIdentity - $ \tc -> strictifyBindingsPass tc (def {_biSemanticsVariant = biVariant}) + $ \tc -> strictifyBindingsPass tc (def {_biSemanticsVariant = biVariant}) diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/ThunkRecursions/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/ThunkRecursions/Tests.hs index 021ed53e695..98f6d17f28d 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/ThunkRecursions/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/ThunkRecursions/Tests.hs @@ -17,19 +17,20 @@ import Test.QuickCheck.Property (Property, withMaxSuccess) test_thunkRecursions :: TestTree test_thunkRecursions = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "ThunkRecursions"] $ - map - (goldenPir (runIdentity . runTestPass (\tc -> thunkRecursionsPass tc def)) pTerm) - [ "listFold" - , "listFoldTrace" - , "monoMap" - , "errorBinding" - , "mutuallyRecursiveValues" - , "preserveEffectOrder" - , "preserveStrictness" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "ThunkRecursions"] $ + map + (goldenPir (runIdentity . runTestPass (\tc -> thunkRecursionsPass tc def)) pTerm) + [ "listFold" + , "listFoldTrace" + , "monoMap" + , "errorBinding" + , "mutuallyRecursiveValues" + , "preserveEffectOrder" + , "preserveStrictness" + ] prop_thunkRecursions :: BuiltinSemanticsVariant DefaultFun -> Property prop_thunkRecursions biVariant = withMaxSuccess numTestsForPassProp $ - testPassProp runIdentity $ \tc -> thunkRecursionsPass tc (def {_biSemanticsVariant = biVariant}) + testPassProp runIdentity $ + \tc -> thunkRecursionsPass tc (def {_biSemanticsVariant = biVariant}) diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/Unwrap/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/Unwrap/Tests.hs index 265682b9961..5ea1139ad90 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/Unwrap/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/Unwrap/Tests.hs @@ -13,11 +13,11 @@ import Test.QuickCheck.Property (Property, withMaxSuccess) test_unwrap :: TestTree test_unwrap = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Unwrap"] $ - map - (goldenPir (runIdentity . runTestPass unwrapCancelPass) pTerm) - [ "unwrapWrap" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Unwrap"] $ + map + (goldenPir (runIdentity . runTestPass unwrapCancelPass) pTerm) + [ "unwrapWrap" + ] prop_unwrap :: Property prop_unwrap = diff --git a/plutus-core/plutus-ir/test/PlutusIR/TypeCheck/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/TypeCheck/Tests.hs index 52ea41e0f64..deef5ba14be 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/TypeCheck/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/TypeCheck/Tests.hs @@ -9,42 +9,42 @@ import PlutusIR.Transform.Rename () test_types :: TestTree test_types = - runTestNested ["plutus-ir", "test", "PlutusIR", "TypeCheck"] $ - map - (goldenTypeFromPir topSrcSpan pTerm) - [ "letInLet" - , "listMatch" - , "maybe" - , "ifError" - , "mutuallyRecursiveTypes" - , "mutuallyRecursiveValues" - , "nonrec1" - , "nonrec2" - , "nonrec3" - , "nonrec4" - , "nonrec6" - , "nonrec7" - , "nonrec8" - , "rec1" - , "rec2" - , "rec3" - , "rec4" - , "nonrecToRec" - , "nonrecToNonrec" - , "oldLength" - , "strictValue" - , "strictNonValue" - , "strictNonValue2" - , "strictNonValue3" - , "strictValueNonValue" - , "strictValueValue" - , "strictNonValueDeep" - , "even3Eval" - , "sameNameDifferentEnv" - , "typeLet" - , "typeLetRec" - -- errors - , "wrongDataConstrReturnType" - , "nonSelfRecursive" - , "typeLetWrong" - ] + runTestNested ["plutus-ir", "test", "PlutusIR", "TypeCheck"] $ + map + (goldenTypeFromPir topSrcSpan pTerm) + [ "letInLet" + , "listMatch" + , "maybe" + , "ifError" + , "mutuallyRecursiveTypes" + , "mutuallyRecursiveValues" + , "nonrec1" + , "nonrec2" + , "nonrec3" + , "nonrec4" + , "nonrec6" + , "nonrec7" + , "nonrec8" + , "rec1" + , "rec2" + , "rec3" + , "rec4" + , "nonrecToRec" + , "nonrecToNonrec" + , "oldLength" + , "strictValue" + , "strictNonValue" + , "strictNonValue2" + , "strictNonValue3" + , "strictValueNonValue" + , "strictValueValue" + , "strictNonValueDeep" + , "even3Eval" + , "sameNameDifferentEnv" + , "typeLet" + , "typeLetRec" + , -- errors + "wrongDataConstrReturnType" + , "nonSelfRecursive" + , "typeLetWrong" + ] diff --git a/plutus-core/prelude/PlutusPrelude.hs b/plutus-core/prelude/PlutusPrelude.hs index 44c9257873d..90619477407 100644 --- a/plutus-core/prelude/PlutusPrelude.hs +++ b/plutus-core/prelude/PlutusPrelude.hs @@ -1,115 +1,135 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusPrelude - ( -- * Reexports from base - (&) - , (&&&) - , (>>>) - , (<&>) - , toList - , first - , second - , on - , isNothing - , isJust - , fromMaybe - , guard - , foldl' - , for_ - , traverse_ - , fold - , for - , throw - , join - , (<=<) - , (>=>) - , ($>) - , fromRight - , isRight - , isLeft - , void - , through - , coerce - , coerceVia - , coerceArg - , coerceRes - , (#.) - , Generic - , NFData - , Natural - , NonEmpty (..) - , Word8 - , Alternative (..) - , Exception - , PairT (..) - , Coercible - , Typeable - -- * Lens - , Lens' - , lens - , (^.) - , view - , (.~) - , set - , (%~) - , over - , purely - , (<^>) - -- * Debugging - , traceShowId - , trace - -- * Reexports from "Control.Composition" - , (.*) - -- * Custom functions - , (<<$>>) - , (<<*>>) - , forJoin - , foldMapM - , reoption - , enumerate - , tabulateArray - , (?) - , ensure - , asksM - , timesA - -- * Pretty-printing - , Doc - , ShowPretty (..) - , Pretty (..) - , PrettyBy (..) - , HasPrettyDefaults - , PrettyDefaultBy - , PrettyAny (..) - , Render (..) - , display - -- * GHCi - , printPretty - -- * Text - , showText - , Default (def) - -- * Lists - , zipExact - , allSame - , distinct - , unsafeFromRight - , addTheRest - , lowerInitialChar - ) where +module PlutusPrelude ( + -- * Reexports from base + (&), + (&&&), + (>>>), + (<&>), + toList, + first, + second, + on, + isNothing, + isJust, + fromMaybe, + guard, + foldl', + for_, + traverse_, + fold, + for, + throw, + join, + (<=<), + (>=>), + ($>), + fromRight, + isRight, + isLeft, + void, + through, + coerce, + coerceVia, + coerceArg, + coerceRes, + (#.), + Generic, + NFData, + Natural, + NonEmpty (..), + Word8, + Alternative (..), + Exception, + PairT (..), + Coercible, + Typeable, + + -- * Lens + Lens', + lens, + (^.), + view, + (.~), + set, + (%~), + over, + purely, + (<^>), + + -- * Debugging + traceShowId, + trace, + + -- * Reexports from "Control.Composition" + (.*), + + -- * Custom functions + (<<$>>), + (<<*>>), + forJoin, + foldMapM, + reoption, + enumerate, + tabulateArray, + (?), + ensure, + asksM, + timesA, + + -- * Pretty-printing + Doc, + ShowPretty (..), + Pretty (..), + PrettyBy (..), + HasPrettyDefaults, + PrettyDefaultBy, + PrettyAny (..), + Render (..), + display, + + -- * GHCi + printPretty, + + -- * Text + showText, + Default (def), + + -- * Lists + zipExact, + allSame, + distinct, + unsafeFromRight, + addTheRest, + lowerInitialChar, +) where import Control.Applicative import Control.Arrow ((&&&), (>>>)) import Control.Composition ((.*)) import Control.DeepSeq (NFData) import Control.Exception (Exception, throw) -import Control.Lens (Fold, Identity, Lens', ala, lens, over, set, view, (%~), (&), (.~), (<&>), - (^.)) +import Control.Lens ( + Fold, + Identity, + Lens', + ala, + lens, + over, + set, + view, + (%~), + (&), + (.~), + (<&>), + (^.), + ) import Control.Monad import Control.Monad.Reader (MonadReader, ask) import Data.Array (Array, Ix, listArray) @@ -147,23 +167,26 @@ infixr 6 <^> -- | A newtype wrapper around @a@ whose point is to provide a 'Show' instance -- for anything that has a 'Pretty' instance. newtype ShowPretty a = ShowPretty - { unShowPretty :: a - } deriving stock (Eq) + { unShowPretty :: a + } + deriving stock (Eq) instance Pretty a => Show (ShowPretty a) where - show = display . unShowPretty + show = display . unShowPretty instance (Pretty a, Pretty b) => Pretty (Either a b) where - pretty (Left x) = parens ("Left" <+> pretty x) - pretty (Right y) = parens ("Right" <+> pretty y) + pretty (Left x) = parens ("Left" <+> pretty x) + pretty (Right y) = parens ("Right" <+> pretty y) -- | Default pretty-printing for the __spine__ of 'Either' (elements are pretty-printed the way -- @PrettyBy config@ constraints specify it). instance (PrettyBy config a, PrettyBy config b) => DefaultPrettyBy config (Either a b) -- | An instance extending the set of types supporting default pretty-printing with 'Either'. -deriving via PrettyCommon (Either a b) - instance PrettyDefaultBy config (Either a b) => PrettyBy config (Either a b) +deriving via + PrettyCommon (Either a b) + instance + PrettyDefaultBy config (Either a b) => PrettyBy config (Either a b) -- | Coerce the second argument to the result type of the first one. The motivation for this -- function is that it's often more annoying to explicitly specify a target type for 'coerce' than @@ -184,6 +207,7 @@ coerceRes = coerce {-# INLINE coerceRes #-} -- See Note [Function coercion] in GHC.Internal.Data.Functor.Utils. + -- | Same as @(.)@, but ignores the first argument and uses a no-op coerction instead. (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c (#.) _ = coerce @@ -204,7 +228,8 @@ forJoin a f = join <$> for a f -- | Fold a monadic function over a 'Foldable'. The monadic version of 'foldMap'. foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b -foldMapM f xs = foldr step return xs mempty where +foldMapM f xs = foldr step return xs mempty + where step x r z = f x >>= \y -> r $! z `mappend` y -- | This function generalizes 'eitherToMaybe', 'eitherToList', @@ -219,11 +244,11 @@ tabulateArray :: (Bounded i, Enum i, Ix i) => (i -> a) -> Array i a tabulateArray f = listArray (minBound, maxBound) $ map f enumerate newtype PairT b f a = PairT - { unPairT :: f (b, a) - } + { unPairT :: f (b, a) + } instance Functor f => Functor (PairT b f) where - fmap f (PairT p) = PairT $ fmap (fmap f) p + fmap f (PairT p) = PairT $ fmap (fmap f) p -- | @b ? x@ is equal to @pure x@ whenever @b@ holds and is 'empty' otherwise. (?) :: Alternative f => Bool -> a -> f a @@ -239,6 +264,7 @@ asksM k = ask >>= k -- For GHCi to use this properly it needs to be in a registered package, hence -- why we're naming such a trivial thing. + -- | A command suitable for use in GHCi as an interactive printer. printPretty :: Pretty a => a -> IO () printPretty = print . pretty @@ -255,16 +281,16 @@ purely = coerce -- | Zips two lists of the same length together, returning 'Nothing' if they are not -- the same length. -zipExact :: [a] -> [b] -> Maybe [(a,b)] -zipExact [] [] = Just [] -zipExact (a:as) (b:bs) = (:) (a, b) <$> zipExact as bs -zipExact _ _ = Nothing +zipExact :: [a] -> [b] -> Maybe [(a, b)] +zipExact [] [] = Just [] +zipExact (a : as) (b : bs) = (:) (a, b) <$> zipExact as bs +zipExact _ _ = Nothing -- | Similar to Maybe's `fromJust`. Returns the `Right` and errors out with the show instance -- of the `Left`. -unsafeFromRight :: (Show e) => Either e a -> a +unsafeFromRight :: Show e => Either e a -> a unsafeFromRight (Right a) = a -unsafeFromRight (Left e) = error $ show e +unsafeFromRight (Left e) = error $ show e -- | function recursively applied N times timesA :: Natural -> (a -> a) -> a -> a @@ -275,16 +301,16 @@ timesA = ala Endo . stimes -- >>> addTheRest "abcd" -- [('a',"bcd"),('b',"acd"),('c',"abd"),('d',"abc")] addTheRest :: [a] -> [(a, [a])] -addTheRest [] = [] -addTheRest (x:xs) = (x, xs) : map (fmap (x :)) (addTheRest xs) +addTheRest [] = [] +addTheRest (x : xs) = (x, xs) : map (fmap (x :)) (addTheRest xs) allSame :: Eq a => [a] -> Bool -allSame [] = True -allSame (x:xs) = all (x ==) xs +allSame [] = True +allSame (x : xs) = all (x ==) xs distinct :: Eq a => [a] -> Bool distinct = not . allSame lowerInitialChar :: String -> String -lowerInitialChar [] = [] -lowerInitialChar (c:cs) = toLower c : cs +lowerInitialChar [] = [] +lowerInitialChar (c : cs) = toLower c : cs diff --git a/plutus-core/satint/src/Data/SatInt.hs b/plutus-core/satint/src/Data/SatInt.hs index 49dc2791159..3e6db612424 100644 --- a/plutus-core/satint/src/Data/SatInt.hs +++ b/plutus-core/satint/src/Data/SatInt.hs @@ -1,22 +1,21 @@ -- editorconfig-checker-disable-file -{- | -Adapted from 'Data.SafeInt' to perform saturating arithmetic (i.e. returning max or min bounds) instead of throwing on overflow. - -This is not quite as fast as using 'Int' or 'Int64' directly, but we need the safety. --} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ViewPatterns #-} - -module Data.SatInt - ( -- Not exporting the constructor, so that 'coerce' doesn't work, see 'unsafeToSatInt'. - SatInt (unSatInt) - , unsafeToSatInt - , fromSatInt - , dividedBy - ) where +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Adapted from 'Data.SafeInt' to perform saturating arithmetic (i.e. returning max or min bounds) instead of throwing on overflow. +-- +-- This is not quite as fast as using 'Int' or 'Int64' directly, but we need the safety. +module Data.SatInt ( + -- Not exporting the constructor, so that 'coerce' doesn't work, see 'unsafeToSatInt'. + SatInt (unSatInt), + unsafeToSatInt, + fromSatInt, + dividedBy, +) where import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) @@ -31,13 +30,13 @@ import GHC.Real import Language.Haskell.TH.Syntax (Lift) import NoThunks.Class -newtype SatInt = SI { unSatInt :: Int } - deriving newtype (Show, Read, Eq, Ord, Bounded, NFData, Bits, FiniteBits, Prim) - deriving stock (Lift, Generic) - deriving (FromJSON, ToJSON) via Int - deriving FromField via Int -- For reading cost model data from CSV input - deriving Serialise via Int - deriving anyclass NoThunks +newtype SatInt = SI {unSatInt :: Int} + deriving newtype (Show, Read, Eq, Ord, Bounded, NFData, Bits, FiniteBits, Prim) + deriving stock (Lift, Generic) + deriving (FromJSON, ToJSON) via Int + deriving (FromField) via Int -- For reading cost model data from CSV input + deriving (Serialise) via Int + deriving anyclass (NoThunks) -- | Wrap an 'Int' as a 'SatInt'. This is unsafe because the 'Int' can be a result of an arbitrary -- potentially underflowing/overflowing operation. @@ -65,11 +64,11 @@ instance Num SatInt where {-# INLINE negate #-} negate (SI y) | y == minBound = maxBound - | otherwise = SI (negate y) + | otherwise = SI (negate y) {-# INLINE abs #-} abs x - | x >= 0 = x + | x >= 0 = x | otherwise = negate x {-# INLINE signum #-} @@ -77,28 +76,28 @@ instance Num SatInt where {-# INLINE fromInteger #-} fromInteger x - | x > maxBoundInteger = maxBound - | x < minBoundInteger = minBound - | otherwise = SI (fromInteger x) + | x > maxBoundInteger = maxBound + | x < minBoundInteger = minBound + | otherwise = SI (fromInteger x) -- | Divide a `SatInt` by a natural number. If the natural number is zero, -- return `maxBound`; if we're at the maximum or minimum value then leave the -- input unaltered. This should never throw. dividedBy :: SatInt -> Natural -> SatInt -dividedBy _ 0 = maxBound +dividedBy _ 0 = maxBound dividedBy x@(SI n) d = if n == maxBound || n == minBound - then x - else SI (n `div` (fromIntegral d)) + then x + else SI (n `div` (fromIntegral d)) {-# INLINE dividedBy #-} maxBoundInteger :: Integer maxBoundInteger = toInteger maxInt -{-# INLINABLE maxBoundInteger #-} +{-# INLINEABLE maxBoundInteger #-} minBoundInteger :: Integer minBoundInteger = toInteger minInt -{-# INLINABLE minBoundInteger #-} +{-# INLINEABLE minBoundInteger #-} {- 'addIntC#', 'subIntC#', and 'mulIntMayOflow#' have tricky returns: @@ -113,15 +112,18 @@ kind of overflow we're facing, and pick the correct result accordingly. plusSI :: SatInt -> SatInt -> SatInt plusSI (SI (I# x#)) (SI (I# y#)) = - case addIntC# x# y# of + case addIntC# x# y# of (# r#, 0# #) -> SI (I# r#) -- Overflow _ -> - if isTrue# ((x# ># 0#) `andI#` (y# ># 0#)) then maxBound - else if isTrue# ((x# <# 0#) `andI#` (y# <# 0#)) then minBound - -- x and y have opposite signs, and yet we've overflowed, should - -- be impossible - else overflowError + if isTrue# ((x# ># 0#) `andI#` (y# ># 0#)) + then maxBound + else + if isTrue# ((x# <# 0#) `andI#` (y# <# 0#)) + then minBound + -- x and y have opposite signs, and yet we've overflowed, should + -- be impossible + else overflowError {-# INLINE plusSI #-} minusSI :: SatInt -> SatInt -> SatInt @@ -130,26 +132,36 @@ minusSI (SI (I# x#)) (SI (I# y#)) = (# r#, 0# #) -> SI (I# r#) -- Overflow _ -> - if isTrue# ((x# >=# 0#) `andI#` (y# <# 0#)) then maxBound - else if isTrue# ((x# <=# 0#) `andI#` (y# ># 0#)) then minBound - -- x and y have the same sign, and yet we've overflowed, should - -- be impossible - else overflowError + if isTrue# ((x# >=# 0#) `andI#` (y# <# 0#)) + then maxBound + else + if isTrue# ((x# <=# 0#) `andI#` (y# ># 0#)) + then minBound + -- x and y have the same sign, and yet we've overflowed, should + -- be impossible + else overflowError {-# INLINE minusSI #-} timesSI :: SatInt -> SatInt -> SatInt timesSI (SI (I# x#)) (SI (I# y#)) = case mulIntMayOflo# x# y# of - 0# -> SI (I# (x# *# y#)) - -- Overflow - _ -> - if isTrue# ((x# ># 0#) `andI#` (y# ># 0#)) then maxBound - else if isTrue# ((x# ># 0#) `andI#` (y# <# 0#)) then minBound - else if isTrue# ((x# <# 0#) `andI#` (y# ># 0#)) then minBound - else if isTrue# ((x# <# 0#) `andI#` (y# <# 0#)) then maxBound - -- Logically unreachable unless x or y is 0, in which case - -- it should be impossible to overflow - else overflowError + 0# -> SI (I# (x# *# y#)) + -- Overflow + _ -> + if isTrue# ((x# ># 0#) `andI#` (y# ># 0#)) + then maxBound + else + if isTrue# ((x# ># 0#) `andI#` (y# <# 0#)) + then minBound + else + if isTrue# ((x# <# 0#) `andI#` (y# ># 0#)) + then minBound + else + if isTrue# ((x# <# 0#) `andI#` (y# <# 0#)) + then maxBound + -- Logically unreachable unless x or y is 0, in which case + -- it should be impossible to overflow + else overflowError {-# INLINE timesSI #-} -- Specialized versions of several functions. They're specialized for @@ -157,18 +169,18 @@ timesSI (SI (I# x#)) (SI (I# y#)) = -- including specialized code and adding a rewrite rule. sumSI :: [SatInt] -> SatInt -sumSI l = sum' l 0 +sumSI l = sum' l 0 where - sum' [] a = a - sum' (x:xs) a = sum' xs $! a + x + sum' [] a = a + sum' (x : xs) a = sum' xs $! a + x productSI :: [SatInt] -> SatInt -productSI l = prod l 1 +productSI l = prod l 1 where - prod [] a = a - prod (x:xs) a = prod xs $! a * x + prod [] a = a + prod (x : xs) a = prod xs $! a * x {-# RULES - "sum/SatInt" sum = sumSI; - "product/SatInt" product = productSI +"sum/SatInt" sum = sumSI +"product/SatInt" product = productSI #-} diff --git a/plutus-core/satint/test/TestSatInt.hs b/plutus-core/satint/test/TestSatInt.hs index 0d39684875a..6a0429bb25f 100644 --- a/plutus-core/satint/test/TestSatInt.hs +++ b/plutus-core/satint/test/TestSatInt.hs @@ -1,7 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} + -- These tests are deliberately not in the same style as our other tests, but rather mirror the tests -- in safeint, since I want to upstream this in due course. module Main where @@ -20,69 +21,80 @@ main :: IO () main = defaultMain tests isArithException :: a -> IO Bool -isArithException n = E.catch (n `seq` return False) - (\ (_ :: ArithException) -> return True) +isArithException n = + E.catch + (n `seq` return False) + (\(_ :: ArithException) -> return True) -saturatesPos :: forall a . (Eq a, Bounded a) => a -> Bool +saturatesPos :: forall a. (Eq a, Bounded a) => a -> Bool saturatesPos n = n == maxBound -saturatesNeg :: forall a . (Eq a, Bounded a) => a -> Bool +saturatesNeg :: forall a. (Eq a, Bounded a) => a -> Bool saturatesNeg n = n == minBound behavesOk :: (forall a. Num a => a) -> IO Bool behavesOk n = do - let - sat = (n :: SatInt) - int = (n :: Integer) - lb = toInteger $ unSatInt (minBound :: SatInt) - ub = toInteger $ unSatInt (maxBound :: SatInt) - satThrows <- isArithException sat - intThrows <- isArithException int - pure $ if satThrows && intThrows then True - else if lb <= int && int <= ub then toInteger (unSatInt sat) == int - else if int < lb then saturatesNeg sat - else if int > ub then saturatesPos sat - else False + let + sat = (n :: SatInt) + int = (n :: Integer) + lb = toInteger $ unSatInt (minBound :: SatInt) + ub = toInteger $ unSatInt (maxBound :: SatInt) + satThrows <- isArithException sat + intThrows <- isArithException int + pure $ + if satThrows && intThrows + then True + else + if lb <= int && int <= ub + then toInteger (unSatInt sat) == int + else + if int < lb + then saturatesNeg sat + else + if int > ub + then saturatesPos sat + else False unitTest :: Assertable t => TestName -> t -> TF.Test unitTest msg p = testCase msg (T.assert p) wordSize :: Int -wordSize = fromJust (find (\ n -> 2 ^ n == (0 :: Word)) [8,16,32,64,128]) +wordSize = fromJust (find (\n -> 2 ^ n == (0 :: Word)) [8, 16, 32, 64, 128]) tests :: [TF.Test] tests = - [ unitTest "0" ((0 :: SatInt) + 0 == 0), - unitTest "max+" (saturatesPos ((maxBound :: SatInt) + 1)), - unitTest "min-" (saturatesNeg ((minBound :: SatInt) - 1)), - unitTest "min*-1" (saturatesPos ((minBound :: SatInt) * (-1))), - unitTest "0-min" (saturatesPos (0 - (minBound :: SatInt))), - unitTest "max+min" ((maxBound :: SatInt) + (minBound :: SatInt) == -1), - unitTest "max+*" (saturatesPos ((2 :: SatInt) ^ (wordSize `div` 2) * 2 ^ (wordSize `div` 2 - 1))), - unitTest "min-*" (saturatesNeg (negate ((2 :: SatInt) ^ (wordSize `div` 2)) * 2 ^ (wordSize `div` 2 - 1))), - unitTest "max/2" (saturatesPos ((maxBound :: SatInt) `dividedBy` 2)), - unitTest "min/2" (saturatesNeg ((minBound :: SatInt) `dividedBy` 2)), - testProperty "*" (propBinOp (*)), - testProperty "+" (propBinOp (+)), - testProperty "-" (propBinOp (-)), - testProperty "/0" propDividedBy0 - -- lcm and gcd do *not* pass `behavesOk` since they *internally* use `abs` (which will give the wrong/saturated - -- answer for minBound), and hence go astray after that. But we can't easily detect that this is the "correct" - -- saturated thing to do as we do for other operations (where we can just see if the saturating version is - -- at one of the bounds) + [ unitTest "0" ((0 :: SatInt) + 0 == 0) + , unitTest "max+" (saturatesPos ((maxBound :: SatInt) + 1)) + , unitTest "min-" (saturatesNeg ((minBound :: SatInt) - 1)) + , unitTest "min*-1" (saturatesPos ((minBound :: SatInt) * (-1))) + , unitTest "0-min" (saturatesPos (0 - (minBound :: SatInt))) + , unitTest "max+min" ((maxBound :: SatInt) + (minBound :: SatInt) == -1) + , unitTest "max+*" (saturatesPos ((2 :: SatInt) ^ (wordSize `div` 2) * 2 ^ (wordSize `div` 2 - 1))) + , unitTest "min-*" (saturatesNeg (negate ((2 :: SatInt) ^ (wordSize `div` 2)) * 2 ^ (wordSize `div` 2 - 1))) + , unitTest "max/2" (saturatesPos ((maxBound :: SatInt) `dividedBy` 2)) + , unitTest "min/2" (saturatesNeg ((minBound :: SatInt) `dividedBy` 2)) + , testProperty "*" (propBinOp (*)) + , testProperty "+" (propBinOp (+)) + , testProperty "-" (propBinOp (-)) + , testProperty "/0" propDividedBy0 + -- lcm and gcd do *not* pass `behavesOk` since they *internally* use `abs` (which will give the wrong/saturated + -- answer for minBound), and hence go astray after that. But we can't easily detect that this is the "correct" + -- saturated thing to do as we do for other operations (where we can just see if the saturating version is + -- at one of the bounds) ] -- We really want to test the special cases involving combinations of -1, minBound, and maxBound. The ordinary -- generator does *not* produce these with enough frequency to find anything. intWithSpecialCases :: Gen Int -intWithSpecialCases = frequency [ (1, pure (-1)), (1, pure minBound), (1, pure maxBound), (80, arbitrary) ] +intWithSpecialCases = frequency [(1, pure (-1)), (1, pure minBound), (1, pure maxBound), (80, arbitrary)] propBinOp :: (forall a. Num a => a -> a -> a) -> Property propBinOp (!) = withMaxSuccess 10000 $ - forAll intWithSpecialCases $ \ x -> - forAll intWithSpecialCases $ \ y -> - ioProperty $ behavesOk (fromIntegral x ! fromIntegral y) + forAll intWithSpecialCases $ \x -> + forAll intWithSpecialCases $ \y -> + ioProperty $ behavesOk (fromIntegral x ! fromIntegral y) propDividedBy0 :: Property propDividedBy0 = withMaxSuccess 1000 $ - forAll intWithSpecialCases $ \n -> saturatesPos ((fromIntegral n) `dividedBy` 0) + forAll intWithSpecialCases $ + \n -> saturatesPos ((fromIntegral n) `dividedBy` 0) diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog.hs index f0bb36883bc..ed08ea46751 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog.hs @@ -1,12 +1,11 @@ -- | Reexports from modules from the @PlutusCore.Generators.Internal@ folder. - -module PlutusCore.Generators.Hedgehog - ( module Export - ) where +module PlutusCore.Generators.Hedgehog ( + module Export, +) where import PlutusCore.Generators.Hedgehog.Builtin as Export import PlutusCore.Generators.Hedgehog.Denotation as Export import PlutusCore.Generators.Hedgehog.Entity as Export -import PlutusCore.Generators.Hedgehog.TypedBuiltinGen as Export import PlutusCore.Generators.Hedgehog.TypeEvalCheck as Export +import PlutusCore.Generators.Hedgehog.TypedBuiltinGen as Export import PlutusCore.Generators.Hedgehog.Utils as Export diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs index 0855f346229..07970a3abd4 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs @@ -1,26 +1,26 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module PlutusCore.Generators.Hedgehog.AST - ( simpleRecursive - , regenConstantUntil - , regenConstantsUntil - , AstGen - , runAstGen - , genVersion - , genNames - , genName - , genTyName - , genKind - , genBuiltin - , genConstant - , genType - , genTerm - , genProgram - , genNameMangler - , mangleNames - ) where +{-# LANGUAGE TypeApplications #-} + +module PlutusCore.Generators.Hedgehog.AST ( + simpleRecursive, + regenConstantUntil, + regenConstantsUntil, + AstGen, + runAstGen, + genVersion, + genNames, + genName, + genTyName, + genKind, + genBuiltin, + genConstant, + genType, + genTerm, + genProgram, + genNameMangler, + mangleNames, +) where import PlutusPrelude @@ -52,53 +52,56 @@ all the machineries handle variables with same uniques from distinct scopes corr -} -- See Note [ScopeHandling]. + -- | The monad that generators run in. The environment is a list of names to choose from for -- generation of variables and binders. type AstGen = GenT (Reader [Name]) runAstGen :: MonadGen m => AstGen a -> m a runAstGen a = do - names <- genNames - Gen.fromGenT $ hoist (return . flip runReader names) a - -regenConstantUntil - :: MonadGen m - => (Some (ValueOf DefaultUni) -> Bool) - -> Some (ValueOf DefaultUni) - -> m (Maybe (Some (ValueOf DefaultUni))) -regenConstantUntil p = go $ \_ -> Nothing where + names <- genNames + Gen.fromGenT $ hoist (return . flip runReader names) a + +regenConstantUntil :: + MonadGen m => + (Some (ValueOf DefaultUni) -> Bool) -> + Some (ValueOf DefaultUni) -> + m (Maybe (Some (ValueOf DefaultUni))) +regenConstantUntil p = go $ \_ -> Nothing + where go ret val - | p val = pure $ ret val - | otherwise = genConstant >>= go Just + | p val = pure $ ret val + | otherwise = genConstant >>= go Just -- | Replace all constants in a program failing the given predicate with newly generated ones that -- are guaranteed to satisfy the predicate (if such constants cannot be generated, this generator -- will fail). -regenConstantsUntil - :: MonadGen m - => (Some (ValueOf DefaultUni) -> Bool) - -> Program tyname name DefaultUni fun ann - -> m (Program tyname name DefaultUni fun ann) +regenConstantsUntil :: + MonadGen m => + (Some (ValueOf DefaultUni) -> Bool) -> + Program tyname name DefaultUni fun ann -> + m (Program tyname name DefaultUni fun ann) regenConstantsUntil p = - progTerm . termSubstConstantsM $ \ann -> fmap (fmap $ Constant ann) . regenConstantUntil p + progTerm . termSubstConstantsM $ \ann -> fmap (fmap $ Constant ann) . regenConstantUntil p -- The parser will reject uses of new constructs if the version is not high enough -- In order to keep our lives simple, we just generate a version that is always high -- enough to support everything. That gives us less coverage of parsing versions, but -- that's not likely to be the place where things go wrong genVersion :: MonadGen m => m Version -genVersion = Version <$> intFrom 1 <*> intFrom 1 <*> intFrom 0 where +genVersion = Version <$> intFrom 1 <*> intFrom 1 <*> intFrom 0 + where intFrom x = Gen.integral_ $ Range.linear x 20 genNameText :: MonadGen m => m Text genNameText = Gen.choice [genUnquoted, genQuoted] where genUnquoted = - Text.cons - <$> Gen.alpha - <*> Gen.text (Range.linear 0 4) (Gen.choice [Gen.alphaNum, Gen.element ['_', '\'']]) + Text.cons + <$> Gen.alpha + <*> Gen.text (Range.linear 0 4) (Gen.choice [Gen.alphaNum, Gen.element ['_', '\'']]) genQuoted = - Gen.text (Range.linear 1 5) (Gen.filterT isQuotedIdentifierChar Gen.ascii) + Gen.text (Range.linear 1 5) (Gen.filterT isQuotedIdentifierChar Gen.ascii) -- | Generate a fixed set of names which we will use, of only up to a short size to make it -- likely that we get reuse. @@ -107,11 +110,11 @@ genNameText = Gen.choice [genUnquoted, genQuoted] -- In the readable syntax that would be troubling, though, but we don't have a parser for that anyway. genNames :: MonadGen m => m [Name] genNames = do - let genUniq = Unique <$> Gen.int (Range.linear 0 100) - uniqs <- Set.toList <$> Gen.set (Range.linear 1 20) genUniq - for uniqs $ \uniq -> do - text <- genNameText - return $ Name text uniq + let genUniq = Unique <$> Gen.int (Range.linear 0 100) + uniqs <- Set.toList <$> Gen.set (Range.linear 1 20) genUniq + for uniqs $ \uniq -> do + text <- genNameText + return $ Name text uniq genName :: AstGen Name genName = ask >>= Gen.element @@ -120,7 +123,8 @@ genTyName :: AstGen TyName genTyName = TyName <$> genName genKind :: AstGen (Kind ()) -genKind = simpleRecursive nonRecursive recursive where +genKind = simpleRecursive nonRecursive recursive + where nonRecursive = pure <$> sequence [Type] () recursive = [KindArrow () <$> genKind <*> genKind] @@ -136,7 +140,8 @@ genSomeTypeIn :: MonadGen m => m (SomeTypeIn DefaultUni) genSomeTypeIn = arbitrary genType :: AstGen (Type TyName DefaultUni ()) -genType = simpleRecursive nonRecursive recursive where +genType = simpleRecursive nonRecursive recursive + where varGen = TyVar () <$> genTyName funGen = TyFun () <$> genType <*> genType lamGen = TyLam () <$> genTyName <*> genKind <*> genType @@ -148,7 +153,8 @@ genType = simpleRecursive nonRecursive recursive where nonRecursive = [varGen, lamGen, forallGen, tyBuiltinGen] genTerm :: forall fun. (Bounded fun, Enum fun) => AstGen (Term TyName Name DefaultUni fun ()) -genTerm = simpleRecursive nonRecursive recursive where +genTerm = simpleRecursive nonRecursive recursive + where varGen = Var () <$> genName absGen = TyAbs () <$> genTyName <*> genKind <*> genTerm instGen = TyInst () <$> genTerm <*> genType @@ -180,9 +186,10 @@ variables. This way we get diverse and interesting mangled terms. subset1 :: (MonadGen m, Ord a) => Set a -> m (Maybe (Set a)) subset1 s - | null xs = return Nothing - | otherwise = fmap (Just . Set.fromList) $ (:) <$> Gen.element xs <*> Gen.subsequence xs - where xs = Set.toList s + | null xs = return Nothing + | otherwise = fmap (Just . Set.fromList) $ (:) <$> Gen.element xs <*> Gen.subsequence xs + where + xs = Set.toList s -- See Note [Name mangling] -- Returns a 'Maybe' instead of doing 'Gen.justT' at the end so that if the original term is hard to @@ -191,32 +198,32 @@ subset1 s -- steam. genNameMangler :: Set Name -> AstGen (Maybe (Name -> AstGen (Maybe Name))) genNameMangler names = do - mayNamesMangle <- subset1 names - for mayNamesMangle $ \namesMangle -> do - let isNew name = not $ name `Set.member` namesMangle - newNames <- Gen.justT $ ensure (not . null) . filter isNew <$> genNames - pure $ \name -> - if name `Set.member` namesMangle - then Just <$> Gen.element newNames - else pure Nothing - -substAllNames - :: Monad m - => (Name -> m (Maybe Name)) - -> Term TyName Name DefaultUni DefaultFun () - -> m (Term TyName Name DefaultUni DefaultFun ()) + mayNamesMangle <- subset1 names + for mayNamesMangle $ \namesMangle -> do + let isNew name = not $ name `Set.member` namesMangle + newNames <- Gen.justT $ ensure (not . null) . filter isNew <$> genNames + pure $ \name -> + if name `Set.member` namesMangle + then Just <$> Gen.element newNames + else pure Nothing + +substAllNames :: + Monad m => + (Name -> m (Maybe Name)) -> + Term TyName Name DefaultUni DefaultFun () -> + m (Term TyName Name DefaultUni DefaultFun ()) substAllNames ren = - termSubstNamesM (fmap (fmap $ Var ()) . ren) >=> - termSubstTyNamesM (fmap (fmap $ TyVar () . TyName) . ren . unTyName) + termSubstNamesM (fmap (fmap $ Var ()) . ren) + >=> termSubstTyNamesM (fmap (fmap $ TyVar () . TyName) . ren . unTyName) -- See Note [ScopeHandling]. allTermNames :: Term TyName Name DefaultUni DefaultFun () -> Set Name allTermNames = setOf $ vTerm <^> tvTerm . coerced -- See Note [Name mangling] -mangleNames - :: Term TyName Name DefaultUni DefaultFun () - -> AstGen (Maybe (Term TyName Name DefaultUni DefaultFun ())) +mangleNames :: + Term TyName Name DefaultUni DefaultFun () -> + AstGen (Maybe (Term TyName Name DefaultUni DefaultFun ())) mangleNames term = do - mayMang <- genNameMangler $ allTermNames term - for mayMang $ \mang -> substAllNames mang term + mayMang <- genNameMangler $ allTermNames term + for mayMang $ \mang -> substAllNames mang term diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Builtin.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Builtin.hs index dcf1c32d56c..08136aa0f0b 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Builtin.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Builtin.hs @@ -1,15 +1,15 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module PlutusCore.Generators.Hedgehog.Builtin ( - GenTypedTerm (..), - GenArbitraryTerm (..), - genConstant + GenTypedTerm (..), + GenArbitraryTerm (..), + genConstant, ) where import PlutusCore hiding (Constr) @@ -18,8 +18,10 @@ import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing import PlutusCore.Data (Data (..)) -import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally, - NumBytesCostedAsNumWords) +import PlutusCore.Evaluation.Machine.ExMemoryUsage ( + IntegerCostedLiterally, + NumBytesCostedAsNumWords, + ) import PlutusCore.Generators.Hedgehog.AST hiding (genConstant) import PlutusCore.Generators.QuickCheck.Builtin import PlutusCore.Value (Value) @@ -45,98 +47,98 @@ import Type.Reflection -- TODO: Move this to "PlutusIR.Generators.AST", and merge `genConstant` with -- `PlutusIR.Generators.AST.genConstant`. class GenTypedTerm uni where - -- | Generate a `Term` in @uni@ with the given type. - genTypedTerm :: - forall (a :: GHC.Type) fun. - KnownTypeAst TyName uni a => - TypeRep a -> - Gen (Term TyName Name uni fun ()) + -- | Generate a `Term` in @uni@ with the given type. + genTypedTerm :: + forall (a :: GHC.Type) fun. + KnownTypeAst TyName uni a => + TypeRep a -> + Gen (Term TyName Name uni fun ()) instance GenTypedTerm DefaultUni where - -- TODO: currently it generates constants or constant functions returning constants. - genTypedTerm tr0 = go (toTypeAst tr0) tr0 where - go :: - forall (a :: GHC.Type) fun. - Type TyName DefaultUni () -> - TypeRep a -> - Gen (Term TyName Name DefaultUni fun ()) - go sch tr - | trOpaque `App` _ `App` trEl <- tr - , Just HRefl <- eqTypeRep trOpaque (typeRep @Opaque) = - go sch trEl - go (TyFun _ dom cod) tr - | trFun `App` _ `App` trCod <- tr - , Just HRefl <- eqTypeRep trFun (typeRep @(->)) = - LamAbs () (Name "_" (Unique 0)) dom <$> go cod trCod - go _ tr = case genConstant tr of - SomeGen gen -> Constant () . someValue <$> gen + -- TODO: currently it generates constants or constant functions returning constants. + genTypedTerm tr0 = go (toTypeAst tr0) tr0 + where + go :: + forall (a :: GHC.Type) fun. + Type TyName DefaultUni () -> + TypeRep a -> + Gen (Term TyName Name DefaultUni fun ()) + go sch tr + | trOpaque `App` _ `App` trEl <- tr + , Just HRefl <- eqTypeRep trOpaque (typeRep @Opaque) = + go sch trEl + go (TyFun _ dom cod) tr + | trFun `App` _ `App` trCod <- tr + , Just HRefl <- eqTypeRep trFun (typeRep @(->)) = + LamAbs () (Name "_" (Unique 0)) dom <$> go cod trCod + go _ tr = case genConstant tr of + SomeGen gen -> Constant () . someValue <$> gen -- | This class exists so we can provide an ad-hoc arbitrary term generator -- for various universes. class GenArbitraryTerm uni where - -- | Generate an arbitrary `Term` in @uni@. - genArbitraryTerm :: - forall fun. - (Bounded fun, Enum fun) => - Gen (Term TyName Name uni fun ()) + -- | Generate an arbitrary `Term` in @uni@. + genArbitraryTerm :: + forall fun. + (Bounded fun, Enum fun) => + Gen (Term TyName Name uni fun ()) instance GenArbitraryTerm DefaultUni where - genArbitraryTerm = runAstGen genTerm + genArbitraryTerm = runAstGen genTerm data SomeGen uni = forall a. uni `HasTermLevel` a => SomeGen (Gen a) -genArbitraryBuiltin - :: forall a. (ArbitraryBuiltin a, DefaultUni `HasTermLevel` a) => SomeGen DefaultUni +genArbitraryBuiltin :: + forall a. (ArbitraryBuiltin a, DefaultUni `HasTermLevel` a) => SomeGen DefaultUni genArbitraryBuiltin = SomeGen $ unAsArbitraryBuiltin <$> arbitrary @(AsArbitraryBuiltin a) genConstant :: forall (a :: GHC.Type). TypeRep a -> SomeGen DefaultUni genConstant tr - | Just HRefl <- eqTypeRep tr (typeRep @()) = genArbitraryBuiltin @() - | Just HRefl <- eqTypeRep tr (typeRep @Integer) = genArbitraryBuiltin @Integer - | Just HRefl <- eqTypeRep tr (typeRep @Int) = genArbitraryBuiltin @Integer - | Just HRefl <- eqTypeRep tr (typeRep @Word8) = genArbitraryBuiltin @Integer - | Just HRefl <- eqTypeRep tr (typeRep @Natural) = genArbitraryBuiltin @Integer - | Just HRefl <- eqTypeRep tr (typeRep @NumBytesCostedAsNumWords) = genArbitraryBuiltin @Integer - | Just HRefl <- eqTypeRep tr (typeRep @IntegerCostedLiterally) = genArbitraryBuiltin @Integer - | Just HRefl <- eqTypeRep tr (typeRep @Bool) = genArbitraryBuiltin @Bool - | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = genArbitraryBuiltin @BS.ByteString - | Just HRefl <- eqTypeRep tr (typeRep @Text) = genArbitraryBuiltin @Text - | Just HRefl <- eqTypeRep tr (typeRep @Data) = genArbitraryBuiltin @Data - | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G1.Element) = - genArbitraryBuiltin @BLS12_381.G1.Element - | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G2.Element) = - genArbitraryBuiltin @BLS12_381.G2.Element - | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.Pairing.MlResult) = - genArbitraryBuiltin @BLS12_381.Pairing.MlResult - | Just HRefl <- eqTypeRep tr (typeRep @Value) = genArbitraryBuiltin @Value - | trPair `App` tr1 `App` tr2 <- tr - , Just HRefl <- eqTypeRep trPair (typeRep @(,)) = - -- We can perhaps use the @QuickCheck@ generator here too, but this seems rather hard. - -- Maybe we should simply copy the logic. Should we halve the size explicitly here? - case (genConstant tr1, genConstant tr2) of - (SomeGen g1, SomeGen g2) -> SomeGen $ (,) <$> g1 <*> g2 - | trList `App` trElem <- tr - , Just HRefl <- eqTypeRep trList (typeRep @[]) = - case genConstant trElem of - SomeGen genElem -> SomeGen $ Gen.list (Range.linear 0 10) genElem - | trArray `App` trElem <- tr - , Just HRefl <- eqTypeRep trArray (typeRep @Vector) = - case genConstant trElem of SomeGen genElem -> SomeGen (genArray genElem) - | trSomeConstant `App` _ `App` trEl <- tr - , Just HRefl <- eqTypeRep trSomeConstant (typeRep @SomeConstant) = - genConstant trEl - | trLastArg `App` _ `App` trY <- tr - , Just HRefl <- eqTypeRep trLastArg (typeRep @LastArg) = - genConstant trY - | trTyVarRep `App` _ <- tr - , Just HRefl <- eqTypeRep trTyVarRep (typeRep @(TyVarRep @GHC.Type)) = - -- In the current implementation, all type variables are instantiated - -- to `Integer` (TODO: change this?). - genArbitraryBuiltin @Integer - | otherwise = - error $ - "genConstant: I don't know how to generate constants of this type: " <> show tr - + | Just HRefl <- eqTypeRep tr (typeRep @()) = genArbitraryBuiltin @() + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = genArbitraryBuiltin @Integer + | Just HRefl <- eqTypeRep tr (typeRep @Int) = genArbitraryBuiltin @Integer + | Just HRefl <- eqTypeRep tr (typeRep @Word8) = genArbitraryBuiltin @Integer + | Just HRefl <- eqTypeRep tr (typeRep @Natural) = genArbitraryBuiltin @Integer + | Just HRefl <- eqTypeRep tr (typeRep @NumBytesCostedAsNumWords) = genArbitraryBuiltin @Integer + | Just HRefl <- eqTypeRep tr (typeRep @IntegerCostedLiterally) = genArbitraryBuiltin @Integer + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = genArbitraryBuiltin @Bool + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = genArbitraryBuiltin @BS.ByteString + | Just HRefl <- eqTypeRep tr (typeRep @Text) = genArbitraryBuiltin @Text + | Just HRefl <- eqTypeRep tr (typeRep @Data) = genArbitraryBuiltin @Data + | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G1.Element) = + genArbitraryBuiltin @BLS12_381.G1.Element + | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.G2.Element) = + genArbitraryBuiltin @BLS12_381.G2.Element + | Just HRefl <- eqTypeRep tr (typeRep @BLS12_381.Pairing.MlResult) = + genArbitraryBuiltin @BLS12_381.Pairing.MlResult + | Just HRefl <- eqTypeRep tr (typeRep @Value) = genArbitraryBuiltin @Value + | trPair `App` tr1 `App` tr2 <- tr + , Just HRefl <- eqTypeRep trPair (typeRep @(,)) = + -- We can perhaps use the @QuickCheck@ generator here too, but this seems rather hard. + -- Maybe we should simply copy the logic. Should we halve the size explicitly here? + case (genConstant tr1, genConstant tr2) of + (SomeGen g1, SomeGen g2) -> SomeGen $ (,) <$> g1 <*> g2 + | trList `App` trElem <- tr + , Just HRefl <- eqTypeRep trList (typeRep @[]) = + case genConstant trElem of + SomeGen genElem -> SomeGen $ Gen.list (Range.linear 0 10) genElem + | trArray `App` trElem <- tr + , Just HRefl <- eqTypeRep trArray (typeRep @Vector) = + case genConstant trElem of SomeGen genElem -> SomeGen (genArray genElem) + | trSomeConstant `App` _ `App` trEl <- tr + , Just HRefl <- eqTypeRep trSomeConstant (typeRep @SomeConstant) = + genConstant trEl + | trLastArg `App` _ `App` trY <- tr + , Just HRefl <- eqTypeRep trLastArg (typeRep @LastArg) = + genConstant trY + | trTyVarRep `App` _ <- tr + , Just HRefl <- eqTypeRep trTyVarRep (typeRep @(TyVarRep @GHC.Type)) = + -- In the current implementation, all type variables are instantiated + -- to `Integer` (TODO: change this?). + genArbitraryBuiltin @Integer + | otherwise = + error $ + "genConstant: I don't know how to generate constants of this type: " <> show tr where genArray :: Gen x -> Gen (Vector x) genArray = fmap Vector.fromList . Gen.list (Range.linear 0 10) diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Denotation.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Denotation.hs index cc4097ecb51..2905dbca322 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Denotation.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Denotation.hs @@ -1,21 +1,20 @@ --- | This module defines tools for associating PLC terms with their corresponding --- Haskell values. - {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} -module PlutusCore.Generators.Hedgehog.Denotation - ( KnownType - , Denotation(..) - , DenotationContextMember(..) - , DenotationContext(..) - , lookupInContext - , denoteVariable - , insertVariable - , insertBuiltin - , typedBuiltins - ) where +-- | This module defines tools for associating PLC terms with their corresponding +-- Haskell values. +module PlutusCore.Generators.Hedgehog.Denotation ( + KnownType, + Denotation (..), + DenotationContextMember (..), + DenotationContext (..), + lookupInContext, + denoteVariable, + insertVariable, + insertBuiltin, + typedBuiltins, +) where import PlutusCore.Builtin import PlutusCore.Core @@ -32,21 +31,21 @@ type KnownType val a = (KnownTypeAst TyName (UniOf val) a, MakeKnown val a) -- | Haskell denotation of a PLC object. An object can be a 'Builtin' or a variable for example. data Denotation term object res = forall args. Denotation - { _denotationObject :: object - -- ^ A PLC object. - , _denotationToTerm :: object -> term - -- ^ How to embed the object into a term. - , _denotationItself :: FoldArgs args res - -- ^ The denotation of the object. E.g. the denotation of 'AddInteger' is '(+)'. - , _denotationScheme :: TypeScheme term args res - -- ^ The 'TypeScheme' of the object. - } + { _denotationObject :: object + -- ^ A PLC object. + , _denotationToTerm :: object -> term + -- ^ How to embed the object into a term. + , _denotationItself :: FoldArgs args res + -- ^ The denotation of the object. E.g. the denotation of 'AddInteger' is '(+)'. + , _denotationScheme :: TypeScheme term args res + -- ^ The 'TypeScheme' of the object. + } -- | A member of a 'DenotationContext'. -- @object@ is existentially quantified, so the only thing that can be done with it, -- is turning it into a 'Term' using '_denotationToTerm'. -data DenotationContextMember term res = - forall object. DenotationContextMember (Denotation term object res) +data DenotationContextMember term res + = forall object. DenotationContextMember (Denotation term object res) -- | A context of 'DenotationContextMember's. -- Each row is a mapping from a type to a list of things that can return that type. @@ -55,16 +54,16 @@ data DenotationContextMember term res = -- 2. a bound variable of functional type with the result being @integer@ -- 3. the 'AddInteger' 'Builtin' or any other 'Builtin' which returns an @integer@. newtype DenotationContext term = DenotationContext - { unDenotationContext :: DMap TypeRep (Compose [] (DenotationContextMember term)) - } + { unDenotationContext :: DMap TypeRep (Compose [] (DenotationContextMember term)) + } -- | Look up a list of 'Denotation's from 'DenotationContext' each of which has a type that ends in -- the same type as the one that the 'TypeRep' argument represents. -lookupInContext - :: forall a term. - TypeRep a - -> DenotationContext term - -> [DenotationContextMember term a] +lookupInContext :: + forall a term. + TypeRep a -> + DenotationContext term -> + [DenotationContextMember term a] lookupInContext tr = foldMap getCompose . DMap.lookup tr . unDenotationContext -- Here the only search that we need to perform is the search for things that return an appropriate @@ -74,55 +73,56 @@ lookupInContext tr = foldMap getCompose . DMap.lookup tr . unDenotationContext -- | The resulting type of a 'TypeScheme'. withTypeSchemeResult :: TypeScheme term args res -> (KnownType term res => TypeRep res -> c) -> c -withTypeSchemeResult TypeSchemeResult k = k typeRep +withTypeSchemeResult TypeSchemeResult k = k typeRep withTypeSchemeResult (TypeSchemeArrow schB) k = withTypeSchemeResult schB k withTypeSchemeResult (TypeSchemeAll _ schK) k = withTypeSchemeResult schK k -- | Get the 'Denotation' of a variable. -denoteVariable - :: KnownType (Term TyName Name uni fun ()) res - => Name -> TypeRep res -> res -> Denotation (Term TyName Name uni fun ()) Name res +denoteVariable :: + KnownType (Term TyName Name uni fun ()) res => + Name -> TypeRep res -> res -> Denotation (Term TyName Name uni fun ()) Name res denoteVariable name tr meta = withTypeable tr $ Denotation name (Var ()) meta TypeSchemeResult -- | Insert the 'Denotation' of an object into a 'DenotationContext'. -insertDenotation - :: TypeRep res -> Denotation term object res -> DenotationContext term -> DenotationContext term -insertDenotation tr denotation (DenotationContext vs) = DenotationContext $ +insertDenotation :: + TypeRep res -> Denotation term object res -> DenotationContext term -> DenotationContext term +insertDenotation tr denotation (DenotationContext vs) = + DenotationContext $ DMap.insertWith' - (\(Compose xs) (Compose ys) -> Compose $ xs ++ ys) - tr - (Compose [DenotationContextMember denotation]) - vs + (\(Compose xs) (Compose ys) -> Compose $ xs ++ ys) + tr + (Compose [DenotationContextMember denotation]) + vs -- | Insert a variable into a 'DenotationContext'. -insertVariable - :: KnownType (Term TyName Name uni fun ()) a - => Name - -> TypeRep a - -> a - -> DenotationContext (Term TyName Name uni fun ()) - -> DenotationContext (Term TyName Name uni fun ()) +insertVariable :: + KnownType (Term TyName Name uni fun ()) a => + Name -> + TypeRep a -> + a -> + DenotationContext (Term TyName Name uni fun ()) -> + DenotationContext (Term TyName Name uni fun ()) insertVariable name tr = insertDenotation tr . denoteVariable name tr -- | Insert a builtin into a 'DenotationContext'. -insertBuiltin - :: DefaultFun - -> DenotationContext (Term TyName Name DefaultUni DefaultFun ()) - -> DenotationContext (Term TyName Name DefaultUni DefaultFun ()) +insertBuiltin :: + DefaultFun -> + DenotationContext (Term TyName Name DefaultUni DefaultFun ()) -> + DenotationContext (Term TyName Name DefaultUni DefaultFun ()) insertBuiltin fun = - case toBuiltinMeaning def fun of - BuiltinMeaning sch meta _ -> - withTypeSchemeResult sch $ \tr -> - insertDenotation tr $ Denotation fun (Builtin ()) meta sch + case toBuiltinMeaning def fun of + BuiltinMeaning sch meta _ -> + withTypeSchemeResult sch $ \tr -> + insertDenotation tr $ Denotation fun (Builtin ()) meta sch -- | A 'DenotationContext' that consists of 'DefaultFun's. -- -- DEPRECATED: No need to update for a new builtin. -- Outdated, since we moved to quickcheck generators. -typedBuiltins - :: DenotationContext (Term TyName Name DefaultUni DefaultFun ()) -typedBuiltins - = insertBuiltin AddInteger +typedBuiltins :: + DenotationContext (Term TyName Name DefaultUni DefaultFun ()) +typedBuiltins = + insertBuiltin AddInteger . insertBuiltin SubtractInteger . insertBuiltin MultiplyInteger -- We insert those, but they don't really get selected, because the 'TypeRep' of diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Entity.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Entity.hs index a03400dd20d..344d3bb7529 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Entity.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Entity.hs @@ -1,28 +1,27 @@ -- editorconfig-checker-disable-file --- | Generators of various PLC things: 'Builtin's, 'IterApp's, 'Term's, etc. - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module PlutusCore.Generators.Hedgehog.Entity - ( PlcGenT - , IterApp(..) - , IterAppValue(..) - , runPlcT - , withTypedBuiltinGen - , genIterAppValue - , genTerm - , genTermLoose - , withAnyTermLoose - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Generators of various PLC things: 'Builtin's, 'IterApp's, 'Term's, etc. +module PlutusCore.Generators.Hedgehog.Entity ( + PlcGenT, + IterApp (..), + IterAppValue (..), + runPlcT, + withTypedBuiltinGen, + genIterAppValue, + genTerm, + genTermLoose, + withAnyTermLoose, +) where import PlutusPrelude @@ -51,10 +50,10 @@ type Plain f (uni :: GHC.Type -> GHC.Type) (fun :: GHC.Type) = f TyName Name uni -- | Generators of built-ins supplied to computations that run in the 'PlcGenT' monad. newtype BuiltinGensT uni fun m = BuiltinGensT - { _builtinGensTyped :: TypedBuiltinGenT (Plain Term uni fun) m - -- ^ Generates a PLC 'Term' and the corresponding - -- Haskell value out of a 'TypedBuiltin'. - } + { _builtinGensTyped :: TypedBuiltinGenT (Plain Term uni fun) m + -- ^ Generates a PLC 'Term' and the corresponding + -- Haskell value out of a 'TypedBuiltin'. + } -- | The type used in generators defined in this module. -- It's parameterized by a 'BuiltinGensT' which makes it possible to supply @@ -66,28 +65,44 @@ type PlcGenT uni fun m = GenT (ReaderT (BuiltinGensT uni fun m) m) -- | A function (called "head") applied to a list of arguments (called "spine"). data IterApp head arg = IterApp - { _iterAppHead :: head - , _iterAppSpine :: [arg] - } + { _iterAppHead :: head + , _iterAppSpine :: [arg] + } instance (PrettyBy config head, PrettyBy config arg) => PrettyBy config (IterApp head arg) where - prettyBy config (IterApp appHead appSpine) = - parens $ foldl' (\fun arg -> fun <+> prettyBy config arg) (prettyBy config appHead) appSpine + prettyBy config (IterApp appHead appSpine) = + parens $ foldl' (\fun arg -> fun <+> prettyBy config arg) (prettyBy config appHead) appSpine -- | One iterated application of a @head@ to @arg@s represented in three distinct ways. data IterAppValue uni fun head arg r = IterAppValue - { _iterTerm :: Plain Term uni fun -- ^ As a PLC 'Term'. - , _iterApp :: IterApp head arg -- ^ As an 'IterApp'. - , _iterTbv :: r -- ^ As a Haskell value. - } - -instance ( PrettyBy config (Plain Term uni fun) - , PrettyBy config head, PrettyBy config arg, PrettyConst r - ) => PrettyBy config (IterAppValue uni fun head arg r) where - prettyBy config (IterAppValue term pia y) = parens $ fold - [ "{ ", prettyBy config term, line - , "| ", prettyBy config pia, line - , "| ", prettyConst botRenderContext y, line + { _iterTerm :: Plain Term uni fun + -- ^ As a PLC 'Term'. + , _iterApp :: IterApp head arg + -- ^ As an 'IterApp'. + , _iterTbv :: r + -- ^ As a Haskell value. + } + +instance + ( PrettyBy config (Plain Term uni fun) + , PrettyBy config head + , PrettyBy config arg + , PrettyConst r + ) => + PrettyBy config (IterAppValue uni fun head arg r) + where + prettyBy config (IterAppValue term pia y) = + parens $ + fold + [ "{ " + , prettyBy config term + , line + , "| " + , prettyBy config pia + , line + , "| " + , prettyConst botRenderContext y + , line , "}" ] @@ -103,20 +118,24 @@ iterAppValueToTermOf (IterAppValue term _ y) = TermOf term y -- without any additional symbols inbetween. revealUnique :: Name -> Name revealUnique (Name name uniq) = - Name (name <> display (unUnique uniq)) uniq + Name (name <> display (unUnique uniq)) uniq -- TODO: we can generate more types here. + -- | Generate a 'Builtin' and supply its typed version to a continuation. -withTypedBuiltinGen - :: Monad m - => Proxy fun - -> (forall a. (KnownTypeAst TyName DefaultUni a, MakeKnown (Plain Term DefaultUni fun) a) => - TypeRep a -> GenT m c) - -> GenT m c -withTypedBuiltinGen _ k = Gen.choice - [ k @Integer typeRep +withTypedBuiltinGen :: + Monad m => + Proxy fun -> + ( forall a. + (KnownTypeAst TyName DefaultUni a, MakeKnown (Plain Term DefaultUni fun) a) => + TypeRep a -> GenT m c + ) -> + GenT m c +withTypedBuiltinGen _ k = + Gen.choice + [ k @Integer typeRep , k @BS.ByteString typeRep - , k @Bool typeRep + , k @Bool typeRep ] -- | Generate an 'IterAppValue' from a 'Denotation'. @@ -125,84 +144,89 @@ withTypedBuiltinGen _ k = Gen.choice -- 1. grow the 'Term' component by applying it to arguments using 'Apply' -- 2. grow the 'IterApp' component by appending arguments to its spine -- 3. feed arguments to the Haskell function -genIterAppValue - :: forall head uni fun res m. Monad m - => Denotation (Plain Term uni fun) head res - -> PlcGenT uni fun m (IterAppValue uni fun head (Plain Term uni fun) res) -genIterAppValue (Denotation object embed meta scheme) = result where +genIterAppValue :: + forall head uni fun res m. + Monad m => + Denotation (Plain Term uni fun) head res -> + PlcGenT uni fun m (IterAppValue uni fun head (Plain Term uni fun) res) +genIterAppValue (Denotation object embed meta scheme) = result + where result = go scheme (embed object) id meta - go - :: TypeScheme (Plain Term uni fun) args res - -> Plain Term uni fun - -> ([Plain Term uni fun] -> [Plain Term uni fun]) - -> FoldArgs args res - -> PlcGenT uni fun m (IterAppValue uni fun head (Plain Term uni fun) res) - go TypeSchemeResult term args y = do -- Computed the result. - let pia = IterApp object $ args [] - return $ IterAppValue term pia y - go (TypeSchemeArrow schB) term args f = do -- Another argument is required. - BuiltinGensT genTb <- ask - TermOf v x <- liftT $ genTb typeRep -- Get a Haskell and the corresponding PLC values. - let term' = Apply () term v -- Apply the term to the PLC value. - args' = args . (v :) -- Append the PLC value to the spine. - y = f x -- Apply the Haskell function to the generated argument. - go schB term' args' y + go :: + TypeScheme (Plain Term uni fun) args res -> + Plain Term uni fun -> + ([Plain Term uni fun] -> [Plain Term uni fun]) -> + FoldArgs args res -> + PlcGenT uni fun m (IterAppValue uni fun head (Plain Term uni fun) res) + go TypeSchemeResult term args y = do + -- Computed the result. + let pia = IterApp object $ args [] + return $ IterAppValue term pia y + go (TypeSchemeArrow schB) term args f = do + -- Another argument is required. + BuiltinGensT genTb <- ask + TermOf v x <- liftT $ genTb typeRep -- Get a Haskell and the corresponding PLC values. + let term' = Apply () term v -- Apply the term to the PLC value. + args' = args . (v :) -- Append the PLC value to the spine. + y = f x -- Apply the Haskell function to the generated argument. + go schB term' args' y go (TypeSchemeAll _ schK) term args f = - go schK term args f + go schK term args f -- | Generate a PLC 'Term' of the specified type and the corresponding Haskell value. -- Generates first-order functions and constants including constant applications. -- Arguments to functions and 'Builtin's are generated recursively. -genTerm - :: forall uni fun m. - (uni ~ DefaultUni, Monad m) - => TypedBuiltinGenT (Plain Term uni fun) m - -- ^ Ground generators of built-ins. The base case of the recursion. - -> DenotationContext (Plain Term uni fun) - -- ^ A context to generate terms in. See for example 'typedBuiltins'. - -- Gets extended by a variable when an applied lambda is generated. - -> Int - -- ^ Depth of recursion. - -> TypedBuiltinGenT (Plain Term uni fun) m -genTerm genBase context0 depth0 = Morph.hoist runQuoteT . go context0 depth0 where - go - :: DenotationContext (Plain Term uni fun) - -> Int - -> TypeRep r - -> GenT (QuoteT m) (TermOf (Plain Term uni fun) r) +genTerm :: + forall uni fun m. + (uni ~ DefaultUni, Monad m) => + -- | Ground generators of built-ins. The base case of the recursion. + TypedBuiltinGenT (Plain Term uni fun) m -> + -- | A context to generate terms in. See for example 'typedBuiltins'. + -- Gets extended by a variable when an applied lambda is generated. + DenotationContext (Plain Term uni fun) -> + -- | Depth of recursion. + Int -> + TypedBuiltinGenT (Plain Term uni fun) m +genTerm genBase context0 depth0 = Morph.hoist runQuoteT . go context0 depth0 + where + go :: + DenotationContext (Plain Term uni fun) -> + Int -> + TypeRep r -> + GenT (QuoteT m) (TermOf (Plain Term uni fun) r) go context depth tr - -- FIXME: should be using 'variables' but this is now the same as 'recursive' - | depth == 0 = choiceDef (liftT $ genBase tr) [] - | depth == 1 = choiceDef (liftT $ genBase tr) $ variables ++ recursive - | depth == 2 = Gen.frequency $ stopOrDeeper ++ map (3 ,) variables ++ map (5 ,) recursive - | depth == 3 = Gen.frequency $ stopOrDeeper ++ map (3 ,) recursive - | otherwise = Gen.frequency stopOrDeeper - where - stopOrDeeper = [(1, liftT $ genBase tr), (5, lambdaApply)] - -- Generators of built-ins to feed them to 'genIterAppValue'. - -- Note that the typed built-ins generator calls 'go' recursively. - builtinGens = BuiltinGensT (flip Gen.subterm id . go context (depth - 1)) - -- Generate arguments for functions recursively or return a variable. - proceed (DenotationContextMember denotation) = - fmap iterAppValueToTermOf . hoistSupply builtinGens $ genIterAppValue denotation - -- A list of variables generators. - variables = map proceed $ lookupInContext tr context - -- A list of recursive generators. - recursive = map proceed $ lookupInContext tr context - -- Generate a lambda and immediately apply it to a generated argument of a generated type. - lambdaApply = withTypedBuiltinGen (Proxy @fun) $ \argTr -> do - -- Generate a name for the name representing the argument. - name <- lift $ revealUnique <$> freshName "x" - -- Get the 'Type' of the argument from a generated 'TypedBuiltin'. - let argTy = toTypeAst argTr - -- Generate the argument. - TermOf arg x <- go context (depth - 1) argTr - -- Generate the body of the lambda abstraction adding the new variable to the context. - TermOf body y <- go (insertVariable name argTr x context) (depth - 1) tr - -- Assemble the term. - let term = Apply () (LamAbs () name argTy body) arg - return $ TermOf term y + -- FIXME: should be using 'variables' but this is now the same as 'recursive' + | depth == 0 = choiceDef (liftT $ genBase tr) [] + | depth == 1 = choiceDef (liftT $ genBase tr) $ variables ++ recursive + | depth == 2 = Gen.frequency $ stopOrDeeper ++ map (3,) variables ++ map (5,) recursive + | depth == 3 = Gen.frequency $ stopOrDeeper ++ map (3,) recursive + | otherwise = Gen.frequency stopOrDeeper + where + stopOrDeeper = [(1, liftT $ genBase tr), (5, lambdaApply)] + -- Generators of built-ins to feed them to 'genIterAppValue'. + -- Note that the typed built-ins generator calls 'go' recursively. + builtinGens = BuiltinGensT (flip Gen.subterm id . go context (depth - 1)) + -- Generate arguments for functions recursively or return a variable. + proceed (DenotationContextMember denotation) = + fmap iterAppValueToTermOf . hoistSupply builtinGens $ genIterAppValue denotation + -- A list of variables generators. + variables = map proceed $ lookupInContext tr context + -- A list of recursive generators. + recursive = map proceed $ lookupInContext tr context + -- Generate a lambda and immediately apply it to a generated argument of a generated type. + lambdaApply = withTypedBuiltinGen (Proxy @fun) $ \argTr -> do + -- Generate a name for the name representing the argument. + name <- lift $ revealUnique <$> freshName "x" + -- Get the 'Type' of the argument from a generated 'TypedBuiltin'. + let argTy = toTypeAst argTr + -- Generate the argument. + TermOf arg x <- go context (depth - 1) argTr + -- Generate the body of the lambda abstraction adding the new variable to the context. + TermOf body y <- go (insertVariable name argTr x context) (depth - 1) tr + -- Assemble the term. + let term = Apply () (LamAbs () name argTy body) arg + return $ TermOf term y -- | Generates a 'Term' with rather small values to make out-of-bounds failures less likely. -- There are still like a half of terms that fail with out-of-bounds errors being evaluated. @@ -211,8 +235,8 @@ genTermLoose = genTerm genTypedBuiltinDef typedBuiltins 4 -- | Generate a 'TypedBuiltin' and a 'TermOf' of the corresponding type, -- attach the 'TypedBuiltin' to the value part of the 'TermOf' and pass that to a continuation. -withAnyTermLoose - :: (uni ~ DefaultUni, fun ~ DefaultFun, Monad m) - => (forall a. KnownType (Plain Term uni fun) a => TermOf (Plain Term uni fun) a -> GenT m c) - -> GenT m c +withAnyTermLoose :: + (uni ~ DefaultUni, fun ~ DefaultFun, Monad m) => + (forall a. KnownType (Plain Term uni fun) a => TermOf (Plain Term uni fun) a -> GenT m c) -> + GenT m c withAnyTermLoose k = withTypedBuiltinGen (Proxy @DefaultFun) $ \tr -> genTermLoose tr >>= k diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Interesting.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Interesting.hs index e0040648f8a..b9e3bf24a83 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Interesting.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Interesting.hs @@ -1,25 +1,24 @@ -- editorconfig-checker-disable-file --- | Sample generators used for tests. - -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} -module PlutusCore.Generators.Hedgehog.Interesting - ( TermGen - , TermOf(..) - , genOverapplication - , factorial - , genFactorial - , naiveFib - , genNaiveFib - , genNatRoundtrip - , natSum - , genScottListSum - , genIfIntegers - , fromInterestingTermGens - ) where +-- | Sample generators used for tests. +module PlutusCore.Generators.Hedgehog.Interesting ( + TermGen, + TermOf (..), + genOverapplication, + factorial, + genFactorial, + naiveFib, + genNaiveFib, + genNatRoundtrip, + natSum, + genScottListSum, + genIfIntegers, + fromInterestingTermGens, +) where import PlutusCore.Generators.Hedgehog.Denotation import PlutusCore.Generators.Hedgehog.Entity @@ -55,35 +54,36 @@ type TermGen a = Gen (TermOf (Term TyName Name DefaultUni DefaultFun ()) a) -- > == if i < j then i + j else i - j genOverapplication :: TermGen Integer genOverapplication = do - let typedInteger = typeRep - integer = toTypeAst typedInteger - TermOf ti i <- genTypedBuiltinDef typedInteger - TermOf tj j <- genTypedBuiltinDef typedInteger - let term = - mkIterAppNoAnn - (TyInst () (Builtin () IfThenElse) . TyFun () integer $ TyFun () integer integer) - [ mkIterAppNoAnn (Builtin () LessThanInteger) [ti, tj] - , Builtin () AddInteger - , Builtin () SubtractInteger - , ti - , tj - ] - return . TermOf term $ if i < j then i + j else i - j + let typedInteger = typeRep + integer = toTypeAst typedInteger + TermOf ti i <- genTypedBuiltinDef typedInteger + TermOf tj j <- genTypedBuiltinDef typedInteger + let term = + mkIterAppNoAnn + (TyInst () (Builtin () IfThenElse) . TyFun () integer $ TyFun () integer integer) + [ mkIterAppNoAnn (Builtin () LessThanInteger) [ti, tj] + , Builtin () AddInteger + , Builtin () SubtractInteger + , ti + , tj + ] + return . TermOf term $ if i < j then i + j else i - j -- | @\i -> product [1 :: Integer .. i]@ as a PLC term. -- -- > \(i : integer) -> product (enumFromTo 1 i) factorial :: Term TyName Name DefaultUni DefaultFun () factorial = runQuote $ do - i <- freshName "i" - let int = mkTyBuiltin @_ @Integer () - return - . LamAbs () i int - . apply () ScottList.product - $ mkIterAppNoAnn ScottList.enumFromTo - [ mkConstant @Integer () 1 - , Var () i - ] + i <- freshName "i" + let int = mkTyBuiltin @_ @Integer () + return + . LamAbs () i int + . apply () ScottList.product + $ mkIterAppNoAnn + ScottList.enumFromTo + [ mkConstant @Integer () 1 + , Var () i + ] -- | The naive exponential fibonacci function as a PLC term. -- @@ -99,48 +99,58 @@ factorial = runQuote $ do -- > i0 naiveFib :: Integer -> Term TyName Name DefaultUni DefaultFun () naiveFib iv = runQuote $ do - i0 <- freshName "i0" - rec <- freshName "rec" - i <- freshName "i" - u <- freshName "u" - let - intS = mkTyBuiltin @_ @Integer () - fib = LamAbs () i0 intS - $ mkIterAppNoAnn (mkIterInstNoAnn fix [intS, intS]) - [ LamAbs () rec (TyFun () intS intS) + i0 <- freshName "i0" + rec <- freshName "rec" + i <- freshName "i" + u <- freshName "u" + let + intS = mkTyBuiltin @_ @Integer () + fib = + LamAbs () i0 intS $ + mkIterAppNoAnn + (mkIterInstNoAnn fix [intS, intS]) + [ LamAbs () rec (TyFun () intS intS) . LamAbs () i intS - $ mkIterAppNoAnn (TyInst () ifThenElse intS) - [ mkIterAppNoAnn (Builtin () LessThanEqualsInteger) - [Var () i, mkConstant @Integer () 1] - , LamAbs () u unit $ Var () i - , LamAbs () u unit $ mkIterAppNoAnn (Builtin () AddInteger) - [ Apply () (Var () rec) $ mkIterAppNoAnn (Builtin () SubtractInteger) - [Var () i, mkConstant @Integer () 1] - , Apply () (Var () rec) $ mkIterAppNoAnn (Builtin () SubtractInteger) - [Var () i, mkConstant @Integer () 2] + $ mkIterAppNoAnn + (TyInst () ifThenElse intS) + [ mkIterAppNoAnn + (Builtin () LessThanEqualsInteger) + [Var () i, mkConstant @Integer () 1] + , LamAbs () u unit $ Var () i + , LamAbs () u unit $ + mkIterAppNoAnn + (Builtin () AddInteger) + [ Apply () (Var () rec) $ + mkIterAppNoAnn + (Builtin () SubtractInteger) + [Var () i, mkConstant @Integer () 1] + , Apply () (Var () rec) $ + mkIterAppNoAnn + (Builtin () SubtractInteger) + [Var () i, mkConstant @Integer () 2] ] - ] - , Var () i0 - ] - pure . Apply () fib $ mkConstant @Integer () iv + ] + , Var () i0 + ] + pure . Apply () fib $ mkConstant @Integer () iv -- | Generate a term that computes the factorial of an @integer@ and return it -- along with the factorial of the corresponding 'Integer' computed on the Haskell side. genFactorial :: TermGen Integer genFactorial = do - let m = 10 - iv <- Gen.integral $ Range.linear 1 m - let term = Apply () factorial (mkConstant @Integer () iv) - return . TermOf term $ Prelude.product [1..iv] + let m = 10 + iv <- Gen.integral $ Range.linear 1 m + let term = Apply () factorial (mkConstant @Integer () iv) + return . TermOf term $ Prelude.product [1 .. iv] -- | Generate a term that computes the ith Fibonacci number and return it -- along with the corresponding 'Integer' computed on the Haskell side. genNaiveFib :: TermGen Integer genNaiveFib = do - let fibs = scanl (+) 0 $ 1 : fibs - m = 16 - iv <- Gen.integral $ Range.linear 0 m - return . TermOf (naiveFib iv) $ fibs `genericIndex` iv + let fibs = scanl (+) 0 $ 1 : fibs + m = 16 + iv <- Gen.integral $ Range.linear 0 m + return . TermOf (naiveFib iv) $ fibs `genericIndex` iv -- | Generate an 'Integer', turn it into a Scott-encoded PLC @Nat@ (see 'Nat'), -- turn that @Nat@ into the corresponding PLC @integer@ using a fold (see 'FoldNat') @@ -148,124 +158,129 @@ genNaiveFib = do -- along with the original 'Integer' genNatRoundtrip :: TermGen Integer genNatRoundtrip = do - let typedInt = typeRep - TermOf _ iv <- Gen.filter ((>= 0) . _termOfValue) $ - genTypedBuiltinDef @(Term TyName Name DefaultUni DefaultFun ()) typedInt - let term = apply () natToInteger $ metaIntegerToNat iv - return $ TermOf term iv + let typedInt = typeRep + TermOf _ iv <- + Gen.filter ((>= 0) . _termOfValue) $ + genTypedBuiltinDef @(Term TyName Name DefaultUni DefaultFun ()) typedInt + let term = apply () natToInteger $ metaIntegerToNat iv + return $ TermOf term iv -- | @sumNat@ as a PLC term. natSum :: Term TyName Name DefaultUni DefaultFun () natSum = runQuote $ do - let int = mkTyBuiltin @_ @Integer () - nat = _recursiveType natData - add = Builtin () AddInteger - acc <- freshName "acc" - n <- freshName "n" - return - $ mkIterAppNoAnn (mkIterInstNoAnn foldList [nat, int]) - [ LamAbs () acc int - . LamAbs () n nat - . mkIterAppNoAnn add - $ [ Var () acc - , mkIterAppNoAnn natToInteger [ Var () n ] - ] - , mkConstant @Integer () 0 - ] + let int = mkTyBuiltin @_ @Integer () + nat = _recursiveType natData + add = Builtin () AddInteger + acc <- freshName "acc" + n <- freshName "n" + return $ + mkIterAppNoAnn + (mkIterInstNoAnn foldList [nat, int]) + [ LamAbs () acc int + . LamAbs () n nat + . mkIterAppNoAnn add + $ [ Var () acc + , mkIterAppNoAnn natToInteger [Var () n] + ] + , mkConstant @Integer () 0 + ] -- | Generate a list of 'Integer's, turn it into a Scott-encoded PLC @List@ (see 'List'), -- sum elements of the list (see 'Sum') and return it along with the sum of the original list. genScottListSum :: TermGen Integer genScottListSum = do - let typedInt = typeRep - intS = toTypeAst typedInt - ps <- Gen.list (Range.linear 0 10) $ genTypedBuiltinDef typedInt - let list = metaListToScottList intS $ Prelude.map _termOfTerm ps - term = apply () ScottList.sum list - let haskSum = Prelude.sum $ Prelude.map _termOfValue ps - return $ TermOf term haskSum + let typedInt = typeRep + intS = toTypeAst typedInt + ps <- Gen.list (Range.linear 0 10) $ genTypedBuiltinDef typedInt + let list = metaListToScottList intS $ Prelude.map _termOfTerm ps + term = apply () ScottList.sum list + let haskSum = Prelude.sum $ Prelude.map _termOfValue ps + return $ TermOf term haskSum -- | Generate a @boolean@ and two @integer@s and check whether @if b then i1 else i2@ -- means the same thing in Haskell and PLC. Terms are generated using 'genTermLoose'. genIfIntegers :: TermGen Integer genIfIntegers = do - let typedInt = typeRep - int = toTypeAst typedInt - TermOf b bv <- genTermLoose typeRep - TermOf i iv <- genTermLoose typedInt - TermOf j jv <- genTermLoose typedInt - let instConst = Apply () $ mkIterInstNoAnn Function.const [int, unit] - value = if bv then iv else jv - term = - mkIterAppNoAnn - (TyInst () ifThenElse int) - [b, instConst i, instConst j] - return $ TermOf term value + let typedInt = typeRep + int = toTypeAst typedInt + TermOf b bv <- genTermLoose typeRep + TermOf i iv <- genTermLoose typedInt + TermOf j jv <- genTermLoose typedInt + let instConst = Apply () $ mkIterInstNoAnn Function.const [int, unit] + value = if bv then iv else jv + term = + mkIterAppNoAnn + (TyInst () ifThenElse int) + [b, instConst i, instConst j] + return $ TermOf term value -- | Check that builtins can be partially applied. genApplyAdd1 :: TermGen Integer genApplyAdd1 = do - let typedInt = typeRep - int = toTypeAst typedInt - TermOf i iv <- genTermLoose typedInt - TermOf j jv <- genTermLoose typedInt - let term = - mkIterAppNoAnn (mkIterInstNoAnn applyFun [int, int]) - [ Apply () (Builtin () AddInteger) i - , j - ] - return . TermOf term $ iv + jv + let typedInt = typeRep + int = toTypeAst typedInt + TermOf i iv <- genTermLoose typedInt + TermOf j jv <- genTermLoose typedInt + let term = + mkIterAppNoAnn + (mkIterInstNoAnn applyFun [int, int]) + [ Apply () (Builtin () AddInteger) i + , j + ] + return . TermOf term $ iv + jv -- | Check that builtins can be partially applied. genApplyAdd2 :: TermGen Integer genApplyAdd2 = do - let typedInt = typeRep - int = toTypeAst typedInt - TermOf i iv <- genTermLoose typedInt - TermOf j jv <- genTermLoose typedInt - let term = - mkIterAppNoAnn (mkIterInstNoAnn applyFun [int, TyFun () int int]) - [ Builtin () AddInteger - , i - , j - ] - return . TermOf term $ iv + jv + let typedInt = typeRep + int = toTypeAst typedInt + TermOf i iv <- genTermLoose typedInt + TermOf j jv <- genTermLoose typedInt + let term = + mkIterAppNoAnn + (mkIterInstNoAnn applyFun [int, TyFun () int int]) + [ Builtin () AddInteger + , i + , j + ] + return . TermOf term $ iv + jv -- | Check that division by zero results in 'Error'. genDivideByZero :: TermGen (BuiltinResult Integer) genDivideByZero = do - op <- Gen.element [DivideInteger, QuotientInteger, ModInteger, RemainderInteger] - TermOf i _ <- genTermLoose $ typeRep @Integer - let term = mkIterAppNoAnn (Builtin () op) [i, mkConstant @Integer () 0] - return $ TermOf term builtinResultFailure + op <- Gen.element [DivideInteger, QuotientInteger, ModInteger, RemainderInteger] + TermOf i _ <- genTermLoose $ typeRep @Integer + let term = mkIterAppNoAnn (Builtin () op) [i, mkConstant @Integer () 0] + return $ TermOf term builtinResultFailure -- | Check that division by zero results in 'Error' even if a function doesn't use that argument. genDivideByZeroDrop :: TermGen (BuiltinResult Integer) genDivideByZeroDrop = do - op <- Gen.element [DivideInteger, QuotientInteger, ModInteger, RemainderInteger] - let typedInt = typeRep - int = toTypeAst typedInt - TermOf i iv <- genTermLoose typedInt - let term = - mkIterAppNoAnn (mkIterInstNoAnn Function.const [int, int]) - [ mkConstant @Integer () iv - , mkIterAppNoAnn (Builtin () op) [i, mkConstant @Integer () 0] - ] - return $ TermOf term builtinResultFailure + op <- Gen.element [DivideInteger, QuotientInteger, ModInteger, RemainderInteger] + let typedInt = typeRep + int = toTypeAst typedInt + TermOf i iv <- genTermLoose typedInt + let term = + mkIterAppNoAnn + (mkIterInstNoAnn Function.const [int, int]) + [ mkConstant @Integer () iv + , mkIterAppNoAnn (Builtin () op) [i, mkConstant @Integer () 0] + ] + return $ TermOf term builtinResultFailure -- | Apply a function to all interesting generators and collect the results. -fromInterestingTermGens - :: (forall a. KnownType (Term TyName Name DefaultUni DefaultFun ()) a => String -> TermGen a -> c) - -> [c] +fromInterestingTermGens :: + (forall a. KnownType (Term TyName Name DefaultUni DefaultFun ()) a => String -> TermGen a -> c) -> + [c] fromInterestingTermGens f = - [ f "overapplication" genOverapplication - , f "factorial" genFactorial - , f "fibonacci" genNaiveFib - , f "NatRoundTrip" genNatRoundtrip - , f "ScottListSum" genScottListSum - , f "IfIntegers" genIfIntegers - , f "ApplyAdd1" genApplyAdd1 - , f "ApplyAdd2" genApplyAdd2 - , f "DivideByZero" genDivideByZero - , f "DivideByZeroDrop" genDivideByZeroDrop - ] + [ f "overapplication" genOverapplication + , f "factorial" genFactorial + , f "fibonacci" genNaiveFib + , f "NatRoundTrip" genNatRoundtrip + , f "ScottListSum" genScottListSum + , f "IfIntegers" genIfIntegers + , f "ApplyAdd1" genApplyAdd1 + , f "ApplyAdd2" genApplyAdd2 + , f "DivideByZero" genDivideByZero + , f "DivideByZeroDrop" genDivideByZeroDrop + ] diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs index e268379e680..cff3960026d 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs @@ -1,20 +1,19 @@ --- | This module defines functions useful for testing. - -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module PlutusCore.Generators.Hedgehog.Test - ( TypeEvalCheckError (..) - , TypeEvalCheckResult (..) - , TypeEvalCheckM - , typeEvalCheckBy - , unsafeTypeEvalCheck - , getSampleTermValue - , getSampleProgramAndValue - , printSampleProgramAndValue - , sampleProgramValueGolden - , propEvaluate - ) where +-- | This module defines functions useful for testing. +module PlutusCore.Generators.Hedgehog.Test ( + TypeEvalCheckError (..), + TypeEvalCheckResult (..), + TypeEvalCheckM, + typeEvalCheckBy, + unsafeTypeEvalCheck, + getSampleTermValue, + getSampleProgramAndValue, + printSampleProgramAndValue, + sampleProgramValueGolden, + propEvaluate, +) where import PlutusPrelude (ShowPretty (..)) @@ -38,82 +37,97 @@ import Hedgehog.Gen qualified as Gen import System.FilePath (()) -- | Generate a term using a given generator and check that it's well-typed and evaluates correctly. -getSampleTermValue - :: ( uni ~ DefaultUni, fun ~ DefaultFun - , KnownTypeAst TyName uni a, MakeKnown (Term TyName Name uni fun ()) a - ) - => TermGen a - -> IO (TermOf (Term TyName Name uni fun ()) (EvaluationResult (Term TyName Name uni fun ()))) +getSampleTermValue :: + ( uni ~ DefaultUni + , fun ~ DefaultFun + , KnownTypeAst TyName uni a + , MakeKnown (Term TyName Name uni fun ()) a + ) => + TermGen a -> + IO (TermOf (Term TyName Name uni fun ()) (EvaluationResult (Term TyName Name uni fun ()))) getSampleTermValue genTerm = Gen.sample $ unsafeTypeEvalCheck <$> genTerm -- | Generate a program using a given generator and check that it's well-typed and evaluates -- correctly. -getSampleProgramAndValue - :: ( uni ~ DefaultUni, fun ~ DefaultFun - , KnownTypeAst TyName uni a, MakeKnown (Term TyName Name uni fun ()) a - ) - => TermGen a - -> IO (Program TyName Name uni fun (), EvaluationResult (Term TyName Name uni fun ())) +getSampleProgramAndValue :: + ( uni ~ DefaultUni + , fun ~ DefaultFun + , KnownTypeAst TyName uni a + , MakeKnown (Term TyName Name uni fun ()) a + ) => + TermGen a -> + IO (Program TyName Name uni fun (), EvaluationResult (Term TyName Name uni fun ())) getSampleProgramAndValue genTerm = - getSampleTermValue genTerm <&> \(TermOf term result) -> - (Program () latestVersion term, result) + getSampleTermValue genTerm <&> \(TermOf term result) -> + (Program () latestVersion term, result) -- | Generate a program using a given generator, check that it's well-typed and evaluates correctly -- and pretty-print it to stdout using the default pretty-printing mode. -printSampleProgramAndValue - :: ( uni ~ DefaultUni, fun ~ DefaultFun - , KnownTypeAst TyName uni a, MakeKnown (Term TyName Name uni fun ()) a - ) - => TermGen a -> IO () +printSampleProgramAndValue :: + ( uni ~ DefaultUni + , fun ~ DefaultFun + , KnownTypeAst TyName uni a + , MakeKnown (Term TyName Name uni fun ()) a + ) => + TermGen a -> IO () printSampleProgramAndValue = - getSampleProgramAndValue >=> \(program, value) -> do - putStrLn $ displayPlc program - putStrLn "" - putStrLn $ displayPlc value + getSampleProgramAndValue >=> \(program, value) -> do + putStrLn $ displayPlc program + putStrLn "" + putStrLn $ displayPlc value -- | Generate a pair of files: @..plc@ and @..plc.golden@. -- The first file contains a term generated by a term generator (wrapped in 'Program'), -- the second file contains the result of evaluation of the term. -sampleProgramValueGolden - :: ( uni ~ DefaultUni, fun ~ DefaultFun - , KnownTypeAst TyName uni a, MakeKnown (Term TyName Name uni fun ()) a - ) - => String -- ^ @folder@ - -> String -- ^ @name@ - -> TermGen a -- ^ A term generator. - -> IO () +sampleProgramValueGolden :: + ( uni ~ DefaultUni + , fun ~ DefaultFun + , KnownTypeAst TyName uni a + , MakeKnown (Term TyName Name uni fun ()) a + ) => + -- | @folder@ + String -> + -- | @name@ + String -> + -- | A term generator. + TermGen a -> + IO () sampleProgramValueGolden folder name genTerm = do - let filePlc = folder (name ++ ".plc") - filePlcGolden = folder (name ++ ".golden.plc") - (program, value) <- getSampleProgramAndValue genTerm - Text.writeFile filePlc $ displayPlc program - Text.writeFile filePlcGolden $ displayPlc value + let filePlc = folder (name ++ ".plc") + filePlcGolden = folder (name ++ ".golden.plc") + (program, value) <- getSampleProgramAndValue genTerm + Text.writeFile filePlc $ displayPlc program + Text.writeFile filePlcGolden $ displayPlc value -- | A property-based testing procedure for evaluators. -- Checks whether a term generated along with the value it's supposed to compute to -- indeed computes to that value according to the provided evaluate. -propEvaluate - :: ( uni ~ DefaultUni, fun ~ DefaultFun - , KnownTypeAst TyName uni a, MakeKnown (Term TyName Name uni fun ()) a - , PrettyPlc structural - ) - => (Term TyName Name uni fun () -> - Either - (EvaluationException structural operational (Term TyName Name uni fun ())) - (Term TyName Name uni fun ())) - -- ^ An evaluator. - -> TermGen a -- ^ A term/value generator. - -> Property +propEvaluate :: + ( uni ~ DefaultUni + , fun ~ DefaultFun + , KnownTypeAst TyName uni a + , MakeKnown (Term TyName Name uni fun ()) a + , PrettyPlc structural + ) => + -- | An evaluator. + ( Term TyName Name uni fun () -> + Either + (EvaluationException structural operational (Term TyName Name uni fun ())) + (Term TyName Name uni fun ()) + ) -> + -- | A term/value generator. + TermGen a -> + Property propEvaluate eval genTermOfTbv = withTests 200 . property $ do - termOfTbv <- forAllNoShow genTermOfTbv - case typeEvalCheckBy eval termOfTbv of - Left (TypeEvalCheckErrorIllFormed err) -> fail $ prettyPlcErrorString err - Left (TypeEvalCheckErrorIllTyped expected actual) -> - -- We know that these two are distinct, but there is no nice way we - -- can report this via 'hedgehog' except by comparing them here again. - ShowPretty expected === ShowPretty actual - Left (TypeEvalCheckErrorException err) -> fail err - Left (TypeEvalCheckErrorIllEvaled expected actual) -> - -- Ditto. - ShowPretty expected === ShowPretty actual - Right _ -> return () + termOfTbv <- forAllNoShow genTermOfTbv + case typeEvalCheckBy eval termOfTbv of + Left (TypeEvalCheckErrorIllFormed err) -> fail $ prettyPlcErrorString err + Left (TypeEvalCheckErrorIllTyped expected actual) -> + -- We know that these two are distinct, but there is no nice way we + -- can report this via 'hedgehog' except by comparing them here again. + ShowPretty expected === ShowPretty actual + Left (TypeEvalCheckErrorException err) -> fail err + Left (TypeEvalCheckErrorIllEvaled expected actual) -> + -- Ditto. + ShowPretty expected === ShowPretty actual + Right _ -> return () diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs index 119bb31e2b7..843938f3b90 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs @@ -1,23 +1,22 @@ -- editorconfig-checker-disable-file --- | This module defines types and functions related to "type-eval checking". - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -module PlutusCore.Generators.Hedgehog.TypeEvalCheck - ( TypeEvalCheckError (..) - , TypeEvalCheckResult (..) - , TypeEvalCheckM - , typeEvalCheckBy - , unsafeTypeEvalCheck - ) where +-- | This module defines types and functions related to "type-eval checking". +module PlutusCore.Generators.Hedgehog.TypeEvalCheck ( + TypeEvalCheckError (..), + TypeEvalCheckResult (..), + TypeEvalCheckM, + typeEvalCheckBy, + unsafeTypeEvalCheck, +) where import PlutusPrelude @@ -45,85 +44,103 @@ the actual one. Thus "type-eval checking". -- | The type of errors that can occur during type-eval checking. data TypeEvalCheckError uni fun - = TypeEvalCheckErrorIllFormed !(Error uni fun ()) - | TypeEvalCheckErrorIllTyped - !(Normalized (Type TyName uni ())) - !(Normalized (Type TyName uni ())) - | TypeEvalCheckErrorException !String - | TypeEvalCheckErrorIllEvaled - !(EvaluationResult (Term TyName Name uni fun ())) - !(EvaluationResult (Term TyName Name uni fun ())) - -- ^ The former is an expected result of evaluation, the latter -- is an actual one. + = TypeEvalCheckErrorIllFormed !(Error uni fun ()) + | TypeEvalCheckErrorIllTyped + !(Normalized (Type TyName uni ())) + !(Normalized (Type TyName uni ())) + | TypeEvalCheckErrorException !String + | -- | The former is an expected result of evaluation, the latter -- is an actual one. + TypeEvalCheckErrorIllEvaled + !(EvaluationResult (Term TyName Name uni fun ())) + !(EvaluationResult (Term TyName Name uni fun ())) -- | Type-eval checking of a term results in a value of this type. data TypeEvalCheckResult uni fun = TypeEvalCheckResult - { _termCheckResultType :: Normalized (Type TyName uni ()) - -- ^ The type of the term. - , _termCheckResultValue :: EvaluationResult (Term TyName Name uni fun ()) - -- ^ The result of evaluation of the term. - } + { _termCheckResultType :: Normalized (Type TyName uni ()) + -- ^ The type of the term. + , _termCheckResultValue :: EvaluationResult (Term TyName Name uni fun ()) + -- ^ The result of evaluation of the term. + } -instance ( PrettyBy config (Type TyName uni ()) - , PrettyBy config (Term TyName Name uni fun ()) - , PrettyBy config (Error uni fun ()) - ) => PrettyBy config (TypeEvalCheckError uni fun) where - prettyBy config (TypeEvalCheckErrorIllFormed err) = - "The term is ill-formed:" <+> prettyBy config err - prettyBy config (TypeEvalCheckErrorIllTyped expected actual) = - "The expected type:" <+> prettyBy config expected <> hardline <> - "doesn't match with the actual type:" <+> prettyBy config actual - prettyBy _ (TypeEvalCheckErrorException err) = - "An exception occurred:" <+> fromString err - prettyBy config (TypeEvalCheckErrorIllEvaled expected actual) = - "The expected value:" <+> prettyBy config expected <> hardline <> - "doesn't match with the actual value:" <+> prettyBy config actual +instance + ( PrettyBy config (Type TyName uni ()) + , PrettyBy config (Term TyName Name uni fun ()) + , PrettyBy config (Error uni fun ()) + ) => + PrettyBy config (TypeEvalCheckError uni fun) + where + prettyBy config (TypeEvalCheckErrorIllFormed err) = + "The term is ill-formed:" <+> prettyBy config err + prettyBy config (TypeEvalCheckErrorIllTyped expected actual) = + "The expected type:" + <+> prettyBy config expected + <> hardline + <> "doesn't match with the actual type:" + <+> prettyBy config actual + prettyBy _ (TypeEvalCheckErrorException err) = + "An exception occurred:" <+> fromString err + prettyBy config (TypeEvalCheckErrorIllEvaled expected actual) = + "The expected value:" + <+> prettyBy config expected + <> hardline + <> "doesn't match with the actual value:" + <+> prettyBy config actual -- | The monad type-eval checking runs in. type TypeEvalCheckM uni fun = Either (TypeEvalCheckError uni fun) -- See Note [Type-eval checking]. + -- | Type check and evaluate a term and check that the expected result is equal to the actual one. -typeEvalCheckBy - :: ( uni ~ DefaultUni, fun ~ DefaultFun - , KnownTypeAst TyName uni a, MakeKnown (Term TyName Name uni fun ()) a - , PrettyPlc structural - ) - => (Term TyName Name uni fun () -> - Either - (EvaluationException structural operational (Term TyName Name uni fun ())) - (Term TyName Name uni fun ())) - -- ^ An evaluator. - -> TermOf (Term TyName Name uni fun ()) a - -> TypeEvalCheckM uni fun (TermOf (Term TyName Name uni fun ()) (TypeEvalCheckResult uni fun)) -typeEvalCheckBy eval (TermOf term (x :: a)) = TermOf term <$> do +typeEvalCheckBy :: + ( uni ~ DefaultUni + , fun ~ DefaultFun + , KnownTypeAst TyName uni a + , MakeKnown (Term TyName Name uni fun ()) a + , PrettyPlc structural + ) => + -- | An evaluator. + ( Term TyName Name uni fun () -> + Either + (EvaluationException structural operational (Term TyName Name uni fun ())) + (Term TyName Name uni fun ()) + ) -> + TermOf (Term TyName Name uni fun ()) a -> + TypeEvalCheckM uni fun (TermOf (Term TyName Name uni fun ()) (TypeEvalCheckResult uni fun)) +typeEvalCheckBy eval (TermOf term (x :: a)) = + TermOf term <$> do let tyExpected = runQuote . normalizeType $ toTypeAst (Proxy @a) valExpected = makeKnownOrFail x tyActual <- runQuoteT $ modifyError (TypeEvalCheckErrorIllFormed . TypeErrorE) $ do - config <- getDefTypeCheckConfig () - inferType config term + config <- getDefTypeCheckConfig () + inferType config term if tyExpected == tyActual - then case splitStructuralOperational $ eval term of - Right valActual -> - if valExpected == valActual - then return $ TypeEvalCheckResult tyExpected valActual - else throwError $ TypeEvalCheckErrorIllEvaled valExpected valActual - Left exc -> throwError $ TypeEvalCheckErrorException $ show exc - else throwError $ TypeEvalCheckErrorIllTyped tyExpected tyActual + then case splitStructuralOperational $ eval term of + Right valActual -> + if valExpected == valActual + then return $ TypeEvalCheckResult tyExpected valActual + else throwError $ TypeEvalCheckErrorIllEvaled valExpected valActual + Left exc -> throwError $ TypeEvalCheckErrorException $ show exc + else throwError $ TypeEvalCheckErrorIllTyped tyExpected tyActual -- | Type check and evaluate a term and check that the expected result is equal to the actual one. -- Throw an error in case something goes wrong. -unsafeTypeEvalCheck - :: ( uni ~ DefaultUni, fun ~ DefaultFun - , KnownTypeAst TyName uni a, MakeKnown (Term TyName Name uni fun ()) a - ) - => TermOf (Term TyName Name uni fun ()) a - -> TermOf (Term TyName Name uni fun ()) (EvaluationResult (Term TyName Name uni fun ())) +unsafeTypeEvalCheck :: + ( uni ~ DefaultUni + , fun ~ DefaultFun + , KnownTypeAst TyName uni a + , MakeKnown (Term TyName Name uni fun ()) a + ) => + TermOf (Term TyName Name uni fun ()) a -> + TermOf (Term TyName Name uni fun ()) (EvaluationResult (Term TyName Name uni fun ())) unsafeTypeEvalCheck termOfTbv = do - let errOrRes = typeEvalCheckBy (evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def) termOfTbv - case errOrRes of - Left err -> error $ concat - [ prettyPlcErrorString err - , "\nin\n" - , render . prettyPlcClassicSimple $ _termOfTerm termOfTbv - ] - Right termOfTecr -> _termCheckResultValue <$> termOfTecr + let errOrRes = typeEvalCheckBy (evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def) termOfTbv + case errOrRes of + Left err -> + error $ + concat + [ prettyPlcErrorString err + , "\nin\n" + , render . prettyPlcClassicSimple $ _termOfTerm termOfTbv + ] + Right termOfTecr -> _termCheckResultValue <$> termOfTecr diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypedBuiltinGen.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypedBuiltinGen.hs index aead65c9c08..46a933b5e42 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypedBuiltinGen.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypedBuiltinGen.hs @@ -1,23 +1,22 @@ --- | This module defines the 'TypedBuiltinGen' type and functions of this type. - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -module PlutusCore.Generators.Hedgehog.TypedBuiltinGen - ( TermOf(..) - , TypedBuiltinGenT - , TypedBuiltinGen - , genLowerBytes - , genTypedBuiltinFail - , genTypedBuiltinDef - ) where +-- | This module defines the 'TypedBuiltinGen' type and functions of this type. +module PlutusCore.Generators.Hedgehog.TypedBuiltinGen ( + TermOf (..), + TypedBuiltinGenT, + TypedBuiltinGen, + genLowerBytes, + genTypedBuiltinFail, + genTypedBuiltinDef, +) where import PlutusPrelude @@ -38,11 +37,15 @@ genLowerBytes :: Monad m => Range Int -> GenT m BS.ByteString genLowerBytes range = Gen.utf8 range Gen.lower -- TODO: rename me to @TermWith@. + -- | A @term@ along with the corresponding Haskell value. data TermOf term a = TermOf - { _termOfTerm :: term -- ^ The term - , _termOfValue :: a -- ^ The Haskell value. - } deriving stock (Functor, Foldable, Traversable) + { _termOfTerm :: term + -- ^ The term + , _termOfValue :: a + -- ^ The Haskell value. + } + deriving stock (Functor, Foldable, Traversable) -- | A function of this type generates values of built-in typed (see 'TypedBuiltin' for -- the list of such types) and returns it along with the corresponding PLC value. @@ -51,47 +54,57 @@ type TypedBuiltinGenT term m = forall a. TypeRep a -> GenT m (TermOf term a) -- | 'TypedBuiltinGenT' specified to 'Identity'. type TypedBuiltinGen term = TypedBuiltinGenT term Identity -instance (PrettyBy config a, PrettyBy config term) => - PrettyBy config (TermOf term a) where - prettyBy config (TermOf t x) = prettyBy config t <+> "~>" <+> prettyBy config x +instance + (PrettyBy config a, PrettyBy config term) => + PrettyBy config (TermOf term a) + where + prettyBy config (TermOf t x) = prettyBy config t <+> "~>" <+> prettyBy config x -attachCoercedTerm - :: (Monad m, MakeKnown term a, PrettyConst a) - => GenT m a -> GenT m (TermOf term a) +attachCoercedTerm :: + (Monad m, MakeKnown term a, PrettyConst a) => + GenT m a -> GenT m (TermOf term a) attachCoercedTerm a = do - x <- a - case makeKnownOrFail x of - -- I've attempted to implement support for generating 'EvaluationFailure', - -- but it turned out to be too much of a pain for something that we do not really need. - EvaluationFailure -> fail $ concat - [ "Got 'EvaluationFailure' when generating a value of a built-in type: " - , render $ prettyConst botRenderContext x - ] - EvaluationSuccess res -> pure $ TermOf res x + x <- a + case makeKnownOrFail x of + -- I've attempted to implement support for generating 'EvaluationFailure', + -- but it turned out to be too much of a pain for something that we do not really need. + EvaluationFailure -> + fail $ + concat + [ "Got 'EvaluationFailure' when generating a value of a built-in type: " + , render $ prettyConst botRenderContext x + ] + EvaluationSuccess res -> pure $ TermOf res x -- | Update a typed built-ins generator by overwriting the generator for a certain built-in. -updateTypedBuiltinGen - :: forall a term m. (Typeable a, MakeKnown term a, PrettyConst a, Monad m) - => GenT m a -- ^ A new generator. - -> TypedBuiltinGenT term m -- ^ An old typed built-ins generator. - -> TypedBuiltinGenT term m -- ^ The updated typed built-ins generator. +updateTypedBuiltinGen :: + forall a term m. + (Typeable a, MakeKnown term a, PrettyConst a, Monad m) => + -- | A new generator. + GenT m a -> + -- | An old typed built-ins generator. + TypedBuiltinGenT term m -> + -- | The updated typed built-ins generator. + TypedBuiltinGenT term m updateTypedBuiltinGen genX genTb tr - | Just Refl <- typeRep @a `geq` tr = attachCoercedTerm genX - | otherwise = genTb tr + | Just Refl <- typeRep @a `geq` tr = attachCoercedTerm genX + | otherwise = genTb tr -- | A built-ins generator that always fails. genTypedBuiltinFail :: Monad m => TypedBuiltinGenT term m -genTypedBuiltinFail tb = fail $ fold - [ "A generator for the following built-in is not implemented: " - , show tb - ] +genTypedBuiltinFail tb = + fail $ + fold + [ "A generator for the following built-in is not implemented: " + , show tb + ] -- | A default built-ins generator. -genTypedBuiltinDef - :: (HasConstantIn DefaultUni term, Monad m) - => TypedBuiltinGenT term m -genTypedBuiltinDef - = updateTypedBuiltinGen @Integer (Gen.integral $ Range.linearFrom 0 0 10) - $ updateTypedBuiltinGen (genLowerBytes (Range.linear 0 10)) - $ updateTypedBuiltinGen Gen.bool - $ genTypedBuiltinFail +genTypedBuiltinDef :: + (HasConstantIn DefaultUni term, Monad m) => + TypedBuiltinGenT term m +genTypedBuiltinDef = + updateTypedBuiltinGen @Integer (Gen.integral $ Range.linearFrom 0 0 10) $ + updateTypedBuiltinGen (genLowerBytes (Range.linear 0 10)) $ + updateTypedBuiltinGen Gen.bool $ + genTypedBuiltinFail diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs index c5b759791e6..352bbfef8b8 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs @@ -1,21 +1,20 @@ --- | Utilities used in modules from the @TestSupport@ folder. - -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -module PlutusCore.Generators.Hedgehog.Utils - ( liftT - , generalizeT - , hoistSupply - , choiceDef - , forAllNoShow - , forAllNoShowT - , forAllPretty - , forAllPrettyT - , forAllPrettyPlc - , forAllPrettyPlcT - , prettyPlcErrorString - ) where +-- | Utilities used in modules from the @TestSupport@ folder. +module PlutusCore.Generators.Hedgehog.Utils ( + liftT, + generalizeT, + hoistSupply, + choiceDef, + forAllNoShow, + forAllNoShowT, + forAllPretty, + forAllPrettyT, + forAllPrettyPlc, + forAllPrettyPlcT, + prettyPlcErrorString, +) where import PlutusCore.Pretty diff --git a/plutus-core/testlib/PlutusCore/Generators/NEAT/Common.hs b/plutus-core/testlib/PlutusCore/Generators/NEAT/Common.hs index db156e8a1f7..9c839c40a92 100644 --- a/plutus-core/testlib/PlutusCore/Generators/NEAT/Common.hs +++ b/plutus-core/testlib/PlutusCore/Generators/NEAT/Common.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module PlutusCore.Generators.NEAT.Common where @@ -12,13 +12,6 @@ module PlutusCore.Generators.NEAT.Common where !!! AND THEN RUN agda2hs ON IT. -} - - - - - - - import Control.Enumerable import Data.Stream qualified as Stream import Data.Text qualified as Text @@ -27,65 +20,67 @@ import PlutusCore.Quote (MonadQuote (..), freshName) data Z deriving stock (Eq, Ord, Show) -data S n = FZ - | FS n - deriving stock (Eq, Ord, Show, Functor) +data S n + = FZ + | FS n + deriving stock (Eq, Ord, Show, Functor) instance Enumerable Z where enumerate = datatype [] instance Enumerable n => Enumerable (S n) where - enumerate = share $ aconcat - [ c0 FZ - , c1 FS - ] - --- |Absurd for the zero type. + enumerate = + share $ + aconcat + [ c0 FZ + , c1 FS + ] + +-- | Absurd for the zero type. fromZ :: Z -> a fromZ i = case i of {} -- * Namespaces -data NameState n = NameState { nameOf :: n -> Name, freshNameStrings :: Stream.Stream Text.Text } +data NameState n = NameState {nameOf :: n -> Name, freshNameStrings :: Stream.Stream Text.Text} newtype TyNameState n = TyNameState (NameState n) tynameOf :: TyNameState n -> n -> TyName -tynameOf (TyNameState NameState{..}) i = TyName (nameOf i) +tynameOf (TyNameState NameState {..}) i = TyName (nameOf i) --- |Create an empty name state from a stream of text names. +-- | Create an empty name state from a stream of text names. emptyNameState :: Stream.Stream Text.Text -> NameState Z -emptyNameState strs = NameState { nameOf = fromZ, freshNameStrings = strs } - --- |Extend name state with a fresh name. -extNameState - :: (MonadQuote m) - => NameState n - -> m (NameState (S n)) -extNameState NameState{..} = liftQuote $ do +emptyNameState strs = NameState {nameOf = fromZ, freshNameStrings = strs} + +-- | Extend name state with a fresh name. +extNameState :: + MonadQuote m => + NameState n -> + m (NameState (S n)) +extNameState NameState {..} = liftQuote $ do let str = Stream.head freshNameStrings freshNameStrings' = Stream.tail freshNameStrings name <- freshName str - let nameOf' FZ = name + let nameOf' FZ = name nameOf' (FS i) = nameOf i - return NameState { nameOf = nameOf', freshNameStrings = freshNameStrings' } + return NameState {nameOf = nameOf', freshNameStrings = freshNameStrings'} --- |Create an empty name state from a stream of text names. +-- | Create an empty name state from a stream of text names. emptyTyNameState :: Stream.Stream Text.Text -> TyNameState Z emptyTyNameState strs = TyNameState (emptyNameState strs) --- |Extend type name state with a fresh type name. -extTyNameState - :: (MonadQuote m) - => TyNameState n - -> m (TyNameState (S n)) +-- | Extend type name state with a fresh type name. +extTyNameState :: + MonadQuote m => + TyNameState n -> + m (TyNameState (S n)) extTyNameState (TyNameState nameState) = TyNameState <$> extNameState nameState --- |Create a stream of names |x0, x1, x2, ...| from a prefix |"x"| +-- | Create a stream of names |x0, x1, x2, ...| from a prefix |"x"| mkTextNameStream :: Text.Text -> Stream.Stream Text.Text mkTextNameStream prefix = Stream.map (\n -> prefix <> Text.pack (show n)) - (Stream.iterate (+1) (0 :: Integer)) - + (Stream.iterate (+ 1) (0 :: Integer)) diff --git a/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs b/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs index a447b3c7573..05cf71eb2a0 100644 --- a/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs +++ b/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs @@ -1,32 +1,30 @@ -- editorconfig-checker-disable-file -{-| Description : Property based testing for Plutus Core - -This file contains the tests and some associated machinery but not the -generators. --} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} - -module PlutusCore.Generators.NEAT.Spec - ( tests - , Options (..) - , TestFail (..) - , bigTest - , packAssertion - , tynames - , names - , throwCtrex - , Ctrex (..) - , handleError - , handleUError - , GenDepth (..) - , GenMode (..) - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- | Description : Property based testing for Plutus Core +-- +-- This file contains the tests and some associated machinery but not the +-- generators. +module PlutusCore.Generators.NEAT.Spec ( + tests, + Options (..), + TestFail (..), + bigTest, + packAssertion, + tynames, + names, + throwCtrex, + Ctrex (..), + handleError, + handleUError, + GenDepth (..), + GenMode (..), +) where import PlutusCore import PlutusCore.Compiler.Erase @@ -57,46 +55,50 @@ import Text.Printf -- | Search depth, measured in program size newtype GenDepth = GenDepth {unGenDepth :: Int} - deriving newtype (Read, Eq, Ord) + deriving newtype (Read, Eq, Ord) -- | Search strategy newtype GenMode = GenMode {unGenMode :: Options} - deriving newtype (Read) + deriving newtype (Read) instance IsOption GenDepth where - defaultValue = GenDepth 20 - parseValue = safeRead - optionName = Tagged @GenDepth "gen-depth" - optionHelp = Tagged @GenDepth "Gen depth" + defaultValue = GenDepth 20 + parseValue = safeRead + optionName = Tagged @GenDepth "gen-depth" + optionHelp = Tagged @GenDepth "Gen depth" instance IsOption GenMode where - defaultValue = GenMode OF - parseValue = safeRead - optionName = Tagged @GenMode "gen-mode" - optionHelp = Tagged @GenMode "Gen Mode" + defaultValue = GenMode OF + parseValue = safeRead + optionName = Tagged @GenMode "gen-mode" + optionHelp = Tagged @GenMode "Gen Mode" tests :: TestTree tests = - testGroup "NEAT" - -- the `adjustOption (min ...)` allows to make these big tests easier at runtime - [ adjustOption (min $ GenDepth 10) $ - bigTest "normalization commutes with conversion from generated types" - (Type ()) - (packAssertion prop_normalizeConvertCommuteTypes) - , adjustOption (min $ GenDepth 12) $ - bigTest "normal types cannot reduce" - (Type ()) - (packAssertion prop_normalTypesCannotReduce) - , adjustOption (min $ GenDepth 15) $ - bigTest "type preservation - CK" - (TyBuiltinG TyUnitG) - (packAssertion prop_typePreservation) - , adjustOption (min $ GenDepth 15) $ - bigTest "typed CK vs untyped CEK produce the same output" - (TyBuiltinG TyUnitG) - (packAssertion prop_agree_termEval) - ] - + testGroup + "NEAT" + -- the `adjustOption (min ...)` allows to make these big tests easier at runtime + [ adjustOption (min $ GenDepth 10) $ + bigTest + "normalization commutes with conversion from generated types" + (Type ()) + (packAssertion prop_normalizeConvertCommuteTypes) + , adjustOption (min $ GenDepth 12) $ + bigTest + "normal types cannot reduce" + (Type ()) + (packAssertion prop_normalTypesCannotReduce) + , adjustOption (min $ GenDepth 15) $ + bigTest + "type preservation - CK" + (TyBuiltinG TyUnitG) + (packAssertion prop_typePreservation) + , adjustOption (min $ GenDepth 15) $ + bigTest + "typed CK vs untyped CEK produce the same output" + (TyBuiltinG TyUnitG) + (packAssertion prop_agree_termEval) + ] {- NOTE: @@ -111,27 +113,29 @@ not exploited. -} -- handle a user error and turn it back into an error term -handleError :: Type TyName DefaultUni () - -> U.ErrorWithCause (U.EvaluationError structural operational) term - -> Either (U.ErrorWithCause (U.EvaluationError structural operational) term) - (Term TyName Name DefaultUni DefaultFun ()) +handleError :: + Type TyName DefaultUni () -> + U.ErrorWithCause (U.EvaluationError structural operational) term -> + Either + (U.ErrorWithCause (U.EvaluationError structural operational) term) + (Term TyName Name DefaultUni DefaultFun ()) handleError ty e = case U._ewcError e of - U.StructuralError _ -> throwError e + U.StructuralError _ -> throwError e U.OperationalError _ -> return (Error () ty) -- untyped version of `handleError` handleUError :: - U.ErrorWithCause (U.EvaluationError structural operational) term - -> Either (U.ErrorWithCause (U.EvaluationError structural operational) term) - (U.Term Name DefaultUni DefaultFun ()) + U.ErrorWithCause (U.EvaluationError structural operational) term -> + Either + (U.ErrorWithCause (U.EvaluationError structural operational) term) + (U.Term Name DefaultUni DefaultFun ()) handleUError e = case U._ewcError e of - U.StructuralError _ -> throwError e + U.StructuralError _ -> throwError e U.OperationalError _ -> return (U.Error ()) --- |Property: check if the type is preserved by evaluation. --- --- This property is expected to hold for the CK machine. +-- | Property: check if the type is preserved by evaluation. -- +-- This property is expected to hold for the CK machine. prop_typePreservation :: ClosedTypeG -> ClosedTermG -> ExceptT TestFail Quote () prop_typePreservation tyG tmG = do tcConfig <- withExceptT TypeError $ getDefTypeCheckConfig () @@ -144,13 +148,14 @@ prop_typePreservation tyG tmG = do -- Check if the converted term, when evaluated by CK, still has the same type: - tmCK <- withExceptT CkP $ liftEither $ - evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def tm `catchError` handleError ty + tmCK <- + withExceptT CkP $ + liftEither $ + evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def tm `catchError` handleError ty withExceptT TypeError $ checkType tcConfig () tmCK (Normalized ty) --- |Property: check if both the typed CK and untyped CEK machines produce the same output --- modulo erasure. --- +-- | Property: check if both the typed CK and untyped CEK machines produce the same output +-- modulo erasure. prop_agree_termEval :: ClosedTypeG -> ClosedTermG -> ExceptT TestFail Quote () prop_agree_termEval tyG tmG = do tcConfig <- withExceptT TypeError $ getDefTypeCheckConfig () @@ -162,37 +167,41 @@ prop_agree_termEval tyG tmG = do withExceptT TypeError $ checkType tcConfig () tm (Normalized ty) -- run typed CK on input - tmCk <- withExceptT CkP $ liftEither $ - evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def tm `catchError` handleError ty + tmCk <- + withExceptT CkP $ + liftEither $ + evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def tm `catchError` handleError ty -- erase CK output let tmUCk = eraseTerm tmCk -- run untyped CEK on erased input - tmUCek <- withExceptT UCekP $ liftEither $ - U.evaluateCekNoEmit defaultCekParametersForTesting (eraseTerm tm) `catchError` handleUError + tmUCek <- + withExceptT UCekP $ + liftEither $ + U.evaluateCekNoEmit defaultCekParametersForTesting (eraseTerm tm) `catchError` handleUError -- check if typed CK and untyped CEK give the same output modulo erasure unless (tmUCk == tmUCek) $ - throwCtrex (CtrexUntypedTermEvaluationMismatch tyG tmG [("untyped CK",tmUCk),("untyped CEK",tmUCek)]) + throwCtrex (CtrexUntypedTermEvaluationMismatch tyG tmG [("untyped CK", tmUCk), ("untyped CEK", tmUCek)]) --- |Property: the following diagram commutes for well-kinded types... --- --- @ --- convertClosedType --- ClosedTypeG ---------------------> Type TyName DefaultUni () --- | | --- | | --- | normalizeTypeG | normalizeType --- | | --- v v --- ClosedTypeG ---------------------> Type TyName DefaultUni () --- convertClosedType --- @ +-- | Property: the following diagram commutes for well-kinded types... -- -prop_normalizeConvertCommuteTypes :: Kind () - -> ClosedTypeG - -> ExceptT TestFail Quote () +-- @ +-- convertClosedType +-- ClosedTypeG ---------------------> Type TyName DefaultUni () +-- | | +-- | | +-- | normalizeTypeG | normalizeType +-- | | +-- v v +-- ClosedTypeG ---------------------> Type TyName DefaultUni () +-- convertClosedType +-- @ +prop_normalizeConvertCommuteTypes :: + Kind () -> + ClosedTypeG -> + ExceptT TestFail Quote () prop_normalizeConvertCommuteTypes k tyG = do -- Check if the kind checker for generated types is sound: ty <- withExceptT GenError $ convertClosedType tynames k tyG @@ -208,12 +217,11 @@ prop_normalizeConvertCommuteTypes k tyG = do unless (ty1 == ty2) $ throwCtrex (CtrexNormalizeConvertCommuteTypes k tyG ty1 ty2) - - --- |Property: normal types cannot reduce -prop_normalTypesCannotReduce :: Kind () - -> Normalized ClosedTypeG - -> ExceptT TestFail Quote () +-- | Property: normal types cannot reduce +prop_normalTypesCannotReduce :: + Kind () -> + Normalized ClosedTypeG -> + ExceptT TestFail Quote () prop_normalTypesCannotReduce k (Normalized tyG) = unless (isNothing $ stepTypeG tyG) $ throwCtrex (CtrexNormalTypesCannotReduce k tyG) @@ -233,11 +241,12 @@ prop_normalTypesCannotReduce k (Normalized tyG) = data TestFail = GenError GenError | TypeError - (TypeError - (Term TyName Name DefaultUni DefaultFun ()) - DefaultUni - DefaultFun - ()) + ( TypeError + (Term TyName Name DefaultUni DefaultFun ()) + DefaultUni + DefaultFun + () + ) | AgdaErrorP () | FVErrorP FreeVariableError | CkP (CkEvaluationException DefaultUni DefaultFun) @@ -246,61 +255,61 @@ data TestFail data Ctrex = CtrexNormalizeConvertCommuteTypes - (Kind ()) - ClosedTypeG - (Type TyName DefaultUni ()) - (Type TyName DefaultUni ()) + (Kind ()) + ClosedTypeG + (Type TyName DefaultUni ()) + (Type TyName DefaultUni ()) | CtrexNormalTypesCannotReduce - (Kind ()) - ClosedTypeG + (Kind ()) + ClosedTypeG | CtrexKindCheckFail - (Kind ()) - ClosedTypeG + (Kind ()) + ClosedTypeG | CtrexKindPreservationFail - (Kind ()) - ClosedTypeG + (Kind ()) + ClosedTypeG | CtrexKindMismatch - (Kind ()) - ClosedTypeG - (Kind ()) - (Kind ()) + (Kind ()) + ClosedTypeG + (Kind ()) + (Kind ()) | CtrexTypeNormalizationFail - (Kind ()) - ClosedTypeG + (Kind ()) + ClosedTypeG | CtrexTypeNormalizationMismatch - (Kind ()) - ClosedTypeG - (Type TyName DefaultUni ()) - (Type TyName DefaultUni ()) + (Kind ()) + ClosedTypeG + (Type TyName DefaultUni ()) + (Type TyName DefaultUni ()) | CtrexTypeCheckFail - ClosedTypeG - ClosedTermG + ClosedTypeG + ClosedTermG | CtrexTypePreservationFail - ClosedTypeG - ClosedTermG - (Term TyName Name DefaultUni DefaultFun ()) - (Term TyName Name DefaultUni DefaultFun ()) + ClosedTypeG + ClosedTermG + (Term TyName Name DefaultUni DefaultFun ()) + (Term TyName Name DefaultUni DefaultFun ()) | CtrexTermEvaluationFail - String - ClosedTypeG - ClosedTermG + String + ClosedTypeG + ClosedTermG | CtrexTermEvaluationMismatch - ClosedTypeG - ClosedTermG - [(String,Term TyName Name DefaultUni DefaultFun ())] + ClosedTypeG + ClosedTermG + [(String, Term TyName Name DefaultUni DefaultFun ())] | CtrexUntypedTermEvaluationMismatch - ClosedTypeG - ClosedTermG - [(String,U.Term Name DefaultUni DefaultFun ())] + ClosedTypeG + ClosedTermG + [(String, U.Term Name DefaultUni DefaultFun ())] instance Show TestFail where - show (TypeError e) = "type error: " ++ show e - show (GenError e) = "generator error: " ++ show e - show (Ctrex e) = "counter example error: " ++ show e + show (TypeError e) = "type error: " ++ show e + show (GenError e) = "generator error: " ++ show e + show (Ctrex e) = "counter example error: " ++ show e show (AgdaErrorP e) = "agda error: " ++ show e - show (FVErrorP e) = "free variable error: " ++ show e - show (CkP e) = "CK error: " ++ show e - show (UCekP e) = "UCEK error: " ++ show e + show (FVErrorP e) = "free variable error: " ++ show e + show (CkP e) = "CK error: " ++ show e + show (UCekP e) = "UCEK error: " ++ show e instance Show Ctrex where show (CtrexNormalizeConvertCommuteTypes k tyG ty1 ty2) = @@ -311,17 +320,16 @@ instance Show Ctrex where (show (pretty ty1)) (show (pretty ty2)) where - tpl = unlines - [ "Counterexample found: %s :: %s" - , "- convert then normalize gives %s" - , "- normalize then convert gives %s" - ] - + tpl = + unlines + [ "Counterexample found: %s :: %s" + , "- convert then normalize gives %s" + , "- normalize then convert gives %s" + ] show (CtrexNormalTypesCannotReduce k tyG) = printf tpl (show tyG) (show (pretty k)) where tpl = "Counterexample found: normal type %s of kind %s can reduce." - show (CtrexKindCheckFail k tyG) = printf tpl (show tyG) (show (pretty k)) where @@ -338,11 +346,12 @@ instance Show Ctrex where (show (pretty k')) (show (pretty k'')) where - tpl = unlines - [ "Counterexample found: %s :: %s" - , "- inferer1 gives %s" - , "- inferer2 gives %s" - ] + tpl = + unlines + [ "Counterexample found: %s :: %s" + , "- inferer1 gives %s" + , "- inferer2 gives %s" + ] show (CtrexTypeNormalizationFail k tyG) = printf tpl (show tyG) (show (pretty k)) where @@ -355,11 +364,12 @@ instance Show Ctrex where (show (pretty ty1)) (show (pretty ty2)) where - tpl = unlines - [ "Counterexample found: %s :: %s" - , "- normalizer1 gives %s" - , "- normalizer2 gives %s" - ] + tpl = + unlines + [ "Counterexample found: %s :: %s" + , "- normalizer1 gives %s" + , "- normalizer2 gives %s" + ] show (CtrexTypeCheckFail tyG tmG) = printf tpl (show tmG) (show tyG) where @@ -372,48 +382,49 @@ instance Show Ctrex where printf tpl (show tmG) (show tyG) ++ results tms where tpl = "TypedTermEvaluationMismatch\n" ++ "Counterexample found: %s :: %s\n" - results ((s,t):ts) = s ++ " evaluation: " ++ show (pretty t) ++ "\n" ++ results ts - results [] = "" + results ((s, t) : ts) = s ++ " evaluation: " ++ show (pretty t) ++ "\n" ++ results ts + results [] = "" show (CtrexUntypedTermEvaluationMismatch tyG tmG tms) = printf tpl (show tmG) (show tyG) ++ results tms where tpl = "UntypedTermEvaluationMismatch\n" ++ "Counterexample found: %s :: %s\n" - results ((s,t):ts) = s ++ " evaluation: " ++ show (pretty t) ++ "\n" ++ results ts - results [] = "" + results ((s, t) : ts) = s ++ " evaluation: " ++ show (pretty t) ++ "\n" ++ results ts + results [] = "" show (CtrexTypePreservationFail tyG tmG tm1 tm2) = printf tpl (show tmG) (show tyG) (show (pretty tm1)) (show (pretty tm2)) where - tpl = unlines - [ "Counterexample found: %s :: %s" - , "before evaluation: %s" - , "after evaluation: %s" - ] + tpl = + unlines + [ "Counterexample found: %s :: %s" + , "before evaluation: %s" + , "after evaluation: %s" + ] -- | Throw a counter-example. throwCtrex :: Ctrex -> ExceptT TestFail Quote () throwCtrex ctrex = throwError (Ctrex ctrex) --- |Stream of type names t0, t1, t2, .. +-- | Stream of type names t0, t1, t2, .. tynames :: Stream.Stream Text.Text tynames = mkTextNameStream "t" --- |Stream of names x0, x1, x2, .. +-- | Stream of names x0, x1, x2, .. names :: Stream.Stream Text.Text names = mkTextNameStream "x" -- | given a prop, generate one test -packAssertion :: (Show e) => (t -> a -> ExceptT e Quote ()) -> t -> a -> Assertion +packAssertion :: Show e => (t -> a -> ExceptT e Quote ()) -> t -> a -> Assertion packAssertion f t a = case runQuote . runExceptT $ f t a of - Left e -> assertFailure $ show e + Left e -> assertFailure $ show e Right _ -> return () -- | generate examples using `search'` and then generate one big test -- that applies the given test to each of them. - -bigTest :: (Check t a, Enumerable a) - => String -> t -> (t -> a -> Assertion) -> TestTree -bigTest s t f = askOption $ \ genMode -> askOption $ \ genDepth -> testCaseInfo s $ do - as <- search' (unGenMode genMode) (unGenDepth genDepth) (\a -> check t a) - _ <- traverse (f t) as +bigTest :: + (Check t a, Enumerable a) => + String -> t -> (t -> a -> Assertion) -> TestTree +bigTest s t f = askOption $ \genMode -> askOption $ \genDepth -> testCaseInfo s $ do + as <- search' (unGenMode genMode) (unGenDepth genDepth) (\a -> check t a) + _ <- traverse (f t) as return $ show (length as) diff --git a/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs b/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs index ad695aed8de..940e27adcfa 100644 --- a/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs +++ b/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs @@ -1,40 +1,37 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} -- editorconfig-checker-disable-file -{-| Description: PLC Syntax, typechecker,semantics property based testing. - -This file contains -1. A duplicate of the Plutus Core Abstract Syntax (types and terms) -2. A kind checker and a type checker -3. Reduction semantics for types --} +{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - - -module PlutusCore.Generators.NEAT.Term - ( TypeBuiltinG (..) - , TermConstantG (..) - , TypeG (..) - , ClosedTypeG - , convertClosedType - , TermG (..) - , ClosedTermG - , convertClosedTerm - , Check (..) - , stepTypeG - , normalizeTypeG - , GenError (..) - , Neutral (..) - ) where +-- | Description: PLC Syntax, typechecker,semantics property based testing. +-- +-- This file contains +-- 1. A duplicate of the Plutus Core Abstract Syntax (types and terms) +-- 2. A kind checker and a type checker +-- 3. Reduction semantics for types +module PlutusCore.Generators.NEAT.Term ( + TypeBuiltinG (..), + TermConstantG (..), + TypeG (..), + ClosedTypeG, + convertClosedType, + TermG (..), + ClosedTermG, + convertClosedTerm, + Check (..), + stepTypeG, + normalizeTypeG, + GenError (..), + Neutral (..), +) where import Control.Enumerable import Control.Monad.Except @@ -83,20 +80,24 @@ NOTE: We don't just want to enumerate arbitrary types but also normal -} instance Enumerable tyname => Enumerable (Normalized (TypeG tyname)) where - enumerate = share $ aconcat - [ c1 $ \ty -> Normalized (unNeutral ty) - , pay . c1 $ \ty -> Normalized (TyLamG (unNormalized ty)) - , pay . c3 $ \ty1 k ty2 -> Normalized (TyIFixG (unNormalized ty1) k (unNormalized ty2)) - , pay . c2 $ \k ty -> Normalized (TyForallG k (unNormalized ty)) - , pay . c1 $ \tyBuiltin -> Normalized (TyBuiltinG tyBuiltin) - , pay . c2 $ \ty1 ty2 -> Normalized (TyFunG (unNormalized ty1) (unNormalized ty2)) - ] + enumerate = + share $ + aconcat + [ c1 $ \ty -> Normalized (unNeutral ty) + , pay . c1 $ \ty -> Normalized (TyLamG (unNormalized ty)) + , pay . c3 $ \ty1 k ty2 -> Normalized (TyIFixG (unNormalized ty1) k (unNormalized ty2)) + , pay . c2 $ \k ty -> Normalized (TyForallG k (unNormalized ty)) + , pay . c1 $ \tyBuiltin -> Normalized (TyBuiltinG tyBuiltin) + , pay . c2 $ \ty1 ty2 -> Normalized (TyFunG (unNormalized ty1) (unNormalized ty2)) + ] instance Enumerable tyname => Enumerable (Neutral (TypeG tyname)) where - enumerate = share $ aconcat - [ pay . c1 $ \i -> Neutral (TyVarG i) - , pay . c3 $ \ty1 ty2 k -> Neutral (TyAppG (unNeutral ty1) (unNormalized ty2) k) - ] + enumerate = + share $ + aconcat + [ pay . c1 $ \i -> Neutral (TyVarG i) + , pay . c3 $ \ty1 ty2 k -> Neutral (TyAppG (unNeutral ty1) (unNormalized ty2) k) + ] -- ** Enumerating terms @@ -107,13 +108,14 @@ instance Enumerable ByteString where instance (Enumerable Text.Text) where enumerate = share $ fmap (decodeUtf8 . pack) access -data TermConstantG = TmIntegerG Integer - | TmByteStringG ByteString - | TmStringG Text.Text - | TmBoolG Bool - | TmUnitG () - | TmDataG Data - deriving stock (Show, Eq) +data TermConstantG + = TmIntegerG Integer + | TmByteStringG ByteString + | TmStringG Text.Text + | TmBoolG Bool + | TmUnitG () + | TmDataG Data + deriving stock (Show, Eq) deriveEnumerable ''Data @@ -122,27 +124,27 @@ deriveEnumerable ''TermConstantG deriveEnumerable ''DefaultFun data TermG tyname name - = VarG + = VarG name - | LamAbsG + | LamAbsG (TermG tyname (S name)) - | ApplyG + | ApplyG (TermG tyname name) (TermG tyname name) (TypeG tyname) - | TyAbsG + | TyAbsG (TermG (S tyname) name) - | TyInstG + | TyInstG (TermG tyname name) (TypeG (S tyname)) (TypeG tyname) (Kind ()) - | ConstantG TermConstantG - | BuiltinG DefaultFun - | WrapG (TermG tyname name) - | UnWrapG (TypeG tyname) (Kind ()) (TypeG tyname) (TermG tyname name) - | ErrorG (TypeG tyname) - deriving stock (Eq, Functor, Show) + | ConstantG TermConstantG + | BuiltinG DefaultFun + | WrapG (TermG tyname name) + | UnWrapG (TypeG tyname) (Kind ()) (TypeG tyname) (TermG tyname name) + | ErrorG (TypeG tyname) + deriving stock (Eq, Functor, Show) deriveBifunctor ''TermG deriveEnumerable ''TermG @@ -151,39 +153,41 @@ type ClosedTermG = TermG Z Z -- * Converting types --- |Convert generated builtin types to Plutus builtin types. +-- | Convert generated builtin types to Plutus builtin types. convertTypeBuiltin :: TypeBuiltinG -> SomeTypeIn DefaultUni convertTypeBuiltin TyByteStringG = SomeTypeIn DefaultUniByteString -convertTypeBuiltin TyIntegerG = SomeTypeIn DefaultUniInteger -convertTypeBuiltin TyBoolG = SomeTypeIn DefaultUniBool -convertTypeBuiltin TyUnitG = SomeTypeIn DefaultUniUnit -convertTypeBuiltin (TyListG a) = +convertTypeBuiltin TyIntegerG = SomeTypeIn DefaultUniInteger +convertTypeBuiltin TyBoolG = SomeTypeIn DefaultUniBool +convertTypeBuiltin TyUnitG = SomeTypeIn DefaultUniUnit +convertTypeBuiltin (TyListG a) = case convertTypeBuiltin a of SomeTypeIn a' -> case decodeKindedUni (encodeUni a') of Nothing -> error "encode;decode failed" Just (SomeTypeIn (Kinded ka)) -> case checkStar @DefaultUni ka of - Nothing -> error "higher kinded thing in list" + Nothing -> error "higher kinded thing in list" Just Refl -> SomeTypeIn (DefaultUniList ka) +convertTypeBuiltin TyStringG = SomeTypeIn DefaultUniString +convertTypeBuiltin TyDataG = SomeTypeIn DefaultUniData -convertTypeBuiltin TyStringG = SomeTypeIn DefaultUniString -convertTypeBuiltin TyDataG = SomeTypeIn DefaultUniData - --- |Convert well-kinded generated types to Plutus types. +-- | Convert well-kinded generated types to Plutus types. -- --- NOTE: Passes an explicit `TyNameState`, instead of using a State --- monad, as the type of the `TyNameState` changes throughout --- the computation. Alternatively, this could be written using --- an indexed State monad. +-- NOTE: Passes an explicit `TyNameState`, instead of using a State +-- monad, as the type of the `TyNameState` changes throughout +-- the computation. Alternatively, this could be written using +-- an indexed State monad. -- --- NOTE: Roman points out that this is more like reader than state, --- however it doesn't fit easily into this pattern as the --- function `extTyNameState` is monadic (`MonadQuote`). -convertType - :: (Show tyname, MonadQuote m, MonadError GenError m) - => TyNameState tyname -- ^ Type name environment with fresh name stream - -> Kind () -- ^ Kind of type below - -> TypeG tyname -- ^ Type to convert - -> m (Type TyName DefaultUni ()) +-- NOTE: Roman points out that this is more like reader than state, +-- however it doesn't fit easily into this pattern as the +-- function `extTyNameState` is monadic (`MonadQuote`). +convertType :: + (Show tyname, MonadQuote m, MonadError GenError m) => + -- | Type name environment with fresh name stream + TyNameState tyname -> + -- | Kind of type below + Kind () -> + -- | Type to convert + TypeG tyname -> + m (Type TyName DefaultUni ()) convertType tns _ (TyVarG i) = return (TyVar () (tynameOf tns i)) convertType tns (Type _) (TyFunG ty1 ty2) = @@ -202,45 +206,49 @@ convertType tns k2 (TyAppG ty1 ty2 k1) = TyApp () <$> convertType tns (KindArrow () k1 k2) ty1 <*> convertType tns k1 ty2 convertType _ k ty = throwError $ BadTypeG k ty --- |Convert generated closed types to Plutus types. -convertClosedType - :: (MonadQuote m, MonadError GenError m) - => Stream.Stream Text.Text - -> Kind () - -> ClosedTypeG - -> m (Type TyName DefaultUni ()) +-- | Convert generated closed types to Plutus types. +convertClosedType :: + (MonadQuote m, MonadError GenError m) => + Stream.Stream Text.Text -> + Kind () -> + ClosedTypeG -> + m (Type TyName DefaultUni ()) convertClosedType tynames = convertType (emptyTyNameState tynames) -- ** Converting terms --- |Convert (well-typed) generated terms to Plutus terms. +-- | Convert (well-typed) generated terms to Plutus terms. -- --- NOTE: Passes an explicit `TyNameState` and `NameState`, instead of using a --- State monad, as the type of the `TyNameState` changes throughout the --- computation. This could be written using an indexed State monad. +-- NOTE: Passes an explicit `TyNameState` and `NameState`, instead of using a +-- State monad, as the type of the `TyNameState` changes throughout the +-- computation. This could be written using an indexed State monad. -- --- No checking is performed during conversion. The type is given --- as it contains information needed to fully annotate a `Term`. --- `Term`, unlike `TermG`, contains all necessary type --- information to infer the type of the term. It is expected --- that this function is only called on a well-typed --- term. Violating this would point to an error in the --- generator/checker. +-- No checking is performed during conversion. The type is given +-- as it contains information needed to fully annotate a `Term`. +-- `Term`, unlike `TermG`, contains all necessary type +-- information to infer the type of the term. It is expected +-- that this function is only called on a well-typed +-- term. Violating this would point to an error in the +-- generator/checker. convertTermConstant :: TermConstantG -> Some (ValueOf DefaultUni) convertTermConstant (TmByteStringG b) = Some $ ValueOf DefaultUniByteString b -convertTermConstant (TmIntegerG i) = Some $ ValueOf DefaultUniInteger i -convertTermConstant (TmStringG s) = Some $ ValueOf DefaultUniString s -convertTermConstant (TmBoolG b) = Some $ ValueOf DefaultUniBool b -convertTermConstant (TmUnitG u) = Some $ ValueOf DefaultUniUnit u -convertTermConstant (TmDataG d) = Some $ ValueOf DefaultUniData d - -convertTerm - :: (Show tyname, Show name, MonadQuote m, MonadError GenError m) - => TyNameState tyname -- ^ Type name environment with fresh name stream - -> NameState name -- ^ Name environment with fresh name stream - -> TypeG tyname -- ^ Type of term below - -> TermG tyname name -- ^ Term to convert - -> m (Term TyName Name DefaultUni DefaultFun ()) +convertTermConstant (TmIntegerG i) = Some $ ValueOf DefaultUniInteger i +convertTermConstant (TmStringG s) = Some $ ValueOf DefaultUniString s +convertTermConstant (TmBoolG b) = Some $ ValueOf DefaultUniBool b +convertTermConstant (TmUnitG u) = Some $ ValueOf DefaultUniUnit u +convertTermConstant (TmDataG d) = Some $ ValueOf DefaultUniData d + +convertTerm :: + (Show tyname, Show name, MonadQuote m, MonadError GenError m) => + -- | Type name environment with fresh name stream + TyNameState tyname -> + -- | Name environment with fresh name stream + NameState name -> + -- | Type of term below + TypeG tyname -> + -- | Term to convert + TermG tyname name -> + m (Term TyName Name DefaultUni DefaultFun ()) convertTerm _tns ns _ty (VarG i) = return (Var () (nameOf ns i)) convertTerm tns ns (TyFunG ty1 ty2) (LamAbsG tm) = do @@ -257,7 +265,8 @@ convertTerm tns ns _ (TyInstG tm cod ty k) = convertTerm _tns _ns _ (ConstantG c) = return $ Constant () (convertTermConstant c) convertTerm _tns _ns _ (BuiltinG b) = return $ Builtin () b -convertTerm tns ns (TyIFixG ty1 k ty2) (WrapG tm) = IWrap () +convertTerm tns ns (TyIFixG ty1 k ty2) (WrapG tm) = + IWrap () <$> convertType tns (toPatFuncKind k) ty1 <*> convertType tns k ty2 <*> convertTerm tns ns (normalizeTypeG ty') tm @@ -268,165 +277,192 @@ convertTerm tns ns _ (UnWrapG ty1 k ty2 tm) = Unwrap () <$> convertTerm tns ns ( convertTerm tns _ns _ (ErrorG ty) = Error () <$> convertType tns (Type ()) ty convertTerm _ _ ty tm = throwError $ BadTermG ty tm --- |Convert generated closed terms to Plutus terms. -convertClosedTerm - :: (MonadQuote m, MonadError GenError m) - => Stream.Stream Text.Text - -> Stream.Stream Text.Text - -> ClosedTypeG - -> ClosedTermG - -> m (Term TyName Name DefaultUni DefaultFun ()) +-- | Convert generated closed terms to Plutus terms. +convertClosedTerm :: + (MonadQuote m, MonadError GenError m) => + Stream.Stream Text.Text -> + Stream.Stream Text.Text -> + ClosedTypeG -> + ClosedTermG -> + m (Term TyName Name DefaultUni DefaultFun ()) convertClosedTerm tynames names = convertTerm (emptyTyNameState tynames) (emptyNameState names) - -- * Checking class Check t a where check :: t -> a -> Cool - -- ** Kind checking --- |Kind check builtin types. --- --- NOTE: If we make |checkTypeBuiltinG| non-strict in its second argument, --- lazy-search will only ever return one of the various builtin types. --- Perhaps this is preferable? +-- | Kind check builtin types. -- +-- NOTE: If we make |checkTypeBuiltinG| non-strict in its second argument, +-- lazy-search will only ever return one of the various builtin types. +-- Perhaps this is preferable? instance Check (Kind ()) TypeBuiltinG where check (Type _) TyByteStringG = true - check (Type _) TyIntegerG = true - check (Type _) TyBoolG = true - check (Type _) TyUnitG = true - check (Type _) (TyListG _a) = false -- check (Type ()) a - check (Type _) TyStringG = true - check (Type _) TyDataG = true - check _ _ = false - --- |Kind check types. + check (Type _) TyIntegerG = true + check (Type _) TyBoolG = true + check (Type _) TyUnitG = true + check (Type _) (TyListG _a) = false -- check (Type ()) a + check (Type _) TyStringG = true + check (Type _) TyDataG = true + check _ _ = false + +-- | Kind check types. checkKindG :: KCS n -> Kind () -> TypeG n -> Cool -checkKindG kcs k (TyVarG i) - = varKindOk +checkKindG kcs k (TyVarG i) = + varKindOk where varKindOk = toCool $ k == kindOf kcs i - -checkKindG kcs (Type _) (TyFunG ty1 ty2) - = ty1KindOk &&& ty2KindOk +checkKindG kcs (Type _) (TyFunG ty1 ty2) = + ty1KindOk &&& ty2KindOk where ty1KindOk = checkKindG kcs (Type ()) ty1 ty2KindOk = checkKindG kcs (Type ()) ty2 - -checkKindG kcs (Type _) (TyIFixG ty1 k ty2) - = ty1KindOk &&& ty2KindOk +checkKindG kcs (Type _) (TyIFixG ty1 k ty2) = + ty1KindOk &&& ty2KindOk where - ty1Kind = toPatFuncKind k + ty1Kind = toPatFuncKind k ty1KindOk = checkKindG kcs ty1Kind ty1 ty2KindOk = checkKindG kcs k ty2 - -checkKindG kcs (Type _) (TyForallG k body) - = tyKindOk +checkKindG kcs (Type _) (TyForallG k body) = + tyKindOk where tyKindOk = checkKindG (extKCS k kcs) (Type ()) body - -checkKindG _ k (TyBuiltinG tyBuiltin) - = tyBuiltinKindOk +checkKindG _ k (TyBuiltinG tyBuiltin) = + tyBuiltinKindOk where tyBuiltinKindOk = check k tyBuiltin - -checkKindG kcs (KindArrow () k1 k2) (TyLamG body) - = bodyKindOk +checkKindG kcs (KindArrow () k1 k2) (TyLamG body) = + bodyKindOk where bodyKindOk = checkKindG (extKCS k1 kcs) k2 body - -checkKindG kcs k' (TyAppG ty1 ty2 k) - = ty1KindOk &&& ty2KindOk +checkKindG kcs k' (TyAppG ty1 ty2 k) = + ty1KindOk &&& ty2KindOk where - ty1Kind = KindArrow () k k' + ty1Kind = KindArrow () k k' ty1KindOk = checkKindG kcs ty1Kind ty1 ty2KindOk = checkKindG kcs k ty2 - checkKindG _ _ _ = false - instance Check (Kind ()) ClosedTypeG where check = checkKindG emptyKCS - instance Check (Kind ()) (Normalized ClosedTypeG) where check k ty = check k (unNormalized ty) - -- ** Kind checking state -newtype KCS tyname = KCS{ kindOf :: tyname -> Kind () } +newtype KCS tyname = KCS {kindOf :: tyname -> Kind ()} emptyKCS :: KCS Z -emptyKCS = KCS{ kindOf = fromZ } +emptyKCS = KCS {kindOf = fromZ} extKCS :: forall tyname. Kind () -> KCS tyname -> KCS (S tyname) -extKCS k KCS{..} = KCS{ kindOf = kindOf' } +extKCS k KCS {..} = KCS {kindOf = kindOf'} where kindOf' :: S tyname -> Kind () - kindOf' FZ = k + kindOf' FZ = k kindOf' (FS i) = kindOf i - -- ** Type checking instance Check (TypeG n) TermConstantG where check (TyBuiltinG TyByteStringG) (TmByteStringG _) = true - check (TyBuiltinG TyIntegerG ) (TmIntegerG _) = true - check (TyBuiltinG TyBoolG ) (TmBoolG _) = true - check (TyBuiltinG TyUnitG ) (TmUnitG _) = true - check (TyBuiltinG TyStringG ) (TmStringG _) = true - check (TyBuiltinG TyDataG ) (TmDataG _) = true - check _ _ = false - + check (TyBuiltinG TyIntegerG) (TmIntegerG _) = true + check (TyBuiltinG TyBoolG) (TmBoolG _) = true + check (TyBuiltinG TyUnitG) (TmUnitG _) = true + check (TyBuiltinG TyStringG) (TmStringG _) = true + check (TyBuiltinG TyDataG) (TmDataG _) = true + check _ _ = false -- | DEPRECATED: No Need to Update for a new Builtin. -- NEAT tests are useless for builtins, see https://github.com/IntersectMBO/plutus/issues/6075 defaultFunTypes :: Ord tyname => Map.Map (TypeG tyname) [DefaultFun] -defaultFunTypes = Map.fromList [(TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyIntegerG)) - ,[AddInteger,SubtractInteger,MultiplyInteger,DivideInteger,QuotientInteger,RemainderInteger,ModInteger]) - ,(TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyBoolG)) - ,[LessThanInteger,LessThanEqualsInteger,EqualsInteger]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG)) - ,[AppendByteString]) - ,(TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG)) - ,[ConsByteString]) - ,(TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG))) - ,[SliceByteString]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyIntegerG) - ,[LengthOfByteString]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyIntegerG)) - ,[IndexByteString]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG) - ,[Sha2_256,Sha3_256,Blake2b_224,Blake2b_256,Keccak_256,Ripemd_160]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyBoolG))) - ,[VerifyEd25519Signature]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyBoolG)) - ,[EqualsByteString,LessThanByteString,LessThanEqualsByteString]) - ,(TyForallG (Type ()) (TyFunG (TyBuiltinG TyBoolG) (TyFunG (TyVarG FZ) (TyFunG (TyVarG FZ) (TyVarG FZ)))) - ,[IfThenElse]) - ,(TyFunG (TyBuiltinG TyStringG) (TyFunG (TyBuiltinG TyStringG) (TyBuiltinG TyStringG)) - ,[AppendString]) - ,(TyFunG (TyBuiltinG TyStringG) (TyFunG (TyBuiltinG TyStringG) (TyBuiltinG TyBoolG)) - ,[EqualsString]) - ,(TyFunG (TyBuiltinG TyStringG) (TyBuiltinG TyByteStringG) - ,[EncodeUtf8]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyStringG) - ,[DecodeUtf8]) - ,(TyForallG (Type ()) (TyFunG (TyBuiltinG TyStringG) (TyFunG (TyVarG FZ) (TyVarG FZ))) - ,[Trace]) - ,(TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyDataG) - ,[IData]) - ,(TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyDataG) - ,[BData]) - ,(TyFunG (TyBuiltinG TyDataG) (TyBuiltinG TyIntegerG) - ,[UnIData]) - ,(TyFunG (TyBuiltinG TyDataG) (TyBuiltinG TyByteStringG) - ,[UnBData, SerialiseData]) - ] +defaultFunTypes = + Map.fromList + [ + ( TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyIntegerG)) + , [AddInteger, SubtractInteger, MultiplyInteger, DivideInteger, QuotientInteger, RemainderInteger, ModInteger] + ) + , + ( TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyBoolG)) + , [LessThanInteger, LessThanEqualsInteger, EqualsInteger] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG)) + , [AppendByteString] + ) + , + ( TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG)) + , [ConsByteString] + ) + , + ( TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG))) + , [SliceByteString] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyIntegerG) + , [LengthOfByteString] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyIntegerG)) + , [IndexByteString] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyByteStringG) + , [Sha2_256, Sha3_256, Blake2b_224, Blake2b_256, Keccak_256, Ripemd_160] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyBoolG))) + , [VerifyEd25519Signature] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyBoolG)) + , [EqualsByteString, LessThanByteString, LessThanEqualsByteString] + ) + , + ( TyForallG (Type ()) (TyFunG (TyBuiltinG TyBoolG) (TyFunG (TyVarG FZ) (TyFunG (TyVarG FZ) (TyVarG FZ)))) + , [IfThenElse] + ) + , + ( TyFunG (TyBuiltinG TyStringG) (TyFunG (TyBuiltinG TyStringG) (TyBuiltinG TyStringG)) + , [AppendString] + ) + , + ( TyFunG (TyBuiltinG TyStringG) (TyFunG (TyBuiltinG TyStringG) (TyBuiltinG TyBoolG)) + , [EqualsString] + ) + , + ( TyFunG (TyBuiltinG TyStringG) (TyBuiltinG TyByteStringG) + , [EncodeUtf8] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyStringG) + , [DecodeUtf8] + ) + , + ( TyForallG (Type ()) (TyFunG (TyBuiltinG TyStringG) (TyFunG (TyVarG FZ) (TyVarG FZ))) + , [Trace] + ) + , + ( TyFunG (TyBuiltinG TyIntegerG) (TyBuiltinG TyDataG) + , [IData] + ) + , + ( TyFunG (TyBuiltinG TyByteStringG) (TyBuiltinG TyDataG) + , [BData] + ) + , + ( TyFunG (TyBuiltinG TyDataG) (TyBuiltinG TyIntegerG) + , [UnIData] + ) + , + ( TyFunG (TyBuiltinG TyDataG) (TyBuiltinG TyByteStringG) + , [UnBData, SerialiseData] + ) + ] instance Ord tyname => Check (TypeG tyname) DefaultFun where check ty b = case Map.lookup ty defaultFunTypes of @@ -435,37 +471,33 @@ instance Ord tyname => Check (TypeG tyname) DefaultFun where -- it's not clear to me whether this function should insist that some -- types are in normal form... -checkTypeG - :: Ord tyname - => KCS tyname - -> TCS tyname name - -> TypeG tyname - -> TermG tyname name - -> Cool -checkTypeG _ tcs ty (VarG i) - = varTypeOk +checkTypeG :: + Ord tyname => + KCS tyname -> + TCS tyname name -> + TypeG tyname -> + TermG tyname name -> + Cool +checkTypeG _ tcs ty (VarG i) = + varTypeOk where varTypeOk = toCool $ ty == typeOf tcs i - -checkTypeG kcs tcs (TyForallG k ty) (TyAbsG tm) - = tmTypeOk +checkTypeG kcs tcs (TyForallG k ty) (TyAbsG tm) = + tmTypeOk where tmTypeOk = checkTypeG (extKCS k kcs) (firstTCS FS tcs) ty tm - -checkTypeG kcs tcs (TyFunG ty1 ty2) (LamAbsG tm) - = tyKindOk &&& tmTypeOk +checkTypeG kcs tcs (TyFunG ty1 ty2) (LamAbsG tm) = + tyKindOk &&& tmTypeOk where tyKindOk = checkKindG kcs (Type ()) ty1 tmTypeOk = checkTypeG kcs (extTCS ty1 tcs) ty2 tm - -checkTypeG kcs tcs ty2 (ApplyG tm1 tm2 ty1) - = tm1TypeOk &&& tm2TypeOk +checkTypeG kcs tcs ty2 (ApplyG tm1 tm2 ty1) = + tm1TypeOk &&& tm2TypeOk where tm1TypeOk = checkTypeG kcs tcs (TyFunG ty1 ty2) tm1 tm2TypeOk = checkTypeG kcs tcs ty1 tm2 - -checkTypeG kcs tcs vTy (TyInstG tm vCod ty k) - = tmTypeOk &&& tyKindOk &&& tyOk +checkTypeG kcs tcs vTy (TyInstG tm vCod ty k) = + tmTypeOk &&& tyKindOk &&& tyOk where tmTypeOk = checkTypeG kcs tcs (TyForallG k vCod) tm tyKindOk = checkKindG kcs k ty @@ -475,13 +507,13 @@ checkTypeG kcs tcs (TyIFixG ty1 k ty2) (WrapG tm) = ty1Ok &&& ty2Ok &&& tmOk where ty1Ok = checkKindG kcs (toPatFuncKind k) ty1 ty2Ok = checkKindG kcs k ty2 - tmTy = TyAppG (TyAppG ty1 (TyLamG (TyIFixG (weakenTy ty1) k (TyVarG FZ))) (KindArrow () k (Type ()))) ty2 k - tmOk = checkTypeG kcs tcs (normalizeTypeG tmTy) tm + tmTy = TyAppG (TyAppG ty1 (TyLamG (TyIFixG (weakenTy ty1) k (TyVarG FZ))) (KindArrow () k (Type ()))) ty2 k + tmOk = checkTypeG kcs tcs (normalizeTypeG tmTy) tm checkTypeG kcs tcs vTy (UnWrapG ty1 k ty2 tm) = ty1Ok &&& ty2Ok &&& tmOk &&& vTyOk where ty1Ok = checkKindG kcs (toPatFuncKind k) ty1 ty2Ok = checkKindG kcs k ty2 - tmOk = checkTypeG kcs tcs (TyIFixG ty1 k ty2) tm + tmOk = checkTypeG kcs tcs (TyIFixG ty1 k ty2) tm vTyOk = vTy == normalizeTypeG (TyAppG (TyAppG ty1 (TyLamG (TyIFixG (weakenTy ty1) k (TyVarG FZ))) (KindArrow () k (Type ()))) ty2 k) checkTypeG kcs _tcs vTy (ErrorG ty) = tyKindOk &&& tyOk where @@ -493,45 +525,46 @@ checkTypeG _ _ _ _ = false instance Check ClosedTypeG ClosedTermG where check = checkTypeG emptyKCS emptyTCS - -- ** Type checking state -newtype TCS tyname name = TCS{ typeOf :: name -> TypeG tyname } +newtype TCS tyname name = TCS {typeOf :: name -> TypeG tyname} emptyTCS :: TCS tyname Z -emptyTCS = TCS{ typeOf = fromZ } +emptyTCS = TCS {typeOf = fromZ} extTCS :: forall tyname name. TypeG tyname -> TCS tyname name -> TCS tyname (S name) -extTCS ty TCS{..} = TCS{ typeOf = typeOf' } +extTCS ty TCS {..} = TCS {typeOf = typeOf'} where typeOf' :: S name -> TypeG tyname - typeOf' FZ = ty + typeOf' FZ = ty typeOf' (FS i) = typeOf i firstTCS :: (tyname -> tyname') -> TCS tyname name -> TCS tyname' name -firstTCS f tcs = TCS{ typeOf = fmap f . typeOf tcs } - +firstTCS f tcs = TCS {typeOf = fmap f . typeOf tcs} -- * Normalisation weakenTy :: TypeG m -> TypeG (S m) weakenTy ty = sub (TyVarG . FS) ty --- |Reduce a generated type by a single step, or fail. +-- | Reduce a generated type by a single step, or fail. stepTypeG :: TypeG n -> Maybe (TypeG n) -stepTypeG (TyVarG _) = empty -stepTypeG (TyFunG ty1 ty2) = (TyFunG <$> stepTypeG ty1 <*> pure ty2) - <|> (TyFunG <$> pure ty1 <*> stepTypeG ty2) -stepTypeG (TyIFixG ty1 k ty2) = (TyIFixG <$> stepTypeG ty1 <*> pure k <*> pure ty2) - <|> (TyIFixG <$> pure ty1 <*> pure k <*> stepTypeG ty2) -stepTypeG (TyForallG k ty) = TyForallG <$> pure k <*> stepTypeG ty -stepTypeG (TyBuiltinG _) = empty -stepTypeG (TyLamG ty) = TyLamG <$> stepTypeG ty +stepTypeG (TyVarG _) = empty +stepTypeG (TyFunG ty1 ty2) = + (TyFunG <$> stepTypeG ty1 <*> pure ty2) + <|> (TyFunG <$> pure ty1 <*> stepTypeG ty2) +stepTypeG (TyIFixG ty1 k ty2) = + (TyIFixG <$> stepTypeG ty1 <*> pure k <*> pure ty2) + <|> (TyIFixG <$> pure ty1 <*> pure k <*> stepTypeG ty2) +stepTypeG (TyForallG k ty) = TyForallG <$> pure k <*> stepTypeG ty +stepTypeG (TyBuiltinG _) = empty +stepTypeG (TyLamG ty) = TyLamG <$> stepTypeG ty stepTypeG (TyAppG (TyLamG ty1) ty2 _) = pure (sub (\case FZ -> ty2; FS i -> TyVarG i) ty1) -stepTypeG (TyAppG ty1 ty2 k) = (TyAppG <$> stepTypeG ty1 <*> pure ty2 <*> pure k) - <|> (TyAppG <$> pure ty1 <*> stepTypeG ty2 <*> pure k) +stepTypeG (TyAppG ty1 ty2 k) = + (TyAppG <$> stepTypeG ty1 <*> pure ty2 <*> pure k) + <|> (TyAppG <$> pure ty1 <*> stepTypeG ty2 <*> pure k) --- |Normalise a generated type. +-- | Normalise a generated type. normalizeTypeG :: TypeG n -> TypeG n normalizeTypeG ty = maybe ty normalizeTypeG (stepTypeG ty) diff --git a/plutus-core/testlib/PlutusCore/Generators/NEAT/Type.hs b/plutus-core/testlib/PlutusCore/Generators/NEAT/Type.hs index bda3304bb8a..4b02fb39275 100644 --- a/plutus-core/testlib/PlutusCore/Generators/NEAT/Type.hs +++ b/plutus-core/testlib/PlutusCore/Generators/NEAT/Type.hs @@ -1,13 +1,13 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusCore.Generators.NEAT.Type where @@ -17,17 +17,6 @@ module PlutusCore.Generators.NEAT.Type where !!! AND THEN RUN agda2hs ON IT. -} - - - - - - - - - - - import Control.Enumerable import Control.Monad (ap) import PlutusCore @@ -37,25 +26,27 @@ newtype Neutral a = Neutral { unNeutral :: a } -data TypeBuiltinG = TyByteStringG - | TyIntegerG - | TyBoolG - | TyUnitG - | TyStringG - | TyListG TypeBuiltinG - | TyDataG - deriving stock (Show, Eq, Ord) +data TypeBuiltinG + = TyByteStringG + | TyIntegerG + | TyBoolG + | TyUnitG + | TyStringG + | TyListG TypeBuiltinG + | TyDataG + deriving stock (Show, Eq, Ord) deriveEnumerable ''TypeBuiltinG -data TypeG n = TyVarG n - | TyFunG (TypeG n) (TypeG n) - | TyIFixG (TypeG n) (Kind ()) (TypeG n) - | TyForallG (Kind ()) (TypeG (S n)) - | TyBuiltinG TypeBuiltinG - | TyLamG (TypeG (S n)) - | TyAppG (TypeG n) (TypeG n) (Kind ()) - deriving stock (Eq, Ord, Show) +data TypeG n + = TyVarG n + | TyFunG (TypeG n) (TypeG n) + | TyIFixG (TypeG n) (Kind ()) (TypeG n) + | TyForallG (Kind ()) (TypeG (S n)) + | TyBuiltinG TypeBuiltinG + | TyLamG (TypeG (S n)) + | TyAppG (TypeG n) (TypeG n) (Kind ()) + deriving stock (Eq, Ord, Show) deriving stock instance Ord (Kind ()) @@ -69,36 +60,36 @@ instance Functor TypeG where fmap = ren ext :: (m -> n) -> S m -> S n -ext _ FZ = FZ +ext _ FZ = FZ ext f (FS x) = FS (f x) ren :: (m -> n) -> TypeG m -> TypeG n -ren f (TyVarG x) = TyVarG (f x) -ren f (TyFunG ty1 ty2) = TyFunG (ren f ty1) (ren f ty2) -ren f (TyIFixG ty1 k ty2) = TyIFixG (ren f ty1) k (ren f ty2) -ren f (TyForallG k ty) = TyForallG k (ren (ext f) ty) +ren f (TyVarG x) = TyVarG (f x) +ren f (TyFunG ty1 ty2) = TyFunG (ren f ty1) (ren f ty2) +ren f (TyIFixG ty1 k ty2) = TyIFixG (ren f ty1) k (ren f ty2) +ren f (TyForallG k ty) = TyForallG k (ren (ext f) ty) ren _ (TyBuiltinG someUni) = TyBuiltinG someUni -ren f (TyLamG ty) = TyLamG (ren (ext f) ty) -ren f (TyAppG ty1 ty2 k) = TyAppG (ren f ty1) (ren f ty2) k +ren f (TyLamG ty) = TyLamG (ren (ext f) ty) +ren f (TyAppG ty1 ty2 k) = TyAppG (ren f ty1) (ren f ty2) k exts :: (n -> TypeG m) -> S n -> TypeG (S m) -exts _ FZ = TyVarG FZ +exts _ FZ = TyVarG FZ exts s (FS i) = ren FS (s i) sub :: (n -> TypeG m) -> TypeG n -> TypeG m -sub s (TyVarG i) = s i -sub s (TyFunG ty1 ty2) = TyFunG (sub s ty1) (sub s ty2) -sub s (TyIFixG ty1 k ty2) = TyIFixG (sub s ty1) k (sub s ty2) -sub s (TyForallG k ty) = TyForallG k (sub (exts s) ty) +sub s (TyVarG i) = s i +sub s (TyFunG ty1 ty2) = TyFunG (sub s ty1) (sub s ty2) +sub s (TyIFixG ty1 k ty2) = TyIFixG (sub s ty1) k (sub s ty2) +sub s (TyForallG k ty) = TyForallG k (sub (exts s) ty) sub _ (TyBuiltinG tyBuiltin) = TyBuiltinG tyBuiltin -sub s (TyLamG ty) = TyLamG (sub (exts s) ty) -sub s (TyAppG ty1 ty2 k) = TyAppG (sub s ty1) (sub s ty2) k +sub s (TyLamG ty) = TyLamG (sub (exts s) ty) +sub s (TyAppG ty1 ty2 k) = TyAppG (sub s ty1) (sub s ty2) k instance Monad TypeG where a >>= f = sub f a + -- return = pure instance Applicative TypeG where (<*>) = ap pure = TyVarG - diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs index 62034c9a3e9..dad50822e34 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs @@ -1,13 +1,12 @@ -- editorconfig-checker-disable {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusCore.Generators.QuickCheck.Builtin where @@ -44,13 +43,13 @@ import Universe -- | Same as 'Arbitrary' but specifically for Plutus built-in types, so that we are not tied to -- the default implementation of the methods for a built-in type. class ArbitraryBuiltin a where - arbitraryBuiltin :: Gen a - default arbitraryBuiltin :: Arbitrary a => Gen a - arbitraryBuiltin = arbitrary + arbitraryBuiltin :: Gen a + default arbitraryBuiltin :: Arbitrary a => Gen a + arbitraryBuiltin = arbitrary - shrinkBuiltin :: a -> [a] - default shrinkBuiltin :: Arbitrary a => a -> [a] - shrinkBuiltin = shrink + shrinkBuiltin :: a -> [a] + default shrinkBuiltin :: Arbitrary a => a -> [a] + shrinkBuiltin = shrink instance ArbitraryBuiltin () instance ArbitraryBuiltin Bool @@ -88,19 +87,21 @@ highInterestingBound = toInteger (maxBound :: Int64) * 16 -- [(1,127),(128,32767),(32768,2147483647),(2147483648,9223372036854775807)] magnitudesPositive :: (Integer -> Integer) -> Integer -> [(Integer, Integer)] magnitudesPositive next high = - zipWith (\lo hi -> (lo + 1, hi)) borders (tail borders) + zipWith (\lo hi -> (lo + 1, hi)) borders (tail borders) where preborders = tail . takeWhile (\x -> next x < high) $ iterate next 1 borders = 0 : preborders ++ [next $ last preborders, high] chooseIntegerPreferEnds :: (Integer, Integer) -> Gen Integer chooseIntegerPreferEnds (lo, hi) - | hi - lo < 20 = chooseInteger (lo, hi) - | otherwise = frequency $ concat - [ zip (50 : [9, 8.. 1]) $ map pure [lo..] - , zip (50 : [9, 8.. 1]) $ map pure [hi, hi - 1] - , [(200, chooseInteger (lo + 10, hi - 10))] - ] + | hi - lo < 20 = chooseInteger (lo, hi) + | otherwise = + frequency $ + concat + [ zip (50 : [9, 8 .. 1]) $ map pure [lo ..] + , zip (50 : [9, 8 .. 1]) $ map pure [hi, hi - 1] + , [(200, chooseInteger (lo + 10, hi - 10))] + ] -- | Generate asymptotically larger positive negative numbers (sans zero) with exponentially lower -- chance, stop at the geometric mean of the range and start increasing the probability of @@ -109,10 +110,12 @@ chooseIntegerPreferEnds (lo, hi) -- generated than at the very end, but only by a fairly small factor. The size parameter is ignored, -- which is perhaps wrong and should be fixed. arbitraryPositive :: (Integer -> Integer) -> Integer -> Gen Integer -arbitraryPositive next high = frequency . zip freqs $ map chooseIntegerPreferEnds magnitudes where +arbitraryPositive next high = frequency . zip freqs $ map chooseIntegerPreferEnds magnitudes + where magnitudes = magnitudesPositive next high prefreqs = map floor $ iterate (* 1.1) (100 :: Double) - freqs = concat + freqs = + concat [ reverse (take (length magnitudes `div` 2) prefreqs) , map (floor . (/ (1.5 :: Double)) . fromIntegral) prefreqs ] @@ -122,7 +125,8 @@ arbitraryNegative :: (Integer -> Integer) -> Integer -> Gen Integer arbitraryNegative next high = negate <$> arbitraryPositive next high arbitrarySigned :: (Integer -> Integer) -> Integer -> Gen Integer -arbitrarySigned next high = frequency +arbitrarySigned next high = + frequency [ (48, arbitraryNegative next high) , (4, pure 0) , (48, arbitraryPositive next high) @@ -142,7 +146,8 @@ arbitrarySigned next high = frequency -- >>> shrinkIntegralFast (-10000 :: Integer) -- [0,10000,-100,-5000,-7500,-8750,-9375,-9688,-9844,-9922,-9961,-9981,-9991,-9996,-9998,-9999] shrinkIntegralFast :: Integral a => a -> [a] -shrinkIntegralFast x = concat +shrinkIntegralFast x = + concat [ [0 | x /= 0] , [-x | x < 0] , [signum x * floor (sqrt @Double $ fromIntegral xA) | let xA = abs x, xA > 4] @@ -150,25 +155,26 @@ shrinkIntegralFast x = concat ] instance ArbitraryBuiltin Integer where - -- See Note [QuickCheck and integral types]. - arbitraryBuiltin = arbitrarySigned nextInterestingBound highInterestingBound - shrinkBuiltin = shrinkIntegralFast + -- See Note [QuickCheck and integral types]. + arbitraryBuiltin = arbitrarySigned nextInterestingBound highInterestingBound + shrinkBuiltin = shrinkIntegralFast -- | -- -- >>> shrinkBuiltin $ Text.pack "abcd" -- ["","cd","ab","bcd","acd","abd","abc","aacd","abad","abbd","abca","abcb","abcc"] instance ArbitraryBuiltin Text where - arbitraryBuiltin = Text.pack . getPrintableString <$> arbitrary - shrinkBuiltin = map (Text.pack . getPrintableString) . shrink . PrintableString . Text.unpack + arbitraryBuiltin = Text.pack . getPrintableString <$> arbitrary + shrinkBuiltin = map (Text.pack . getPrintableString) . shrink . PrintableString . Text.unpack instance ArbitraryBuiltin ByteString where - arbitraryBuiltin = Text.encodeUtf8 <$> arbitraryBuiltin - shrinkBuiltin = map Text.encodeUtf8 . shrinkBuiltin . Text.decodeUtf8 + arbitraryBuiltin = Text.encodeUtf8 <$> arbitraryBuiltin + shrinkBuiltin = map Text.encodeUtf8 . shrinkBuiltin . Text.decodeUtf8 -- | Generate a tag for the 'Constr' constructor. genConstrTag :: Gen Integer -genConstrTag = frequency +genConstrTag = + frequency [ -- We want to generate most plausible constructor IDs most often. (6, chooseInteger (0, 2)) , -- Less plausible -- less often. @@ -182,35 +188,46 @@ genConstrTag = frequency -- list splitting. genDataFromSpine :: [()] -> Gen Data genDataFromSpine [] = - oneof - [ Constr <$> genConstrTag <*> pure [] - , pure $ List [] - , pure $ Map [] - ] + oneof + [ Constr <$> genConstrTag <*> pure [] + , pure $ List [] + , pure $ Map [] + ] genDataFromSpine [()] = oneof [I <$> arbitraryBuiltin, B <$> arbitraryBuiltin] -genDataFromSpine els = oneof +genDataFromSpine els = + oneof [ Constr <$> genConstrTag <*> (multiSplit0 0.1 els >>= traverse genDataFromSpine) , List <$> (multiSplit0 0.1 els >>= traverse genDataFromSpine) , do elss <- multiSplit1 els - Map <$> frequency + Map + <$> frequency [ -- Generate maps from 'ByteString's most often. - (6, for elss $ \(NonEmpty els') -> - (,) . B <$> arbitraryBuiltin <*> genDataFromSpine (drop 1 els')) + + ( 6 + , for elss $ \(NonEmpty els') -> + (,) . B <$> arbitraryBuiltin <*> genDataFromSpine (drop 1 els') + ) , -- Generate maps from 'Integer's less often. - (3, for elss $ \(NonEmpty els') -> - (,) . I <$> arbitraryBuiltin <*> genDataFromSpine (drop 1 els')) + + ( 3 + , for elss $ \(NonEmpty els') -> + (,) . I <$> arbitraryBuiltin <*> genDataFromSpine (drop 1 els') + ) , -- Occasionally generate maps with random nonsense in place of keys. - (1, for elss $ \(NonEmpty els') -> do - splitRes <- multiSplit1In 2 els' - case splitRes of + + ( 1 + , for elss $ \(NonEmpty els') -> do + splitRes <- multiSplit1In 2 els' + case splitRes of [] -> - (,) <$> genDataFromSpine [] <*> genDataFromSpine [] + (,) <$> genDataFromSpine [] <*> genDataFromSpine [] [NonEmpty elsL'] -> - (,) <$> genDataFromSpine elsL' <*> genDataFromSpine [] + (,) <$> genDataFromSpine elsL' <*> genDataFromSpine [] [NonEmpty elsL', NonEmpty elsR'] -> - (,) <$> genDataFromSpine elsL' <*> genDataFromSpine elsR' - _ -> error "Panic: 'multiSplit1In 2' returned a list longer than 2 elements") + (,) <$> genDataFromSpine elsL' <*> genDataFromSpine elsR' + _ -> error "Panic: 'multiSplit1In 2' returned a list longer than 2 elements" + ) ] ] @@ -218,65 +235,67 @@ pureIfNull :: (Foldable f, Applicative f) => a -> f a -> f a pureIfNull x xs = if null xs then pure x else xs instance ArbitraryBuiltin Data where - arbitraryBuiltin = arbitrary >>= genDataFromSpine - - -- We arbitrarily assume that @I 0@ is the smallest 'Data' object just so that anything else in - -- a counterexample gives us a clue as to what the culprit may be. Hence @I 0@ needs to be - -- reachable from all nodes apart from @I 0@ itself. For all nodes but 'I' we achieve this by - -- returning @[I 0]@ if there's no other way to shrink the value, i.e. either shrinking keeps - -- going or it's time to return the smallest object. The clause for @I i@ doesn't require - -- mentioning @I 0@ explicitly, since we get it through general shrinking of @i@ (unless @i@ - -- equals @0@, as desired). - shrinkBuiltin (Constr i ds) = pureIfNull (I 0) $ concat + arbitraryBuiltin = arbitrary >>= genDataFromSpine + + -- We arbitrarily assume that @I 0@ is the smallest 'Data' object just so that anything else in + -- a counterexample gives us a clue as to what the culprit may be. Hence @I 0@ needs to be + -- reachable from all nodes apart from @I 0@ itself. For all nodes but 'I' we achieve this by + -- returning @[I 0]@ if there's no other way to shrink the value, i.e. either shrinking keeps + -- going or it's time to return the smallest object. The clause for @I i@ doesn't require + -- mentioning @I 0@ explicitly, since we get it through general shrinking of @i@ (unless @i@ + -- equals @0@, as desired). + shrinkBuiltin (Constr i ds) = + pureIfNull (I 0) $ + concat [ ds , map (Constr i) $ shrinkBuiltin ds , map (flip Constr ds) $ shrinkBuiltin i ] - shrinkBuiltin (Map ps) = pureIfNull (I 0) $ concat + shrinkBuiltin (Map ps) = + pureIfNull (I 0) $ + concat [ map fst ps , map snd ps , map Map $ shrinkBuiltin ps ] - shrinkBuiltin (List ds) = pureIfNull (I 0) $ concat + shrinkBuiltin (List ds) = + pureIfNull (I 0) $ + concat [ ds , map List $ shrinkBuiltin ds ] - shrinkBuiltin (B b) = pureIfNull (I 0) . map B $ shrinkBuiltin b - shrinkBuiltin (I i) = map I $ shrinkBuiltin i + shrinkBuiltin (B b) = pureIfNull (I 0) . map B $ shrinkBuiltin b + shrinkBuiltin (I i) = map I $ shrinkBuiltin i instance Arbitrary Data where - arbitrary = arbitraryBuiltin - shrink = shrinkBuiltin + arbitrary = arbitraryBuiltin + shrink = shrinkBuiltin ---------------Generator for Builtin Value--------------- -{-| Return how many candidates to randomly choose from to fill the given number of cells. For -example, if we only need to fill a single cell, we choose from 6 different candidates, and if we -need to fill 5 cells, we choose from 11 candidates. - ->>> map (\i -> (i, toCellCandidatesNumber i)) [1..13] -[(1,6),(2,6),(3,6),(4,8),(5,11),(6,14),(7,18),(8,22),(9,27),(10,31),(11,36),(12,41),(13,46)] --} +-- | Return how many candidates to randomly choose from to fill the given number of cells. For +-- example, if we only need to fill a single cell, we choose from 6 different candidates, and if we +-- need to fill 5 cells, we choose from 11 candidates. +-- +-- >>> map (\i -> (i, toCellCandidatesNumber i)) [1..13] +-- [(1,6),(2,6),(3,6),(4,8),(5,11),(6,14),(7,18),(8,22),(9,27),(10,31),(11,36),(12,41),(13,46)] toCellCandidatesNumber :: Int -> Int toCellCandidatesNumber i = max 6 . floor @Double $ fromIntegral i ** 1.5 -{-| Generate a 'ByteString' by picking one of the predetermined ones, given a number of -cells to fill (see 'toCellCandidatesNumber'). The idea is that we want to occasionally generate -the same 'CurrencySymbol' or 'TokenName' for different 'Value's to have decent test coverage, -hence to make name clashing more likely we pick from a predetermined set of -'ByteString's. Otherwise the chance of generating the same 'ByteString' for two -different 'Value's would be virtually zero. --} +-- | Generate a 'ByteString' by picking one of the predetermined ones, given a number of +-- cells to fill (see 'toCellCandidatesNumber'). The idea is that we want to occasionally generate +-- the same 'CurrencySymbol' or 'TokenName' for different 'Value's to have decent test coverage, +-- hence to make name clashing more likely we pick from a predetermined set of +-- 'ByteString's. Otherwise the chance of generating the same 'ByteString' for two +-- different 'Value's would be virtually zero. genShortHex :: Int -> Gen Value.K genShortHex i = (Base16.encode . BC.pack . show <$> elements [0 .. toCellCandidatesNumber i]) - `suchThatMap` - Value.k + `suchThatMap` Value.k -{-| Annotate each element of the give list with a @name@, given a function turning -'ByteString' into names. --} -uniqueNames :: (Eq name) => (Value.K -> name) -> [b] -> Gen [(name, b)] +-- | Annotate each element of the give list with a @name@, given a function turning +-- 'ByteString' into names. +uniqueNames :: Eq name => (Value.K -> name) -> [b] -> Gen [(name, b)] uniqueNames wrap ys = do let len = length ys -- We always generate unique 'CurrencySymbol's within a single 'Value' and 'TokenName' within a @@ -290,8 +309,8 @@ instance ArbitraryBuiltin Value.K where arbitraryBuiltin = arbitraryBuiltin `suchThatMap` Value.k instance Arbitrary Value.K where - arbitrary = arbitraryBuiltin - shrink = shrinkBuiltin + arbitrary = arbitraryBuiltin + shrink = shrinkBuiltin instance ArbitraryBuiltin Value.Quantity where arbitraryBuiltin = @@ -301,12 +320,11 @@ instance ArbitraryBuiltin Value.Quantity where mapMaybe Value.quantity . shrinkIntegralFast @Integer . Value.unQuantity instance Arbitrary Value.Quantity where - arbitrary = arbitraryBuiltin - shrink = shrinkBuiltin + arbitrary = arbitraryBuiltin + shrink = shrinkBuiltin -{-| A wrapper for satisfying an @Arbitrary a@ constraint without implementing an 'Arbitrary' -instance for @a@. --} +-- | A wrapper for satisfying an @Arbitrary a@ constraint without implementing an 'Arbitrary' +-- instance for @a@. newtype NoArbitrary a = NoArbitrary { unNoArbitrary :: a } @@ -324,157 +342,163 @@ instance ArbitraryBuiltin Value where -- Generate 'TokenName's and 'CurrencySymbol's. currencies <- uniqueNames id =<< traverse (uniqueNames id) quantities case Value.fromList currencies of - BuiltinSuccess v -> pure v + BuiltinSuccess v -> pure v BuiltinSuccessWithLogs _ v -> pure v - BuiltinFailure logs _ -> error $ "Failed to generate valid Value: " <> show logs + BuiltinFailure logs _ -> error $ "Failed to generate valid Value: " <> show logs shrinkBuiltin = mapMaybe ( \keys -> case Value.fromList keys of - BuiltinSuccess v -> Just v + BuiltinSuccess v -> Just v BuiltinSuccessWithLogs _ v -> Just v - BuiltinFailure{} -> Nothing + BuiltinFailure {} -> Nothing ) . coerce (shrink @[(NoArbitrary Value.K, [(NoArbitrary Value.K, Value.Quantity)])]) . Value.toList instance Arbitrary Value where - arbitrary = arbitraryBuiltin - shrink = shrinkBuiltin + arbitrary = arbitraryBuiltin + shrink = shrinkBuiltin instance ArbitraryBuiltin BLS12_381.G1.Element where - arbitraryBuiltin = - BLS12_381.G1.hashToGroup <$> arbitrary <*> pure Data.ByteString.empty >>= \case - -- We should only get a failure if the second argument is greater than 255 bytes, which - -- it isn't. - Left err -> error $ show err - Right p -> pure p - -- It's difficult to come up with a sensible shrinking function here given - -- that there's no sensible order on the elements of G1, let alone one - -- that's compatible with the group structure. We can't try shrinking the - -- x-coordinate of a known point for example because only about only about - -- 1/10^39 of the field elements are the x-coordinate of a point in G1, so - -- we're highly unlikely to find a suitable x value. - shrinkBuiltin _ = [] + arbitraryBuiltin = + BLS12_381.G1.hashToGroup <$> arbitrary <*> pure Data.ByteString.empty >>= \case + -- We should only get a failure if the second argument is greater than 255 bytes, which + -- it isn't. + Left err -> error $ show err + Right p -> pure p + + -- It's difficult to come up with a sensible shrinking function here given + -- that there's no sensible order on the elements of G1, let alone one + -- that's compatible with the group structure. We can't try shrinking the + -- x-coordinate of a known point for example because only about only about + -- 1/10^39 of the field elements are the x-coordinate of a point in G1, so + -- we're highly unlikely to find a suitable x value. + shrinkBuiltin _ = [] instance ArbitraryBuiltin BLS12_381.G2.Element where - arbitraryBuiltin = - BLS12_381.G2.hashToGroup <$> arbitrary <*> pure Data.ByteString.empty >>= \case - -- We should only get a failure if the second argument is greater than 255 bytes, which - -- it isn't. - Left err -> error $ show err - Right p -> pure p - -- See the comment about shrinking for G1; G2 is even worse. - shrinkBuiltin _ = [] + arbitraryBuiltin = + BLS12_381.G2.hashToGroup <$> arbitrary <*> pure Data.ByteString.empty >>= \case + -- We should only get a failure if the second argument is greater than 255 bytes, which + -- it isn't. + Left err -> error $ show err + Right p -> pure p + + -- See the comment about shrinking for G1; G2 is even worse. + shrinkBuiltin _ = [] instance ArbitraryBuiltin BLS12_381.Pairing.MlResult where - arbitraryBuiltin = BLS12_381.Pairing.millerLoop <$> arbitraryBuiltin <*> arbitraryBuiltin - -- Shrinking here is even more difficult than for G1 and G2 since we don't - -- have direct access to elements of MlResult. - shrinkBuiltin _ = [] + arbitraryBuiltin = BLS12_381.Pairing.millerLoop <$> arbitraryBuiltin <*> arbitraryBuiltin + + -- Shrinking here is even more difficult than for G1 and G2 since we don't + -- have direct access to elements of MlResult. + shrinkBuiltin _ = [] -- | For providing an 'Arbitrary' instance deferring to 'ArbitraryBuiltin'. Useful for implementing -- 'ArbitraryBuiltin' for a polymorphic built-in type by taking the logic for handling spines from -- the 'Arbitrary' class and the logic for handling elements from 'ArbitraryBuiltin'. newtype AsArbitraryBuiltin a = AsArbitraryBuiltin - { unAsArbitraryBuiltin :: a - } deriving newtype (Show, Eq, Ord, Num) + { unAsArbitraryBuiltin :: a + } + deriving newtype (Show, Eq, Ord, Num) instance ArbitraryBuiltin a => Arbitrary (AsArbitraryBuiltin a) where - arbitrary = coerce $ arbitraryBuiltin @a - shrink = coerce $ shrinkBuiltin @a + arbitrary = coerce $ arbitraryBuiltin @a + shrink = coerce $ shrinkBuiltin @a -- We could do this and the next one generically using 'ElaborateBuiltin', but it would be more -- code, so we keep it simple. instance ArbitraryBuiltin a => ArbitraryBuiltin [a] where - arbitraryBuiltin = do - spine <- arbitrary - let len = length spine - for spine $ \() -> - -- Scale the elements, so that generating a list of lists of lists doesn't take - -- exponential size (and thus time). - scale (`div` len) . coerce $ arbitrary @(AsArbitraryBuiltin a) - shrinkBuiltin = coerce $ shrink @[AsArbitraryBuiltin a] + arbitraryBuiltin = do + spine <- arbitrary + let len = length spine + for spine $ \() -> + -- Scale the elements, so that generating a list of lists of lists doesn't take + -- exponential size (and thus time). + scale (`div` len) . coerce $ arbitrary @(AsArbitraryBuiltin a) + shrinkBuiltin = coerce $ shrink @[AsArbitraryBuiltin a] instance ArbitraryBuiltin a => ArbitraryBuiltin (Strict.Vector a) where arbitraryBuiltin = Strict.fromList <$> arbitraryBuiltin shrinkBuiltin = map Strict.fromList . shrinkBuiltin . Strict.toList instance (ArbitraryBuiltin a, ArbitraryBuiltin b) => ArbitraryBuiltin (a, b) where - arbitraryBuiltin = do - (,) - <$> coerce (scale (`div` 2) $ arbitrary @(AsArbitraryBuiltin a)) - <*> coerce (scale (`div` 2) $ arbitrary @(AsArbitraryBuiltin b)) - shrinkBuiltin = coerce $ shrink @(AsArbitraryBuiltin a, AsArbitraryBuiltin b) + arbitraryBuiltin = do + (,) + <$> coerce (scale (`div` 2) $ arbitrary @(AsArbitraryBuiltin a)) + <*> coerce (scale (`div` 2) $ arbitrary @(AsArbitraryBuiltin b)) + shrinkBuiltin = coerce $ shrink @(AsArbitraryBuiltin a, AsArbitraryBuiltin b) -- | Either a fail to generate anything or a built-in type of a given kind. data MaybeSomeTypeOf k - = NothingSomeType - | forall (a :: k). JustSomeType (DefaultUni (Esc a)) + = NothingSomeType + | forall (a :: k). JustSomeType (DefaultUni (Esc a)) instance Eq (MaybeSomeTypeOf k) where - NothingSomeType == NothingSomeType = True - JustSomeType uni1 == JustSomeType uni2 = uni1 `defaultEq` uni2 - NothingSomeType == JustSomeType{} = False - JustSomeType{} == NothingSomeType = False + NothingSomeType == NothingSomeType = True + JustSomeType uni1 == JustSomeType uni2 = uni1 `defaultEq` uni2 + NothingSomeType == JustSomeType {} = False + JustSomeType {} == NothingSomeType = False -- | Forget the reflected at the type level kind. eraseMaybeSomeTypeOf :: MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni) -eraseMaybeSomeTypeOf NothingSomeType = Nothing +eraseMaybeSomeTypeOf NothingSomeType = Nothing eraseMaybeSomeTypeOf (JustSomeType uni) = Just $ SomeTypeIn uni -- | Generate a 'DefaultUniApply' if possible. genDefaultUniApply :: KnownKind k => Gen (MaybeSomeTypeOf k) genDefaultUniApply = do - -- We don't scale the function, because sizes don't matter for application heads anyway, plus - -- the function may itself be an application and we certainly don't want type arguments that - -- come first to be smaller than those that come latter as that would make no sense. - mayFun <- arbitrary - -- We don't want to generate deeply nested built-in types, hence the scaling. - mayArg <- scale (`div` 5) arbitrary :: Gen (MaybeSomeTypeOf GHC.Type) - pure $ case (mayFun, mayArg) of - (JustSomeType fun, JustSomeType arg) -> JustSomeType $ fun `DefaultUniApply` arg - _ -> NothingSomeType + -- We don't scale the function, because sizes don't matter for application heads anyway, plus + -- the function may itself be an application and we certainly don't want type arguments that + -- come first to be smaller than those that come latter as that would make no sense. + mayFun <- arbitrary + -- We don't want to generate deeply nested built-in types, hence the scaling. + mayArg <- scale (`div` 5) arbitrary :: Gen (MaybeSomeTypeOf GHC.Type) + pure $ case (mayFun, mayArg) of + (JustSomeType fun, JustSomeType arg) -> JustSomeType $ fun `DefaultUniApply` arg + _ -> NothingSomeType -- | Shrink a 'DefaultUniApply' to one of the elements of the spine and throw away the head -- (because the head of an application can't be of the same kind as the whole application). -- We don't have higher-kinded built-in types, so we don't do this kind of shrinking for any kinds -- other than *. shrinkToStarArgs :: DefaultUni (Esc a) -> [MaybeSomeTypeOf GHC.Type] -shrinkToStarArgs = go [] where +shrinkToStarArgs = go [] + where go :: [MaybeSomeTypeOf GHC.Type] -> DefaultUni (Esc b) -> [MaybeSomeTypeOf GHC.Type] go args (fun `DefaultUniApply` arg) = - go ([JustSomeType arg | SingType <- [toSingKind arg]] ++ args) fun + go ([JustSomeType arg | SingType <- [toSingKind arg]] ++ args) fun go args _ = args -- | Shrink a built-in type while preserving its kind. shrinkDropBuiltinSameKind :: DefaultUni (Esc (a :: k)) -> [MaybeSomeTypeOf k] shrinkDropBuiltinSameKind uni = - case toSingKind uni of - SingType -> case uni of - -- 'DefaultUniUnit' is the "minimal" built-in type, can't shrink it any further. - DefaultUniUnit -> [] - -- Any other built-in type of kind @*@ shrinks to 'DefaultUniUnit' and if it happens to - -- be a built-in type application, then also all suitable arguments of the - -- application that are not 'DefaultUniUnit'. - _ -> - let ju = JustSomeType DefaultUniUnit - in ju : filter (/= ju) (shrinkToStarArgs uni) - -- Any built-in type of kind @* -> *@ can be shrunk to @[] :: * -> *@ as long as the - -- built-in type is not @[]@ already. - -- If we had higher-kinded built-in types, we'd need 'shrinkToStarToStarArgs' here like with - -- 'shrinkToStarArgs' above, so the current approach would need some generalization. But we - -- we don't have higher-kinded built-in types and are unlikely to introduce them, so we opt - -- for not complicating things here. - SingType `SingKindArrow` SingType -> case uni of - DefaultUniProtoList -> [] - _ -> [JustSomeType DefaultUniProtoList] - _ -> [] + case toSingKind uni of + SingType -> case uni of + -- 'DefaultUniUnit' is the "minimal" built-in type, can't shrink it any further. + DefaultUniUnit -> [] + -- Any other built-in type of kind @*@ shrinks to 'DefaultUniUnit' and if it happens to + -- be a built-in type application, then also all suitable arguments of the + -- application that are not 'DefaultUniUnit'. + _ -> + let ju = JustSomeType DefaultUniUnit + in ju : filter (/= ju) (shrinkToStarArgs uni) + -- Any built-in type of kind @* -> *@ can be shrunk to @[] :: * -> *@ as long as the + -- built-in type is not @[]@ already. + -- If we had higher-kinded built-in types, we'd need 'shrinkToStarToStarArgs' here like with + -- 'shrinkToStarArgs' above, so the current approach would need some generalization. But we + -- we don't have higher-kinded built-in types and are unlikely to introduce them, so we opt + -- for not complicating things here. + SingType `SingKindArrow` SingType -> case uni of + DefaultUniProtoList -> [] + _ -> [JustSomeType DefaultUniProtoList] + _ -> [] -- | Shrink a function application by shrinking either the function or the argument. -- The kind is preserved. shrinkDefaultUniApply :: DefaultUni (Esc (a :: k)) -> [MaybeSomeTypeOf k] -shrinkDefaultUniApply (fun `DefaultUniApply` arg) = concat +shrinkDefaultUniApply (fun `DefaultUniApply` arg) = + concat [ [ JustSomeType $ fun' `DefaultUniApply` arg | JustSomeType fun' <- shrinkBuiltinSameKind fun ] @@ -502,68 +526,73 @@ I.e. we have a correct-by-construction built-in type generator. -- See Note [Kind-driven generation of built-in types]. instance KnownKind k => Arbitrary (MaybeSomeTypeOf k) where - arbitrary = do - size <- getSize - oneof $ case knownKind @k of - SingType -> - [genDefaultUniApply | size > 10] ++ map pure - [ JustSomeType DefaultUniInteger - , JustSomeType DefaultUniByteString - , JustSomeType DefaultUniString - , JustSomeType DefaultUniUnit - , JustSomeType DefaultUniBool - , JustSomeType DefaultUniData - , JustSomeType DefaultUniBLS12_381_G1_Element - , JustSomeType DefaultUniBLS12_381_G2_Element - , JustSomeType DefaultUniBLS12_381_MlResult - , JustSomeType DefaultUniValue - ] - SingType `SingKindArrow` SingType -> - [ genDefaultUniApply | size > 10 ] - ++ map pure - [ JustSomeType DefaultUniProtoList - , JustSomeType DefaultUniProtoArray - ] - SingType `SingKindArrow` SingType `SingKindArrow` SingType -> - -- No 'genDefaultUniApply', because we don't have any built-in type constructors - -- taking three or more arguments. - [pure $ JustSomeType DefaultUniProtoPair] - _ -> [pure NothingSomeType] - - shrink NothingSomeType = [] -- No shrinks if you don't have anything to shrink. - shrink (JustSomeType uni) = shrinkBuiltinSameKind uni + arbitrary = do + size <- getSize + oneof $ case knownKind @k of + SingType -> + [genDefaultUniApply | size > 10] + ++ map + pure + [ JustSomeType DefaultUniInteger + , JustSomeType DefaultUniByteString + , JustSomeType DefaultUniString + , JustSomeType DefaultUniUnit + , JustSomeType DefaultUniBool + , JustSomeType DefaultUniData + , JustSomeType DefaultUniBLS12_381_G1_Element + , JustSomeType DefaultUniBLS12_381_G2_Element + , JustSomeType DefaultUniBLS12_381_MlResult + , JustSomeType DefaultUniValue + ] + SingType `SingKindArrow` SingType -> + [genDefaultUniApply | size > 10] + ++ map + pure + [ JustSomeType DefaultUniProtoList + , JustSomeType DefaultUniProtoArray + ] + SingType `SingKindArrow` SingType `SingKindArrow` SingType -> + -- No 'genDefaultUniApply', because we don't have any built-in type constructors + -- taking three or more arguments. + [pure $ JustSomeType DefaultUniProtoPair] + _ -> [pure NothingSomeType] + + shrink NothingSomeType = [] -- No shrinks if you don't have anything to shrink. + shrink (JustSomeType uni) = shrinkBuiltinSameKind uni instance Arbitrary (Some (ValueOf DefaultUni)) where - arbitrary = do - mayUni <- arbitrary - case mayUni of - NothingSomeType -> error "Panic: no *-kinded built-in types exist" - JustSomeType uni -> - -- IMPORTANT: if you get a type error here saying an instance is missing, add the - -- missing instance and also update the @Arbitrary (MaybeSomeTypeOf k)@ instance by - -- adding the relevant type tag to the generator. - bring (Proxy @ArbitraryBuiltin) uni $ - Some . ValueOf uni <$> arbitraryBuiltin - - shrink (Some (ValueOf DefaultUniUnit ())) = [] - shrink (Some (ValueOf uni x)) = someValue () : - bring (Proxy @ArbitraryBuiltin) uni (map (Some . ValueOf uni) $ shrinkBuiltin x) + arbitrary = do + mayUni <- arbitrary + case mayUni of + NothingSomeType -> error "Panic: no *-kinded built-in types exist" + JustSomeType uni -> + -- IMPORTANT: if you get a type error here saying an instance is missing, add the + -- missing instance and also update the @Arbitrary (MaybeSomeTypeOf k)@ instance by + -- adding the relevant type tag to the generator. + bring (Proxy @ArbitraryBuiltin) uni $ + Some . ValueOf uni <$> arbitraryBuiltin + + shrink (Some (ValueOf DefaultUniUnit ())) = [] + shrink (Some (ValueOf uni x)) = + someValue () + : bring (Proxy @ArbitraryBuiltin) uni (map (Some . ValueOf uni) $ shrinkBuiltin x) -- | Generate a built-in type of a given kind. genBuiltinTypeOf :: Kind () -> Gen (Maybe (SomeTypeIn DefaultUni)) genBuiltinTypeOf kind = - -- See Note [Kind-driven generation of built-in types]. - withKnownKind kind $ \(_ :: Proxy kind) -> - eraseMaybeSomeTypeOf <$> arbitrary @(MaybeSomeTypeOf kind) + -- See Note [Kind-driven generation of built-in types]. + withKnownKind kind $ \(_ :: Proxy kind) -> + eraseMaybeSomeTypeOf <$> arbitrary @(MaybeSomeTypeOf kind) -- | Shrink a built-in type by dropping a part of it or dropping the whole built-in type in favor of -- a some minimal one (see 'shrinkDropBuiltinSameKind'). The kind is not preserved in the general -- case. shrinkDropBuiltin :: DefaultUni (Esc (a :: k)) -> [SomeTypeIn DefaultUni] -shrinkDropBuiltin uni = concat +shrinkDropBuiltin uni = + concat [ case toSingKind uni of - SingType `SingKindArrow` _ -> shrinkDropBuiltin $ uni `DefaultUniApply` DefaultUniUnit - _ -> [] + SingType `SingKindArrow` _ -> shrinkDropBuiltin $ uni `DefaultUniApply` DefaultUniUnit + _ -> [] , mapMaybe eraseMaybeSomeTypeOf $ shrinkDropBuiltinSameKind uni ] @@ -597,18 +626,22 @@ shrinkDropBuiltin uni = concat -- (pair bool integer) -- (pair (list unit) integer) -- (pair (list bool) unit) + -- | Non-kind-preserving shrinking for 'DefaultUni'. shrinkBuiltinType :: SomeTypeIn DefaultUni -> [SomeTypeIn DefaultUni] -shrinkBuiltinType (SomeTypeIn uni) = concat +shrinkBuiltinType (SomeTypeIn uni) = + concat [ shrinkDropBuiltin uni , mapMaybe eraseMaybeSomeTypeOf $ shrinkDefaultUniApply uni ] instance Arbitrary (SomeTypeIn DefaultUni) where - arbitrary = genKindOfBuiltin >>= (`suchThatMap` id) . genBuiltinTypeOf where - genKindOfBuiltin = frequency - [ (8, pure $ Type ()) - , (1, pure . KindArrow () (Type ()) $ Type ()) - , (1, pure . KindArrow () (Type ()) . KindArrow () (Type ()) $ Type ()) - ] - shrink = shrinkBuiltinType + arbitrary = genKindOfBuiltin >>= (`suchThatMap` id) . genBuiltinTypeOf + where + genKindOfBuiltin = + frequency + [ (8, pure $ Type ()) + , (1, pure . KindArrow () (Type ()) $ Type ()) + , (1, pure . KindArrow () (Type ()) . KindArrow () (Type ()) $ Type ()) + ] + shrink = shrinkBuiltinType diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Common.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Common.hs index aa3dc1ff471..f33b933ec2a 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Common.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Common.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module PlutusCore.Generators.QuickCheck.Common where @@ -28,25 +27,28 @@ import Test.QuickCheck.Property import Text.PrettyBy.Internal instance Testable (Either String ()) where - property = property . \case - Left err -> failed { reason = err } - Right () -> succeeded + property = + property . \case + Left err -> failed {reason = err} + Right () -> succeeded deriving newtype instance Pretty i => Pretty (NonNegative i) instance PrettyBy config i => DefaultPrettyBy config (NonNegative i) -deriving via PrettyCommon (NonNegative i) - instance PrettyDefaultBy config (NonNegative i) => PrettyBy config (NonNegative i) +deriving via + PrettyCommon (NonNegative i) + instance + PrettyDefaultBy config (NonNegative i) => PrettyBy config (NonNegative i) type TypeCtx = Map TyName (Kind ()) -- | Infer the kind of a type in a given kind context inferKind :: TypeCtx -> Type TyName DefaultUni () -> Either String (Kind ()) inferKind ctx ty = - first display . modifyError (PLCTypeError) . runTypeCheckM defKindCheckConfig $ - foldr - (uncurry withTyVar) - (inferKindM @_ @DefaultUni @DefaultFun ty) - (Map.toList ctx) + first display . modifyError (PLCTypeError) . runTypeCheckM defKindCheckConfig $ + foldr + (uncurry withTyVar) + (inferKindM @_ @DefaultUni @DefaultFun ty) + (Map.toList ctx) -- | Partial unsafeInferKind, useful for context where invariants are set up to guarantee -- that types are well-kinded. @@ -54,19 +56,21 @@ unsafeInferKind :: HasCallStack => TypeCtx -> Type TyName DefaultUni () -> Kind unsafeInferKind ctx ty = case inferKind ctx ty of Left msg -> error msg - Right k -> k + Right k -> k -- | Check well-kindedness of a type in a context checkKind :: TypeCtx -> Type TyName DefaultUni () -> Kind () -> Either String () checkKind ctx ty kExp = - if kInf == Right kExp - then Right () - else Left $ concat - [ "Inferred kind is " - , display kInf - , " while expected " - , display kExp - ] + if kInf == Right kExp + then Right () + else + Left $ + concat + [ "Inferred kind is " + , display kInf + , " while expected " + , display kExp + ] where kInf = inferKind ctx ty @@ -86,5 +90,5 @@ checkKind ctx ty kExp = -- @ genList :: Int -> Int -> Gen a -> Gen [a] genList lb ub gen = do - len <- Gen.chooseInt (lb, ub) - Gen.vectorOf len gen + len <- Gen.chooseInt (lb, ub) + Gen.vectorOf len gen diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenTm.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenTm.hs index d3b9d4f419d..ea48f1c915d 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenTm.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenTm.hs @@ -1,16 +1,15 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module PlutusCore.Generators.QuickCheck.GenTm - ( module PlutusCore.Generators.QuickCheck.GenTm - , module Export - , Arbitrary (..) - , Gen - ) where +module PlutusCore.Generators.QuickCheck.GenTm ( + module PlutusCore.Generators.QuickCheck.GenTm, + module Export, + Arbitrary (..), + Gen, +) where import PlutusCore.Generators.QuickCheck.Common import PlutusCore.Generators.QuickCheck.Utils @@ -34,39 +33,40 @@ import Test.QuickCheck qualified as QC import Test.QuickCheck.GenT as Export hiding (var) instance MonadReader r m => MonadReader r (GenT m) where - ask = lift ask - local f (GenT k) = GenT $ \qc size -> local f $ k qc size + ask = lift ask + local f (GenT k) = GenT $ \qc size -> local f $ k qc size -- | Term generators carry around a context to know -- e.g. what types and terms are in scope. type GenTm = GenT (Reader GenEnv) data GenEnv = GenEnv - { geAstSize :: Int + { geAstSize :: Int -- ^ Generator size bound. See Note [Recursion Control and geAstSize] - , geDatas :: Map TyName (Datatype TyName Name DefaultUni ()) + , geDatas :: Map TyName (Datatype TyName Name DefaultUni ()) -- ^ Datatype context. -- TODO: it's a little weird, 'cause it maps the datatype name to the datatype and the datatype -- introduces multiple names. It's probably fine to have something like that, though. - , geTypes :: TypeCtx + , geTypes :: TypeCtx -- ^ Type context - , geTerms :: Map Name (Type TyName DefaultUni ()) + , geTerms :: Map Name (Type TyName DefaultUni ()) -- ^ Term context , geUnboundUsedTyNames :: Set TyName -- ^ Names that we have generated and don't want to shadow but haven't bound yet. - , geEscaping :: AllowEscape + , geEscaping :: AllowEscape -- ^ Are we in a place where we are allowed to generate a datatype binding? - , geCustomGen :: Maybe (Type TyName DefaultUni ()) - -- TODO: this could return a `Maybe` perhaps. Or it - -- could be `Maybe (Maybe Type -> ...)`. - -> GenTm (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) + , geCustomGen :: + Maybe (Type TyName DefaultUni ()) -> + -- TODO: this could return a `Maybe` perhaps. Or it + -- could be `Maybe (Maybe Type -> ...)`. + GenTm (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) -- ^ A custom user-controlled generator for terms - useful for situations where -- we want to e.g. generate custom strings for coverage or test some specific -- pattern that generates a special case for the compiler. - , geCustomFreq :: Int + , geCustomFreq :: Int -- ^ How often do we use the custom generator - -- values in the range of 10-30 are usually reasonable. - , geDebug :: Bool + , geDebug :: Bool -- ^ Are we currently running in debug-mode (to debug our generators) } @@ -83,7 +83,7 @@ at the leaves of the AST and use 'geAstSize' to control the size of the AST itse -- | Run a generator in debug-mode. withDebug :: GenTm a -> GenTm a -withDebug gen = local (\env -> env { geDebug = True }) gen +withDebug gen = local (\env -> env {geDebug = True}) gen -- | Run a `GenTm generator in a top-level empty context where we are allowed to generate -- datatypes. @@ -92,26 +92,29 @@ runGenTm = runGenTmCustom 0 (error "No custom generator.") -- | Run a `GenTm` generator with a plug-in custom generator for terms that is included with -- the other generators. -runGenTmCustom :: Int - -> (Maybe (Type TyName DefaultUni ()) - -> GenTm (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ())) - -> GenTm a - -> Gen a +runGenTmCustom :: + Int -> + ( Maybe (Type TyName DefaultUni ()) -> + GenTm (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) + ) -> + GenTm a -> + Gen a runGenTmCustom f cg g = do - sized $ \ n -> do - let env = GenEnv - { -- Duplicating the QC size parameter that we use to control the size of constants as - -- the initial AST size parameter. - geAstSize = n - , geDatas = Map.empty - , geTypes = Map.empty - , geTerms = Map.empty - , geUnboundUsedTyNames = Set.empty - , geEscaping = YesEscape - , geCustomGen = cg - , geCustomFreq = f - , geDebug = False - } + sized $ \n -> do + let env = + GenEnv + { -- Duplicating the QC size parameter that we use to control the size of constants as + -- the initial AST size parameter. + geAstSize = n + , geDatas = Map.empty + , geTypes = Map.empty + , geTerms = Map.empty + , geUnboundUsedTyNames = Set.empty + , geEscaping = YesEscape + , geCustomGen = cg + , geCustomFreq = f + , geDebug = False + } flip runReader env <$> runGenT g -- | Create a generator that runs the given generator and applies the given function to produced @@ -128,13 +131,13 @@ deliver gen = gen `suchThatMap` id -- | Don't allow types to escape from a generator. withNoEscape :: GenTm a -> GenTm a -withNoEscape = local $ \env -> env { geEscaping = NoEscape } +withNoEscape = local $ \env -> env {geEscaping = NoEscape} -- * Dealing with size -- | Map a function over the generator size onAstSize :: (Int -> Int) -> GenTm a -> GenTm a -onAstSize f = local $ \ env -> env { geAstSize = f (geAstSize env) } +onAstSize f = local $ \env -> env {geAstSize = f (geAstSize env)} -- | Default to the first generator if the size is zero (or negative), -- use the second generator otherwise. @@ -210,12 +213,13 @@ Overall, this chaotic goodness needs to be sorted out. -- | Get all uniques we have generated and are used in the current context. getUniques :: GenTm (Set Unique) getUniques = do - GenEnv{geDatas = dts, geTypes = tys, geTerms = tms, geUnboundUsedTyNames = used} <- ask - return $ Set.mapMonotonic (_nameUnique . unTyName) (Map.keysSet dts <> Map.keysSet tys <> used) <> - Set.mapMonotonic _nameUnique (Map.keysSet tms) <> - Set.unions [ names d | d <- Map.elems dts ] + GenEnv {geDatas = dts, geTypes = tys, geTerms = tms, geUnboundUsedTyNames = used} <- ask + return $ + Set.mapMonotonic (_nameUnique . unTyName) (Map.keysSet dts <> Map.keysSet tys <> used) + <> Set.mapMonotonic _nameUnique (Map.keysSet tms) + <> Set.unions [names d | d <- Map.elems dts] where - names (Datatype _ _ _ m cs) = Set.fromList $ _nameUnique m : [ _nameUnique c | VarDecl _ c _ <- cs ] + names (Datatype _ _ _ m cs) = Set.fromList $ _nameUnique m : [_nameUnique c | VarDecl _ c _ <- cs] {- Note [Warning about generating fresh names] Since 'GenTm' is a *reader* monad names are not immediately put into any state when generated. @@ -233,6 +237,7 @@ genLikelyFreshName s = head <$> genLikelyFreshNames [s] -- See Note [Chaotic Good fresh name generation]. -- See Note [Warning about generating fresh names]. + -- | Generate one likely fresh name per string in the input list. -- Note that this may not give you a fresh name, if it happens to generate a name that was removed -- from the terms map in 'bindTyName' (due to referencing a now-shadowed type variable) but is still @@ -241,8 +246,8 @@ genLikelyFreshNames :: [String] -> GenTm [Name] genLikelyFreshNames ss = do used <- getUniques let i = fromEnum $ Set.findMax $ Set.insert (Unique 0) used - js = [ j | j <- [1..i], not $ Unique j `Set.member` used ] - is = js ++ take (length ss + 10) [i+1..] + js = [j | j <- [1 .. i], not $ Unique j `Set.member` used] + is = js ++ take (length ss + 10) [i + 1 ..] is' <- liftGen $ QC.shuffle is return [Name (fromString $ s ++ show j) (toEnum j) | (s, j) <- zip ss is'] @@ -255,6 +260,7 @@ genLikelyFreshTyNames :: [String] -> GenTm [TyName] genLikelyFreshTyNames ss = map TyName <$> genLikelyFreshNames ss -- See Note [Chaotic Good fresh name generation]. + -- | Generate a name that likely overlaps with existing names on purpose. If there are no existing -- names, generate a fresh name. This function doesn't distinguish between the type- and term-level -- scopes, hence it may generate a 'Name' \"clashing\" with a previously generated 'TyName' and not @@ -267,7 +273,7 @@ genLikelyNotFreshName s = do used <- Set.toList <$> getUniques case used of [] -> genLikelyFreshName s - _ -> liftGen $ elements [ Name (fromString $ s ++ show (unUnique i)) i | i <- used ] + _ -> liftGen $ elements [Name (fromString $ s ++ show (unUnique i)) i | i <- used] -- | Generate a fresh name most (roughly 75%) of the time and otherwise -- generate an already bound name. When there are no bound names generate a fresh name. @@ -280,10 +286,11 @@ genMaybeFreshTyName s = TyName <$> genMaybeFreshName s -- | Bind a type name to a kind and avoid capturing free type variables. bindTyName :: TyName -> Kind () -> GenTm a -> GenTm a -bindTyName x k = local $ \ e -> e +bindTyName x k = local $ \e -> + e { geTypes = Map.insert x k (geTypes e) - -- See Note [Chaotic Good fresh name generation]. - , geTerms = Map.filter (\ty -> not $ x `Set.member` setOf ftvTy ty) (geTerms e) + , -- See Note [Chaotic Good fresh name generation]. + geTerms = Map.filter (\ty -> not $ x `Set.member` setOf ftvTy ty) (geTerms e) , geDatas = Map.delete x (geDatas e) } @@ -294,11 +301,11 @@ bindTyNames = flip $ foldr (uncurry bindTyName) -- | Remember that we have generated a type name locally but don't bind it. -- Useful for non-recursive definitions where we want to control name overlap. registerTyName :: TyName -> GenTm a -> GenTm a -registerTyName n = local $ \ e -> e { geUnboundUsedTyNames = Set.insert n (geUnboundUsedTyNames e) } +registerTyName n = local $ \e -> e {geUnboundUsedTyNames = Set.insert n (geUnboundUsedTyNames e)} -- | Bind a term to a type in a generator. bindTmName :: Name -> Type TyName DefaultUni () -> GenTm a -> GenTm a -bindTmName x ty = local $ \ e -> e { geTerms = Map.insert x ty (geTerms e) } +bindTmName x ty = local $ \e -> e {geTerms = Map.insert x ty (geTerms e)} -- | Bind term names bindTmNames :: [(Name, Type TyName DefaultUni ())] -> GenTm a -> GenTm a @@ -311,22 +318,24 @@ bindLikelyFreshTmName name ty k = do bindTmName x ty (k x) -- | Bind a datatype declaration in a generator. -bindDat :: Datatype TyName Name DefaultUni () - -> GenTm a - -> GenTm a +bindDat :: + Datatype TyName Name DefaultUni () -> + GenTm a -> + GenTm a bindDat dat@(Datatype _ (TyVarDecl _ a k) _ _ _) cont = bindTyName a k $ - local (\ e -> e { geDatas = Map.insert a dat (geDatas e) }) $ - foldr (uncurry bindTmName) cont (matchType dat : constrTypes dat) + local (\e -> e {geDatas = Map.insert a dat (geDatas e)}) $ + foldr (uncurry bindTmName) cont (matchType dat : constrTypes dat) -- | Bind a binding. -bindBind :: Binding TyName Name DefaultUni DefaultFun () - -> GenTm a - -> GenTm a -bindBind (DatatypeBind _ dat) = bindDat dat +bindBind :: + Binding TyName Name DefaultUni DefaultFun () -> + GenTm a -> + GenTm a +bindBind (DatatypeBind _ dat) = bindDat dat bindBind (TermBind _ _ (VarDecl _ x ty) _) = bindTmName x ty -- TODO: We should generate type bindings -bindBind _ = error "unreachable" +bindBind _ = error "unreachable" -- | Bind multiple bindings bindBinds :: Foldable f => f (Binding TyName Name DefaultUni DefaultFun ()) -> GenTm a -> GenTm a diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateKinds.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateKinds.hs index d57d362af43..e482e3e4673 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateKinds.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateKinds.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusCore.Generators.QuickCheck.GenerateKinds where @@ -13,7 +12,7 @@ A kind @k1 = foldr (->) * ks1@ is less than or equal to a kind @k2 = foldr (->) can be constructed by dropping and shrinking kinds in @ks2@. This shrinking order means that @* -> (* -> * -> * -> *) -> *@ can shrink to @* -> *@ or @* -> (* -> -*) -> *@ but not to @* -> * -> * -> *@. Not allowing this final shrink is important as we are +\*) -> *@ but not to @* -> * -> * -> *@. Not allowing this final shrink is important as we are guaranteed to only ever reduce the number of type arguments we need to provide when shrinking - thus allowing us to guarantee that e.g. generated datatypes never increase their number of parameters. This restriction is important because once the number of parameters starts to grow @@ -25,11 +24,11 @@ and cause a shrink-loop. leKind :: Kind () -> Kind () -> Bool leKind k1 k2 = go (reverse $ argsFunKind k1) (reverse $ argsFunKind k2) where - go [] _ = True - go _ [] = False + go [] _ = True + go _ [] = False go (k : ks) (k' : ks') | leKind k k' = go ks ks' - | otherwise = go (k : ks) ks' + | otherwise = go (k : ks) ks' -- | Strict shrinking order on kinds. ltKind :: Kind () -> Kind () -> Bool @@ -39,10 +38,13 @@ instance Arbitrary (Kind ()) where arbitrary = sized $ arb . (`div` 3) where arb 0 = pure $ Type () - arb n = frequency [(4, pure $ Type ()), - (1, KindArrow () <$> arb (div n 6) <*> arb (div (5 * n) 6))] + arb n = + frequency + [ (4, pure $ Type ()) + , (1, KindArrow () <$> arb (div n 6) <*> arb (div (5 * n) 6)) + ] -- See Note [Shriking order on kinds]. - shrink (Type _) = [] + shrink (Type _) = [] -- Reminder: @a@ can have bigger arity than @a -> b@ so don't shrink to it! shrink (KindArrow _ a b) = b : [KindArrow () a' b' | (a', b') <- shrink (a, b)] diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateTypes.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateTypes.hs index 5a5e6ad6097..4392670cd7f 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateTypes.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/GenerateTypes.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module PlutusCore.Generators.QuickCheck.GenerateTypes where import PlutusCore.Generators.QuickCheck.Builtin import PlutusCore.Generators.QuickCheck.Common -import PlutusCore.Generators.QuickCheck.GenerateKinds () import PlutusCore.Generators.QuickCheck.GenTm +import PlutusCore.Generators.QuickCheck.GenerateKinds () import PlutusCore.Builtin import PlutusCore.Core @@ -52,49 +52,55 @@ genAtomicType :: Kind () -> GenTm (Type TyName DefaultUni ()) genAtomicType k = do tys <- asks geTypes dts <- asks geDatas - let atoms = [ TyVar () x | (x, k') <- Map.toList tys, k == k' ] ++ - [ TyVar () x | (x, Datatype _ (TyVarDecl _ _ k') _ _ _) <- Map.toList dts, k == k' ] + let atoms = + [TyVar () x | (x, k') <- Map.toList tys, k == k'] + ++ [TyVar () x | (x, Datatype _ (TyVarDecl _ _ k') _ _ _) <- Map.toList dts, k == k'] genBuiltin = fmap (TyBuiltin ()) <$> genBuiltinTypeOf k lam k1 k2 = do x <- genMaybeFreshTyName "a" TyLam () x k1 <$> bindTyName x k1 (genAtomicType k2) -- There's always an atomic type of a given kind, hence the usage of 'deliver': we definitely have -- builtin types of kind @*@, and for all other kinds we can generate type lambdas. - deliver $ frequency - [ (7, if null atoms then pure Nothing else Just <$> elements atoms) - , (1, liftGen genBuiltin) - -- There may not be a type variable or a built-in type of the given type, hence we have to - -- resort to generating a lambda occasionally. Plus it's a lambda that ignores the bound - -- variable in its body, so it's fine to call it "atomic". - , (3, sequence $ listToMaybe [lam k1 k2 | KindArrow _ k1 k2 <- [k]]) - ] + deliver $ + frequency + [ (7, if null atoms then pure Nothing else Just <$> elements atoms) + , (1, liftGen genBuiltin) + , -- There may not be a type variable or a built-in type of the given type, hence we have to + -- resort to generating a lambda occasionally. Plus it's a lambda that ignores the bound + -- variable in its body, so it's fine to call it "atomic". + (3, sequence $ listToMaybe [lam k1 k2 | KindArrow _ k1 k2 <- [k]]) + ] -- | Generate a type at a given kind genType :: Kind () -> GenTm (Type TyName DefaultUni ()) genType k = do - ty <- onAstSize (min 10) $ ifAstSizeZero (genAtomicType k) $ - frequency $ concat - [ [ (5, genAtomicType k) ] - , [ (10, genFun) | k == Type () ] - , [ (5, genForall) | k == Type () ] - , [ (1, genIFix) | k == Type () ] - , [ (5, genLam k1 k2) | KindArrow _ k1 k2 <- [k] ] - , [ (5, genApp) ] - , [ (3, genSOP) | k == Type () ] - ] - debug <- asks geDebug - when debug $ do - ctx <- asks geTypes - case checkKind ctx ty k of - Right _ -> pure () - Left err -> - error . show $ fold - [ "genType - checkInvariants: type " <> prettyReadable ty - , " does not match kind " <> prettyReadable k - , " in context " <> prettyReadable ctx - , " with error message " <> fromString err - ] - pure ty + ty <- + onAstSize (min 10) $ + ifAstSizeZero (genAtomicType k) $ + frequency $ + concat + [ [(5, genAtomicType k)] + , [(10, genFun) | k == Type ()] + , [(5, genForall) | k == Type ()] + , [(1, genIFix) | k == Type ()] + , [(5, genLam k1 k2) | KindArrow _ k1 k2 <- [k]] + , [(5, genApp)] + , [(3, genSOP) | k == Type ()] + ] + debug <- asks geDebug + when debug $ do + ctx <- asks geTypes + case checkKind ctx ty k of + Right _ -> pure () + Left err -> + error . show $ + fold + [ "genType - checkInvariants: type " <> prettyReadable ty + , " does not match kind " <> prettyReadable k + , " in context " <> prettyReadable ctx + , " with error message " <> fromString err + ] + pure ty where -- This size split keeps us from generating ridiculous types that -- grow huge to the left of an arrow or abstraction (See also the @@ -110,8 +116,8 @@ genType k = do fmap (TyForall () a k') $ onAstSize (subtract 1) $ bindTyName a k' $ genType $ Type () genLam k1 k2 = do - a <- genMaybeFreshTyName "a" - fmap (TyLam () a k1) $ onAstSize (subtract 1) $ bindTyName a k1 (genType k2) + a <- genMaybeFreshTyName "a" + fmap (TyLam () a k1) $ onAstSize (subtract 1) $ bindTyName a k1 (genType k2) genApp = do k' <- liftGen arbitrary @@ -119,21 +125,25 @@ genType k = do genIFix = do k' <- liftGen arbitrary - uncurry (TyIFix ()) <$> astSizeSplit_ 5 2 - (genType $ toPatFuncKind k') - (genType k') + uncurry (TyIFix ()) + <$> astSizeSplit_ + 5 + 2 + (genType $ toPatFuncKind k') + (genType k') genSOP = do - n <- asks geAstSize - -- Generate up to five constructors or fewer than that if we don't have much size left. - iSum <- liftGen $ chooseInt (0, min 5 $ n `div` 5) - jsProd <- liftGen . replicateM iSum $ - -- The more constructors a data type has, the less arguments each of them can have. - -- This is so that we don't generate data types with a large number of constructors each - -- which takes a large number of arguments. - chooseInt (0, min (7 - iSum) $ n `div` (2 * iSum)) - withAstSize (n `div` sum jsProd) $ - TySOP () <$> traverse (\j -> replicateM j . genType $ Type ()) jsProd + n <- asks geAstSize + -- Generate up to five constructors or fewer than that if we don't have much size left. + iSum <- liftGen $ chooseInt (0, min 5 $ n `div` 5) + jsProd <- + liftGen . replicateM iSum $ + -- The more constructors a data type has, the less arguments each of them can have. + -- This is so that we don't generate data types with a large number of constructors each + -- which takes a large number of arguments. + chooseInt (0, min (7 - iSum) $ n `div` (2 * iSum)) + withAstSize (n `div` sum jsProd) $ + TySOP () <$> traverse (\j -> replicateM j . genType $ Type ()) jsProd -- | Generate a closed type at a given kind genClosedType :: Kind () -> Gen (Type TyName DefaultUni ()) @@ -145,17 +155,17 @@ genClosedTypeDebug = genTypeWithCtxDebug mempty -- | Generate a type in the given context with the given kind. genTypeWithCtx :: TypeCtx -> Kind () -> Gen (Type TyName DefaultUni ()) -genTypeWithCtx ctx k = runGenTm $ local (\ e -> e { geTypes = ctx }) (genType k) +genTypeWithCtx ctx k = runGenTm $ local (\e -> e {geTypes = ctx}) (genType k) -- | Generate a type in the given context with the given kind. genTypeWithCtxDebug :: TypeCtx -> Kind () -> Gen (Type TyName DefaultUni ()) -genTypeWithCtxDebug ctx k = runGenTm $ local (\ e -> e { geTypes = ctx }) (withDebug $ genType k) +genTypeWithCtxDebug ctx k = runGenTm $ local (\e -> e {geTypes = ctx}) (withDebug $ genType k) -- | Generate a well-kinded type and its kind in a given context -genKindAndTypeWithCtx :: TypeCtx -> Gen (Kind(), Type TyName DefaultUni ()) +genKindAndTypeWithCtx :: TypeCtx -> Gen (Kind (), Type TyName DefaultUni ()) genKindAndTypeWithCtx ctx = do k <- arbitrary - runGenTm $ local (\ e -> e { geTypes = ctx }) ((k,) <$> genType k) + runGenTm $ local (\e -> e {geTypes = ctx}) ((k,) <$> genType k) -- | Get the kind of a builtin builtinKind :: SomeTypeIn DefaultUni -> Kind () @@ -180,12 +190,13 @@ normalizeTy :: Type TyName DefaultUni () -> Type TyName DefaultUni () normalizeTy = unNormalized . runQuote . normalizeType -- See Note [Chaotic Good fresh name generation]. + -- | Generate a context of free type variables with kinds genCtx :: Gen TypeCtx genCtx = do let m = 20 n <- choose (0, m) - let xVars = [TyName $ Name (fromString $ "x" ++ show i) (toEnum i) | i <- [1..m]] + let xVars = [TyName $ Name (fromString $ "x" ++ show i) (toEnum i) | i <- [1 .. m]] shuf <- shuffle xVars let xs = take n shuf ks <- vectorOf n arbitrary diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/ShrinkTypes.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/ShrinkTypes.hs index 5847f64b222..b0a687e75ce 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/ShrinkTypes.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/ShrinkTypes.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | This module defines the type shrinker. The shrinking order isn't specified, so the shrinker -- may or may not behave correctly, we don't really know. If shrinking ever loops, feel free to kill @@ -10,8 +10,8 @@ module PlutusCore.Generators.QuickCheck.ShrinkTypes where import PlutusCore.Generators.QuickCheck.Builtin import PlutusCore.Generators.QuickCheck.Common -import PlutusCore.Generators.QuickCheck.GenerateKinds import PlutusCore.Generators.QuickCheck.GenTm +import PlutusCore.Generators.QuickCheck.GenerateKinds import PlutusCore.Builtin import PlutusCore.Core @@ -50,6 +50,7 @@ import Test.QuickCheck.Arbitrary -- Note that compared to 'genAtomicType' this one for, say, @* -> * -> *@ always gives @pair@, while -- 'genAtomicType' can give you a type variable, 'pair' or a type lambda returning a type variable, -- 'list' or a type lambda returning a type variable or a built-in type of kind @*@. + -- | Give a unique "least" (intentionally vaguely specified by "shrinking order") -- type of that kind. Note: this function requires care and attention to not get -- a shrinking loop. If you think you need to mess with this function: @@ -59,220 +60,245 @@ import Test.QuickCheck.Arbitrary -- test the shrinking to make sure you don't get in a loop. -- 3. Finally, you *must* read the note Note [Avoiding Shrinking Loops] minimalType :: Kind () -> Type TyName DefaultUni () -minimalType = go . argsFunKind where - go = \case - [] -> unit - [Type{}] -> list - [Type{}, Type{}] -> pair - k:ks -> TyLam () (TyName $ Name "_" (toEnum 0)) k $ go ks +minimalType = go . argsFunKind + where + go = \case + [] -> unit + [Type {}] -> list + [Type {}, Type {}] -> pair + k : ks -> TyLam () (TyName $ Name "_" (toEnum 0)) k $ go ks - unit = mkTyBuiltin @_ @() () - list = mkTyBuiltin @_ @[] () - pair = mkTyBuiltin @_ @(,) () + unit = mkTyBuiltin @_ @() () + list = mkTyBuiltin @_ @[] () + pair = mkTyBuiltin @_ @(,) () -- | Take a type in a context and a target kind and try adjust the type to have the target kind. -- If can't make the adjusting successful, return the 'minimalType' of the target kind. -- Precondition: new kind is smaller or equal to old kind of the type. -- Complies with the implicit shrinking order. -- TODO (later): also allow changing which context it's valid in -fixKind :: HasCallStack - => TypeCtx - -> Type TyName DefaultUni () - -> Kind () - -> Type TyName DefaultUni () +fixKind :: + HasCallStack => + TypeCtx -> + Type TyName DefaultUni () -> + Kind () -> + Type TyName DefaultUni () fixKind ctx ty k -- Nothing to do if we already have the right kind | origK == k = ty - | not $ k `leKind` origK = error $ concat - [ "Internal error. New kind: " - , display k - , "\nis not smaller than the old one: " - , display $ unsafeInferKind ctx ty - ] + | not $ k `leKind` origK = + error $ + concat + [ "Internal error. New kind: " + , display k + , "\nis not smaller than the old one: " + , display $ unsafeInferKind ctx ty + ] | otherwise = case ty of - -- Switch a variable out for a different variable of the right kind - TyVar _ _ -> case [y | (y, k') <- Map.toList ctx, k == k'] of + -- Switch a variable out for a different variable of the right kind + TyVar _ _ -> case [y | (y, k') <- Map.toList ctx, k == k'] of y : _ -> TyVar () y - _ -> minimalType k - -- Try to fix application by fixing the function - TyApp _ a b -> TyApp () (fixKind ctx a $ KindArrow () (unsafeInferKind ctx b) k) b - TyLam _ x kx b -> - case k of - -- Fix lambdas to * by substituting a minimal type for the argument - -- and fixing the body. - Type{} -> fixKind ctx (typeSubstClosedType x (minimalType kx) b) k - -- Fix functions by either keeping the argument around (if we can) or getting - -- rid of the argument (by turning its use-sites into minimal types) and introducing - -- a new argument. - KindArrow _ ka kb - | ka == kx -> TyLam () x kx $ fixKind (Map.insert x kx ctx) b kb - | not $ kb `leKind` kb' -> error "fixKind" - | otherwise -> TyLam () x ka $ fixKind ctx' b' kb + _ -> minimalType k + -- Try to fix application by fixing the function + TyApp _ a b -> TyApp () (fixKind ctx a $ KindArrow () (unsafeInferKind ctx b) k) b + TyLam _ x kx b -> + case k of + -- Fix lambdas to * by substituting a minimal type for the argument + -- and fixing the body. + Type {} -> fixKind ctx (typeSubstClosedType x (minimalType kx) b) k + -- Fix functions by either keeping the argument around (if we can) or getting + -- rid of the argument (by turning its use-sites into minimal types) and introducing + -- a new argument. + KindArrow _ ka kb + | ka == kx -> TyLam () x kx $ fixKind (Map.insert x kx ctx) b kb + | not $ kb `leKind` kb' -> error "fixKind" + | otherwise -> TyLam () x ka $ fixKind ctx' b' kb where ctx' = Map.insert x ka ctx - b' = typeSubstClosedType x (minimalType kx) b - kb' = unsafeInferKind ctx' b' - -- Ill-kinded builtins just go to minimal types - TyBuiltin{} -> minimalType k - -- Unreachable, because the target kind must be less than or equal to the original kind. We - -- handled the case where they are equal at the beginning of the function, so at this point the - -- target kind must be strictly less than the original kind, but for these types we know the - -- original kind is @*@, and there is no kind smaller than that. - TyFun{} -> error "Internal error: unreachable clause." - TyIFix{} -> error "Internal error: unreachable clause." - TyForall{} -> error "Internal error: unreachable clause." - TySOP{} -> error "Internal error: unreachable clause." - where origK = unsafeInferKind ctx ty + b' = typeSubstClosedType x (minimalType kx) b + kb' = unsafeInferKind ctx' b' + -- Ill-kinded builtins just go to minimal types + TyBuiltin {} -> minimalType k + -- Unreachable, because the target kind must be less than or equal to the original kind. We + -- handled the case where they are equal at the beginning of the function, so at this point the + -- target kind must be strictly less than the original kind, but for these types we know the + -- original kind is @*@, and there is no kind smaller than that. + TyFun {} -> error "Internal error: unreachable clause." + TyIFix {} -> error "Internal error: unreachable clause." + TyForall {} -> error "Internal error: unreachable clause." + TySOP {} -> error "Internal error: unreachable clause." + where + origK = unsafeInferKind ctx ty -- | Shrink a well-kinded type in a context to new types, possibly with new kinds. -- The new kinds are guaranteed to be smaller than or equal to the old kind. -- TODO: also shrink to new context -- need old context and new context -shrinkKindAndType :: HasCallStack - => TypeCtx - -> (Kind (), Type TyName DefaultUni ()) - -> [(Kind (), Type TyName DefaultUni ())] +shrinkKindAndType :: + HasCallStack => + TypeCtx -> + (Kind (), Type TyName DefaultUni ()) -> + [(Kind (), Type TyName DefaultUni ())] shrinkKindAndType ctx (k0, ty) = - let minK0 = minimalType k0 in - -- If we are not already minimal, add the minial type as a possible shrink. - ([(k0, m) | let m = minimalType k0, m /= ty] ++) . filter ((/= minK0) . snd) $ - [(k, m) | k <- shrink k0, let m = minimalType k] ++ - case ty of - -- Variables shrink to arbitrary "smaller" variables - -- Note: the order on variable names here doesn't matter, - -- it's just because we need *some* order or otherwise - -- shrinking doesn't terminate. - TyVar _ x -> - [ (ky, TyVar () y) - | (y, ky) <- Map.toList ctx - , ltKind ky k0 || ky == k0 && y < x - ] - -- Functions shrink to either side of the arrow and both sides - -- of the arrow shrink independently. - TyFun _ a b -> map (Type (), ) $ concat - [ [ a - , b - ] - , [ TyFun () a' b - | a' <- shrinkType ctx a - ] - , [ TyFun () a b' - | b' <- shrinkType ctx b - ] - ] - -- This case needs to be handled with a bit of care. First we shrink applications by - -- doing simple stuff like shrinking the function and body separately when we can. - -- The slightly tricky case is the concat trace. See comment below. - TyApp _ f a -> concat - [ [ (ka, a) - | ka `leKind` k0 - ] - , [ (k0, typeSubstClosedType x m b) - | TyLam _ x _ b <- [f] - , let m = minimalType ka - , m /= a -- @m == a@ is handled right below. - ] - , [ (k0, typeSubstClosedType x a b) - | TyLam _ x _ b <- [f], null (setOf ftvTy a) - ] - -- Here we try to shrink the function f, if we get something whose kind - -- is small enough we can return the new function f', otherwise we - -- apply f' to `fixKind ctx a ka'` - which takes `a` and tries to rewrite it - -- to something of kind `ka'`. - , concat - [ case kf' of - Type{} -> - [ (kf', f') - | f' /= a -- @f' == a@ is handled above. + let minK0 = minimalType k0 + in -- If we are not already minimal, add the minial type as a possible shrink. + ([(k0, m) | let m = minimalType k0, m /= ty] ++) . filter ((/= minK0) . snd) $ + [(k, m) | k <- shrink k0, let m = minimalType k] + ++ case ty of + -- Variables shrink to arbitrary "smaller" variables + -- Note: the order on variable names here doesn't matter, + -- it's just because we need *some* order or otherwise + -- shrinking doesn't terminate. + TyVar _ x -> + [ (ky, TyVar () y) + | (y, ky) <- Map.toList ctx + , ltKind ky k0 || ky == k0 && y < x + ] + -- Functions shrink to either side of the arrow and both sides + -- of the arrow shrink independently. + TyFun _ a b -> + map (Type (),) $ + concat + [ + [ a + , b ] - KindArrow _ ka' kb' -> - [ (kb', TyApp () f' (fixKind ctx a ka')) - | leKind kb' k0, leKind ka' ka + , [ TyFun () a' b + | a' <- shrinkType ctx a ] - | (kf', f') <- shrinkKindAndType ctx (KindArrow () ka k0, f) - ] - , -- Here we shrink the argument and fixup the function to have the right kind. - [ (k0, TyApp () (fixKind ctx f (KindArrow () ka' k0)) a') - | (ka', a') <- shrinkKindAndType ctx (ka, a) - ] - ] - where ka = unsafeInferKind ctx a - -- type lambdas shrink by either shrinking the kind of the argument or shrinking the body - TyLam _ x ka b -> concat - [ -- We can simply get rid of the binding by instantiating the variable. - [ (kb, typeSubstClosedType x (minimalType ka) b) - ] - -- We could've used @fixKind (Map.insert x ka' ctx) (TyVar () x) ka)@ here instead of - -- @minimalType ka@, so that the usages of @x@ are preserved when possible, but that would - -- mean fixing a kind to a bigger one (because @ka'@ has to be smaller than @ka@ and we'd go - -- in the opposite direction), which is not supported by 'fixKind' (even though just - -- commenting out the relevant check and making the change here does seem to give us - -- better shrinking that still properly terminates, 'cause why would it not). - , [ (KindArrow () ka' kb, TyLam () x ka' $ typeSubstClosedType x (minimalType ka) b) - | ka' <- shrink ka - ] - , [ (KindArrow () ka kb', TyLam () x ka b') - | (kb', b') <- shrinkKindAndType (Map.insert x ka ctx) (kb, b) - ] - ] - where - kb = case k0 of - KindArrow _ _ k' -> k' - _ -> - error $ "Internal error: " ++ display k0 ++ " is not a 'KindArrow'" - TyForall _ x ka b -> map (Type (), ) $ concat - [ -- We can simply get rid of the binding by instantiating the variable. - [ typeSubstClosedType x (minimalType ka) b - ] - , -- We can always just shrink the bound variable to a smaller kind and ignore it - -- Similarly to 'TyLam', we could've used 'fixKind' here, but we don't do it for the same - -- reason. - [ TyForall () x ka' $ typeSubstClosedType x (minimalType ka) b - | ka' <- shrink ka - ] - , [ TyForall () x ka b' - -- or we shrink the body. - | b' <- shrinkType (Map.insert x ka ctx) b - ] - ] - TyBuiltin _ someUni -> - [ (kindOfBuiltinType uni', TyBuiltin () $ SomeTypeIn uni') - | SomeTypeIn uni' <- shrinkBuiltinType someUni - ] - TyIFix _ pat arg -> map (Type (), ) $ concat - [ [ fixKind ctx pat $ Type () - , fixKind ctx arg $ Type () - ] - , [ TyIFix () pat' (fixKind ctx arg kArg') - | (kPat', pat') <- shrinkKindAndType ctx (toPatFuncKind kArg, pat), - Just kArg' <- [fromPatFuncKind kPat'] - ] - , [ TyIFix () (fixKind ctx pat $ toPatFuncKind kArg') arg' - | (kArg', arg') <- shrinkKindAndType ctx (kArg, arg) - ] - ] - where - kArg = unsafeInferKind ctx arg - TySOP _ tyls -> map (Type (), ) $ concat - [ -- Shrink to any type within the SOP. - concat tyls - , -- Shrink either the entire sum or a product within it or a type within a product. - TySOP () <$> shrinkList (shrinkList $ shrinkType ctx) tyls - ] + , [ TyFun () a b' + | b' <- shrinkType ctx b + ] + ] + -- This case needs to be handled with a bit of care. First we shrink applications by + -- doing simple stuff like shrinking the function and body separately when we can. + -- The slightly tricky case is the concat trace. See comment below. + TyApp _ f a -> + concat + [ [ (ka, a) + | ka `leKind` k0 + ] + , [ (k0, typeSubstClosedType x m b) + | TyLam _ x _ b <- [f] + , let m = minimalType ka + , m /= a -- @m == a@ is handled right below. + ] + , [ (k0, typeSubstClosedType x a b) + | TyLam _ x _ b <- [f] + , null (setOf ftvTy a) + ] + , -- Here we try to shrink the function f, if we get something whose kind + -- is small enough we can return the new function f', otherwise we + -- apply f' to `fixKind ctx a ka'` - which takes `a` and tries to rewrite it + -- to something of kind `ka'`. + concat + [ case kf' of + Type {} -> + [ (kf', f') + | f' /= a -- @f' == a@ is handled above. + ] + KindArrow _ ka' kb' -> + [ (kb', TyApp () f' (fixKind ctx a ka')) + | leKind kb' k0 + , leKind ka' ka + ] + | (kf', f') <- shrinkKindAndType ctx (KindArrow () ka k0, f) + ] + , -- Here we shrink the argument and fixup the function to have the right kind. + [ (k0, TyApp () (fixKind ctx f (KindArrow () ka' k0)) a') + | (ka', a') <- shrinkKindAndType ctx (ka, a) + ] + ] + where + ka = unsafeInferKind ctx a + -- type lambdas shrink by either shrinking the kind of the argument or shrinking the body + TyLam _ x ka b -> + concat + [ -- We can simply get rid of the binding by instantiating the variable. + + [ (kb, typeSubstClosedType x (minimalType ka) b) + ] + , -- We could've used @fixKind (Map.insert x ka' ctx) (TyVar () x) ka)@ here instead of + -- @minimalType ka@, so that the usages of @x@ are preserved when possible, but that would + -- mean fixing a kind to a bigger one (because @ka'@ has to be smaller than @ka@ and we'd go + -- in the opposite direction), which is not supported by 'fixKind' (even though just + -- commenting out the relevant check and making the change here does seem to give us + -- better shrinking that still properly terminates, 'cause why would it not). + [ (KindArrow () ka' kb, TyLam () x ka' $ typeSubstClosedType x (minimalType ka) b) + | ka' <- shrink ka + ] + , [ (KindArrow () ka kb', TyLam () x ka b') + | (kb', b') <- shrinkKindAndType (Map.insert x ka ctx) (kb, b) + ] + ] + where + kb = case k0 of + KindArrow _ _ k' -> k' + _ -> + error $ "Internal error: " ++ display k0 ++ " is not a 'KindArrow'" + TyForall _ x ka b -> + map (Type (),) $ + concat + [ -- We can simply get rid of the binding by instantiating the variable. + + [ typeSubstClosedType x (minimalType ka) b + ] + , -- We can always just shrink the bound variable to a smaller kind and ignore it + -- Similarly to 'TyLam', we could've used 'fixKind' here, but we don't do it for the same + -- reason. + [ TyForall () x ka' $ typeSubstClosedType x (minimalType ka) b + | ka' <- shrink ka + ] + , [ TyForall () x ka b' + | -- or we shrink the body. + b' <- shrinkType (Map.insert x ka ctx) b + ] + ] + TyBuiltin _ someUni -> + [ (kindOfBuiltinType uni', TyBuiltin () $ SomeTypeIn uni') + | SomeTypeIn uni' <- shrinkBuiltinType someUni + ] + TyIFix _ pat arg -> + map (Type (),) $ + concat + [ + [ fixKind ctx pat $ Type () + , fixKind ctx arg $ Type () + ] + , [ TyIFix () pat' (fixKind ctx arg kArg') + | (kPat', pat') <- shrinkKindAndType ctx (toPatFuncKind kArg, pat) + , Just kArg' <- [fromPatFuncKind kPat'] + ] + , [ TyIFix () (fixKind ctx pat $ toPatFuncKind kArg') arg' + | (kArg', arg') <- shrinkKindAndType ctx (kArg, arg) + ] + ] + where + kArg = unsafeInferKind ctx arg + TySOP _ tyls -> + map (Type (),) $ + concat + [ -- Shrink to any type within the SOP. + concat tyls + , -- Shrink either the entire sum or a product within it or a type within a product. + TySOP () <$> shrinkList (shrinkList $ shrinkType ctx) tyls + ] -- | Shrink a type in a context assuming that it is of kind *. -shrinkType :: HasCallStack - => TypeCtx - -> Type TyName DefaultUni () - -> [Type TyName DefaultUni ()] +shrinkType :: + HasCallStack => + TypeCtx -> + Type TyName DefaultUni () -> + [Type TyName DefaultUni ()] shrinkType ctx ty = map snd $ shrinkKindAndType ctx (Type (), ty) -- | Shrink a type of a given kind in a given context in a way that keeps its kind -shrinkTypeAtKind :: HasCallStack - => TypeCtx - -> Kind () - -> Type TyName DefaultUni () - -> [Type TyName DefaultUni ()] +shrinkTypeAtKind :: + HasCallStack => + TypeCtx -> + Kind () -> + Type TyName DefaultUni () -> + [Type TyName DefaultUni ()] -- It is unfortunate that we need to produce all those shrunk types just to filter out a lot of them -- afterwards. But we still should get good coverage in the end. -shrinkTypeAtKind ctx k ty = [ ty' | (k', ty') <- shrinkKindAndType ctx (k, ty), k == k' ] +shrinkTypeAtKind ctx k ty = [ty' | (k', ty') <- shrinkKindAndType ctx (k, ty), k == k'] diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Split.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Split.hs index c42aa71189f..2d06e87feb1 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Split.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Split.hs @@ -15,29 +15,29 @@ smallLength = 6 -- | Generate a sublist of the given size of the given list. Preserves the order of elements. sublistN :: Int -> [a] -> Gen [a] -sublistN lenRes - = fmap (map snd . sortBy (comparing fst) . take lenRes) +sublistN lenRes = + fmap (map snd . sortBy (comparing fst) . take lenRes) . shuffle . zip [0 :: Int ..] -- | Calculate the maximum number of chunks to split a list of the given list into. toMaxChunkNumber :: Int -> Int toMaxChunkNumber len - -- For short lists we take the maximum number of chunks to be the length of the list, - -- i.e. the maximum number of chunks grows at a maximum speed for short lists. - | len <= smallLength = len - -- For longer lists the maximum number of chunks grows slower. We don't really want to split a - -- 50-element list into each of 1..50 number of chunks. - | len <= smallLength ^ (2 :: Int) = smallLength + len `div` smallLength - -- For long lists it grows even slower. - | otherwise = smallLength + round @Double (sqrt $ fromIntegral len) + -- For short lists we take the maximum number of chunks to be the length of the list, + -- i.e. the maximum number of chunks grows at a maximum speed for short lists. + | len <= smallLength = len + -- For longer lists the maximum number of chunks grows slower. We don't really want to split a + -- 50-element list into each of 1..50 number of chunks. + | len <= smallLength ^ (2 :: Int) = smallLength + len `div` smallLength + -- For long lists it grows even slower. + | otherwise = smallLength + round @Double (sqrt $ fromIntegral len) -- | Calculate the number of ways to divide a list of length @len@ into @chunkNum@ chunks. -- Equals to @C(len - 1, chunksNum - 1)@. toChunkNumber :: Int -> Int -> Int toChunkNumber len chunkNum = - product [len - 1, len - 2 .. len - chunkNum + 1] `div` - product [chunkNum - 1, chunkNum - 2 .. 2] + product [len - 1, len - 2 .. len - chunkNum + 1] + `div` product [chunkNum - 1, chunkNum - 2 .. 2] -- | Return a list of pairs, each of which consists of -- @@ -58,27 +58,29 @@ toChunkNumber len chunkNum = -- [(3,1),(4,2),(5,3),(6,4),(7,5),(8,6),(9,7),(10,8),(11,9),(12,10),(13,11),(14,12),(15,13)] toChunkFrequencies :: Int -> [(Int, Int)] toChunkFrequencies len - -- For short lists we calculate exact chunk numbers and use those as frequencies in order to get - -- uniform distribution of list lengths (which does not lead to uniform distribution of lengths - -- of subtrees, since subtrees with small total count of elements get generated much more often - -- than those with a big total count of elements, particularly because the latter contain the - -- former). - | len <= smallLength = map (\num -> (toChunkNumber len num, num)) chunks - | otherwise = - let -- The probability of "splitting" a list into a single sublist (i.e. simply 'pure') is - -- about 3%. - singleElemProb = 3 - -- Computing @delta@ in order for each subsequent chunk length to get picked a bit more - -- likely, so that we generate longer forests more often when we can. For not-too-long - -- lists the frequencies add up to roughly 100. For long lists the sum of frequencies - -- can be significantly greater than 100 making the chance of generating a single - -- sublist less than 3%. - deltaN = chunkMax * (chunkMax - 1) `div` 2 - delta = max 1 $ (100 - chunkMax * singleElemProb) `div` deltaN - in zip (iterate (+ delta) singleElemProb) chunks - where - chunkMax = toMaxChunkNumber len - chunks = [1 .. chunkMax] + -- For short lists we calculate exact chunk numbers and use those as frequencies in order to get + -- uniform distribution of list lengths (which does not lead to uniform distribution of lengths + -- of subtrees, since subtrees with small total count of elements get generated much more often + -- than those with a big total count of elements, particularly because the latter contain the + -- former). + | len <= smallLength = map (\num -> (toChunkNumber len num, num)) chunks + | otherwise = + let + -- The probability of "splitting" a list into a single sublist (i.e. simply 'pure') is + -- about 3%. + singleElemProb = 3 + -- Computing @delta@ in order for each subsequent chunk length to get picked a bit more + -- likely, so that we generate longer forests more often when we can. For not-too-long + -- lists the frequencies add up to roughly 100. For long lists the sum of frequencies + -- can be significantly greater than 100 making the chance of generating a single + -- sublist less than 3%. + deltaN = chunkMax * (chunkMax - 1) `div` 2 + delta = max 1 $ (100 - chunkMax * singleElemProb) `div` deltaN + in + zip (iterate (+ delta) singleElemProb) chunks + where + chunkMax = toMaxChunkNumber len + chunks = [1 .. chunkMax] -- | Split the given list in chunks. The length of each chunk, apart from the final one, is taken -- from the first argument. @@ -86,30 +88,31 @@ toChunkFrequencies len -- >>> toChunks [3, 1] "abcdef" -- ["abc","d","ef"] toChunks :: [Int] -> [a] -> [[a]] -toChunks [] xs = [xs] -toChunks (n : ns) xs = chunk : toChunks ns xs' where +toChunks [] xs = [xs] +toChunks (n : ns) xs = chunk : toChunks ns xs' + where (chunk, xs') = splitAt n xs -- | Split a list into the given number of chunks. Concatenating the resulting lists gives back the -- original one. Doesn't generate empty chunks. multiSplit1In :: Int -> [a] -> Gen [NonEmptyList a] -multiSplit1In _ [] = pure [] +multiSplit1In _ [] = pure [] multiSplit1In chunkNum xs = do - let len = length xs - -- Pick a list of breakpoints. - breakpoints <- sublistN (chunkNum - 1) [1 .. len - 1] - -- Turn the list of breakpoints into a list of chunk lengths. - let chunkLens = zipWith (-) breakpoints (0 : breakpoints) - -- Chop the argument into chunks according to the list of chunk lengths. - pure . coerce $ toChunks chunkLens xs + let len = length xs + -- Pick a list of breakpoints. + breakpoints <- sublistN (chunkNum - 1) [1 .. len - 1] + -- Turn the list of breakpoints into a list of chunk lengths. + let chunkLens = zipWith (-) breakpoints (0 : breakpoints) + -- Chop the argument into chunks according to the list of chunk lengths. + pure . coerce $ toChunks chunkLens xs -- | Split a list into chunks at random. Concatenating the resulting lists gives back the original -- one. Doesn't generate empty chunks. multiSplit1 :: [a] -> Gen [NonEmptyList a] multiSplit1 xs = do - -- Pick a number of chunks. - chunkNum <- frequency . map (fmap pure) . toChunkFrequencies $ length xs - multiSplit1In chunkNum xs + -- Pick a number of chunks. + chunkNum <- frequency . map (fmap pure) . toChunkFrequencies $ length xs + multiSplit1In chunkNum xs -- | Return the left and the right halves of the given list. The first argument controls whether -- the middle element of a list having an odd length goes into the left half or the right one. @@ -127,16 +130,18 @@ multiSplit1 xs = do -- >>> halve False [1, 2, 3 :: Int] -- ([1],[2,3]) halve :: Bool -> [a] -> ([a], [a]) -halve isOddToLeft xs0 = go xs0 xs0 where - go (_ : _ : xsFast) (x : xsSlow) = first (x :) $ go xsFast xsSlow - go [_] (x : xsSlow) | isOddToLeft = ([x], xsSlow) - go _ xsSlow = ([], xsSlow) +halve isOddToLeft xs0 = go xs0 xs0 + where + go (_ : _ : xsFast) (x : xsSlow) = first (x :) $ go xsFast xsSlow + go [_] (x : xsSlow) | isOddToLeft = ([x], xsSlow) + go _ xsSlow = ([], xsSlow) -- | Insert a value into a list an arbitrary number of times. The first argument controls whether -- to allow inserting at the beginning of the list, the second argument is the probability of -- inserting an element at the end of the list. insertManyPreferRight :: forall a. Bool -> Double -> a -> [a] -> Gen [a] -insertManyPreferRight keepPrefix lastProb y xs0 = go keepPrefix initWeight xs0 where +insertManyPreferRight keepPrefix lastProb y xs0 = go keepPrefix initWeight xs0 + where -- The weight of the "insert @y@ operation" operation at the beginning of the list. initWeight = 10 -- How more likely we're to insert an element when moving one element forward in the list. @@ -149,21 +154,21 @@ insertManyPreferRight keepPrefix lastProb y xs0 = go keepPrefix initWeight xs0 w go :: Bool -> Double -> [a] -> Gen [a] go keep weight xs = do - doCons <- frequency [(floor weight, pure True), (noopWeight, pure False)] - if doCons - -- If we don't want to insert elements into the head of the list, then we simply ignore - -- the generated one and carry on. Ugly, but works. - then ([y | keep] ++) <$> go keep weight xs - else case xs of - [] -> pure [] - x : xs' -> (x :) <$> go True (weight * scaling) xs' + doCons <- frequency [(floor weight, pure True), (noopWeight, pure False)] + if doCons + -- If we don't want to insert elements into the head of the list, then we simply ignore + -- the generated one and carry on. Ugly, but works. + then ([y | keep] ++) <$> go keep weight xs + else case xs of + [] -> pure [] + x : xs' -> (x :) <$> go True (weight * scaling) xs' -- | Insert a value into a list an arbitrary number of times. The first argument controls whether -- to allow inserting at the end of the list, the second argument is the probability of -- inserting an element at the beginning of the list. insertManyPreferLeft :: Bool -> Double -> a -> [a] -> Gen [a] insertManyPreferLeft keepSuffix headProb y = - fmap reverse . insertManyPreferRight keepSuffix headProb y . reverse + fmap reverse . insertManyPreferRight keepSuffix headProb y . reverse -- | Insert a value into a list an arbitrary number of times. The first argument is the probability -- of inserting an element at an end of the list (i.e. either the beginning or the end, not @@ -174,19 +179,19 @@ insertManyPreferEnds :: Double -> a -> [a] -> Gen [a] -- operations, so that we get a list where additional elements are more likely to occur close to -- the sides. insertManyPreferEnds endProb y xs = do - -- In order not to get skewed results we sometimes put the middle element of the list into its - -- first half and sometimes into its second half. - isOddToLeft <- arbitrary - let (xsL, xsR) = halve isOddToLeft xs - -- If the list has even length, then it was cut into two halves of equal length meaning one slot - -- for to put an element in appears twice: at the end of the left half and at the beginning of - -- the right one. Hence in order to avoid skeweness we don't put anything into this slot at the - -- end of the left half. - -- Maybe we do want to skew generation to favor the middle of the list like we do for its ends, - -- but then we need to do that intentionally and systematically, not randomly and a little bit. - xsL' <- insertManyPreferLeft (length xsL /= length xsR) endProb y xsL - xsR' <- insertManyPreferRight True endProb y xsR - pure $ xsL' ++ xsR' + -- In order not to get skewed results we sometimes put the middle element of the list into its + -- first half and sometimes into its second half. + isOddToLeft <- arbitrary + let (xsL, xsR) = halve isOddToLeft xs + -- If the list has even length, then it was cut into two halves of equal length meaning one slot + -- for to put an element in appears twice: at the end of the left half and at the beginning of + -- the right one. Hence in order to avoid skeweness we don't put anything into this slot at the + -- end of the left half. + -- Maybe we do want to skew generation to favor the middle of the list like we do for its ends, + -- but then we need to do that intentionally and systematically, not randomly and a little bit. + xsL' <- insertManyPreferLeft (length xsL /= length xsR) endProb y xsL + xsR' <- insertManyPreferRight True endProb y xsR + pure $ xsL' ++ xsR' -- | Split a list into chunks at random. Concatenating the resulting lists gives back the original -- one. Generates empty chunks. The first argument is the probability of generating at least one diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Substitutions.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Substitutions.hs index 6b09cd72069..0d8b41b58a2 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Substitutions.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Substitutions.hs @@ -37,39 +37,47 @@ once there's a specific reason to do that. -} -- | The most general substitution worker. -substTypeCustomGo - :: HasCallStack - => Bool -- ^ Nested ('True') or parallel ('False') - -> Set TyName -- ^ Variables that are considered free. - -> TypeSub -- ^ Type substitution to use. - -> Type TyName DefaultUni () -- ^ Type to substitute in. - -> Type TyName DefaultUni () -substTypeCustomGo nested fvs0 = go fvs0 Set.empty where +substTypeCustomGo :: + HasCallStack => + -- | Nested ('True') or parallel ('False') + Bool -> + -- | Variables that are considered free. + Set TyName -> + -- | Type substitution to use. + TypeSub -> + -- | Type to substitute in. + Type TyName DefaultUni () -> + Type TyName DefaultUni () +substTypeCustomGo nested fvs0 = go fvs0 Set.empty + where go fvs seen sub ty = case ty of - TyVar _ x | Set.member x seen -> error "substType' loop" - -- In the case where we do nested substitution we just continue, in parallel substitution - -- we never go below a substitution. - TyVar _ x | nested -> maybe ty (go fvs (Set.insert x seen) sub) $ Map.lookup x sub - | otherwise -> maybe ty id $ Map.lookup x sub - TyFun _ a b -> TyFun () (go fvs seen sub a) (go fvs seen sub b) - TyApp _ a b -> TyApp () (go fvs seen sub a) (go fvs seen sub b) - TyLam _ x k b - | Set.member x fvs -> - -- This 'renameVar' makes the complexity of this function at the very least quadratic. - TyLam () x' k $ go (Set.insert x' fvs) seen sub (renameVar x x' b) - | otherwise -> - TyLam () x k $ go (Set.insert x fvs) (Set.delete x seen) sub b - where x' = freshenTyNameWith (fvs <> setOf ftvTy b) x - TyForall _ x k b - | Set.member x fvs -> - -- This 'renameVar' makes the complexity of this function at the very least quadratic. - TyForall () x' k $ go (Set.insert x' fvs) seen sub (renameVar x x' b) - | otherwise -> - TyForall () x k $ go (Set.insert x fvs) (Set.delete x seen) sub b - where x' = freshenTyNameWith (fvs <> setOf ftvTy b) x - TyBuiltin{} -> ty - TyIFix _ a b -> TyIFix () (go fvs seen sub a) (go fvs seen sub b) - TySOP _ tyls -> TySOP () ((fmap . fmap) (go fvs seen sub) tyls) + TyVar _ x | Set.member x seen -> error "substType' loop" + -- In the case where we do nested substitution we just continue, in parallel substitution + -- we never go below a substitution. + TyVar _ x + | nested -> maybe ty (go fvs (Set.insert x seen) sub) $ Map.lookup x sub + | otherwise -> maybe ty id $ Map.lookup x sub + TyFun _ a b -> TyFun () (go fvs seen sub a) (go fvs seen sub b) + TyApp _ a b -> TyApp () (go fvs seen sub a) (go fvs seen sub b) + TyLam _ x k b + | Set.member x fvs -> + -- This 'renameVar' makes the complexity of this function at the very least quadratic. + TyLam () x' k $ go (Set.insert x' fvs) seen sub (renameVar x x' b) + | otherwise -> + TyLam () x k $ go (Set.insert x fvs) (Set.delete x seen) sub b + where + x' = freshenTyNameWith (fvs <> setOf ftvTy b) x + TyForall _ x k b + | Set.member x fvs -> + -- This 'renameVar' makes the complexity of this function at the very least quadratic. + TyForall () x' k $ go (Set.insert x' fvs) seen sub (renameVar x x' b) + | otherwise -> + TyForall () x k $ go (Set.insert x fvs) (Set.delete x seen) sub b + where + x' = freshenTyNameWith (fvs <> setOf ftvTy b) x + TyBuiltin {} -> ty + TyIFix _ a b -> TyIFix () (go fvs seen sub a) (go fvs seen sub b) + TySOP _ tyls -> TySOP () ((fmap . fmap) (go fvs seen sub) tyls) -- CODE REVIEW: this function is a bit strange and I don't like it. Ideas welcome for how to -- do this better. It basically deals with the fact that we want to be careful when substituting @@ -78,52 +86,58 @@ substTypeCustomGo nested fvs0 = go fvs0 Set.empty where -- This might not be a welcome opinion, but working with this stuff exposes some of -- the shortcomings of the current PIR design. It would be cleaner if a PIR program was a list -- of declarations and datatype declarations weren't in terms. -substEscape :: Set TyName - -> TypeSub - -> Type TyName DefaultUni () - -> Type TyName DefaultUni () +substEscape :: + Set TyName -> + TypeSub -> + Type TyName DefaultUni () -> + Type TyName DefaultUni () substEscape = substTypeCustomGo True -- See Note [Substitution in generators]. + -- | Generalized substitution algorithm. -substTypeCustom - :: HasCallStack - => Bool - -- ^ Nested (True) or parallel (False) - -> TypeSub - -> Type TyName DefaultUni () - -> Type TyName DefaultUni () -substTypeCustom nested sub0 ty0 = substTypeCustomGo nested fvs0 sub0 ty0 where +substTypeCustom :: + HasCallStack => + -- | Nested (True) or parallel (False) + Bool -> + TypeSub -> + Type TyName DefaultUni () -> + Type TyName DefaultUni () +substTypeCustom nested sub0 ty0 = substTypeCustomGo nested fvs0 sub0 ty0 + where fvs0 = Set.unions $ Map.keysSet sub0 : map (setOf ftvTy) (Map.elems sub0) -- See Note [Substitution in generators]. + -- | Regular (i.e. nested type substitution). -substType - :: HasCallStack - => TypeSub - -> Type TyName DefaultUni () - -> Type TyName DefaultUni () +substType :: + HasCallStack => + TypeSub -> + Type TyName DefaultUni () -> + Type TyName DefaultUni () substType = substTypeCustom True -- See Note [Substitution in generators]. + -- | Parallel substitution. -substTypeParallel - :: TypeSub - -> Type TyName DefaultUni () - -> Type TyName DefaultUni () +substTypeParallel :: + TypeSub -> + Type TyName DefaultUni () -> + Type TyName DefaultUni () substTypeParallel = substTypeCustom False -- | Rename one variable to another. renameVar :: TyName -> TyName -> Type TyName DefaultUni () -> Type TyName DefaultUni () renameVar x y - | x == y = id - | otherwise = substType $ Map.singleton x (TyVar () y) + | x == y = id + | otherwise = substType $ Map.singleton x (TyVar () y) -- | Find all free type variables of type `a` given substitution `sub`. If variable `x` is -- free in `a` but in the domain of `sub` we look up `x` in `sub` and get all the free type -- variables of the result - up to the substitution. fvTypeR :: TypeSub -> Type TyName DefaultUni () -> Set TyName -fvTypeR sub = go where +fvTypeR sub = go + where go = foldMap (\v -> maybe (Set.singleton v) go $ Map.lookup v sub) . setOf ftvTy -- * Generators for substitutions @@ -144,27 +158,29 @@ genSubst ctx0 = do -- Counts is used to balance the ratio between the number of times a variable @x@ occurs in the -- substitution and the size of the type it maps to - the more times @x@ occurs the smaller the -- type it maps to needs to be to avoid blowup. - go _ sub _ [] = pure sub + go _ sub _ [] = pure sub go ctx sub counts ((x, k) : xs) = do let - -- @x@ is taken out from the context, because we're going to map it to a type valid in the - -- context without @x@. - ctx' = Map.delete x ctx - -- How many times @x@ occurs in all the so far generated types (the ones that are in the - -- codomain of @sub@). - w = fromMaybe 1 $ Map.lookup x counts - ty <- sized $ \ n -> resize (n `div` w) $ genTypeWithCtx ctx' k - let -- Scale occurrences of all free variables of @ty@ according to how many times @x@ - -- (the variables that is being substituted for) occurs in the so far generated - -- substitution. - moreCounts = fmap (* w) $ fvTypeBag ty - sub' = Map.insert x ty sub - counts' = Map.unionWith (+) counts moreCounts + -- @x@ is taken out from the context, because we're going to map it to a type valid in the + -- context without @x@. + ctx' = Map.delete x ctx + -- How many times @x@ occurs in all the so far generated types (the ones that are in the + -- codomain of @sub@). + w = fromMaybe 1 $ Map.lookup x counts + ty <- sized $ \n -> resize (n `div` w) $ genTypeWithCtx ctx' k + let + -- Scale occurrences of all free variables of @ty@ according to how many times @x@ + -- (the variables that is being substituted for) occurs in the so far generated + -- substitution. + moreCounts = fmap (* w) $ fvTypeBag ty + sub' = Map.insert x ty sub + counts' = Map.unionWith (+) counts moreCounts go ctx' sub' counts' xs shrinkSubst :: TypeCtx -> TypeSub -> [TypeSub] shrinkSubst ctx0 = map Map.fromList . liftShrink shrinkTy . Map.toList where shrinkTy (x, ty) = (,) x <$> shrinkTypeAtKind (pruneCtx ctx0 ty) k ty - where k = fromMaybe (error $ "internal error: " ++ show x ++ " not found") $ Map.lookup x ctx0 + where + k = fromMaybe (error $ "internal error: " ++ show x ++ " not found") $ Map.lookup x ctx0 pruneCtx ctx ty = ctx `Map.restrictKeys` setOf ftvTy ty diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Unification.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Unification.hs index 6cf5107cfb7..b92c3433e5c 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Unification.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Unification.hs @@ -22,23 +22,27 @@ import Data.Set (Set) import Data.Set qualified as Set unificationFailure :: (MonadError String m, Pretty a, Pretty b) => a -> b -> m any -unificationFailure x y = throwError $ concat - [ "Failed to unify\n\n " - , display x - , "\n\nand\n\n " - , display y - , "\n\n" - ] +unificationFailure x y = + throwError $ + concat + [ "Failed to unify\n\n " + , display x + , "\n\nand\n\n " + , display y + , "\n\n" + ] resolutionFailure :: MonadError String m => TyName -> Type TyName DefaultUni () -> String -> m any -resolutionFailure name1 ty2 reason = throwError $ concat - [ "Unification failure: cannot resolve '" - , display name1 - , " as\n\n " - , display ty2 - , "\n\n because " - , reason - ] +resolutionFailure name1 ty2 reason = + throwError $ + concat + [ "Unification failure: cannot resolve '" + , display name1 + , " as\n\n " + , display ty2 + , "\n\n because " + , reason + ] {- Note [The unification algorithm] Type unification expects a context (mapping from type variables to their kinds) and a set of @@ -93,23 +97,26 @@ context, so that's another source of inefficiency. -} -- See Note [The unification algorithm]. + -- | Perform unification. Sound but not complete. -unifyType :: TypeCtx - -- ^ Type context - -> Set TyName - -- ^ @flex@, the flexible variables (those that can be unified) - -> Type TyName DefaultUni () - -- ^ @t1@ - -> Type TyName DefaultUni () - -- ^ @t2@ - -> Either String TypeSub - -- ^ Either an error or a substitution (from a subset of @flex@) unifying @t1@ and @t2@ +unifyType :: + -- | Type context + TypeCtx -> + -- | @flex@, the flexible variables (those that can be unified) + Set TyName -> + -- | @t1@ + Type TyName DefaultUni () -> + -- | @t2@ + Type TyName DefaultUni () -> + -- | Either an error or a substitution (from a subset of @flex@) unifying @t1@ and @t2@ + Either String TypeSub unifyType ctx flex a0 b0 = - execStateT (runReaderT (goType (normalizeTy a0) (normalizeTy b0)) Set.empty) Map.empty + execStateT (runReaderT (goType (normalizeTy a0) (normalizeTy b0)) Set.empty) Map.empty where - goTyName :: TyName - -> Type TyName DefaultUni () - -> ReaderT (Set TyName) (StateT TypeSub (Either String)) () + goTyName :: + TyName -> + Type TyName DefaultUni () -> + ReaderT (Set TyName) (StateT TypeSub (Either String)) () goTyName name1 ty2 = -- If the variable is unified with itself, we don't need to do anything. when (TyVar () name1 /= ty2) $ do @@ -119,7 +126,7 @@ unifyType ctx flex a0 b0 = -- If the meta is already resolved, then look it up in the substitution and continue -- unification. Just ty1' -> goType ty1' ty2 - Nothing -> do + Nothing -> do -- When a meta gets resolved, we do no substitute for all the variables in the solution, -- i.e. the solution can contain variables that themselves are resolved metas. Hence for -- computing the free variables of a type we have to look in the substitution to find @@ -140,9 +147,9 @@ unifyType ctx flex a0 b0 = when (Set.member name1 fvs) $ resolutionFailure name1 ty2 "the variable appears free in the type" -- Cannot resolve a meta to an ill-kinded type. - case checkKind ctx ty2 (Map.findWithDefault (error "impossible") name1 ctx ) of - Left msg -> resolutionFailure name1 ty2 $ "of kind mismatch:\n\n" ++ msg - Right () -> pure () + case checkKind ctx ty2 (Map.findWithDefault (error "impossible") name1 ctx) of + Left msg -> resolutionFailure name1 ty2 $ "of kind mismatch:\n\n" ++ msg + Right () -> pure () -- Cannot capture a locally bound variable. -- Covers situations like @(\x -> _y) =?= (\x -> x)@. -- As naive as the occurs check. @@ -151,35 +158,36 @@ unifyType ctx flex a0 b0 = "the type contains bound variables: " ++ display (Set.toList locals) put $ Map.insert name1 ty2 sub - goType :: Type TyName DefaultUni () - -> Type TyName DefaultUni () - -> ReaderT (Set TyName) (StateT TypeSub (Either String)) () - goType (TyVar _ x) b = goTyName x b - goType a (TyVar _ y) = goTyName y a - goType (TyFun _ a1 a2) (TyFun _ b1 b2) = goType a1 b1 *> goType a2 b2 + goType :: + Type TyName DefaultUni () -> + Type TyName DefaultUni () -> + ReaderT (Set TyName) (StateT TypeSub (Either String)) () + goType (TyVar _ x) b = goTyName x b + goType a (TyVar _ y) = goTyName y a + goType (TyFun _ a1 a2) (TyFun _ b1 b2) = goType a1 b1 *> goType a2 b2 -- This is only structural recursion, because we don't attempt to do higher-order unification. - goType (TyApp _ a1 a2) (TyApp _ b1 b2) = goType a1 b1 *> goType a2 b2 - goType (TyBuiltin _ c1) (TyBuiltin _ c2) = when (c1 /= c2) $ unificationFailure c1 c2 - goType (TyIFix _ a1 a2) (TyIFix _ b1 b2) = goType a1 b1 *> goType a2 b2 + goType (TyApp _ a1 a2) (TyApp _ b1 b2) = goType a1 b1 *> goType a2 b2 + goType (TyBuiltin _ c1) (TyBuiltin _ c2) = when (c1 /= c2) $ unificationFailure c1 c2 + goType (TyIFix _ a1 a2) (TyIFix _ b1 b2) = goType a1 b1 *> goType a2 b2 goType (TyForall _ x k a') (TyForall _ y l b') = do when (k /= l) $ unificationFailure k l locals <- ask -- See Note [Renaming during unification]. let z = freshenTyNameWith (locals <> Map.keysSet ctx) x local (Set.insert z) $ goType (renameVar x z a') (renameVar y z b') - goType (TyLam _ x k a') (TyLam _ y l b') = do + goType (TyLam _ x k a') (TyLam _ y l b') = do when (k /= l) $ unificationFailure k l locals <- ask -- See Note [Renaming during unification]. let z = freshenTyNameWith (locals <> Map.keysSet ctx) x local (Set.insert z) $ goType (renameVar x z a') (renameVar y z b') goType (TySOP _ sum1) (TySOP _ sum2) - -- Sums must be of the same arity. - | Just sum12 <- zipExact sum1 sum2 - = for_ sum12 $ \(prod1, prod2) -> do + -- Sums must be of the same arity. + | Just sum12 <- zipExact sum1 sum2 = + for_ sum12 $ \(prod1, prod2) -> do -- Products within sums must be of the same arity. case zipExact prod1 prod2 of - Nothing -> unificationFailure prod1 prod2 - -- SOPs unify componentwise. - Just prod12 -> traverse_ (uncurry goType) prod12 + Nothing -> unificationFailure prod1 prod2 + -- SOPs unify componentwise. + Just prod12 -> traverse_ (uncurry goType) prod12 goType a b = unificationFailure a b diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs index 8fda3b95806..27984b28302 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} -module PlutusCore.Generators.QuickCheck.Utils - ( module PlutusCore.Generators.QuickCheck.Utils - , module Export - ) where +module PlutusCore.Generators.QuickCheck.Utils ( + module PlutusCore.Generators.QuickCheck.Utils, + module Export, +) where import PlutusCore.Default import PlutusCore.Generators.QuickCheck.Split as Export @@ -28,12 +28,13 @@ import Test.QuickCheck -- | Generate a list of the given length, all arguments of which are distinct. Takes O(n^2) time -- or more if the generator is likely to generate equal values. uniqueVectorOf :: Eq a => Int -> Gen a -> Gen [a] -uniqueVectorOf i0 genX = go [] i0 where +uniqueVectorOf i0 genX = go [] i0 + where go acc i - | i <= 0 = pure acc - | otherwise = do - x <- genX `suchThat` (`notElem` acc) - go (x : acc) (i - 1) + | i <= 0 = pure acc + | otherwise = do + x <- genX `suchThat` (`notElem` acc) + go (x : acc) (i - 1) -- | Show a `Doc` when a property fails. ceDoc :: Testable t => Doc ann -> t -> Property @@ -42,30 +43,33 @@ ceDoc d = counterexample (render d) -- | Bind a value to a name in a property so that -- it is displayed as a `name = thing` binding if the -- property fails. -letCE :: (PrettyReadable a, Testable p) - => String - -> a - -> (a -> p) - -> Property +letCE :: + (PrettyReadable a, Testable p) => + String -> + a -> + (a -> p) -> + Property letCE name x k = ceDoc (fromString name <+> "=" <+> prettyReadable x) (k x) -- | Like `forAllShrink` but displays the bound value as -- a named pretty-printed binding like `letCE` -forAllDoc :: (PrettyReadable a, Testable p) - => String - -> Gen a - -> (a -> [a]) - -> (a -> p) - -> Property +forAllDoc :: + (PrettyReadable a, Testable p) => + String -> + Gen a -> + (a -> [a]) -> + (a -> p) -> + Property forAllDoc name g shr k = - forAllShrinkBlind g shr $ \ x -> - ceDoc (fromString name <+> "=" <+> prettyReadable x) - (k x) + forAllShrinkBlind g shr $ \x -> + ceDoc + (fromString name <+> "=" <+> prettyReadable x) + (k x) -- | Check that a list of potential counterexamples is empty and display the -- list as a QuickCheck counterexample if its not. -assertNoCounterexamples :: (PrettyReadable a) => [a] -> Property -assertNoCounterexamples [] = property True +assertNoCounterexamples :: PrettyReadable a => [a] -> Property +assertNoCounterexamples [] = property True assertNoCounterexamples bad = ceDoc (prettyReadable bad) False -- * Containers (zipper-ish, very useful for shrinking). @@ -75,12 +79,15 @@ assertNoCounterexamples bad = ceDoc (prettyReadable bad) False -- easier to roll out our own version than to dig through the generics in that library. Plus, the -- library has multiple interfaces looking slightly different and it's not immediately clear how -- they relate to each other. + -- | A type is a container for the purposes of shrinking if it has: class Container f where data OneHoleContext f :: GHC.Type -> GHC.Type -- ^ One hole context where we can shrink a single "element" of the container + oneHoleContexts :: f a -> [(OneHoleContext f a, a)] -- ^ A way of getting all the one hole contexts of an `f a` + plugHole :: OneHoleContext f a -> a -> f a -- ^ A way to plug the hole with a new, shrunk, term @@ -89,11 +96,11 @@ instance Container [] where data OneHoleContext [] a = ListContext [a] [a] oneHoleContexts [] = [] - oneHoleContexts (x : xs) - = (ListContext [] xs, x) - : [ (ListContext (x : ys) zs, y) - | (ListContext ys zs, y) <- oneHoleContexts xs - ] + oneHoleContexts (x : xs) = + (ListContext [] xs, x) + : [ (ListContext (x : ys) zs, y) + | (ListContext ys zs, y) <- oneHoleContexts xs + ] plugHole (ListContext xs ys) z = xs ++ [z] ++ ys @@ -101,38 +108,41 @@ instance Container [] where instance Container NonEmpty where data OneHoleContext NonEmpty a = NonEmptyContext [a] [a] - oneHoleContexts (x :| xs) - = (NonEmptyContext [] xs, x) - : [ (NonEmptyContext (x : ys) zs, y) - | (ListContext ys zs, y) <- oneHoleContexts xs - ] + oneHoleContexts (x :| xs) = + (NonEmptyContext [] xs, x) + : [ (NonEmptyContext (x : ys) zs, y) + | (ListContext ys zs, y) <- oneHoleContexts xs + ] - plugHole (NonEmptyContext [] ys) z = z :| ys + plugHole (NonEmptyContext [] ys) z = z :| ys plugHole (NonEmptyContext (x : xs) ys) z = x :| xs ++ [z] ++ ys -- Note that this doesn't have any relation to 'freshenTyName'. Both functions change the unique, -- but do it in incomparably different ways. + -- | Freshen a TyName so that it does not equal any of the names in the set. freshenTyNameWith :: Set TyName -> TyName -> TyName -freshenTyNameWith fvs (TyName (Name x j)) = TyName (Name x i) where - i = succ $ Set.findMax is - is = Set.insert j $ Set.insert (toEnum 0) $ Set.mapMonotonic (_nameUnique . unTyName) fvs +freshenTyNameWith fvs (TyName (Name x j)) = TyName (Name x i) + where + i = succ $ Set.findMax is + is = Set.insert j $ Set.insert (toEnum 0) $ Set.mapMonotonic (_nameUnique . unTyName) fvs maxUsedUnique :: Set TyName -> Unique maxUsedUnique fvs = i where - i = Set.findMax is + i = Set.findMax is is = Set.insert (toEnum 0) $ Set.mapMonotonic (_nameUnique . unTyName) fvs -- | Get the names and types of the constructors of a datatype. constrTypes :: Datatype TyName Name DefaultUni () -> [(Name, Type TyName DefaultUni ())] -constrTypes (Datatype _ _ xs _ cs) = [ (c, mkIterTyForall xs ty) | VarDecl _ c ty <- cs ] +constrTypes (Datatype _ _ xs _ cs) = [(c, mkIterTyForall xs ty) | VarDecl _ c ty <- cs] -- | Get the name and type of the match function for a given datatype. matchType :: Datatype TyName Name DefaultUni () -> (Name, Type TyName DefaultUni ()) matchType d@(Datatype _ (TyVarDecl _ a _) xs m cs) = (m, destrTy) where - fvs = Set.fromList (a : [x | TyVarDecl _ x _ <- xs]) <> - mconcat [setOf ftvTy ty | VarDecl _ _ ty <- cs] + fvs = + Set.fromList (a : [x | TyVarDecl _ x _ <- xs]) + <> mconcat [setOf ftvTy ty | VarDecl _ _ ty <- cs] maxUsed = maxUsedUnique fvs destrTy = runQuote $ markNonFresh maxUsed >> mkDestructorTy d diff --git a/plutus-core/testlib/PlutusCore/Test.hs b/plutus-core/testlib/PlutusCore/Test.hs index 0cec4680237..519c3260fe4 100644 --- a/plutus-core/testlib/PlutusCore/Test.hs +++ b/plutus-core/testlib/PlutusCore/Test.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module PlutusCore.Test ( @@ -55,6 +54,7 @@ module PlutusCore.Test ( test_scopingGood, test_scopingBad, test_scopingSpoilRenamer, + -- * Tasty extras module TastyExtras, ) where @@ -98,8 +98,8 @@ import Prettyprinter qualified as PP import System.IO.Unsafe import Test.Tasty hiding (after) import Test.Tasty.Extras as TastyExtras -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog import Universe -- | Map the 'TestLimit' of a 'Property' with a given function. @@ -108,28 +108,25 @@ mapTestLimit f = mapConfig $ \config -> config { propertyTerminationCriteria = case propertyTerminationCriteria config of - NoEarlyTermination c tests -> NoEarlyTermination c $ f tests + NoEarlyTermination c tests -> NoEarlyTermination c $ f tests NoConfidenceTermination tests -> NoConfidenceTermination $ f tests - EarlyTermination c tests -> EarlyTermination c $ f tests + EarlyTermination c tests -> EarlyTermination c $ f tests } -{- | Set the number of times a property should be executed before it is considered successful, -unless it's already higher than that. --} +-- | Set the number of times a property should be executed before it is considered successful, +-- unless it's already higher than that. withAtLeastTests :: TestLimit -> Property -> Property withAtLeastTests = mapTestLimit . max -{- | Set the number of times a property should be executed before it is considered successful, -unless the given function scales it higher than that. --} +-- | Set the number of times a property should be executed before it is considered successful, +-- unless the given function scales it higher than that. mapTestLimitAtLeast :: TestLimit -> (TestLimit -> TestLimit) -> Property -> Property mapTestLimitAtLeast n f = withAtLeastTests n . mapTestLimit f -{- | @check@ is supposed to just check if the property fails or not, but for some stupid reason it -also performs shrinking and prints the counterexample and other junk. This function is like -@check@, but doesn't do any of that. --} -checkQuiet :: (MonadIO m) => Property -> m Bool +-- | @check@ is supposed to just check if the property fails or not, but for some stupid reason it +-- also performs shrinking and prints the counterexample and other junk. This function is like +-- @check@, but doesn't do any of that. +checkQuiet :: MonadIO m => Property -> m Bool checkQuiet prop = do color <- detectColor -- This is what causes @hedgehog@ to shut up. @@ -150,7 +147,8 @@ checkFails = checkQuiet . withAtLeastTests 100000 >=> \res -> res @?= False -- G1, G2 elements etc can be printed but not serialised, but here for simplicity we just assume -- that all unserialisable terms are unprintable too. isSerialisable :: Some (ValueOf TPLC.DefaultUni) -> Bool -isSerialisable (Some (ValueOf uni0 x0)) = go uni0 x0 where +isSerialisable (Some (ValueOf uni0 x0)) = go uni0 x0 + where go :: TPLC.DefaultUni (TPLC.Esc a) -> a -> Bool go TPLC.DefaultUniInteger _ = True go TPLC.DefaultUniByteString _ = True @@ -160,22 +158,21 @@ isSerialisable (Some (ValueOf uni0 x0)) = go uni0 x0 where go (TPLC.DefaultUniProtoList `TPLC.DefaultUniApply` uniA) xs = all (go uniA) xs go (TPLC.DefaultUniProtoArray `TPLC.DefaultUniApply` uniA) xs = all (go uniA) xs go (TPLC.DefaultUniProtoPair `TPLC.DefaultUniApply` uniA `TPLC.DefaultUniApply` uniB) (x, y) = - go uniA x && go uniB y + go uniA x && go uniB y go (f `TPLC.DefaultUniApply` _ `TPLC.DefaultUniApply` _ `TPLC.DefaultUniApply` _) _ = - noMoreTypeFunctions f + noMoreTypeFunctions f go TPLC.DefaultUniData _ = True go TPLC.DefaultUniValue _ = True go TPLC.DefaultUniBLS12_381_G1_Element _ = False go TPLC.DefaultUniBLS12_381_G2_Element _ = False go TPLC.DefaultUniBLS12_381_MlResult _ = False -{- | Class for ad-hoc overloading of things which can be turned into a PLC program. Any errors -from the process should be caught. --} +-- | Class for ad-hoc overloading of things which can be turned into a PLC program. Any errors +-- from the process should be caught. class ToTPlc a uni fun | a -> uni fun where toTPlc :: a -> ExceptT SomeException IO (TPLC.Program TPLC.TyName TPLC.Name uni fun ()) -instance (ToTPlc a uni fun) => ToTPlc (ExceptT SomeException IO a) uni fun where +instance ToTPlc a uni fun => ToTPlc (ExceptT SomeException IO a) uni fun where toTPlc a = a >>= toTPlc instance ToTPlc (TPLC.Program TPLC.TyName TPLC.Name uni fun ()) uni fun where @@ -184,7 +181,7 @@ instance ToTPlc (TPLC.Program TPLC.TyName TPLC.Name uni fun ()) uni fun where class ToUPlc a uni fun | a -> uni fun where toUPlc :: a -> ExceptT SomeException IO (UPLC.Program TPLC.Name uni fun ()) -instance (ToUPlc a uni fun) => ToUPlc (ExceptT SomeException IO a) uni fun where +instance ToUPlc a uni fun => ToUPlc (ExceptT SomeException IO a) uni fun where toUPlc a = a >>= toUPlc instance ToUPlc (UPLC.Program TPLC.Name uni fun ()) uni fun where @@ -194,9 +191,12 @@ instance ( TPLC.Typecheckable uni fun , CaseBuiltin uni , Hashable fun - , TPLC.GEq uni, TPLC.Closed uni, TPLC.Everywhere uni Eq - ) - => ToUPlc (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) uni fun where + , TPLC.GEq uni + , TPLC.Closed uni + , TPLC.Everywhere uni Eq + ) => + ToUPlc (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) uni fun + where toUPlc = pure . TPLC.runQuote @@ -212,7 +212,7 @@ instance ToUPlc (UPLC.Program UPLC.NamedDeBruijn uni fun ()) uni fun where UPLC.unDeBruijnTerm p -pureTry :: (Exception e) => a -> Either e a +pureTry :: Exception e => a -> Either e a pureTry = unsafePerformIO . try . evaluate catchAll :: a -> ExceptT SomeException IO a @@ -222,7 +222,7 @@ rethrow :: ExceptT SomeException IO a -> IO a rethrow = fmap unsafeFromEither . runExceptT runTPlc :: - (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) => + ToTPlc a TPLC.DefaultUni TPLC.DefaultFun => [a] -> ExceptT SomeException @@ -238,27 +238,32 @@ runTPlc values = do TPLC.evaluateCkNoEmit TPLC.defaultBuiltinsRuntimeForTesting def t -- | An evaluation failure plus the final budget and logs. -data EvaluationExceptionWithLogsAndBudget err = - EvaluationExceptionWithLogsAndBudget err TPLC.ExBudget [Text] +data EvaluationExceptionWithLogsAndBudget err + = EvaluationExceptionWithLogsAndBudget err TPLC.ExBudget [Text] -instance (PrettyBy config err) - => PrettyBy config (EvaluationExceptionWithLogsAndBudget err) where +instance + PrettyBy config err => + PrettyBy config (EvaluationExceptionWithLogsAndBudget err) + where prettyBy config (EvaluationExceptionWithLogsAndBudget err budget logs) = PP.vsep - [ prettyBy config err - , "Final budget:" PP.<+> PP.pretty budget - , "Logs:" PP.<+> PP.vsep (fmap PP.pretty logs) - ] + [ prettyBy config err + , "Final budget:" PP.<+> PP.pretty budget + , "Logs:" PP.<+> PP.vsep (fmap PP.pretty logs) + ] -instance (PrettyPlc err) - => Show (EvaluationExceptionWithLogsAndBudget err) where - show = render . prettyPlcReadableSimple +instance + PrettyPlc err => + Show (EvaluationExceptionWithLogsAndBudget err) + where + show = render . prettyPlcReadableSimple -instance (PrettyPlc err, Exception err) - => Exception (EvaluationExceptionWithLogsAndBudget err) +instance + (PrettyPlc err, Exception err) => + Exception (EvaluationExceptionWithLogsAndBudget err) runUPlcFull :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => + ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => [a] -> ExceptT SomeException @@ -270,11 +275,11 @@ runUPlcFull values = do UPLC.CekReport (UPLC.cekResultToEither -> res) (UPLC.CountingSt budget) logs = UPLC.runCek TPLC.defaultCekParametersForTesting UPLC.counting UPLC.logEmitter t case res of - Left err -> throwError (SomeException $ EvaluationExceptionWithLogsAndBudget err budget logs) + Left err -> throwError (SomeException $ EvaluationExceptionWithLogsAndBudget err budget logs) Right resT -> pure (resT, budget, logs) runUPlc :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => + ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => [a] -> ExceptT SomeException @@ -285,7 +290,7 @@ runUPlc values = do pure t runUPlcBudget :: - (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) => + ToUPlc a TPLC.DefaultUni UPLC.DefaultFun => [a] -> ExceptT SomeException @@ -296,7 +301,7 @@ runUPlcBudget values = do pure budget runUPlcLogs :: - (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) => + ToUPlc a TPLC.DefaultUni UPLC.DefaultFun => [a] -> ExceptT SomeException @@ -307,7 +312,7 @@ runUPlcLogs values = do pure logs runUPlcProfile :: - (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) => + ToUPlc a TPLC.DefaultUni UPLC.DefaultFun => [a] -> ExceptT SomeException @@ -322,10 +327,10 @@ runUPlcProfile values = do UPLC.runCek TPLC.defaultCekParametersForTesting UPLC.counting UPLC.logWithTimeEmitter t case res of Left err -> throwError (SomeException $ EvaluationExceptionWithLogsAndBudget err budget logs) - Right _ -> pure logs + Right _ -> pure logs runUPlcProfile' :: - (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) => + ToUPlc a TPLC.DefaultUni UPLC.DefaultFun => [a] -> ExceptT SomeException @@ -340,25 +345,25 @@ runUPlcProfile' values = do UPLC.runCek TPLC.defaultCekParametersForTesting UPLC.counting UPLC.logWithBudgetEmitter t case res of Left err -> throwError (SomeException err) - Right _ -> pure logs + Right _ -> pure logs -ppCatch :: (PrettyPlc a) => ExceptT SomeException IO a -> IO (Doc ann) +ppCatch :: PrettyPlc a => ExceptT SomeException IO a -> IO (Doc ann) ppCatch value = either (PP.prettyClassic . show) prettyPlcReadableSimple <$> runExceptT value ppCatch' :: ExceptT SomeException IO (Doc ann) -> IO (Doc ann) ppCatch' value = either (PP.prettyClassic . show) id <$> runExceptT value -ppCatchReadable - :: forall a ann - . PrettyBy (PrettyConfigReadable PrettyConfigName) a - => ExceptT SomeException IO a -> IO (Doc ann) +ppCatchReadable :: + forall a ann. + PrettyBy (PrettyConfigReadable PrettyConfigName) a => + ExceptT SomeException IO a -> IO (Doc ann) ppCatchReadable value = let pprint :: forall t. PrettyBy (PrettyConfigReadable PrettyConfigName) t => t -> Doc ann pprint = prettyBy (topPrettyConfigReadable prettyConfigNameSimple def) in either (pprint . show) pprint <$> runExceptT value goldenTPlcWith :: - (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) => + ToTPlc a TPLC.DefaultUni TPLC.DefaultFun => ( ExceptT SomeException IO @@ -373,21 +378,21 @@ goldenTPlcWith pp name value = nestedGoldenVsDocM name ".tplc" $ pp $ do withExceptT @_ @FreeVariableError toException $ traverseOf TPLC.progTerm deBruijnTerm p goldenTPlc :: - (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) => + ToTPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> a -> TestNested goldenTPlc = goldenTPlcWith ppCatch goldenTPlcReadable :: - (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) => + ToTPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> a -> TestNested goldenTPlcReadable = goldenTPlcWith ppCatchReadable goldenUPlcWith :: - (ToUPlc a UPLC.DefaultUni UPLC.DefaultFun) => + ToUPlc a UPLC.DefaultUni UPLC.DefaultFun => ( ExceptT SomeException IO @@ -402,53 +407,55 @@ goldenUPlcWith pp name value = nestedGoldenVsDocM name ".uplc" $ pp $ do withExceptT @_ @FreeVariableError toException $ traverseOf UPLC.progTerm UPLC.deBruijnTerm p goldenUPlc :: - (ToUPlc a UPLC.DefaultUni UPLC.DefaultFun) => + ToUPlc a UPLC.DefaultUni UPLC.DefaultFun => TestName -> a -> TestNested goldenUPlc = goldenUPlcWith ppCatch goldenUPlcReadable :: - (ToUPlc a UPLC.DefaultUni UPLC.DefaultFun) => + ToUPlc a UPLC.DefaultUni UPLC.DefaultFun => TestName -> a -> TestNested goldenUPlcReadable = goldenUPlcWith ppCatchReadable goldenTEval :: - (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) => + ToTPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested goldenTEval name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runTPlc values -goldenUEval :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => TestName -> [a] -> TestNested +goldenUEval :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested goldenUEval name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlc values -goldenUEvalLogs :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => TestName -> [a] -> TestNested +goldenUEvalLogs :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested goldenUEvalLogs name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcLogs values -- | This is mostly useful for profiling a test that is normally -- tested with one of the other functions, as it's a drop-in -- replacement and you can then pass the output into `traceToStacks`. -goldenUEvalProfile :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => TestName -> [a] -> TestNested +goldenUEvalProfile :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested goldenUEvalProfile name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcProfile values -goldenUEvalBudget :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => TestName -> [a] -> TestNested +goldenUEvalBudget :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested goldenUEvalBudget name values = nestedGoldenVsDocM name ".budget" $ ppCatch $ runUPlcBudget values -goldenAstSize :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => TestName -> a -> TestNested +goldenAstSize :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> a -> TestNested goldenAstSize name value = nestedGoldenVsDocM name ".astsize" $ pure . pretty . UPLC.programAstSize =<< rethrow (toUPlc value) -- | This is mostly useful for profiling a test that is normally -- tested with one of the other functions, as it's a drop-in -- replacement and you can then pass the output into `traceToStacks`. -goldenUEvalProfile' :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => TestName -> [a] -> TestNested +goldenUEvalProfile' :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested goldenUEvalProfile' name values = - nestedGoldenVsDocM name ".eval" $ ppCatch' $ - fmap (\ts -> PP.vsep (fmap pretty ts)) $ runUPlcProfile' values + nestedGoldenVsDocM name ".eval" $ + ppCatch' $ + fmap (\ts -> PP.vsep (fmap pretty ts)) $ + runUPlcProfile' values -- | A made-up `SrcSpan` for testing. initialSrcSpan :: FilePath -> SrcSpan @@ -461,10 +468,10 @@ topSrcSpan = initialSrcSpan "top" -- Normally in the compiler we use Provenance, which adds them, but -- we add slightly sketchy instances for SrcSpan here for convenience instance Semigroup TPLC.SrcSpan where - sp1 <> _ = sp1 + sp1 <> _ = sp1 instance Monoid TPLC.SrcSpan where - mempty = initialSrcSpan "" + mempty = initialSrcSpan "" -- See Note [Marking]. @@ -482,7 +489,7 @@ newtype NoMarkRenameT ren m a = NoMarkRenameT ) noMarkRename :: - (Monoid ren) => + Monoid ren => (t -> NoMarkRenameT ren m t) -> t -> m t @@ -505,16 +512,15 @@ instance (Monad m, Monoid ren) => MonadReader ren (NoRenameT ren m) where local _ = id noRename :: - (TPLC.MonadQuote m) => + TPLC.MonadQuote m => (t -> m ()) -> (t -> NoRenameT ren m t) -> t -> m t noRename mark renM = through mark >=> unNoRenameT . renM -{- | A broken version of 'RenameT' whose 'local' updates the scope globally -(as opposed to locally). --} +-- | A broken version of 'RenameT' whose 'local' updates the scope globally +-- (as opposed to locally). newtype BrokenRenameT ren m a = BrokenRenameT { unBrokenRenameT :: StateT ren m a } @@ -527,7 +533,7 @@ newtype BrokenRenameT ren m a = BrokenRenameT , TPLC.MonadQuote ) -instance (Monad m) => MonadReader ren (BrokenRenameT ren m) where +instance Monad m => MonadReader ren (BrokenRenameT ren m) where ask = get local f a = modify f *> a @@ -587,13 +593,13 @@ something wrong with the pass or it's just a limitation of the scoping tests. -- | Determines whether to perform renaming before running the scoping tests. Needed for passes that -- don't perform renaming themselves. -data Prerename = - PrerenameYes | - PrerenameNo +data Prerename + = PrerenameYes + | PrerenameNo runPrerename :: TPLC.Rename a => Prerename -> a -> a runPrerename PrerenameYes = TPLC.runQuote . TPLC.rename -runPrerename PrerenameNo = id +runPrerename PrerenameNo = id -- | Test scoping for a renamer. prop_scopingFor :: @@ -611,11 +617,12 @@ prop_scopingFor :: Property prop_scopingFor gen bindRem preren run = withTests 200 . property $ do prog <- forAllNoShow $ runAstGen gen - let -- TODO: use @enclosed-exceptions@. - catchEverything = unsafePerformIO . try @SomeException . evaluate - prep = runPrerename preren + let + -- TODO: use @enclosed-exceptions@. + catchEverything = unsafePerformIO . try @SomeException . evaluate + prep = runPrerename preren case catchEverything $ checkRespectsScoping bindRem prep (TPLC.runQuote . run) prog of - Left exc -> fail $ displayException exc + Left exc -> fail $ displayException exc Right (Left err) -> fail $ displayPlc err Right (Right ()) -> success diff --git a/plutus-core/testlib/PlutusIR/Generators/AST.hs b/plutus-core/testlib/PlutusIR/Generators/AST.hs index f8b4c56e4b7..c38fe1429f9 100644 --- a/plutus-core/testlib/PlutusIR/Generators/AST.hs +++ b/plutus-core/testlib/PlutusIR/Generators/AST.hs @@ -1,26 +1,34 @@ -- editorconfig-checker-disable-file +{-# LANGUAGE OverloadedStrings #-} + -- | This module defines generators for PIR syntax trees for testing purposes. -- It should only contain those generators that can't be reused from PLC -- (PIR-exclusive constructs, Term, and Program) -{-# LANGUAGE OverloadedStrings #-} -module PlutusIR.Generators.AST - ( module Export - , regenConstantsUntil - , genProgram - , genTerm - , genBinding - , genDatatype - , genTyVarDecl - , genVarDecl - , genRecursivity - ) where +module PlutusIR.Generators.AST ( + module Export, + regenConstantsUntil, + genProgram, + genTerm, + genBinding, + genDatatype, + genTyVarDecl, + genVarDecl, + genRecursivity, +) where import PlutusIR import PlutusIR.Subst import PlutusCore.Default qualified as PLC -import PlutusCore.Generators.Hedgehog.AST as Export (AstGen, genBuiltin, genConstant, genKind, - genVersion, runAstGen, simpleRecursive) +import PlutusCore.Generators.Hedgehog.AST as Export ( + AstGen, + genBuiltin, + genConstant, + genKind, + genVersion, + runAstGen, + simpleRecursive, + ) import PlutusCore.Generators.Hedgehog.AST qualified as PLC import Hedgehog hiding (Rec, Var) @@ -28,23 +36,29 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Universe -regenConstantsUntil - :: MonadGen m - => (Some (ValueOf PLC.DefaultUni) -> Bool) - -> Program tyname name PLC.DefaultUni fun ann - -> m (Program tyname name PLC.DefaultUni fun ann) +regenConstantsUntil :: + MonadGen m => + (Some (ValueOf PLC.DefaultUni) -> Bool) -> + Program tyname name PLC.DefaultUni fun ann -> + m (Program tyname name PLC.DefaultUni fun ann) regenConstantsUntil p = - progTerm . termSubstConstantsM $ \ann -> fmap (fmap $ Constant ann) . PLC.regenConstantUntil p + progTerm . termSubstConstantsM $ \ann -> fmap (fmap $ Constant ann) . PLC.regenConstantUntil p genName :: PLC.AstGen Name -genName = Gen.filterT (not . isPirKw . _nameText) PLC.genName where - isPirKw name = name `elem` - [ "vardecl", "typedecl" - , "let" - , "nonrec", "rec" - , "termbind", "typebind", "datatypebind" - , "datatype" - ] +genName = Gen.filterT (not . isPirKw . _nameText) PLC.genName + where + isPirKw name = + name + `elem` [ "vardecl" + , "typedecl" + , "let" + , "nonrec" + , "rec" + , "termbind" + , "typebind" + , "datatypebind" + , "datatype" + ] genTyName :: PLC.AstGen TyName genTyName = TyName <$> genName @@ -63,16 +77,19 @@ genTyVarDecl = TyVarDecl () <$> genTyName <*> genKind genDatatype :: PLC.AstGen (Datatype TyName Name PLC.DefaultUni ()) genDatatype = Datatype () <$> genTyVarDecl <*> listOf genTyVarDecl <*> genName <*> listOf genVarDecl - where listOf = Gen.list (Range.linear 0 10) + where + listOf = Gen.list (Range.linear 0 10) genBinding :: PLC.AstGen (Binding TyName Name PLC.DefaultUni PLC.DefaultFun ()) -genBinding = Gen.choice [genTermBind, genTypeBind, genDatatypeBind] where +genBinding = Gen.choice [genTermBind, genTypeBind, genDatatypeBind] + where genTermBind = TermBind () <$> genStrictness <*> genVarDecl <*> genTerm genTypeBind = TypeBind () <$> genTyVarDecl <*> genType genDatatypeBind = DatatypeBind () <$> genDatatype genType :: PLC.AstGen (Type TyName PLC.DefaultUni ()) -genType = simpleRecursive nonRecursive recursive where +genType = simpleRecursive nonRecursive recursive + where varGen = TyVar () <$> genTyName funGen = TyFun () <$> genType <*> genType lamGen = TyLam () <$> genTyName <*> genKind <*> genType @@ -83,7 +100,8 @@ genType = simpleRecursive nonRecursive recursive where nonRecursive = [varGen, lamGen, forallGen] genTerm :: PLC.AstGen (Term TyName Name PLC.DefaultUni PLC.DefaultFun ()) -genTerm = simpleRecursive nonRecursive recursive where +genTerm = simpleRecursive nonRecursive recursive + where varGen = Var () <$> genName absGen = TyAbs () <$> genTyName <*> genKind <*> genTerm instGen = TyInst () <$> genTerm <*> genType diff --git a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/Common.hs b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/Common.hs index 0a1e34fa556..6f4e0499220 100644 --- a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/Common.hs +++ b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/Common.hs @@ -26,49 +26,51 @@ import Data.Map.Strict qualified as Map import Data.Set.Lens (setOf) -- | Compute the datatype declarations that escape from a term. -datatypes :: Term TyName Name DefaultUni DefaultFun () - -> [(TyName, (Kind ()))] +datatypes :: + Term TyName Name DefaultUni DefaultFun () -> + [(TyName, (Kind ()))] datatypes tm = case tm of - Var _ _ -> mempty - Builtin _ _ -> mempty - Constant _ _ -> mempty - Apply _ _ _ -> mempty - LamAbs _ _ _ tm' -> datatypes tm' - TyAbs _ _ _ tm' -> datatypes tm' - TyInst _ _ _ -> mempty + Var _ _ -> mempty + Builtin _ _ -> mempty + Constant _ _ -> mempty + Apply _ _ _ -> mempty + LamAbs _ _ _ tm' -> datatypes tm' + TyAbs _ _ _ tm' -> datatypes tm' + TyInst _ _ _ -> mempty Let _ _ binds tm' -> foldr addDatatype (datatypes tm') binds where - addDatatype (DatatypeBind _ (Datatype _ (TyVarDecl _ a k) _ _ _)) = ((a, k):) - addDatatype _ = id + addDatatype (DatatypeBind _ (Datatype _ (TyVarDecl _ a k) _ _ _)) = ((a, k) :) + addDatatype _ = id Error _ _ -> mempty _ -> error "nope" -- | Try to infer the type of an expression in a given type and term context. -- NOTE: one can't just use out-of-the-box type inference here because the -- `inferType` algorithm happy renames things. -inferTypeInContext :: TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> Term TyName Name DefaultUni DefaultFun () - -> Either String (Type TyName DefaultUni ()) -inferTypeInContext tyctx ctx tm0 = first display - $ runQuoteT @(Either (Error DefaultUni DefaultFun ())) $ do - -- CODE REVIEW: this algorithm is fragile, it relies on knowing that `inferType` - -- does renaming to compute the `esc` substitution for datatypes. However, there is also - -- not any other way to do this in a way that makes type inference actually useful - you - -- want to do type inference in non-top-level contexts. Ideally I think type inference - -- probably shouldn't do renaming of datatypes... Or alternatively we need to ensure that - -- the renaming behaviour of type inference is documented and maintained. - cfg <- modifyError (PLCError . PLC.TypeErrorE) $ getDefTypeCheckConfig () - -- Infer the type of `tm` by adding the contexts as (type and term) lambdas - Normalized _ty' <- inferType cfg tm' - -- Substitute the free variables and escaping datatypes to get back to the un-renamed type. - let ty' = substEscape (Map.keysSet esc <> foldr (<>) (setOf ftvTy _ty') (setOf ftvTy <$> esc)) esc _ty' -- yuck - -- Get rid of the stuff we had to add for the context. - return $ stripFuns tms $ stripForalls mempty tys ty' +inferTypeInContext :: + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + Term TyName Name DefaultUni DefaultFun () -> + Either String (Type TyName DefaultUni ()) +inferTypeInContext tyctx ctx tm0 = first display $ + runQuoteT @(Either (Error DefaultUni DefaultFun ())) $ do + -- CODE REVIEW: this algorithm is fragile, it relies on knowing that `inferType` + -- does renaming to compute the `esc` substitution for datatypes. However, there is also + -- not any other way to do this in a way that makes type inference actually useful - you + -- want to do type inference in non-top-level contexts. Ideally I think type inference + -- probably shouldn't do renaming of datatypes... Or alternatively we need to ensure that + -- the renaming behaviour of type inference is documented and maintained. + cfg <- modifyError (PLCError . PLC.TypeErrorE) $ getDefTypeCheckConfig () + -- Infer the type of `tm` by adding the contexts as (type and term) lambdas + Normalized _ty' <- inferType cfg tm' + -- Substitute the free variables and escaping datatypes to get back to the un-renamed type. + let ty' = substEscape (Map.keysSet esc <> foldr (<>) (setOf ftvTy _ty') (setOf ftvTy <$> esc)) esc _ty' -- yuck + -- Get rid of the stuff we had to add for the context. + return $ stripFuns tms $ stripForalls mempty tys ty' where tm' = addTyLams tys $ addLams tms tm0 rntm = case runQuoteT $ rename tm' of - Left _ -> error "impossible" + Left _ -> error "impossible" Right tm'' -> tm'' -- Compute the substitution that takes datatypes that escape @@ -82,30 +84,32 @@ inferTypeInContext tyctx ctx tm0 = first display tys = Map.toList tyctx tms = Map.toList ctx - addTyLams [] tm = tm + addTyLams [] tm = tm addTyLams ((x, k) : xs) tm = TyAbs () x k $ addTyLams xs tm - addLams [] tm = tm + addLams [] tm = tm addLams ((x, ty) : xs) tm = LamAbs () x ty $ addLams xs tm - stripForalls sub [] ty = substTypeParallel sub ty + stripForalls sub [] ty = substTypeParallel sub ty stripForalls sub ((x, _) : xs) (TyForall _ y _ b) = stripForalls (Map.insert y (TyVar () x) sub) xs b - stripForalls _ _ _ = error "stripForalls" + stripForalls _ _ _ = error "stripForalls" - stripFuns [] ty = ty + stripFuns [] ty = ty stripFuns (_ : xs) (TyFun _ _ b) = stripFuns xs b - stripFuns _ _ = error "stripFuns" + stripFuns _ _ = error "stripFuns" -typeCheckTerm :: Term TyName Name DefaultUni DefaultFun () - -> Type TyName DefaultUni () - -> Either String () +typeCheckTerm :: + Term TyName Name DefaultUni DefaultFun () -> + Type TyName DefaultUni () -> + Either String () typeCheckTerm = typeCheckTermInContext Map.empty Map.empty -typeCheckTermInContext :: TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> Term TyName Name DefaultUni DefaultFun () - -> Type TyName DefaultUni () - -> Either String () +typeCheckTermInContext :: + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + Term TyName Name DefaultUni DefaultFun () -> + Type TyName DefaultUni () -> + Either String () typeCheckTermInContext tyctx ctx tm ty = void $ do - ty' <- inferTypeInContext tyctx ctx tm - unifyType tyctx mempty ty' ty + ty' <- inferTypeInContext tyctx ctx tm + unifyType tyctx mempty ty' ty diff --git a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/GenerateTerms.hs b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/GenerateTerms.hs index 95237da67c4..6bda235695c 100644 --- a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/GenerateTerms.hs +++ b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/GenerateTerms.hs @@ -1,17 +1,16 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} module PlutusIR.Generators.QuickCheck.GenerateTerms where @@ -20,8 +19,8 @@ import PlutusIR.Generators.QuickCheck.Common import PlutusCore.Generators.QuickCheck.Builtin import PlutusCore.Generators.QuickCheck.Common -import PlutusCore.Generators.QuickCheck.GenerateTypes import PlutusCore.Generators.QuickCheck.GenTm +import PlutusCore.Generators.QuickCheck.GenerateTypes import PlutusCore.Generators.QuickCheck.ShrinkTypes import PlutusCore.Generators.QuickCheck.Substitutions import PlutusCore.Generators.QuickCheck.Unification @@ -61,7 +60,7 @@ import Prettyprinter -- with `findInstantiation` below where we do unification to figure out if we can -- use a variable to construct a term of a target type. data TyInst = InstApp (Type TyName DefaultUni ()) | InstArg (Type TyName DefaultUni ()) - deriving stock Show + deriving stock (Show) instance PrettyBy config (Type TyName DefaultUni ()) => PrettyBy config TyInst where prettyBy ctx (InstApp ty) = prettyBy ctx ty @@ -70,47 +69,56 @@ instance PrettyBy config (Type TyName DefaultUni ()) => PrettyBy config TyInst w -- | If successful `findInstantiation n target ty` for an `x :: ty` gives a sequence of `TyInst`s containing `n` -- `InstArg`s such that `x` instantiated (type application for `InstApp` and applied to a term of -- the given type for `InstArg`) at the `TyInsts`s has type `target` -findInstantiation :: HasCallStack - => TypeCtx - -> Int - -> Type TyName DefaultUni () - -> Type TyName DefaultUni () - -> Either String [TyInst] +findInstantiation :: + HasCallStack => + TypeCtx -> + Int -> + Type TyName DefaultUni () -> + Type TyName DefaultUni () -> + Either String [TyInst] findInstantiation ctx n target ty = do sub <- unifyType (ctx <> ctx') flex target b - let -- We map any unsolved flexible variable to a 'minimalType'. - defaultSub = minimalType <$> ctx' - doSub :: HasCallStack => _ - doSub = substType defaultSub . substType sub - doSubI (InstApp t) = InstApp (doSub t) - doSubI (InstArg t) = InstArg (doSub t) + let + -- We map any unsolved flexible variable to a 'minimalType'. + defaultSub = minimalType <$> ctx' + doSub :: HasCallStack => _ + doSub = substType defaultSub . substType sub + doSubI (InstApp t) = InstApp (doSub t) + doSubI (InstArg t) = InstArg (doSub t) pure $ map doSubI insts where fvs = setOf ftvTy target <> setOf ftvTy ty <> Map.keysSet ctx (ctx', flex, insts, b) = view Map.empty Set.empty [] n fvs ty -- TODO: documentation! - view ctx' flex insts n fvs (TyForall _ x k b) = view (Map.insert x' k ctx') (Set.insert x' flex) - (InstApp (TyVar () x') : insts) n - (Set.insert x' fvs) b' - where (x', b') | Set.member x fvs = let x' = freshenTyNameWith fvs x in (x', renameVar x x' b) - | otherwise = (x, b) + view ctx' flex insts n fvs (TyForall _ x k b) = + view + (Map.insert x' k ctx') + (Set.insert x' flex) + (InstApp (TyVar () x') : insts) + n + (Set.insert x' fvs) + b' + where + (x', b') + | Set.member x fvs = let x' = freshenTyNameWith fvs x in (x', renameVar x x' b) + | otherwise = (x, b) view ctx' flex insts n fvs (TyFun _ a b) | n > 0 = view ctx' flex (InstArg a : insts) (n - 1) fvs b view ctx' flex insts _ _ a = (ctx', flex, reverse insts, a) genConstant :: SomeTypeIn DefaultUni -> GenTm (Term TyName Name DefaultUni DefaultFun ()) genConstant (SomeTypeIn b) = case toSingKind b of - SingType -> mkConstantOf () b <$> bring (Proxy @ArbitraryBuiltin) b (liftGen arbitraryBuiltin) - _ -> error "Higher-kinded built-in types cannot be used here" + SingType -> mkConstantOf () b <$> bring (Proxy @ArbitraryBuiltin) b (liftGen arbitraryBuiltin) + _ -> error "Higher-kinded built-in types cannot be used here" -- | Try to inhabit a given type in as simple a way as possible, -- prefers to not default to `error` inhabitType :: Type TyName DefaultUni () -> GenTm (Term TyName Name DefaultUni DefaultFun ()) -inhabitType ty0 = local (\ e -> e { geTerms = mempty }) $ do - errOrRes <- runExceptT $ findTm ty0 - pure $ case errOrRes of - Left _ -> Error () ty0 - Right res -> res +inhabitType ty0 = local (\e -> e {geTerms = mempty}) $ do + errOrRes <- runExceptT $ findTm ty0 + pure $ case errOrRes of + Left _ -> Error () ty0 + Right res -> res where -- Do the obvious thing as long as target type is not type var -- When type var: magic (if higher-kinded type var: black magic) @@ -120,8 +128,9 @@ inhabitType ty0 = local (\ e -> e { geTerms = mempty }) $ do -- NOTE: because we make recursive calls to findTm in this function instead of -- inhabitType we don't risk generating terms that are "mostly ok but something is error", -- this function will avoid error if possible. - findTm :: Type TyName DefaultUni () - -> ExceptT String GenTm (Term TyName Name DefaultUni DefaultFun ()) + findTm :: + Type TyName DefaultUni () -> + ExceptT String GenTm (Term TyName Name DefaultUni DefaultFun ()) findTm (normalizeTy -> ty) = case ty of TyFun _ a b -> do x <- lift $ genLikelyFreshName "x" @@ -132,76 +141,77 @@ inhabitType ty0 = local (\ e -> e { geTerms = mempty }) $ do -- If we have a type-function application (viewApp [] -> (f, _)) -> case f of - TyVar () x -> do + TyVar () x -> do _ <- asks geDatas - asks (Map.lookup x . geDatas) >>= \ case + asks (Map.lookup x . geDatas) >>= \case -- If the head is a datatype try to inhabit one of its constructors Just dat -> foldr mplus mzero $ map (tryCon x ty) (constrTypes dat) -- If its not a datatype we try to use whatever bound variables -- we have to inhabit the type - Nothing -> do + Nothing -> do vars <- asks geTerms - ctx <- asks geTypes + ctx <- asks geTypes let cands = Map.toList vars -- If we are instantiating something simply instantiate every -- type application with type required by findInstantiation doInst _ tm (InstApp instTy) = pure $ TyInst () tm instTy -- If we instantiate an application, only succeed if we find -- a non-error argument. - doInst _ tm (InstArg argTy) = Apply () tm <$> findTm argTy + doInst _ tm (InstArg argTy) = Apply () tm <$> findTm argTy -- Go over every type and try to inhabit the type at the arguments - case [ local (\e -> e { geTerms = Map.delete x' (geTerms e) }) - $ foldM (doInst n) (Var () x') insts - | (x', a) <- cands, - n <- [0..typeArity a], - Right insts <- [findInstantiation ctx n ty a], - x `Set.notMember` fvArgs a + case [ local (\e -> e {geTerms = Map.delete x' (geTerms e)}) $ + foldM (doInst n) (Var () x') insts + | (x', a) <- cands + , n <- [0 .. typeArity a] + , Right insts <- [findInstantiation ctx n ty a] + , x `Set.notMember` fvArgs a ] of - [] -> mzero - g:_ -> g + [] -> mzero + g : _ -> g _ -> mzero -- Try to inhabit a constructor `con` of type `conTy` in datatype `d` at type `ty` tryCon d ty1 (con, conTy) - | Set.member d (fvArgs conTy) = mzero -- <- This is ok, since no mutual recursion + | Set.member d (fvArgs conTy) = mzero -- <- This is ok, since no mutual recursion | otherwise = do -- Check that we haven't banned this constructor tmctx <- lift $ asks geTerms if Map.lookup con tmctx == Just conTy - then do - tyctx <- lift $ asks geTypes - insts0 <- liftEither $ findInstantiation tyctx (typeArity conTy) ty1 conTy - let go tm [] = return tm - go tm (InstApp ty : insts) = go (TyInst () tm ty) insts - go tm (InstArg ty : insts) = do - arg <- findTm ty - go (Apply () tm arg) insts - go (Var () con) insts0 - else mzero + then do + tyctx <- lift $ asks geTypes + insts0 <- liftEither $ findInstantiation tyctx (typeArity conTy) ty1 conTy + let go tm [] = return tm + go tm (InstApp ty : insts) = go (TyInst () tm ty) insts + go tm (InstArg ty : insts) = do + arg <- findTm ty + go (Apply () tm arg) insts + go (Var () con) insts0 + else mzero -- CODE REVIEW: wouldn't it be neat if this existed somewhere? viewApp args (TyApp _ f x) = viewApp (x : args) f - viewApp args ty = (ty, args) + viewApp args ty = (ty, args) -- Get the free variables that appear in arguments of a mixed arrow-forall type fvArgs (TyForall _ x _ b) = Set.delete x (fvArgs b) - fvArgs (TyFun _ a b) = setOf ftvTy a <> fvArgs b - fvArgs _ = mempty + fvArgs (TyFun _ a b) = setOf ftvTy a <> fvArgs b + fvArgs _ = mempty -- CODE REVIEW: does this exist anywhere? typeArity :: Num a => Type tyname uni ann -> a typeArity (TyForall _ _ _ a) = typeArity a -typeArity (TyFun _ _ b) = 1 + typeArity b -typeArity _ = 0 +typeArity (TyFun _ _ b) = 1 + typeArity b +typeArity _ = 0 -- | Generate as small a term as possible to match a given type. genAtomicTerm :: Type TyName DefaultUni () -> GenTm (Term TyName Name DefaultUni DefaultFun ()) genAtomicTerm ty = do - ctx <- asks geTypes + ctx <- asks geTypes vars <- asks geTerms -- First try cheap unification - let unifyVar (x, xty) = findInstantiation ctx 0 ty xty - <&> \ tys -> foldl (TyInst ()) (Var () x) [t | InstApp t <- tys] + let unifyVar (x, xty) = + findInstantiation ctx 0 ty xty + <&> \tys -> foldl (TyInst ()) (Var () x) [t | InstApp t <- tys] case rights $ map unifyVar $ Map.toList vars of -- If unification didn't work try the heavy-handed `inhabitType`. -- NOTE: We could probably just replace this whole function with @@ -216,65 +226,74 @@ genAtomicTerm ty = do -- | Generate a term of a given type. -- -- Requires the type to be of kind *. -genTermOfType :: Type TyName DefaultUni () - -> GenTm (Term TyName Name DefaultUni DefaultFun ()) +genTermOfType :: + Type TyName DefaultUni () -> + GenTm (Term TyName Name DefaultUni DefaultFun ()) genTermOfType ty = snd <$> genTerm (Just ty) -- | Generate a term, if the first argument is Nothing then we get something of any type -- and if the first argument is `Just ty` we get something of type `ty`. -- -- Requires the type to be of kind *. -genTerm :: Maybe (Type TyName DefaultUni ()) - -> GenTm (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) +genTerm :: + Maybe (Type TyName DefaultUni ()) -> + GenTm (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) genTerm mty = checkInvariants $ do customF <- asks geCustomFreq customG <- asks geCustomGen vars <- asks geTerms esc <- asks geEscaping -- Prefer to generate things that bind variables until we have "enough" (20...) - let (letF, lamF, varAppF) = if Map.size vars < 20 - then (30, 50, 10) - else (10, 30, 40) + let (letF, lamF, varAppF) = + if Map.size vars < 20 + then (30, 50, 10) + else (10, 30, 40) atomic - | Just ty <- mty = (ty,) <$> genAtomicTerm ty - | otherwise = do - ty <- genType $ Type () - (ty,) <$> genAtomicTerm ty + | Just ty <- mty = (ty,) <$> genAtomicTerm ty + | otherwise = do + ty <- genType $ Type () + (ty,) <$> genAtomicTerm ty ifAstSizeZero atomic $ frequency $ - [ (10, atomic) ] ++ - [ (letF, genLet mty) ] ++ - [ (30, genForall x k a) | Just (TyForall _ x k a) <- [mty] ] ++ - [ (lamF, genLam a b) | Just (a, b) <- [funTypeView mty] ] ++ - [ (varAppF, genVarApp mty) ] ++ - [ (10, genApp mty) ] ++ - [ (1, genError mty) ] ++ - [ (10, genConst mty) | canConst mty ] ++ - [ (10, genDatLet mty) | YesEscape <- [esc] ] ++ - [ (10, genIfTrace) | isNothing mty ] ++ - [ (customF, customG mty) ] + [(10, atomic)] + ++ [(letF, genLet mty)] + ++ [(30, genForall x k a) | Just (TyForall _ x k a) <- [mty]] + ++ [(lamF, genLam a b) | Just (a, b) <- [funTypeView mty]] + ++ [(varAppF, genVarApp mty)] + ++ [(10, genApp mty)] + ++ [(1, genError mty)] + ++ [(10, genConst mty) | canConst mty] + ++ [(10, genDatLet mty) | YesEscape <- [esc]] + ++ [(10, genIfTrace) | isNothing mty] + ++ [(customF, customG mty)] where - checkInvariants gen = do (ty, tm) <- gen - debug <- asks geDebug - tyctx <- asks geTypes - tmctx <- asks geTerms - if debug then - case typeCheckTermInContext tyctx tmctx tm ty of + debug <- asks geDebug + tyctx <- asks geTypes + tmctx <- asks geTerms + if debug + then case typeCheckTermInContext tyctx tmctx tm ty of Left err -> - (error . show $ "genTerm - checkInvariants: term " <> prettyReadable tm - <> " does not type check at type " <> prettyReadable ty - <> " in type context " <> prettyReadable tyctx - <> " and term context " <> prettyReadable tmctx - <> " with error message " <> fromString err) + ( error . show $ + "genTerm - checkInvariants: term " + <> prettyReadable tm + <> " does not type check at type " + <> prettyReadable ty + <> " in type context " + <> prettyReadable tyctx + <> " and term context " + <> prettyReadable tmctx + <> " with error message " + <> fromString err + ) _ -> return (ty, tm) - else - return (ty, tm) + else + return (ty, tm) - funTypeView Nothing = Just (Nothing, Nothing) + funTypeView Nothing = Just (Nothing, Nothing) funTypeView (Just (normalizeTy -> TyFun _ a b)) = Just (Just a, Just b) - funTypeView _ = Nothing + funTypeView _ = Nothing -- Generate builtin ifthenelse and trace calls genIfTrace = do @@ -286,44 +305,49 @@ genTerm mty = checkInvariants $ do return (ty, Error () ty) genError (Just ty) = return (ty, Error () ty) - canConst Nothing = True - canConst (Just TyBuiltin{}) = True - canConst (Just _) = False + canConst Nothing = True + canConst (Just TyBuiltin {}) = True + canConst (Just _) = False genConst Nothing = do someUni <- deliver . liftGen . genBuiltinTypeOf $ Type () - (TyBuiltin () someUni, ) <$> genConstant someUni + (TyBuiltin () someUni,) <$> genConstant someUni genConst (Just ty@(TyBuiltin _ someUni)) = (ty,) <$> genConstant someUni genConst _ = error "genConst: impossible" genDatLet mty = do rec <- liftGen arbitrary - genDatatypeLet rec $ \ dat -> do + genDatatypeLet rec $ \dat -> do (ty, tm) <- genTerm mty return $ (ty, Let () (if rec then Rec else NonRec) (DatatypeBind () dat :| []) tm) genLet mty = do -- How many terms to bind - n <- liftGen $ choose (1, 3) + n <- liftGen $ choose (1, 3) -- Names of the bound terms - xs <- genLikelyFreshNames $ replicate n "f" + xs <- genLikelyFreshNames $ replicate n "f" -- Types of the bound terms -- TODO: generate something that matches the target type - as <- onAstSize (`div` 8) $ vectorOf n $ genType (Type ()) + as <- onAstSize (`div` 8) $ vectorOf n $ genType (Type ()) -- Strictness - ss <- vectorOf n $ liftGen $ elements [Strict, NonStrict] + ss <- vectorOf n $ liftGen $ elements [Strict, NonStrict] -- Recursive? - r <- liftGen $ frequency [(1, pure True), (6, pure False)] + r <- liftGen $ frequency [(1, pure True), (6, pure False)] -- Generate the binding -- TODO: maybe also generate mutually recursive bindings? - let genBin (x, a) | r = withNoEscape . bindTmName x a . genTermOfType $ a - | otherwise = withNoEscape . genTermOfType $ a + let genBin (x, a) + | r = withNoEscape . bindTmName x a . genTermOfType $ a + | otherwise = withNoEscape . genTermOfType $ a -- Generate both bound terms and body with a size split of 1:7 (note, we are generating up to three bound -- terms, so the size split is really something like n:7). (tms, (ty, body)) <- - astSizeSplit_ 1 7 (mapM genBin (zip xs as)) (bindTmNames (zip xs as) $ genTerm mty) - let mkBind (x, a, s) tm = TermBind () s - (VarDecl () x a) tm + astSizeSplit_ 1 7 (mapM genBin (zip xs as)) (bindTmNames (zip xs as) $ genTerm mty) + let mkBind (x, a, s) tm = + TermBind + () + s + (VarDecl () x a) + tm b : bs = zipWith mkBind (zip3 xs as ss) tms pure (ty, Let () (if r then Rec else NonRec) (b :| bs) body) @@ -336,17 +360,19 @@ genTerm mty = checkInvariants $ do genLam ma mb = do x <- genLikelyFreshName "x" (a, (b, body)) <- - astSizeSplit 1 7 + astSizeSplit + 1 + 7 (maybe (genType $ Type ()) return ma) - (\ a -> bindTmName x a . withNoEscape $ genTerm mb) + (\a -> bindTmName x a . withNoEscape $ genTerm mb) pure (TyFun () a b, LamAbs () x a body) genApp mty = withNoEscape $ do - ((_, arg), (toResTy, fun)) <- - astSizeSplit 1 4 (genTerm Nothing) (\ (argTy, _) -> genFun argTy mty) - case toResTy of - TyFun _ _ resTy -> pure (resTy, Apply () fun arg) - _ -> error $ display toResTy ++ "\n\n is not a 'TyFun'" + ((_, arg), (toResTy, fun)) <- + astSizeSplit 1 4 (genTerm Nothing) (\(argTy, _) -> genFun argTy mty) + case toResTy of + TyFun _ _ resTy -> pure (resTy, Apply () fun arg) + _ -> error $ display toResTy ++ "\n\n is not a 'TyFun'" where genFun argTy mty = genTerm . Just . TyFun () argTy =<< maybe (genType (Type ())) pure mty @@ -354,8 +380,8 @@ genTerm mty = checkInvariants $ do genVarApp Nothing = withNoEscape $ do -- CODE REVIEW: this function exists somewhere maybe? (Maybe even in this module...) let arity (TyForall _ _ _ b) = 1 + arity b - arity (TyFun _ _ b) = 1 + arity b - arity _ = 0 + arity (TyFun _ _ b) = 1 + arity b + arity _ = 0 appl :: HasCallStack => Int -> Term TyName Name DefaultUni DefaultFun () -> _ appl 0 tm b = return (b, tm) @@ -372,24 +398,24 @@ genTerm mty = checkInvariants $ do let ty = normalizeTy ty0 n <- liftGen $ choose (0, arity ty) onAstSize (`div` n) $ appl n (Var () x) ty - asks (Map.toList . geTerms) >>= \ case - [] -> do + asks (Map.toList . geTerms) >>= \case + [] -> do ty <- genType $ Type () (ty,) <$> inhabitType ty vars -> oneof $ map genV vars - genVarApp (Just ty) = do vars <- asks geTerms - ctx <- asks geTypes + ctx <- asks geTypes let cands = Map.toList vars doInst _ tm (InstApp instTy) = pure $ TyInst () tm instTy - doInst n tm (InstArg argTy) = onAstSize ((`div` n) . subtract 1) - . withNoEscape - $ Apply () tm <$> genTermOfType argTy + doInst n tm (InstArg argTy) = + onAstSize ((`div` n) . subtract 1) + . withNoEscape + $ Apply () tm <$> genTermOfType argTy case [ foldM (doInst n) (Var () x) insts - | (x, a) <- cands, - n <- [0..typeArity a], - Right insts <- [findInstantiation ctx n ty a] + | (x, a) <- cands + , n <- [0 .. typeArity a] + , Right insts <- [findInstantiation ctx n ty a] ] of [] -> (ty,) <$> inhabitType ty gs -> (ty,) <$> oneof gs @@ -398,30 +424,41 @@ genTerm mty = checkInvariants $ do scaledListOf :: GenTm a -> GenTm [a] scaledListOf g = do sz <- asks geAstSize - n <- choose (0, sz `div` 3) + n <- choose (0, sz `div` 3) onAstSize (`div` n) $ replicateM n g genDatatypeLet :: Bool -> (Datatype TyName Name DefaultUni () -> GenTm a) -> GenTm a genDatatypeLet rec cont = do - k0 <- liftGen arbitrary - let ks = argsFunKind k0 - n <- liftGen $ choose (1, 3) - -- Lazy matching to communicate to GHC the fact that this can't fail and thus doesn't require - -- a 'MonadFail' (which 'GenTm' isn't). - ~(d : xs) <- genLikelyFreshTyNames $ "d" : replicate (length ks) "a" - ~(m : cs) <- genLikelyFreshNames $ "m" : replicate n "c" - let dTy = foldl (TyApp ()) (TyVar () d) [TyVar () x | x <- xs] - bty d = if rec - then bindTyName d k0 - else registerTyName d - conArgss <- bty d $ bindTyNames (zip xs ks) $ - -- Using 'listOf' instead if 'scaledListOf' makes the code slower by several - -- times (didn't check how exactly it affects the generated types). - onAstSize (`div` n) $ replicateM n $ scaledListOf (genType $ Type ()) - let dat = Datatype () (TyVarDecl () d k0) [TyVarDecl () x k | (x, k) <- zip xs ks] m - [ VarDecl () c (foldr (TyFun ()) dTy conArgs) - | (c, conArgs) <- zip cs conArgss ] - bindDat dat $ cont dat + k0 <- liftGen arbitrary + let ks = argsFunKind k0 + n <- liftGen $ choose (1, 3) + -- Lazy matching to communicate to GHC the fact that this can't fail and thus doesn't require + -- a 'MonadFail' (which 'GenTm' isn't). + ~(d : xs) <- genLikelyFreshTyNames $ "d" : replicate (length ks) "a" + ~(m : cs) <- genLikelyFreshNames $ "m" : replicate n "c" + let dTy = foldl (TyApp ()) (TyVar () d) [TyVar () x | x <- xs] + bty d = + if rec + then bindTyName d k0 + else registerTyName d + conArgss <- + bty d $ + bindTyNames (zip xs ks) $ + -- Using 'listOf' instead if 'scaledListOf' makes the code slower by several + -- times (didn't check how exactly it affects the generated types). + onAstSize (`div` n) $ + replicateM n $ + scaledListOf (genType $ Type ()) + let dat = + Datatype + () + (TyVarDecl () d k0) + [TyVarDecl () x k | (x, k) <- zip xs ks] + m + [ VarDecl () c (foldr (TyFun ()) dTy conArgs) + | (c, conArgs) <- zip cs conArgss + ] + bindDat dat $ cont dat -- | Generate up to 5 datatypes and bind them in a generator. -- NOTE: despite its name this function does in fact not generate the `Let` binding @@ -430,7 +467,7 @@ genDatatypeLets :: ([Datatype TyName Name DefaultUni ()] -> GenTm a) -> GenTm a genDatatypeLets cont = do n0 <- liftGen $ choose (1, 5 :: Int) let go 0 k = k [] - go n k = genDatatypeLet False $ \ dat -> go (n - 1) (k . (dat :)) + go n k = genDatatypeLet False $ \dat -> go (n - 1) (k . (dat :)) go n0 cont genTypeAndTerm_ :: Gen (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) @@ -450,14 +487,15 @@ genTypeAndTermDebug_ = runGenTm . withDebug $ do -- should already have plenty of complicated arguments to functions to begin -- with and now we just want to fill out the arguments so that we get -- something that hopefully evaluates for a non-trivial number of steps. -genFullyApplied :: Type TyName DefaultUni () - -> Term TyName Name DefaultUni DefaultFun () - -> Gen (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) +genFullyApplied :: + Type TyName DefaultUni () -> + Term TyName Name DefaultUni DefaultFun () -> + Gen (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) genFullyApplied typ0 trm0 = runGenTm $ go trm0 where go trm = case trm of Let () rec binds body -> second (Let () rec binds) <$> bindBinds binds (go body) - _ -> genArgsApps typ0 trm + _ -> genArgsApps typ0 trm genArgsApps (TyForall _ x k typ) trm = do let ty = minimalType k genArgsApps (typeSubstClosedType x ty typ) (TyInst () trm ty) @@ -467,10 +505,12 @@ genFullyApplied typ0 trm0 = runGenTm $ go trm0 genArgsApps ty trm = return (ty, trm) -- | Generate a term of a specific type given a type and term context -genTermInContext_ :: TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> Type TyName DefaultUni () - -> Gen (Term TyName Name DefaultUni DefaultFun ()) +genTermInContext_ :: + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + Type TyName DefaultUni () -> + Gen (Term TyName Name DefaultUni DefaultFun ()) genTermInContext_ tyctx ctx ty = - runGenTm $ local (\ e -> e { geTypes = tyctx, geTerms = ctx, geEscaping = NoEscape }) $ - snd <$> genTerm (Just ty) + runGenTm $ + local (\e -> e {geTypes = tyctx, geTerms = ctx, geEscaping = NoEscape}) $ + snd <$> genTerm (Just ty) diff --git a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs index b55a8ba2333..0c8dae23ee5 100644 --- a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs +++ b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs @@ -1,10 +1,9 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} module PlutusIR.Generators.QuickCheck.ShrinkTerms where @@ -41,16 +40,18 @@ import Data.Vector.Strict qualified as Vector import GHC.Stack import Test.QuickCheck (shrink, shrinkList) -addTmBind :: Binding TyName Name DefaultUni DefaultFun () - -> Map Name (Type TyName DefaultUni ()) - -> Map Name (Type TyName DefaultUni ()) +addTmBind :: + Binding TyName Name DefaultUni DefaultFun () -> + Map Name (Type TyName DefaultUni ()) -> + Map Name (Type TyName DefaultUni ()) addTmBind (TermBind _ _ (VarDecl _ x a) _) = Map.insert x a -addTmBind (DatatypeBind _ dat) = (Map.fromList (matchType dat : constrTypes dat) <>) -addTmBind _ = id +addTmBind (DatatypeBind _ dat) = (Map.fromList (matchType dat : constrTypes dat) <>) +addTmBind _ = id -scopeCheckTyVars :: TypeCtx - -> (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) - -> Bool +scopeCheckTyVars :: + TypeCtx -> + (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) -> + Bool scopeCheckTyVars tyctx (ty, tm) = setOf ftvTy ty `Set.isSubsetOf` inscope where inscope = Map.keysSet tyctx <> Set.fromList (map fst $ datatypes tm) @@ -59,114 +60,132 @@ scopeCheckTyVars tyctx (ty, tm) = setOf ftvTy ty `Set.isSubsetOf` inscope findHelp :: Map Name (Type TyName DefaultUni ()) -> Maybe Name findHelp ctx = case Map.toList $ Map.filter isHelpType ctx of - [] -> Nothing + [] -> Nothing (x, _) : _ -> Just x where isHelpType (TyForall _ x (Type ()) (TyVar _ x')) = x == x' - isHelpType _ = False + isHelpType _ = False -mkHelp :: Map Name (Type TyName DefaultUni ()) - -> Type TyName DefaultUni () - -> Term TyName Name DefaultUni DefaultFun () -mkHelp _ (TyBuiltin _ someUni) = minimalBuiltin someUni +mkHelp :: + Map Name (Type TyName DefaultUni ()) -> + Type TyName DefaultUni () -> + Term TyName Name DefaultUni DefaultFun () +mkHelp _ (TyBuiltin _ someUni) = minimalBuiltin someUni mkHelp (findHelp -> Just help) ty = TyInst () (Var () help) ty -mkHelp _ ty = Error () ty +mkHelp _ ty = Error () ty -- | Try to take a term from an old context to a new context and a new type. -- If we can't do the new type we might return a different type. -fixupTerm_ :: TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> Type TyName DefaultUni () - -> Term TyName Name DefaultUni DefaultFun () - -> (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) +fixupTerm_ :: + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + Type TyName DefaultUni () -> + Term TyName Name DefaultUni DefaultFun () -> + (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) fixupTerm_ tyctxOld ctxOld tyctxNew ctxNew tyNew tm0 = case inferTypeInContext tyctxNew ctxNew tm0 of Left _ -> case tm0 of -- Make @a@ the new type of @x@. We can't take the old type of @x@, because it may reference -- a removed binding. And we're trying to change the type of @tm0@ to @tyNew@ anyway. - LamAbs _ x _ tm | TyFun () a b <- tyNew -> bimap (TyFun () a) (LamAbs () x a) - $ fixupTerm_ tyctxOld (Map.insert x a ctxOld) - tyctxNew (Map.insert x a ctxNew) b tm + LamAbs _ x _ tm + | TyFun () a b <- tyNew -> + bimap (TyFun () a) (LamAbs () x a) $ + fixupTerm_ + tyctxOld + (Map.insert x a ctxOld) + tyctxNew + (Map.insert x a ctxNew) + b + tm Apply _ (Apply _ (TyInst _ (Builtin _ Trace) _) s) tm -> let (ty', tm') = fixupTerm_ tyctxOld ctxOld tyctxNew ctxNew tyNew tm - in (ty', Apply () (Apply () (TyInst () (Builtin () Trace) ty') s) tm') - _ | TyBuiltin _ someUni <- tyNew -> (tyNew, minimalBuiltin someUni) + in (ty', Apply () (Apply () (TyInst () (Builtin () Trace) ty') s) tm') + _ + | TyBuiltin _ someUni <- tyNew -> (tyNew, minimalBuiltin someUni) | otherwise -> (tyNew, mkHelp ctxNew tyNew) Right ty -> (ty, tm0) -- | Try to take a term from an old context to a new context and a new type - default to `mkHelp`. -fixupTerm :: TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> Type TyName DefaultUni () - -> Term TyName Name DefaultUni DefaultFun () - -> Term TyName Name DefaultUni DefaultFun () +fixupTerm :: + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + Type TyName DefaultUni () -> + Term TyName Name DefaultUni DefaultFun () -> + Term TyName Name DefaultUni DefaultFun () fixupTerm _ _ tyctxNew ctxNew tyNew tm | isRight (typeCheckTermInContext tyctxNew ctxNew tm tyNew) = tm - | otherwise = mkHelp ctxNew tyNew + | otherwise = mkHelp ctxNew tyNew minimalBuiltin :: SomeTypeIn DefaultUni -> Term TyName Name DefaultUni DefaultFun () minimalBuiltin (SomeTypeIn uni) = case toSingKind uni of - SingType -> mkConstantOf () uni $ go uni - _ -> error "Higher-kinded built-in types cannot be used here" + SingType -> mkConstantOf () uni $ go uni + _ -> error "Higher-kinded built-in types cannot be used here" where go :: DefaultUni (Esc a) -> a - go DefaultUniUnit = () - go DefaultUniInteger = 0 - go DefaultUniBool = False - go DefaultUniString = "" - go DefaultUniByteString = "" - go DefaultUniData = I 0 - go DefaultUniValue = Value.empty - go (DefaultUniProtoList `DefaultUniApply` _) = [] - go (DefaultUniProtoArray `DefaultUniApply` _) = Vector.empty - go (DefaultUniProtoPair `DefaultUniApply` a `DefaultUniApply` b) = (go a, go b) - go (f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _) = noMoreTypeFunctions f - go DefaultUniBLS12_381_G1_Element = BLS12_381.G1.offchain_zero - go DefaultUniBLS12_381_G2_Element = BLS12_381.G2.offchain_zero - go DefaultUniBLS12_381_MlResult = BLS12_381.Pairing.identityMlResult - -shrinkBind :: HasCallStack - => Recursivity - -> TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> Binding TyName Name DefaultUni DefaultFun () - -> [Binding TyName Name DefaultUni DefaultFun ()] + go DefaultUniUnit = () + go DefaultUniInteger = 0 + go DefaultUniBool = False + go DefaultUniString = "" + go DefaultUniByteString = "" + go DefaultUniData = I 0 + go DefaultUniValue = Value.empty + go (DefaultUniProtoList `DefaultUniApply` _) = [] + go (DefaultUniProtoArray `DefaultUniApply` _) = Vector.empty + go (DefaultUniProtoPair `DefaultUniApply` a `DefaultUniApply` b) = (go a, go b) + go (f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _) = noMoreTypeFunctions f + go DefaultUniBLS12_381_G1_Element = BLS12_381.G1.offchain_zero + go DefaultUniBLS12_381_G2_Element = BLS12_381.G2.offchain_zero + go DefaultUniBLS12_381_MlResult = BLS12_381.Pairing.identityMlResult + +shrinkBind :: + HasCallStack => + Recursivity -> + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + Binding TyName Name DefaultUni DefaultFun () -> + [Binding TyName Name DefaultUni DefaultFun ()] shrinkBind _ tyctx ctx bind = case bind of -- Note: this is a bit tricky for recursive binds, if we change a recursive bind we need to -- fixup all the other binds in the block. Currently we do this with a fixupTerm_ in the -- structural part of shrinking. In the future this can be made better if we find properties -- where lets don't shrink well enough to be understandable. - TermBind _ s (VarDecl _ x ty) tm -> [ TermBind () s (VarDecl () x ty') tm' - | (ty', tm') <- shrinkTypedTerm tyctx ctx (ty, tm) - ] ++ - [ TermBind () Strict (VarDecl () x ty) tm | s == NonStrict ] + TermBind _ s (VarDecl _ x ty) tm -> + [ TermBind () s (VarDecl () x ty') tm' + | (ty', tm') <- shrinkTypedTerm tyctx ctx (ty, tm) + ] + ++ [TermBind () Strict (VarDecl () x ty) tm | s == NonStrict] -- These cases are basically just structural - TypeBind _ (TyVarDecl _ a k) ty -> [ TypeBind () (TyVarDecl () a k') ty' - | (k', ty') <- shrinkKindAndType tyctx (k, ty) ] - DatatypeBind _ dat -> [ DatatypeBind () dat' | dat' <- shrinkDat tyctx dat ] - -shrinkDat :: TypeCtx - -> Datatype TyName Name DefaultUni () - -> [Datatype TyName Name DefaultUni ()] + TypeBind _ (TyVarDecl _ a k) ty -> + [ TypeBind () (TyVarDecl () a k') ty' + | (k', ty') <- shrinkKindAndType tyctx (k, ty) + ] + DatatypeBind _ dat -> [DatatypeBind () dat' | dat' <- shrinkDat tyctx dat] + +shrinkDat :: + TypeCtx -> + Datatype TyName Name DefaultUni () -> + [Datatype TyName Name DefaultUni ()] shrinkDat ctx (Datatype _ dd@(TyVarDecl _ d _) xs m cs) = - [ Datatype () dd xs m cs' | cs' <- shrinkList shrinkCon cs ] + [Datatype () dd xs m cs' | cs' <- shrinkList shrinkCon cs] where - ctx' = ctx <> Map.fromList [ (x, k) | TyVarDecl _ x k <- xs ] - shrinkCon (VarDecl _ c ty) = [ VarDecl () c ty'' - | ty' <- shrinkType ctx' ty - , let ty'' = setTarget (getTarget ty) ty' - , ty'' /= ty - , d `Set.notMember` setOf ftvTy (setTarget (mkTyBuiltin @_ @() ()) ty') ] + ctx' = ctx <> Map.fromList [(x, k) | TyVarDecl _ x k <- xs] + shrinkCon (VarDecl _ c ty) = + [ VarDecl () c ty'' + | ty' <- shrinkType ctx' ty + , let ty'' = setTarget (getTarget ty) ty' + , ty'' /= ty + , d `Set.notMember` setOf ftvTy (setTarget (mkTyBuiltin @_ @() ()) ty') + ] where getTarget (TyFun _ _ b) = getTarget b - getTarget b = b + getTarget b = b setTarget t (TyFun _ a b) = TyFun () a (setTarget t b) - setTarget t _ = t + setTarget t _ = t {- TODO: Note @@ -196,16 +215,19 @@ let x = "abc" in x -- | Shrink a typed term in a type and term context. -- NOTE: if you want to understand what's going on in this function it's a good -- idea to look at how we do this for types first (it's a lot simpler). -shrinkTypedTerm :: HasCallStack - => TypeCtx - -> Map Name (Type TyName DefaultUni ()) - -> (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) - -> [(Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ())] -shrinkTypedTerm tyctx0 ctx0 (ty0, tm0) = concat +shrinkTypedTerm :: + HasCallStack => + TypeCtx -> + Map Name (Type TyName DefaultUni ()) -> + (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) -> + [(Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ())] +shrinkTypedTerm tyctx0 ctx0 (ty0, tm0) = + concat [ -- TODO: this somehow contributes a huge number of duplicates as reported by the @numShrink@ -- test. How come? Is it because it's called from 'shrinkBind'? Do we even need this kind of -- shrinking? - filter (scopeCheckTyVars tyctx0) + filter + (scopeCheckTyVars tyctx0) [ (ty', tm') | not $ isHelp ctx0 tm0 , ty' <- ty0 : shrinkType (tyctx0 <> Map.fromList (datatypes tm0)) ty0 @@ -214,23 +236,23 @@ shrinkTypedTerm tyctx0 ctx0 (ty0, tm0) = concat , go tyctx0 ctx0 (ty0, tm0) ] where - isHelp _ (Constant _ _) = True + isHelp _ (Constant _ _) = True isHelp ctx (TyInst _ (Var _ x) _) = Just x == findHelp ctx - isHelp _ (Error _ _) = True - isHelp _ _ = False + isHelp _ (Error _ _) = True + isHelp _ _ = False - addTyBind (TypeBind _ (TyVarDecl _ a k) _) = Map.insert a k + addTyBind (TypeBind _ (TyVarDecl _ a k) _) = Map.insert a k addTyBind (DatatypeBind _ (Datatype _ (TyVarDecl _ a k) _ _ _)) = Map.insert a k - addTyBind _ = id + addTyBind _ = id addTyBindSubst (TypeBind _ (TyVarDecl _ a _) ty) = Map.insert a ty - addTyBindSubst _ = id + addTyBindSubst _ = id go :: HasCallStack => _ go tyctx ctx (ty, tm) = filter (scopeCheckTyVars tyctx) $ - nonstructural tyctx ctx (ty, tm) ++ - structural tyctx ctx (ty, tm) + nonstructural tyctx ctx (ty, tm) + ++ structural tyctx ctx (ty, tm) -- TODO: what about 'TyInst'? -- These are the special cases and "tricks" for shrinking @@ -238,43 +260,44 @@ shrinkTypedTerm tyctx0 ctx0 (ty0, tm0) = concat nonstructural tyctx ctx (ty, tm) = case tm of -- TODO: shrink Rec to NonRec - Let _ rec bindsL body -> concat - [ -- - [ fixupTerm_ tyctxInner ctxInner tyctx ctx ty body - | let tyctxInner = foldr addTyBind tyctx bindsL - ctxInner = foldr addTmBind ctx bindsL - ] - , -- Make one of the let-bindings the new body dropping the old body and all the - -- bindings appearing after the chosen binding (we don't need them, since the whole - -- 'let' is non-recursive and hence the chosen binding can't reference those appearing - -- after it). - [ (letTy, case binds of - -- If there's no bindings before the chosen one, we don't recreate the 'let'. - [] -> letTm - b:bs -> Let () NonRec (b :| bs) letTm) - | (NonEmptyContext binds _, TermBind _ _ (VarDecl _ _ letTy) letTm) <- - oneHoleContexts bindsL - , rec == NonRec + Let _ rec bindsL body -> + concat + [ -- + [ fixupTerm_ tyctxInner ctxInner tyctx ctx ty body + | let tyctxInner = foldr addTyBind tyctx bindsL + ctxInner = foldr addTmBind ctx bindsL + ] + , -- Make one of the let-bindings the new body dropping the old body and all the + -- bindings appearing after the chosen binding (we don't need them, since the whole + -- 'let' is non-recursive and hence the chosen binding can't reference those appearing + -- after it). + [ ( letTy + , case binds of + -- If there's no bindings before the chosen one, we don't recreate the 'let'. + [] -> letTm + b : bs -> Let () NonRec (b :| bs) letTm + ) + | (NonEmptyContext binds _, TermBind _ _ (VarDecl _ _ letTy) letTm) <- + oneHoleContexts bindsL + , rec == NonRec -- TODO: check that the body is not one of the bound variables? + ] + , -- Drop a single binding. + [ second (Let () rec (b :| binds')) $ + fixupTerm_ tyctxInner ctxInner tyctxInner' ctxInner' ty body + | (NonEmptyContext binds0 binds1, _) <- oneHoleContexts bindsL + , let tyctxInner = foldr addTyBind tyctx bindsL + ctxInner = foldr addTmBind ctx bindsL + binds = binds0 ++ binds1 + tyctxInner' = foldr addTyBind tyctx binds + ctxInner' = foldr addTmBind ctx binds + , b : binds' <- [binds] + ] ] - , -- Drop a single binding. - [ second (Let () rec (b :| binds')) - $ fixupTerm_ tyctxInner ctxInner tyctxInner' ctxInner' ty body - | (NonEmptyContext binds0 binds1, _) <- oneHoleContexts bindsL, - let tyctxInner = foldr addTyBind tyctx bindsL - ctxInner = foldr addTmBind ctx bindsL - binds = binds0 ++ binds1 - tyctxInner' = foldr addTyBind tyctx binds - ctxInner' = foldr addTmBind ctx binds - , b:binds' <- [binds] - ] - ] - LamAbs _ x a body -> [ fixupTerm_ tyctx (Map.insert x a ctx) tyctx ctx b body | TyFun _ _ b <- [ty] ] - -- Drop substerms Apply _ fun arg -> case inferTypeInContext tyctx ctx arg of Right argTy -> @@ -288,23 +311,21 @@ shrinkTypedTerm tyctx0 ctx0 (ty0, tm0) = concat , (TyFun () argTy ty, fun) ] Left err -> error $ displayPlcCondensedErrorClassic err - TyAbs _ x _ body -> [ fixupTerm_ (Map.insert x k tyctx) ctx tyctx ctx tyInner' body | TyForall _ y k tyInner <- [ty] , let tyInner' = typeSubstClosedType y (minimalType k) tyInner ] - -- TODO: allow non-structural shrinking for some of these. - Var{} -> [] - Constant{} -> [] - Builtin{} -> [] - TyInst{} -> [] - Error{} -> [] - IWrap{} -> [] - Unwrap{} -> [] - PlutusIR.Constr{} -> [] - Case{} -> [] + Var {} -> [] + Constant {} -> [] + Builtin {} -> [] + TyInst {} -> [] + Error {} -> [] + IWrap {} -> [] + Unwrap {} -> [] + PlutusIR.Constr {} -> [] + Case {} -> [] -- These are the structural (basically homomorphic) cases in shrinking. -- They all just try to shrink a single subterm at a time. We also @@ -313,90 +334,92 @@ shrinkTypedTerm tyctx0 ctx0 (ty0, tm0) = concat structural :: HasCallStack => _ structural tyctx ctx (ty, tm) = case tm of - -- TODO: this needs a long, long Note... Let _ rec binds body -> [ (substTypeParallel subst ty', Let () rec binds body') - | (ty', body') <- go tyctxInner ctxInner (ty, body) ] ++ - [ fix $ second (Let () rec binds') $ - fixupTerm_ tyctxInner ctxInner tyctxInner' ctxInner' ty body - | (context@(NonEmptyContext before _), bind) <- oneHoleContexts binds, - let ctxBind | Rec <- rec = ctxInner - | otherwise = foldr addTmBind ctx before - tyctxBind | Rec <- rec = tyctxInner - | otherwise = foldr addTyBind tyctx before, - bind' <- shrinkBind rec tyctxBind ctxBind bind, - let binds' = plugHole context bind' - tyctxInner' = foldr addTyBind tyctx binds' - ctxInner' = foldr addTmBind ctx binds' - fix = uncurry (fixupTerm_ tyctx ctx tyctx ctx) - ] where subst = foldr addTyBindSubst mempty binds - tyctxInner = foldr addTyBind tyctx binds - ctxInner = foldr addTmBind ctx binds - + | (ty', body') <- go tyctxInner ctxInner (ty, body) + ] + ++ [ fix $ + second (Let () rec binds') $ + fixupTerm_ tyctxInner ctxInner tyctxInner' ctxInner' ty body + | (context@(NonEmptyContext before _), bind) <- oneHoleContexts binds + , let ctxBind + | Rec <- rec = ctxInner + | otherwise = foldr addTmBind ctx before + tyctxBind + | Rec <- rec = tyctxInner + | otherwise = foldr addTyBind tyctx before + , bind' <- shrinkBind rec tyctxBind ctxBind bind + , let binds' = plugHole context bind' + tyctxInner' = foldr addTyBind tyctx binds' + ctxInner' = foldr addTmBind ctx binds' + fix = uncurry (fixupTerm_ tyctx ctx tyctx ctx) + ] + where + subst = foldr addTyBindSubst mempty binds + tyctxInner = foldr addTyBind tyctx binds + ctxInner = foldr addTmBind ctx binds TyInst _ fun argTy -> case inferTypeInContext tyctx ctx fun of Right funTy@(TyForall _ x k tyInner) -> [ (substType (Map.singleton x' argTy') tyInner', TyInst () fun' argTy') | (TyForall () x' k' tyInner', fun') <- go tyctx ctx (funTy, fun) - , let argTy' | k == k' = argTy - -- TODO: define and use proper fixupType - | otherwise = minimalType k' - ] ++ - [ (substType (Map.singleton x argTy') tyInner', TyInst () fun' argTy') - | (k', argTy') <- shrinkKindAndType tyctx (k, argTy) - , let tyInner' | k == k' = tyInner - -- TODO: define and use proper fixupType - | otherwise = substType (Map.singleton x $ minimalType k) tyInner - fun' = fixupTerm tyctx ctx tyctx ctx (TyForall () x k' tyInner') fun + , let argTy' + | k == k' = argTy + -- TODO: define and use proper fixupType + | otherwise = minimalType k' ] + ++ [ (substType (Map.singleton x argTy') tyInner', TyInst () fun' argTy') + | (k', argTy') <- shrinkKindAndType tyctx (k, argTy) + , let tyInner' + | k == k' = tyInner + -- TODO: define and use proper fixupType + | otherwise = substType (Map.singleton x $ minimalType k) tyInner + fun' = fixupTerm tyctx ctx tyctx ctx (TyForall () x k' tyInner') fun + ] Left err -> error $ displayPlcCondensedErrorClassic err Right tyWrong -> error $ "Expected a 'TyForall', but got " ++ displayPlc tyWrong - -- TODO: shrink the kind too like with the type in @LamAbs@ below. - TyAbs _ x _ body | not $ Map.member x tyctx -> - [ (TyForall () x k tyInner', TyAbs () x k body') - | TyForall _ y k tyInner <- [ty] - , (tyInner', body') <- go (Map.insert x k tyctx) ctx (renameVar y x tyInner, body) - ] - + TyAbs _ x _ body + | not $ Map.member x tyctx -> + [ (TyForall () x k tyInner', TyAbs () x k body') + | TyForall _ y k tyInner <- [ty] + , (tyInner', body') <- go (Map.insert x k tyctx) ctx (renameVar y x tyInner, body) + ] LamAbs _ x a body -> [ (TyFun () a b', LamAbs () x a body') - | TyFun _ _ b <- [ty], - (b', body') <- go tyctx (Map.insert x a ctx) (b, body) - ] ++ - [ bimap (TyFun () a') (LamAbs () x a') $ - fixupTerm_ tyctx (Map.insert x a ctx) tyctx (Map.insert x a' ctx) b body - | TyFun _ _ b <- [ty], - a' <- shrinkType tyctx a + | TyFun _ _ b <- [ty] + , (b', body') <- go tyctx (Map.insert x a ctx) (b, body) ] - + ++ [ bimap (TyFun () a') (LamAbs () x a') $ + fixupTerm_ tyctx (Map.insert x a ctx) tyctx (Map.insert x a' ctx) b body + | TyFun _ _ b <- [ty] + , a' <- shrinkType tyctx a + ] Apply _ fun arg -> case inferTypeInContext tyctx ctx arg of - Left err -> error err + Left err -> error err Right argTy -> [ (ty', Apply () fun' arg') | (TyFun _ argTy' ty', fun') <- go tyctx ctx (TyFun () argTy ty, fun) , let arg' = fixupTerm tyctx ctx tyctx ctx argTy' arg - ] ++ - [ (ty, Apply () fun' arg') - | (argTy', arg') <- go tyctx ctx (argTy, arg) - , let fun' = fixupTerm tyctx ctx tyctx ctx (TyFun () argTy' ty) fun ] - + ++ [ (ty, Apply () fun' arg') + | (argTy', arg') <- go tyctx ctx (argTy, arg) + , let fun' = fixupTerm tyctx ctx tyctx ctx (TyFun () argTy' ty) fun + ] Constant _ val -> shrink val <&> \val'@(Some (ValueOf uni _)) -> (mkTyBuiltinOf () uni, Constant () val') - Error _ _ -> shrinkType tyctx ty <&> \ty' -> (ty', Error () ty') - -- TODO: allow structural shrinking for some of these. - Var{} -> [] - IWrap{} -> [] - Unwrap{} -> [] - Builtin{} -> [] - Case{} -> [] - TyAbs{} -> [] - PlutusIR.Constr{} -> [] - -shrinkClosedTypedTerm :: (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) - -> [(Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ())] + Var {} -> [] + IWrap {} -> [] + Unwrap {} -> [] + Builtin {} -> [] + Case {} -> [] + TyAbs {} -> [] + PlutusIR.Constr {} -> [] + +shrinkClosedTypedTerm :: + (Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ()) -> + [(Type TyName DefaultUni (), Term TyName Name DefaultUni DefaultFun ())] shrinkClosedTypedTerm = shrinkTypedTerm mempty mempty diff --git a/plutus-core/testlib/PlutusIR/Pass/Test.hs b/plutus-core/testlib/PlutusIR/Pass/Test.hs index 49eaf3b01cc..7b523729cef 100644 --- a/plutus-core/testlib/PlutusIR/Pass/Test.hs +++ b/plutus-core/testlib/PlutusIR/Pass/Test.hs @@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wno-orphans #-} + module PlutusIR.Pass.Test where import Control.Monad.Except @@ -21,14 +22,15 @@ import Test.QuickCheck -- Convert Either Error () to Either String () to match with the Testable (Either String ()) -- instance. -convertToEitherString :: Either (PIR.Error PLC.DefaultUni PLC.DefaultFun ()) () - -> Either String () +convertToEitherString :: + Either (PIR.Error PLC.DefaultUni PLC.DefaultFun ()) () -> + Either String () convertToEitherString = \case Left err -> Left $ show err Right () -> Right () instance Arbitrary (BuiltinSemanticsVariant PLC.DefaultFun) where - arbitrary = elements enumerate + arbitrary = elements enumerate -- | An appropriate number of tests for a compiler pass property, so that we get some decent -- exploration of the program space. If you also take other arguments, then consider multiplying @@ -37,33 +39,34 @@ numTestsForPassProp :: Int numTestsForPassProp = 99 -- | Run a 'Pass' on a 'Term', setting up the typechecking config and throwing errors. -runTestPass - :: (PLC.ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.Pretty a - , Typeable a - , Monoid a - , Monad m - ) - => (TC.PirTCConfig uni fun -> Pass m tyname name uni fun a) - -> Term tyname name uni fun a - -> m (Term tyname name uni fun a) +runTestPass :: + ( PLC.ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.Pretty a + , Typeable a + , Monoid a + , Monad m + ) => + (TC.PirTCConfig uni fun -> Pass m tyname name uni fun a) -> + Term tyname name uni fun a -> + m (Term tyname name uni fun a) runTestPass pass t = do res <- runExceptT $ do tcconfig <- modifyError PIR.PLCTypeError $ TC.getDefTypeCheckConfig mempty runPass (\_ -> pure ()) True (pass tcconfig) t case res of - Left e -> throw e + Left e -> throw e Right v -> pure v -- | Run a 'Pass' on generated 'Terms's, setting up the typechecking config -- and throwing errors. testPassProp :: - Monad m - => (forall a . m a -> a) - -> (TC.PirTCConfig PLC.DefaultUni PLC.DefaultFun - -> Pass m TyName Name PLC.DefaultUni PLC.DefaultFun ()) - -> Property + Monad m => + (forall a. m a -> a) -> + ( TC.PirTCConfig PLC.DefaultUni PLC.DefaultFun -> + Pass m TyName Name PLC.DefaultUni PLC.DefaultFun () + ) -> + Property testPassProp exitMonad pass = testPassProp' () @@ -76,17 +79,19 @@ testPassProp exitMonad pass = -- | A version of 'testPassProp' with more control, allowing some pre-processing -- of the term, and a more specific "exit" function. testPassProp' :: - forall m tyname name a prop - . (Monad m, Testable prop) - => a - -> (Term TyName Name PLC.DefaultUni PLC.DefaultFun () - -> Term tyname name PLC.DefaultUni PLC.DefaultFun a) - -> (ExceptT (PIR.Error PLC.DefaultUni PLC.DefaultFun a) m () -> prop) - -> (TC.PirTCConfig PLC.DefaultUni PLC.DefaultFun - -> Pass m tyname name PLC.DefaultUni PLC.DefaultFun a) - -> Property + forall m tyname name a prop. + (Monad m, Testable prop) => + a -> + ( Term TyName Name PLC.DefaultUni PLC.DefaultFun () -> + Term tyname name PLC.DefaultUni PLC.DefaultFun a + ) -> + (ExceptT (PIR.Error PLC.DefaultUni PLC.DefaultFun a) m () -> prop) -> + ( TC.PirTCConfig PLC.DefaultUni PLC.DefaultFun -> + Pass m tyname name PLC.DefaultUni PLC.DefaultFun a + ) -> + Property testPassProp' ann before after pass = - forAllDoc "ty,tm" genTypeAndTerm_ shrinkClosedTypedTerm $ \ (_ty, tm) -> + forAllDoc "ty,tm" genTypeAndTerm_ shrinkClosedTypedTerm $ \(_ty, tm) -> let res :: ExceptT (PIR.Error PLC.DefaultUni PLC.DefaultFun a) m () res = do @@ -94,4 +99,5 @@ testPassProp' ann before after pass = let tm' = before tm _ <- runPass (\_ -> pure ()) True (pass tcconfig) tm' pure () - in after res + in + after res diff --git a/plutus-core/testlib/PlutusIR/Test.hs b/plutus-core/testlib/PlutusIR/Test.hs index c09ff12f445..3531f305722 100644 --- a/plutus-core/testlib/PlutusIR/Test.hs +++ b/plutus-core/testlib/PlutusIR/Test.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module PlutusIR.Test - ( module PlutusIR.Test - , initialSrcSpan - , topSrcSpan - , rethrow - , PLC.prettyPlcClassicSimple - ) where +module PlutusIR.Test ( + module PlutusIR.Test, + initialSrcSpan, + topSrcSpan, + rethrow, + PLC.prettyPlcClassicSimple, +) where import PlutusPrelude import Test.Tasty.Extras @@ -102,11 +102,10 @@ instance PLC.AnnInline PLC.SrcSpans where pTermAsProg :: Parser (PIR.Program PIR.TyName PIR.Name PLC.DefaultUni PLC.DefaultFun PLC.SrcSpan) pTermAsProg = fmap (PIR.Program mempty PLC.latestVersion) pTerm -{- | Adapt an computation that keeps its errors in an 'Except' into one that looks as if -it caught them in 'IO'. --} +-- | Adapt an computation that keeps its errors in an 'Except' into one that looks as if +-- it caught them in 'IO'. asIfThrown :: - (Exception e) => + Exception e => Except e a -> ExceptT SomeException IO a asIfThrown = withExceptT SomeException . hoist (pure . runIdentity) @@ -155,16 +154,16 @@ withGoldenFileM name op = do ppCatch :: (a -> Doc ann) -> ExceptT SomeException IO a -> IO T.Text ppCatch toDoc value = render . either (pretty . show) toDoc <$> runExceptT value -goldenPir :: (PrettyPlc b) => (a -> b) -> Parser a -> String -> TestNested +goldenPir :: PrettyPlc b => (a -> b) -> Parser a -> String -> TestNested goldenPir op = goldenPirM (return . op) -goldenPirUnique :: (Pretty b) => (a -> b) -> Parser a -> String -> TestNested +goldenPirUnique :: Pretty b => (a -> b) -> Parser a -> String -> TestNested goldenPirUnique op = goldenPirMUnique (return . op) goldenPirDoc :: (a -> Doc ann) -> Parser a -> String -> TestNested goldenPirDoc op = goldenPirDocM (return . op) -goldenPirMUnique :: forall a b. (Pretty b) => (a -> IO b) -> Parser a -> String -> TestNested +goldenPirMUnique :: forall a b. Pretty b => (a -> IO b) -> Parser a -> String -> TestNested goldenPirMUnique op parser name = withGoldenFileM name parseOrError where parseOrError :: T.Text -> IO T.Text @@ -173,7 +172,7 @@ goldenPirMUnique op parser name = withGoldenFileM name parseOrError parseTxt txt = runQuoteT $ parse parser name txt in either (return . display) (fmap display . op) . parseTxt -goldenPirM :: forall a b. (PrettyPlc b) => (a -> IO b) -> Parser a -> String -> TestNested +goldenPirM :: forall a b. PrettyPlc b => (a -> IO b) -> Parser a -> String -> TestNested goldenPirM op parser name = withGoldenFileM name parseOrError where parseOrError :: T.Text -> IO T.Text @@ -193,7 +192,7 @@ goldenPirDocM op parser name = withGoldenFileM name parseOrError . parseTxt goldenPlcFromPir :: - (ToTPlc a PLC.DefaultUni PLC.DefaultFun) => + ToTPlc a PLC.DefaultUni PLC.DefaultFun => Parser a -> String -> TestNested @@ -202,8 +201,12 @@ goldenPlcFromPir = goldenPirM $ \ast -> ppCatch prettyPlcReadableSimple $ do withExceptT @_ @PLC.FreeVariableError toException $ traverseOf PLC.progTerm PLC.deBruijnTerm p goldenPlcFromPirScott :: - (Ord a, Typeable a, Pretty a, PLC.AnnInline a - , prog ~ PIR.Program PIR.TyName PIR.Name PLC.DefaultUni PLC.DefaultFun a) => + ( Ord a + , Typeable a + , Pretty a + , PLC.AnnInline a + , prog ~ PIR.Program PIR.TyName PIR.Name PLC.DefaultUni PLC.DefaultFun a + ) => Parser prog -> String -> TestNested @@ -216,14 +219,14 @@ goldenPlcFromPirScott = goldenPirM $ \ast -> ppCatch prettyPlcReadableSimple $ d withExceptT @_ @PLC.FreeVariableError toException $ traverseOf PLC.progTerm PLC.deBruijnTerm p goldenNamedUPlcFromPir :: - (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => + ToUPlc a PLC.DefaultUni PLC.DefaultFun => Parser a -> String -> TestNested goldenNamedUPlcFromPir = goldenPirM $ ppCatch prettyPlcReadableSimple . toUPlc goldenEvalPir :: - (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => + ToUPlc a PLC.DefaultUni PLC.DefaultFun => Parser a -> String -> TestNested diff --git a/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs b/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs index c71a2887499..783e3fee60e 100644 --- a/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs +++ b/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs @@ -1,12 +1,12 @@ -module UntypedPlutusCore.Generators.Hedgehog.AST - ( regenConstantsUntil - , PLC.AstGen - , PLC.runAstGen - , PLC.genVersion - , genTerm - , genProgram - , mangleNames - ) where +module UntypedPlutusCore.Generators.Hedgehog.AST ( + regenConstantsUntil, + PLC.AstGen, + PLC.runAstGen, + PLC.genVersion, + genTerm, + genProgram, + mangleNames, +) where import PlutusPrelude @@ -19,29 +19,29 @@ import Data.Set.Lens (setOf) import Hedgehog import Universe -regenConstantsUntil - :: MonadGen m - => (Some (ValueOf DefaultUni) -> Bool) - -> Program name DefaultUni fun ann - -> m (Program name DefaultUni fun ann) +regenConstantsUntil :: + MonadGen m => + (Some (ValueOf DefaultUni) -> Bool) -> + Program name DefaultUni fun ann -> + m (Program name DefaultUni fun ann) regenConstantsUntil p = - progTerm . termSubstConstantsM $ \ann -> fmap (fmap $ Constant ann) . PLC.regenConstantUntil p + progTerm . termSubstConstantsM $ \ann -> fmap (fmap $ Constant ann) . PLC.regenConstantUntil p -genTerm - :: forall fun - . (Bounded fun, Enum fun) - => PLC.AstGen (Term Name DefaultUni fun ()) +genTerm :: + forall fun. + (Bounded fun, Enum fun) => + PLC.AstGen (Term Name DefaultUni fun ()) genTerm = fmap eraseTerm PLC.genTerm -genProgram - :: forall fun - . (Bounded fun, Enum fun) => PLC.AstGen (Program Name DefaultUni fun ()) +genProgram :: + forall fun. + (Bounded fun, Enum fun) => PLC.AstGen (Program Name DefaultUni fun ()) genProgram = fmap eraseProgram PLC.genProgram -- See Note [Name mangling] -mangleNames - :: Term Name DefaultUni DefaultFun () - -> PLC.AstGen (Maybe (Term Name DefaultUni DefaultFun ())) +mangleNames :: + Term Name DefaultUni DefaultFun () -> + PLC.AstGen (Maybe (Term Name DefaultUni DefaultFun ())) mangleNames term = do - mayMang <- PLC.genNameMangler $ setOf vTerm term - for mayMang $ \mang -> termSubstNamesM (fmap (fmap $ UPLC.Var ()) . mang) term + mayMang <- PLC.genNameMangler $ setOf vTerm term + for mayMang $ \mang -> termSubstNamesM (fmap (fmap $ UPLC.Var ()) . mang) term diff --git a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs index d2a23a01acb..66385218347 100644 --- a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs +++ b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs @@ -1,28 +1,29 @@ {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module UntypedPlutusCore.Test.DeBruijn.Bad - ( var0 - , lamAbs1 - , fun0var0 - , fun1var0 - , fun1var1 - , deepFun1 - , deepOut0 - , deepMix0_1 - , deepMix1_0 - , deepOutMix1_0 - , manyFree01 - , iteStrict0 - , iteLazy0 - , ite10 - , illITEStrict - , illITELazy - , illPartialBuiltin - , illAdd - , illOverAppBuiltin - , illOverAppFun - ) where +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module UntypedPlutusCore.Test.DeBruijn.Bad ( + var0, + lamAbs1, + fun0var0, + fun1var0, + fun1var1, + deepFun1, + deepOut0, + deepMix0_1, + deepMix1_0, + deepOutMix1_0, + manyFree01, + iteStrict0, + iteLazy0, + ite10, + illITEStrict, + illITELazy, + illPartialBuiltin, + illAdd, + illOverAppBuiltin, + illOverAppFun, +) where import PlutusCore.Default import PlutusCore.MkPlc @@ -37,7 +38,7 @@ var0 :: Term DeBruijn uni fun () var0 = Var () $ DeBruijn 0 -- | Build a `LamAbs` with the binder having a non-sensical index. -lamAbs1 :: (t ~ Term DeBruijn uni fun ()) => t -> t +lamAbs1 :: t ~ Term DeBruijn uni fun () => t -> t lamAbs1 = LamAbs () $ DeBruijn 1 fun0var0, fun1var0, fun1var1 :: Term DeBruijn DefaultUni DefaultFun () @@ -48,122 +49,148 @@ fun1var1 = lamAbs1 $ Var () $ DeBruijn 1 -- | (lam1 ...n.... (Var n)) -- Wrong binders, Well-scoped variable deepFun1 :: Natural -> Term DeBruijn DefaultUni DefaultFun () -deepFun1 n = timesA n lamAbs1 $ - Var () $ DeBruijn $ fromIntegral n +deepFun1 n = + timesA n lamAbs1 $ + Var () $ + DeBruijn $ + fromIntegral n -- | (lam0 ...n.... (Var n+1)) -- Correct binders, Out-of-scope variable deepOut0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () -deepOut0 n = timesA n lamAbs0 $ - Var () $ DeBruijn $ fromIntegral $ n+1 - +deepOut0 n = + timesA n lamAbs0 $ + Var () $ + DeBruijn $ + fromIntegral $ + n + 1 -- | (lam0 ...n.... lam1 ...n.... (Var n+n)) -- Mix of correct and wrong binders, Well-scoped variable deepMix0_1 :: Natural -> Term DeBruijn DefaultUni DefaultFun () -deepMix0_1 n = timesA n lamAbs0 $ - timesA n lamAbs1 $ - Var () $ DeBruijn $ fromIntegral $ n+n +deepMix0_1 n = + timesA n lamAbs0 $ + timesA n lamAbs1 $ + Var () $ + DeBruijn $ + fromIntegral $ + n + n -- | (lam1 ...n.... lam0 ...n.... (Var n+n)) -- Mix of wrong and correct binders, well-scoped variable deepMix1_0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () -deepMix1_0 n = timesA n lamAbs1 $ - timesA n lamAbs0 $ - Var () $ DeBruijn $ fromIntegral $ n+n +deepMix1_0 n = + timesA n lamAbs1 $ + timesA n lamAbs0 $ + Var () $ + DeBruijn $ + fromIntegral $ + n + n -- | (lam1 ...n.... lam0 ...n.... (Var n+n+1)) -- Mix of correct and wrong binders, out-of-scope variable deepOutMix1_0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () -deepOutMix1_0 n = timesA n lamAbs1 $ - timesA n lamAbs0 $ - Var () $ DeBruijn $ fromIntegral $ n+n+1 +deepOutMix1_0 n = + timesA n lamAbs1 $ + timesA n lamAbs0 $ + Var () $ + DeBruijn $ + fromIntegral $ + n + n + 1 -- | [(force (builtin ifThenElse) (con bool True) (con bool True) var99] -- Both branches are evaluated *before* the predicate, -- so it is clear that this should fail in every case. iteStrict0 :: Term DeBruijn DefaultUni DefaultFun () -iteStrict0 = Force () (Builtin () IfThenElse) @@ - [ true -- pred - , true -- then - , var0 -- else - ] +iteStrict0 = + Force () (Builtin () IfThenElse) + @@ [ true -- pred + , true -- then + , var0 -- else + ] -- | [(force (builtin ifThenElse) (con bool True) (delay true) (delay var99)] -- The branches are *lazy*. The evaluation result (success or failure) depends on how the machine -- ignores the irrelevant to the computation) part of the environment. iteLazy0 :: Term DeBruijn DefaultUni DefaultFun () -iteLazy0 = Force () (Builtin () IfThenElse) @@ - [ true -- pred - , Delay () true -- then - , Delay () var0 -- else - ] +iteLazy0 = + Force () (Builtin () IfThenElse) + @@ [ true -- pred + , Delay () true -- then + , Delay () var0 -- else + ] -- | [(force (builtin ifThenElse) (con bool True) (lam0 var1) (lam1 var0)] ite10 :: Term DeBruijn DefaultUni DefaultFun () -ite10 = Force () (Builtin () IfThenElse) @@ - [ true -- pred - , idFun0 -- then - , fun1var0 -- else - ] +ite10 = + Force () (Builtin () IfThenElse) + @@ [ true -- pred + , idFun0 -- then + , fun1var0 -- else + ] -- | An example with a lot of free vars manyFree01 :: Term DeBruijn DefaultUni DefaultFun () -manyFree01 = timesA 5 (Apply () (timesA 10 forceDelay var0)) $ - timesA 20 forceDelay $ - Var () $ DeBruijn 1 - where - forceDelay = Force () . Delay () - +manyFree01 = + timesA 5 (Apply () (timesA 10 forceDelay var0)) $ + timesA 20 forceDelay $ + Var () $ + DeBruijn 1 + where + forceDelay = Force () . Delay () -- * Examples will ill-typed terms -- | [(force (builtin ifThenElse) (con bool True) (con bool True) (con unit ())] -- Note that the branches have **different** types. The machine cannot catch such a type error. illITEStrict :: Term DeBruijn DefaultUni DefaultFun () -illITEStrict = Force () (Builtin () IfThenElse) @@ - [ true -- pred - , true -- then - , unitval -- else - ] +illITEStrict = + Force () (Builtin () IfThenElse) + @@ [ true -- pred + , true -- then + , unitval -- else + ] -- | [(force (builtin ifThenElse) (con bool True) (lam x (con bool True)) (lam x (con unit ()))] -- The branches are *lazy*. Note that the branches have **different** types. -- The machine cannot catch such a type error. illITELazy :: Term DeBruijn DefaultUni DefaultFun () -illITELazy = Force () (Builtin () IfThenElse) @@ - [ true -- pred - , lamAbs0 true -- then - , Delay () true -- else - ] +illITELazy = + Force () (Builtin () IfThenElse) + @@ [ true -- pred + , lamAbs0 true -- then + , Delay () true -- else + ] -- | [(builtin addInteger) (con integer 1) (con unit ())] -- Interesting because it involves a runtime type-error of a builtin. illAdd :: Term DeBruijn DefaultUni DefaultFun () -illAdd = Builtin () AddInteger @@ - [ one - , unitval - ] +illAdd = + Builtin () AddInteger + @@ [ one + , unitval + ] -- | [(builtin addInteger) (con integer 1) (con integer 1) (con integer 1)] -- Interesting because it involves a (builtin) over-saturation type-error, -- which the machine can recognize. illOverAppBuiltin :: Term DeBruijn DefaultUni DefaultFun () -illOverAppBuiltin = Builtin () AddInteger @@ - [ one - , one - , one - ] - +illOverAppBuiltin = + Builtin () AddInteger + @@ [ one + , one + , one + ] -- | [(lam x x) (con integer 1) (con integer 1)] -- Interesting because it involves a (lambda) over-saturation type-error, -- which the machine can recognize. illOverAppFun :: Term DeBruijn DefaultUni DefaultFun () -illOverAppFun = idFun0 @@ - [ one - , one - ] +illOverAppFun = + idFun0 + @@ [ one + , one + ] -- | [addInteger true] -- this relates to the immediate vs deferred unlifting. diff --git a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs index c17c7948fd0..d01ad6ea45f 100644 --- a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs +++ b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module UntypedPlutusCore.Test.DeBruijn.Good - ( lamAbs0 - , idFun0 - , const0 - , deepFun0 - , deeperFun0 - ) where + +module UntypedPlutusCore.Test.DeBruijn.Good ( + lamAbs0, + idFun0, + const0, + deepFun0, + deeperFun0, +) where import PlutusPrelude import UntypedPlutusCore -- | A helper to intro the only "sensical" lam: debruijn binders are always 0-indexed -lamAbs0 :: (t ~ Term DeBruijn uni fun ()) => t -> t +lamAbs0 :: t ~ Term DeBruijn uni fun () => t -> t lamAbs0 = LamAbs () $ DeBruijn deBruijnInitIndex -- | This is a replica of `PlutusCore.StdLib.Data.Function.idFun0` but using `DeBruijn` indices. @@ -31,6 +32,10 @@ deepFun0 n = timesA n lamAbs0 $ Var () $ DeBruijn $ fromIntegral n -- | (lam0 ...n.... lam0 ...n.... (Var n+n)) -- Correct binders, well-scoped variable deeperFun0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () -deeperFun0 n = timesA n lamAbs0 $ - timesA n lamAbs0 $ - Var () $ DeBruijn $ fromIntegral $ n+n +deeperFun0 n = + timesA n lamAbs0 $ + timesA n lamAbs0 $ + Var () $ + DeBruijn $ + fromIntegral $ + n + n diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs index 26f853c31bc..7f863920d19 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs @@ -1,19 +1,19 @@ module UntypedPlutusCore ( - module Export - , Term (..) - , Program (..) - , applyProgram - , parseScoped - , PLC.DefaultUni - , PLC.DefaultFun - ) where + module Export, + Term (..), + Program (..), + applyProgram, + parseScoped, + PLC.DefaultUni, + PLC.DefaultFun, +) where +import UntypedPlutusCore.AstSize as Export import UntypedPlutusCore.Check.Scope as Export import UntypedPlutusCore.Core as Export import UntypedPlutusCore.DeBruijn as Export import UntypedPlutusCore.Parser as Parser (parseScoped) import UntypedPlutusCore.Simplify as Export -import UntypedPlutusCore.AstSize as Export import UntypedPlutusCore.Subst as Export import PlutusCore.Default qualified as PLC @@ -24,12 +24,13 @@ import Control.Monad.Except -- | Applies one program to another. Fails if the versions do not match -- and tries to merge annotations. -applyProgram - :: (MonadError ApplyProgramError m, Semigroup a) - => Program name uni fun a - -> Program name uni fun a - -> m (Program name uni fun a) -applyProgram (Program a1 v1 t1) (Program a2 v2 t2) | v1 == v2 - = pure $ Program (a1 <> a2) v1 (Apply (termAnn t1 <> termAnn t2) t1 t2) +applyProgram :: + (MonadError ApplyProgramError m, Semigroup a) => + Program name uni fun a -> + Program name uni fun a -> + m (Program name uni fun a) +applyProgram (Program a1 v1 t1) (Program a2 v2 t2) + | v1 == v2 = + pure $ Program (a1 <> a2) v1 (Apply (termAnn t1 <> termAnn t2) t1 t2) applyProgram (Program _a1 v1 _t1) (Program _a2 v2 _t2) = - throwError $ MkApplyProgramError v1 v2 + throwError $ MkApplyProgramError v1 v2 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs index 343f2070244..9da6a3b6db4 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs @@ -1,11 +1,12 @@ {-# LANGUAGE LambdaCase #-} + -- | Definition analysis for untyped Plutus Core. -- This just adapts term-related code from PlutusCore.Analysis.Definitions; -- we just re-use the typed machinery to do the hard work here. -module UntypedPlutusCore.Analysis.Definitions - ( termDefs - , runTermDefs - ) where +module UntypedPlutusCore.Analysis.Definitions ( + termDefs, + runTermDefs, +) where import UntypedPlutusCore.Core @@ -19,33 +20,37 @@ import Control.Monad.Writer (MonadWriter, WriterT (runWriterT)) -- | Given a UPLC term, add all of its term definitions and usages, including its subterms, -- to a global map. -termDefs - :: (Ord ann, - HasUnique name TermUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Term name uni fun ann - -> m () +termDefs :: + ( Ord ann + , HasUnique name TermUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Term name uni fun ann -> + m () termDefs tm = do - forMOf_ termSubtermsDeep tm handleTerm + forMOf_ termSubtermsDeep tm handleTerm -handleTerm :: (Ord ann, - HasUnique name TermUnique, - MonadState (UniqueInfos ann) m, - MonadWriter [UniqueError ann] m) - => Term name uni fun ann - -> m () +handleTerm :: + ( Ord ann + , HasUnique name TermUnique + , MonadState (UniqueInfos ann) m + , MonadWriter [UniqueError ann] m + ) => + Term name uni fun ann -> + m () handleTerm = \case - Var ann n -> - addUsage n ann TermScope - LamAbs ann n _ -> - addDef n ann TermScope - _ -> pure () + Var ann n -> + addUsage n ann TermScope + LamAbs ann n _ -> + addDef n ann TermScope + _ -> pure () -runTermDefs - :: (Ord ann, - HasUnique name TermUnique, - Monad m) - => Term name uni fun ann - -> m (UniqueInfos ann, [UniqueError ann]) +runTermDefs :: + ( Ord ann + , HasUnique name TermUnique + , Monad m + ) => + Term name uni fun ann -> + m (UniqueInfos ann, [UniqueError ann]) runTermDefs = runWriterT . flip execStateT mempty . termDefs diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs index 0e7d8547b55..b483e77dd84 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs @@ -1,5 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE FlexibleContexts #-} + -- | Functions for computing variable usage inside terms. module UntypedPlutusCore.Analysis.Usages (termUsages, Usages, getUsageCount, allUsed) where @@ -18,15 +19,15 @@ import Data.Set qualified as Set type Usages = MSet.MultiSet PLC.Unique -- | Get the usage count of @n@. -getUsageCount :: (PLC.HasUnique n unique) => n -> Usages -> Int +getUsageCount :: PLC.HasUnique n unique => n -> Usages -> Int getUsageCount n = MSet.occur (n ^. PLC.unique . coerced) -- | Get a set of @n@s which are used at least once. allUsed :: Usages -> Set.Set PLC.Unique allUsed = MSet.toSet -termUsages - :: (PLC.HasUnique name PLC.TermUnique) - => Term name uni fun a - -> Usages +termUsages :: + PLC.HasUnique name PLC.TermUnique => + Term name uni fun a -> + Usages termUsages = multiSetOf (vTerm . PLC.theUnique) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs index 8c5da932e6a..40e9fe718eb 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs @@ -1,7 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} + module UntypedPlutusCore.Check.Scope (checkScope) where import Control.Lens hiding (index) @@ -11,43 +12,45 @@ import UntypedPlutusCore.DeBruijn as UPLC import Control.Monad (unless) import Control.Monad.Except (MonadError, throwError) -{- | A pass to check that the input term: -1) does not contain free variables and -2) that all binders are set to debruijn index 0. - -Feeding the result of the debruijnification to this function is expected to pass. - -On the other hand, because of (2), this pass is -stricter than the undebruijnification's (indirect) -scope-checking, see Note [DeBruijn indices of Binders]. - -Inlining this function makes a big difference, -since it will usually be called in a context where all the type variables are known. -That then means that GHC can optimize go locally in a completely monomorphic setting, which helps a lot. --} -checkScope :: forall m name uni fun a. - (HasIndex name, MonadError FreeVariableError m) - => UPLC.Term name uni fun a - -> m () +-- | A pass to check that the input term: +-- 1) does not contain free variables and +-- 2) that all binders are set to debruijn index 0. +-- +-- Feeding the result of the debruijnification to this function is expected to pass. +-- +-- On the other hand, because of (2), this pass is +-- stricter than the undebruijnification's (indirect) +-- scope-checking, see Note [DeBruijn indices of Binders]. +-- +-- Inlining this function makes a big difference, +-- since it will usually be called in a context where all the type variables are known. +-- That then means that GHC can optimize go locally in a completely monomorphic setting, which helps a lot. +checkScope :: + forall m name uni fun a. + (HasIndex name, MonadError FreeVariableError m) => + UPLC.Term name uni fun a -> + m () checkScope = go 0 where -- the current level as a reader value go :: Word -> UPLC.Term name uni fun a -> m () go !lvl = \case - Var _ n -> do - let i = n ^. index - -- var index must be larger than 0 - -- var index must be LEQ to the current level - unless (i > 0 && fromIntegral i <= lvl) $ - throwError $ FreeIndex i - LamAbs _ binder t -> do - let bIx = binder^.index - -- binder index must be equal to 0 - unless (bIx == 0) $ - throwError $ FreeIndex bIx - go (lvl+1) t - Apply _ t1 t2 -> go lvl t1 >> go lvl t2 - Force _ t -> go lvl t - Delay _ t -> go lvl t - _ -> pure () + Var _ n -> do + let i = n ^. index + -- var index must be larger than 0 + -- var index must be LEQ to the current level + unless (i > 0 && fromIntegral i <= lvl) $ + throwError $ + FreeIndex i + LamAbs _ binder t -> do + let bIx = binder ^. index + -- binder index must be equal to 0 + unless (bIx == 0) $ + throwError $ + FreeIndex bIx + go (lvl + 1) t + Apply _ t1 t2 -> go lvl t1 >> go lvl t2 + Force _ t -> go lvl t + Delay _ t -> go lvl t + _ -> pure () {-# INLINE checkScope #-} diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs index 04475805734..e63b9b7c05b 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs @@ -1,8 +1,8 @@ -module UntypedPlutusCore.Check.Uniques - ( checkProgram - , checkTerm - , UniqueError (..) - ) where +module UntypedPlutusCore.Check.Uniques ( + checkProgram, + checkTerm, + UniqueError (..), +) where import UntypedPlutusCore.Analysis.Definitions import UntypedPlutusCore.Core @@ -15,22 +15,24 @@ import Control.Monad.Except import Data.Foldable -checkProgram - :: (Ord ann, - HasUnique name TermUnique, - MonadError (UniqueError ann) m) - => (UniqueError ann -> Bool) - -> Program name uni fun ann - -> m () +checkProgram :: + ( Ord ann + , HasUnique name TermUnique + , MonadError (UniqueError ann) m + ) => + (UniqueError ann -> Bool) -> + Program name uni fun ann -> + m () checkProgram p (Program _ _ t) = checkTerm p t -checkTerm - :: (Ord ann, - HasUnique name TermUnique, - MonadError (UniqueError ann) m) - => (UniqueError ann -> Bool) - -> Term name uni fun ann - -> m () +checkTerm :: + ( Ord ann + , HasUnique name TermUnique + , MonadError (UniqueError ann) m + ) => + (UniqueError ann -> Bool) -> + Term name uni fun ann -> + m () checkTerm p t = do - (_, errs) <- runTermDefs t - for_ errs $ \e -> when (p e) $ throwError e + (_, errs) <- runTermDefs t + for_ errs $ \e -> when (p e) $ throwError e diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs index 944cf8a53c5..d3f455fc0c8 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs @@ -7,35 +7,32 @@ import UntypedPlutusCore.Core.Instance.Eq () -- | A context for an iterated term/type application. data AppCtx name uni fun a - = AppCtxTerm a (Term name uni fun a) (AppCtx name uni fun a) + = AppCtxTerm a (Term name uni fun a) (AppCtx name uni fun a) | AppCtxType a (AppCtx name uni fun a) | AppCtxEnd -{-| Takes a term and views it as a head plus an 'AppCtx', e.g. -@ - [{ f t } u v] - --> - (f, [{ _ t } u v]) - == - f (AppCtxType t (AppCtxTerm u (AppCtxTerm v AppCtxEnd))) -@ --} +-- | Takes a term and views it as a head plus an 'AppCtx', e.g. +-- @ +-- [{ f t } u v] +-- --> +-- (f, [{ _ t } u v]) +-- == +-- f (AppCtxType t (AppCtxTerm u (AppCtxTerm v AppCtxEnd))) +-- @ splitAppCtx :: Term nam uni fun a -> (Term nam uni fun a, AppCtx nam uni fun a) splitAppCtx = go AppCtxEnd - where - go appCtx = \case - Apply ann function argument -> go (AppCtxTerm ann argument appCtx) function - Force ann forcedTerm -> go (AppCtxType ann appCtx) forcedTerm - term -> (term, appCtx) + where + go appCtx = \case + Apply ann function argument -> go (AppCtxTerm ann argument appCtx) function + Force ann forcedTerm -> go (AppCtxType ann appCtx) forcedTerm + term -> (term, appCtx) -- | Fills in the hole in an 'AppCtx', the inverse of 'splitAppCtx'. -fillAppCtx - :: Term name uni fun ann - -> AppCtx name uni fun ann - -> Term name uni fun ann +fillAppCtx :: + Term name uni fun ann -> + AppCtx name uni fun ann -> + Term name uni fun ann fillAppCtx term = \case AppCtxEnd -> term AppCtxTerm ann arg ctx -> fillAppCtx (Apply ann term arg) ctx AppCtxType ann ctx -> fillAppCtx (Force ann term) ctx - - diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs index 101a828f0cf..be6771f4321 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs @@ -16,7 +16,7 @@ import Data.Bifunctor splitParams :: Term name uni fun a -> ([name], Term name uni fun a) splitParams = \case LamAbs _ n t -> first (n :) (splitParams t) - t -> ([], t) + t -> ([], t) -- | Strip off arguments splitApplication :: Term name uni fun a -> (Term name uni fun a, [(a, Term name uni fun a)]) @@ -24,4 +24,4 @@ splitApplication = go [] where go acc = \case Apply ann fun arg -> go ((ann, arg) : acc) fun - t -> (t, acc) + t -> (t, acc) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs index 64d617ad9d0..1172a74f4ed 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs @@ -1,11 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- editorconfig-checker-disable-file {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - module UntypedPlutusCore.Core.Instance.Eq () where import PlutusPrelude @@ -22,9 +21,11 @@ import Universe import Data.Hashable import Data.Vector qualified as V -instance (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => - Eq (Term Name uni fun ann) where - term1 == term2 = runEqRename $ eqTermM term1 term2 +instance + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => + Eq (Term Name uni fun ann) + where + term1 == term2 = runEqRename $ eqTermM term1 term2 type HashableTermConstraints uni fun ann = ( GEq uni @@ -48,73 +49,79 @@ instance HashableTermConstraints uni fun ann => Hashable (Term Name uni fun ann) -- c) We do not do equality ""modulo annotations". -- If a user wants to ignore annotations he must prior do `void <$> term`, to throw away any annotations. deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => - Eq (Term NamedDeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => + Eq (Term NamedDeBruijn uni fun ann) instance HashableTermConstraints uni fun ann => Hashable (Term NamedDeBruijn uni fun ann) deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => - Eq (Term FakeNamedDeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => + Eq (Term FakeNamedDeBruijn uni fun ann) instance HashableTermConstraints uni fun ann => Hashable (Term FakeNamedDeBruijn uni fun ann) deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => - Eq (Term DeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) => + Eq (Term DeBruijn uni fun ann) instance HashableTermConstraints uni fun ann => Hashable (Term DeBruijn uni fun ann) -deriving stock instance (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann, - Eq (Term name uni fun ann) - ) => Eq (Program name uni fun ann) +deriving stock instance + ( GEq uni + , Closed uni + , uni `Everywhere` Eq + , Eq fun + , Eq ann + , Eq (Term name uni fun ann) + ) => + Eq (Program name uni fun ann) -- | Check equality of two 'Term's. -eqTermM - :: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann, HasUnique name TermUnique) - => Term name uni fun ann -> Term name uni fun ann -> EqRename (Renaming TermUnique) +eqTermM :: + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann, HasUnique name TermUnique) => + Term name uni fun ann -> Term name uni fun ann -> EqRename (Renaming TermUnique) eqTermM (Constant ann1 con1) (Constant ann2 con2) = do - eqM ann1 ann2 - eqM con1 con2 + eqM ann1 ann2 + eqM con1 con2 eqTermM (Builtin ann1 bi1) (Builtin ann2 bi2) = do - eqM ann1 ann2 - eqM bi1 bi2 + eqM ann1 ann2 + eqM bi1 bi2 eqTermM (Var ann1 name1) (Var ann2 name2) = do - eqM ann1 ann2 - eqNameM name1 name2 + eqM ann1 ann2 + eqNameM name1 name2 eqTermM (LamAbs ann1 name1 body1) (LamAbs ann2 name2 body2) = do - eqM ann1 ann2 - withTwinBindings name1 name2 $ eqTermM body1 body2 + eqM ann1 ann2 + withTwinBindings name1 name2 $ eqTermM body1 body2 eqTermM (Apply ann1 fun1 arg1) (Apply ann2 fun2 arg2) = do - eqM ann1 ann2 - eqTermM fun1 fun2 - eqTermM arg1 arg2 + eqM ann1 ann2 + eqTermM fun1 fun2 + eqTermM arg1 arg2 eqTermM (Delay ann1 term1) (Delay ann2 term2) = do - eqM ann1 ann2 - eqTermM term1 term2 + eqM ann1 ann2 + eqTermM term1 term2 eqTermM (Force ann1 term1) (Force ann2 term2) = do - eqM ann1 ann2 - eqTermM term1 term2 + eqM ann1 ann2 + eqTermM term1 term2 eqTermM (Error ann1) (Error ann2) = eqM ann1 ann2 eqTermM (Constr ann1 i1 args1) (Constr ann2 i2 args2) = do - eqM ann1 ann2 - eqM i1 i2 - case zipExact args1 args2 of - Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 - Nothing -> empty + eqM ann1 ann2 + eqM i1 i2 + case zipExact args1 args2 of + Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 + Nothing -> empty eqTermM (Case ann1 a1 cs1) (Case ann2 a2 cs2) = do - eqM ann1 ann2 - eqTermM a1 a2 - case zipExact (toList cs1) (toList cs2) of - Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 - Nothing -> empty -eqTermM Constant{} _ = empty -eqTermM Builtin{} _ = empty -eqTermM Var{} _ = empty -eqTermM LamAbs{} _ = empty -eqTermM Apply{} _ = empty -eqTermM Delay{} _ = empty -eqTermM Force{} _ = empty -eqTermM Error{} _ = empty -eqTermM Constr{} _ = empty -eqTermM Case{} _ = empty + eqM ann1 ann2 + eqTermM a1 a2 + case zipExact (toList cs1) (toList cs2) of + Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 + Nothing -> empty +eqTermM Constant {} _ = empty +eqTermM Builtin {} _ = empty +eqTermM Var {} _ = empty +eqTermM LamAbs {} _ = empty +eqTermM Apply {} _ = empty +eqTermM Delay {} _ = empty +eqTermM Force {} _ = empty +eqTermM Error {} _ = empty +eqTermM Constr {} _ = empty +eqTermM Case {} _ = empty diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs index 1510a708cc7..f5239363001 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs @@ -1,12 +1,12 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module UntypedPlutusCore.Core.Instance.Flat where @@ -60,12 +60,12 @@ This requires specialised encode/decode functions for each constructor that encodes a different number of possibilities. Here is a list of the tags and their used/available encoding possibilities. -** The BELOW table is for UPLC. ** +\** The BELOW table is for UPLC. ** -| Data type | Function | Bit Width | Total | Used | Remaining | -|------------------|-------------------|-----------|-------|------|-----------| -| default builtins | encodeBuiltin | 7 | 128 | 54 | 74 | -| Terms | encodeTerm | 4 | 16 | 10 | 6 | +\| Data type | Function | Bit Width | Total | Used | Remaining | +\|------------------|-------------------|-----------|-------|------|-----------| +\| default builtins | encodeBuiltin | 7 | 128 | 54 | 74 | +\| Terms | encodeTerm | 4 | 16 | 10 | 6 | For format stability we are manually assigning the tag values to the constructors (and we do not use a generic algorithm that may change this order). @@ -102,173 +102,181 @@ encodeTermTag = safeEncodeBits termTagWidth decodeTermTag :: Get Word8 decodeTermTag = dBEBits8 termTagWidth -encodeTerm - :: forall name uni fun ann - . ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat name - , Flat (Binder name) - ) - => Term name uni fun ann - -> Encoding +encodeTerm :: + forall name uni fun ann. + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat name + , Flat (Binder name) + ) => + Term name uni fun ann -> + Encoding encodeTerm = \case - Var ann n -> encodeTermTag 0 <> encode ann <> encode n - Delay ann t -> encodeTermTag 1 <> encode ann <> encodeTerm t - LamAbs ann n t -> encodeTermTag 2 <> encode ann <> encode (Binder n) <> encodeTerm t - Apply ann t t' -> encodeTermTag 3 <> encode ann <> encodeTerm t <> encodeTerm t' - Constant ann c -> encodeTermTag 4 <> encode ann <> encode c - Force ann t -> encodeTermTag 5 <> encode ann <> encodeTerm t - Error ann -> encodeTermTag 6 <> encode ann - Builtin ann bn -> encodeTermTag 7 <> encode ann <> encode bn - Constr ann i es -> encodeTermTag 8 <> encode ann <> encode i <> encodeListWith encodeTerm es - Case ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm (V.toList cs) - -decodeTerm - :: forall name uni fun ann - . ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat name - , Flat (Binder name) - ) - => Version - -> (fun -> Maybe String) - -> Get (Term name uni fun ann) + Var ann n -> encodeTermTag 0 <> encode ann <> encode n + Delay ann t -> encodeTermTag 1 <> encode ann <> encodeTerm t + LamAbs ann n t -> encodeTermTag 2 <> encode ann <> encode (Binder n) <> encodeTerm t + Apply ann t t' -> encodeTermTag 3 <> encode ann <> encodeTerm t <> encodeTerm t' + Constant ann c -> encodeTermTag 4 <> encode ann <> encode c + Force ann t -> encodeTermTag 5 <> encode ann <> encodeTerm t + Error ann -> encodeTermTag 6 <> encode ann + Builtin ann bn -> encodeTermTag 7 <> encode ann <> encode bn + Constr ann i es -> encodeTermTag 8 <> encode ann <> encode i <> encodeListWith encodeTerm es + Case ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm (V.toList cs) + +decodeTerm :: + forall name uni fun ann. + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat name + , Flat (Binder name) + ) => + Version -> + (fun -> Maybe String) -> + Get (Term name uni fun ann) decodeTerm version builtinPred = go - where - go = handleTerm =<< decodeTermTag - handleTerm 0 = Var <$> decode <*> decode - handleTerm 1 = Delay <$> decode <*> go - handleTerm 2 = LamAbs <$> decode <*> (unBinder <$> decode) <*> go - handleTerm 3 = Apply <$> decode <*> go <*> go - handleTerm 4 = Constant <$> decode <*> decode - handleTerm 5 = Force <$> decode <*> go - handleTerm 6 = Error <$> decode - handleTerm 7 = do - ann <- decode - fun <- decode - let t :: Term name uni fun ann - t = Builtin ann fun - case builtinPred fun of - Nothing -> pure t - Just e -> fail e - handleTerm 8 = do - unless (version >= PLC.plcVersion110) $ fail $ "'constr' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version) - Constr <$> decode <*> decode <*> decodeListWith go - handleTerm 9 = do - unless (version >= PLC.plcVersion110) $ fail $ "'case' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version) - Case <$> decode <*> go <*> (V.fromList <$> decodeListWith go) - handleTerm t = fail $ "Unknown term constructor tag: " ++ show t - -sizeTerm - :: forall name uni fun ann - . ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat name - , Flat (Binder name) - ) - => Term name uni fun ann - -> NumBits - -> NumBits + where + go = handleTerm =<< decodeTermTag + handleTerm 0 = Var <$> decode <*> decode + handleTerm 1 = Delay <$> decode <*> go + handleTerm 2 = LamAbs <$> decode <*> (unBinder <$> decode) <*> go + handleTerm 3 = Apply <$> decode <*> go <*> go + handleTerm 4 = Constant <$> decode <*> decode + handleTerm 5 = Force <$> decode <*> go + handleTerm 6 = Error <$> decode + handleTerm 7 = do + ann <- decode + fun <- decode + let t :: Term name uni fun ann + t = Builtin ann fun + case builtinPred fun of + Nothing -> pure t + Just e -> fail e + handleTerm 8 = do + unless (version >= PLC.plcVersion110) $ fail $ "'constr' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version) + Constr <$> decode <*> decode <*> decodeListWith go + handleTerm 9 = do + unless (version >= PLC.plcVersion110) $ fail $ "'case' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version) + Case <$> decode <*> go <*> (V.fromList <$> decodeListWith go) + handleTerm t = fail $ "Unknown term constructor tag: " ++ show t + +sizeTerm :: + forall name uni fun ann. + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat name + , Flat (Binder name) + ) => + Term name uni fun ann -> + NumBits -> + NumBits sizeTerm tm sz = let sz' = termTagWidth + sz - in case tm of - Var ann n -> size ann $ size n sz' - Delay ann t -> size ann $ sizeTerm t sz' - LamAbs ann n t -> size ann $ size n $ sizeTerm t sz' - Apply ann t t' -> size ann $ sizeTerm t $ sizeTerm t' sz' - Constant ann c -> size ann $ size c sz' - Force ann t -> size ann $ sizeTerm t sz' - Error ann -> size ann sz' - Builtin ann bn -> size ann $ size bn sz' - Constr ann i es -> size ann $ size i $ sizeListWith sizeTerm es sz' - Case ann arg cs -> size ann $ sizeTerm arg $ sizeListWith sizeTerm (V.toList cs) sz' + in + case tm of + Var ann n -> size ann $ size n sz' + Delay ann t -> size ann $ sizeTerm t sz' + LamAbs ann n t -> size ann $ size n $ sizeTerm t sz' + Apply ann t t' -> size ann $ sizeTerm t $ sizeTerm t' sz' + Constant ann c -> size ann $ size c sz' + Force ann t -> size ann $ sizeTerm t sz' + Error ann -> size ann sz' + Builtin ann bn -> size ann $ size bn sz' + Constr ann i es -> size ann $ size i $ sizeListWith sizeTerm es sz' + Case ann arg cs -> size ann $ sizeTerm arg $ sizeListWith sizeTerm (V.toList cs) sz' -- | An encoder for programs. -- -- It is not easy to use this correctly with @flat@. The simplest thing -- is to go via the instance for 'UnrestrictedProgram', which uses this -encodeProgram - :: forall name uni fun ann - . ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat name - , Flat (Binder name) - ) - => Program name uni fun ann - -> Encoding +encodeProgram :: + forall name uni fun ann. + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat name + , Flat (Binder name) + ) => + Program name uni fun ann -> + Encoding encodeProgram (Program ann v t) = encode ann <> encode v <> encodeTerm t -decodeProgram - :: forall name uni fun ann - . ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat name - , Flat (Binder name) - ) - => (fun -> Maybe String) - -> Get (Program name uni fun ann) +decodeProgram :: + forall name uni fun ann. + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat name + , Flat (Binder name) + ) => + (fun -> Maybe String) -> + Get (Program name uni fun ann) decodeProgram builtinPred = do ann <- decode v <- decode Program ann v <$> decodeTerm v builtinPred -sizeProgram - :: forall name uni fun ann - . ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat name - , Flat (Binder name) - ) - => Program name uni fun ann - -> NumBits - -> NumBits +sizeProgram :: + forall name uni fun ann. + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat name + , Flat (Binder name) + ) => + Program name uni fun ann -> + NumBits -> + NumBits sizeProgram (Program ann v t) sz = size ann $ size v $ sizeTerm t sz -- | A program that can be serialized without any restrictions, e.g. -- on the set of allowable builtins or term constructs. It is generally -- safe to use this newtype for serializing, but it should only be used -- for deserializing in tests. -newtype UnrestrictedProgram name uni fun ann = UnrestrictedProgram { unUnrestrictedProgram :: Program name uni fun ann } - deriving newtype (Functor) +newtype UnrestrictedProgram name uni fun ann = UnrestrictedProgram {unUnrestrictedProgram :: Program name uni fun ann} + deriving newtype (Functor) + makeWrapped ''UnrestrictedProgram -deriving newtype instance (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (UnrestrictedProgram name uni fun ann) +deriving newtype instance + (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (UnrestrictedProgram name uni fun ann) -deriving via PrettyAny (UnrestrictedProgram name uni fun ann) - instance DefaultPrettyPlcStrategy (UnrestrictedProgram name uni fun ann) => - PrettyBy PrettyConfigPlc (UnrestrictedProgram name uni fun ann) +deriving via + PrettyAny (UnrestrictedProgram name uni fun ann) + instance + DefaultPrettyPlcStrategy (UnrestrictedProgram name uni fun ann) => + PrettyBy PrettyConfigPlc (UnrestrictedProgram name uni fun ann) deriving newtype instance - (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) - => PrettyBy (PrettyConfigClassic PrettyConfigName) (UnrestrictedProgram name uni fun ann) + (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) => + PrettyBy (PrettyConfigClassic PrettyConfigName) (UnrestrictedProgram name uni fun ann) deriving newtype instance - (PrettyReadable name, PrettyUni uni, Pretty fun) - => PrettyBy (PrettyConfigReadable PrettyConfigName) (UnrestrictedProgram name uni fun ann) + (PrettyReadable name, PrettyUni uni, Pretty fun) => + PrettyBy (PrettyConfigReadable PrettyConfigName) (UnrestrictedProgram name uni fun ann) -- This instance does _not_ check for allowable builtins -instance ( Closed uni - , uni `Everywhere` Flat - , Flat fun - , Flat ann - , Flat name - , Flat (Binder name) - ) => Flat (UnrestrictedProgram name uni fun ann) where - encode (UnrestrictedProgram p) = encodeProgram p - decode = UnrestrictedProgram <$> decodeProgram (const Nothing) - - size (UnrestrictedProgram p) = sizeProgram p +instance + ( Closed uni + , uni `Everywhere` Flat + , Flat fun + , Flat ann + , Flat name + , Flat (Binder name) + ) => + Flat (UnrestrictedProgram name uni fun ann) + where + encode (UnrestrictedProgram p) = encodeProgram p + decode = UnrestrictedProgram <$> decodeProgram (const Nothing) + + size (UnrestrictedProgram p) = sizeProgram p diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs index 0373e323608..6fd91270e3d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs @@ -1,13 +1,11 @@ --- | A "classic" (i.e. as seen in the specification) way to pretty-print Untyped Plutus Core terms. - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | A "classic" (i.e. as seen in the specification) way to pretty-print Untyped Plutus Core terms. module UntypedPlutusCore.Core.Instance.Pretty.Classic () where import PlutusPrelude @@ -21,40 +19,75 @@ import Prettyprinter import Prettyprinter.Custom import Universe (Some (..), SomeTypeIn (SomeTypeIn), ValueOf (..)) -instance (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann) => - PrettyBy (PrettyConfigClassic configName) (Term name uni fun ann) where - prettyBy config = \case - Var ann n -> - sep (consAnnIf config ann [prettyBy config n]) - LamAbs ann n t -> - sexp "lam" (consAnnIf config ann - [prettyBy config n, prettyBy config t]) - Apply ann t1 t2 -> - brackets' (sep (consAnnIf config ann - [prettyBy config t1, prettyBy config t2])) - Constant ann c -> - sexp "con" (consAnnIf config ann [prettyTypeOf c, pretty c]) - Builtin ann bi -> - sexp "builtin" (consAnnIf config ann - [pretty bi]) - Error ann -> - sexp "error" (consAnnIf config ann []) - Delay ann term -> - sexp "delay" (consAnnIf config ann - [prettyBy config term]) - Force ann term -> - sexp "force" (consAnnIf config ann - [prettyBy config term]) - Constr ann i es -> - sexp "constr" (consAnnIf config ann (pretty i : fmap (prettyBy config) es)) - Case ann arg cs -> - sexp "case" (consAnnIf config ann - (prettyBy config arg : fmap (prettyBy config) (toList cs))) - where - prettyTypeOf :: Some (ValueOf uni) -> Doc dann - prettyTypeOf (Some (ValueOf uni _ )) = prettyBy juxtRenderContext $ SomeTypeIn uni +instance + (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann) => + PrettyBy (PrettyConfigClassic configName) (Term name uni fun ann) + where + prettyBy config = \case + Var ann n -> + sep (consAnnIf config ann [prettyBy config n]) + LamAbs ann n t -> + sexp + "lam" + ( consAnnIf + config + ann + [prettyBy config n, prettyBy config t] + ) + Apply ann t1 t2 -> + brackets' + ( sep + ( consAnnIf + config + ann + [prettyBy config t1, prettyBy config t2] + ) + ) + Constant ann c -> + sexp "con" (consAnnIf config ann [prettyTypeOf c, pretty c]) + Builtin ann bi -> + sexp + "builtin" + ( consAnnIf + config + ann + [pretty bi] + ) + Error ann -> + sexp "error" (consAnnIf config ann []) + Delay ann term -> + sexp + "delay" + ( consAnnIf + config + ann + [prettyBy config term] + ) + Force ann term -> + sexp + "force" + ( consAnnIf + config + ann + [prettyBy config term] + ) + Constr ann i es -> + sexp "constr" (consAnnIf config ann (pretty i : fmap (prettyBy config) es)) + Case ann arg cs -> + sexp + "case" + ( consAnnIf + config + ann + (prettyBy config arg : fmap (prettyBy config) (toList cs)) + ) + where + prettyTypeOf :: Some (ValueOf uni) -> Doc dann + prettyTypeOf (Some (ValueOf uni _)) = prettyBy juxtRenderContext $ SomeTypeIn uni -instance (PrettyClassicBy configName (Term name uni fun ann), Pretty ann) => - PrettyBy (PrettyConfigClassic configName) (Program name uni fun ann) where - prettyBy config (Program ann version term) = - sexp "program" (consAnnIf config ann [pretty version, prettyBy config term]) +instance + (PrettyClassicBy configName (Term name uni fun ann), Pretty ann) => + PrettyBy (PrettyConfigClassic configName) (Program name uni fun ann) + where + prettyBy config (Program ann version term) = + sexp "program" (consAnnIf config ann [pretty version, prettyBy config term]) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs index eac92892320..ff603a522c8 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs @@ -1,12 +1,10 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | While the flexible pretty-printing infrastructure is useful when you want it, -- it's helpful to have an implementation of the default Pretty typeclass that -- does the default thing. - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - module UntypedPlutusCore.Core.Instance.Pretty.Default () where import PlutusPrelude @@ -17,10 +15,14 @@ import PlutusCore.Pretty.PrettyConst import UntypedPlutusCore.Core.Instance.Pretty.Classic () import UntypedPlutusCore.Core.Type -instance (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) => - Pretty (Term name uni fun ann) where - pretty = prettyClassic - -instance (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) => - Pretty (Program name uni fun ann) where - pretty = prettyClassic +instance + (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) => + Pretty (Term name uni fun ann) + where + pretty = prettyClassic + +instance + (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) => + Pretty (Program name uni fun ann) + where + pretty = prettyClassic diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs index d7926dabbff..56fd1787dd8 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs @@ -1,8 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module UntypedPlutusCore.Core.Instance.Pretty.Plc () where @@ -14,9 +13,13 @@ import UntypedPlutusCore.Core.Type import PlutusCore.Pretty.Plc -deriving via PrettyAny (Term name uni fun ann) - instance DefaultPrettyPlcStrategy (Term name uni fun ann) => - PrettyBy PrettyConfigPlc (Term name uni fun ann) -deriving via PrettyAny (Program name uni fun ann) - instance DefaultPrettyPlcStrategy (Program name uni fun ann) => - PrettyBy PrettyConfigPlc (Program name uni fun ann) +deriving via + PrettyAny (Term name uni fun ann) + instance + DefaultPrettyPlcStrategy (Term name uni fun ann) => + PrettyBy PrettyConfigPlc (Term name uni fun ann) +deriving via + PrettyAny (Program name uni fun ann) + instance + DefaultPrettyPlcStrategy (Program name uni fun ann) => + PrettyBy PrettyConfigPlc (Program name uni fun ann) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs index 681d1c81ea6..eeb53ee64fd 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | A "readable" Agda-like way to pretty-print Untyped Plutus Core terms. @@ -18,20 +18,21 @@ import Prettyprinter -- | Split an iterated 'LamAbs' (if any) into a list of variables that it binds and its body. viewLamAbs :: Term name uni fun ann -> Maybe ([name], Term name uni fun ann) -viewLamAbs term0@LamAbs{} = Just $ go term0 +viewLamAbs term0@LamAbs {} = Just $ go term0 where go (LamAbs _ name body) = first (name :) $ go body - go term = ([], term) + go term = ([], term) viewLamAbs _ = Nothing -- | Split an iterated 'Apply' (if any) into the head of the application and the spine. viewApp :: Term name uni fun ann -> Maybe (Term name uni fun ann, [Term name uni fun ann]) -viewApp term0 = go term0 [] where +viewApp term0 = go term0 [] + where go (Apply _ fun arg) args = go fun $ arg : args - go _ [] = Nothing - go fun args = Just (fun, args) + go _ [] = Nothing + go fun args = Just (fun, args) instance (PrettyReadableBy configName name, PrettyUni uni, Pretty fun, Show configName) => @@ -42,9 +43,9 @@ instance Builtin _ bi -> unitDocM $ pretty bi Var _ name -> prettyM name (viewLamAbs -> Just (args, body)) -> iterLamAbsPrettyM args body - LamAbs{} -> error "Panic: 'LamAbs' is not covered by 'viewLamAbs'" + LamAbs {} -> error "Panic: 'LamAbs' is not covered by 'viewLamAbs'" (viewApp -> Just (fun, args)) -> iterAppPrettyM fun args - Apply{} -> error "Panic: 'Apply' is not covered by 'viewApp'" + Apply {} -> error "Panic: 'Apply' is not covered by 'viewApp'" Delay _ term -> iterAppDocM $ \_ prettyArg -> "delay" :| [prettyArg term] Force _ term -> iterAppDocM $ \_ prettyArg -> "force" :| [prettyArg term] Error _ -> unitDocM "error" @@ -55,7 +56,7 @@ instance Case _ arg cs -> iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg arg, prettyArg (toList cs)] instance - (PrettyReadableBy configName (Term name uni fun a)) => + PrettyReadableBy configName (Term name uni fun a) => PrettyBy (PrettyConfigReadable configName) (Program name uni fun a) where prettyBy = inContextM $ \(Program _ version term) -> diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs index 043279c2662..668bde9a287 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs @@ -1,8 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module UntypedPlutusCore.Core.Instance.Scoping () where @@ -19,52 +18,53 @@ import Data.Vector qualified as Vector firstBound :: Term name uni fun ann -> [name] firstBound (Apply _ (LamAbs _ name body) _) = name : firstBound body -firstBound _ = [] +firstBound _ = [] instance name ~ Name => Reference Name (Term name uni fun) where - referenceVia reg name term = Apply NotAName term $ Var (reg name) name + referenceVia reg name term = Apply NotAName term $ Var (reg name) name instance name ~ Name => EstablishScoping (Term name uni fun) where - establishScoping (LamAbs _ nameDup body) = do - name <- freshenName nameDup - establishScopingBinder (\ann name' _ -> LamAbs ann name') name Proxy body - establishScoping (Delay _ body) = Delay NotAName <$> establishScoping body - establishScoping (Apply _ fun arg) = - Apply NotAName <$> establishScoping fun <*> establishScoping arg - establishScoping (Error _) = pure $ Error NotAName - establishScoping (Force _ term) = Force NotAName <$> establishScoping term - establishScoping (Var _ nameDup) = do - name <- freshenName nameDup - pure $ Var (registerFree name) name - establishScoping (Constant _ con) = pure $ Constant NotAName con - establishScoping (Builtin _ bi) = pure $ Builtin NotAName bi - establishScoping (Constr _ i es) = Constr NotAName <$> pure i <*> traverse establishScoping es - establishScoping (Case _ a es) = do - esScoped <- traverse establishScoping es - let esScopedPoked = addTheRest . map (\e -> (e, firstBound e)) $ Vector.toList esScoped - branchBounds = map (snd . fst) esScopedPoked - referenceInBranch ((branch, _), others) = referenceOutOfScope (map snd others) branch - aScoped <- establishScoping a - -- For each of the branches reference (as out-of-scope) the variables bound in that branch - -- in all the other ones, as well as outside of the whole case-expression. This is to check - -- that none of the transformations leak variables outside of the branch they're bound in. - pure . referenceOutOfScope branchBounds $ - Case NotAName aScoped . Vector.fromList $ map referenceInBranch esScopedPoked + establishScoping (LamAbs _ nameDup body) = do + name <- freshenName nameDup + establishScopingBinder (\ann name' _ -> LamAbs ann name') name Proxy body + establishScoping (Delay _ body) = Delay NotAName <$> establishScoping body + establishScoping (Apply _ fun arg) = + Apply NotAName <$> establishScoping fun <*> establishScoping arg + establishScoping (Error _) = pure $ Error NotAName + establishScoping (Force _ term) = Force NotAName <$> establishScoping term + establishScoping (Var _ nameDup) = do + name <- freshenName nameDup + pure $ Var (registerFree name) name + establishScoping (Constant _ con) = pure $ Constant NotAName con + establishScoping (Builtin _ bi) = pure $ Builtin NotAName bi + establishScoping (Constr _ i es) = Constr NotAName <$> pure i <*> traverse establishScoping es + establishScoping (Case _ a es) = do + esScoped <- traverse establishScoping es + let esScopedPoked = addTheRest . map (\e -> (e, firstBound e)) $ Vector.toList esScoped + branchBounds = map (snd . fst) esScopedPoked + referenceInBranch ((branch, _), others) = referenceOutOfScope (map snd others) branch + aScoped <- establishScoping a + -- For each of the branches reference (as out-of-scope) the variables bound in that branch + -- in all the other ones, as well as outside of the whole case-expression. This is to check + -- that none of the transformations leak variables outside of the branch they're bound in. + pure . referenceOutOfScope branchBounds $ + Case NotAName aScoped . Vector.fromList $ + map referenceInBranch esScopedPoked instance name ~ Name => EstablishScoping (Program name uni fun) where - establishScoping (Program _ ver term) = Program NotAName ver <$> establishScoping term + establishScoping (Program _ ver term) = Program NotAName ver <$> establishScoping term instance name ~ Name => CollectScopeInfo (Term name uni fun) where - collectScopeInfo (LamAbs ann name body) = handleSname ann name <> collectScopeInfo body - collectScopeInfo (Delay _ body) = collectScopeInfo body - collectScopeInfo (Apply _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg - collectScopeInfo (Error _) = mempty - collectScopeInfo (Force _ term) = collectScopeInfo term - collectScopeInfo (Var ann name) = handleSname ann name - collectScopeInfo (Constant _ _) = mempty - collectScopeInfo (Builtin _ _) = mempty - collectScopeInfo (Constr _ _ es) = foldMap collectScopeInfo es - collectScopeInfo (Case _ arg cs) = collectScopeInfo arg <> foldMap collectScopeInfo cs + collectScopeInfo (LamAbs ann name body) = handleSname ann name <> collectScopeInfo body + collectScopeInfo (Delay _ body) = collectScopeInfo body + collectScopeInfo (Apply _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg + collectScopeInfo (Error _) = mempty + collectScopeInfo (Force _ term) = collectScopeInfo term + collectScopeInfo (Var ann name) = handleSname ann name + collectScopeInfo (Constant _ _) = mempty + collectScopeInfo (Builtin _ _) = mempty + collectScopeInfo (Constr _ _ es) = foldMap collectScopeInfo es + collectScopeInfo (Case _ arg cs) = collectScopeInfo arg <> foldMap collectScopeInfo cs instance name ~ Name => CollectScopeInfo (Program name uni fun) where - collectScopeInfo (Program _ _ term) = collectScopeInfo term + collectScopeInfo (Program _ _ term) = collectScopeInfo term diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs index bb2683bbd16..b9e9116b8e6 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs @@ -1,16 +1,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -module UntypedPlutusCore.Core.Plated - ( termConstants - , termBinds - , termVars - , termUniques - , termSubterms - , termConstantsDeep - , termSubtermsDeep - , termUniquesDeep - ) where +module UntypedPlutusCore.Core.Plated ( + termConstants, + termBinds, + termVars, + termUniques, + termSubterms, + termConstantsDeep, + termSubtermsDeep, + termUniquesDeep, +) where import PlutusCore.Core (HasUniques) import PlutusCore.Name.Unique @@ -22,49 +22,49 @@ import Universe -- | Get all the direct constants of the given 'Term' from 'Constant's. termConstants :: Traversal' (Term name uni fun ann) (Some (ValueOf uni)) termConstants f term0 = case term0 of - Constant ann val -> Constant ann <$> f val - Var{} -> pure term0 - LamAbs{} -> pure term0 - Error{} -> pure term0 - Apply{} -> pure term0 - Force{} -> pure term0 - Delay{} -> pure term0 - Builtin{} -> pure term0 - Constr{} -> pure term0 - Case{} -> pure term0 + Constant ann val -> Constant ann <$> f val + Var {} -> pure term0 + LamAbs {} -> pure term0 + Error {} -> pure term0 + Apply {} -> pure term0 + Force {} -> pure term0 + Delay {} -> pure term0 + Builtin {} -> pure term0 + Constr {} -> pure term0 + Case {} -> pure term0 -- | Get all the direct child 'name a's of the given 'Term' from 'LamAbs'es. termBinds :: Traversal' (Term name uni fun ann) name termBinds f = \case - LamAbs ann n t -> f n <&> \n' -> LamAbs ann n' t - x -> pure x + LamAbs ann n t -> f n <&> \n' -> LamAbs ann n' t + x -> pure x -- | Get all the direct child 'name a's of the given 'Term' from 'Var's. termVars :: Traversal' (Term name uni fun ann) name termVars f = \case - Var ann n -> Var ann <$> f n - x -> pure x + Var ann n -> Var ann <$> f n + x -> pure x -- | Get all the direct child 'Unique's of the given 'Term'. termUniques :: HasUniques (Term name uni fun ann) => Traversal' (Term name uni fun ann) Unique termUniques f = \case - LamAbs ann n t -> theUnique f n <&> \n' -> LamAbs ann n' t - Var ann n -> theUnique f n <&> Var ann - x -> pure x + LamAbs ann n t -> theUnique f n <&> \n' -> LamAbs ann n' t + Var ann n -> theUnique f n <&> Var ann + x -> pure x -- | Get all the direct child 'Term's of the given 'Term'. termSubterms :: Traversal' (Term name uni fun ann) (Term name uni fun ann) termSubterms f = \case - LamAbs ann n t -> LamAbs ann n <$> f t - Apply ann t1 t2 -> Apply ann <$> f t1 <*> f t2 - Delay ann t -> Delay ann <$> f t - Force ann t -> Force ann <$> f t - Constr ann i args -> Constr ann i <$> traverse f args - Case ann arg cs -> Case ann <$> f arg <*> traverse f cs - e@Error {} -> pure e - v@Var {} -> pure v - c@Constant {} -> pure c - b@Builtin {} -> pure b + LamAbs ann n t -> LamAbs ann n <$> f t + Apply ann t1 t2 -> Apply ann <$> f t1 <*> f t2 + Delay ann t -> Delay ann <$> f t + Force ann t -> Force ann <$> f t + Constr ann i args -> Constr ann i <$> traverse f args + Case ann arg cs -> Case ann <$> f arg <*> traverse f cs + e@Error {} -> pure e + v@Var {} -> pure v + c@Constant {} -> pure c + b@Builtin {} -> pure b {-# INLINE termSubterms #-} -- | Get all the transitive child 'Constant's of the given 'Term'. diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs index 55e4d89d512..44304a36962 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs @@ -1,29 +1,29 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module UntypedPlutusCore.Core.Type - ( TPLC.UniOf - , TPLC.Version (..) - , TPLC.Binder (..) - , Term (..) - , Program (..) - , progAnn - , progVer - , progTerm - , bindFunM - , bindFun - , mapFun - , termAnn - , UVarDecl(..) - , uvarDeclName - , uvarDeclAnn - ) where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module UntypedPlutusCore.Core.Type ( + TPLC.UniOf, + TPLC.Version (..), + TPLC.Binder (..), + Term (..), + Program (..), + progAnn, + progVer, + progTerm, + bindFunM, + bindFun, + mapFun, + termAnn, + UVarDecl (..), + uvarDeclName, + uvarDeclAnn, +) where import Control.Lens import Control.Monad.Except @@ -69,127 +69,135 @@ Currently, 'Case' only supports booleans and integers, but we plan to extend it See the @CaseBuiltin DefaultUni@ instance for how casing behaves for supported built-in types. -} -{-| The type of Untyped Plutus Core terms. Mirrors the type of Typed Plutus Core terms except +-- | The type of Untyped Plutus Core terms. Mirrors the type of Typed Plutus Core terms except +-- +-- 1. all types are removed +-- 2. 'IWrap' and 'Unwrap' are removed +-- 3. type abstractions are replaced with 'Delay' +-- 4. type instantiations are replaced with 'Force' +-- +-- The latter two are due to the fact that we don't have value restriction in Typed Plutus Core +-- and hence a computation can be stuck expecting only a single type argument for the computation +-- to become unstuck. Therefore we can't just silently remove type abstractions and instantiations and +-- need to replace them with something else that also blocks evaluation (in order for the semantics +-- of an erased program to match with the semantics of the original typed one). 'Delay' and 'Force' +-- serve exactly this purpose. -1. all types are removed -2. 'IWrap' and 'Unwrap' are removed -3. type abstractions are replaced with 'Delay' -4. type instantiations are replaced with 'Force' - -The latter two are due to the fact that we don't have value restriction in Typed Plutus Core -and hence a computation can be stuck expecting only a single type argument for the computation -to become unstuck. Therefore we can't just silently remove type abstractions and instantiations and -need to replace them with something else that also blocks evaluation (in order for the semantics -of an erased program to match with the semantics of the original typed one). 'Delay' and 'Force' -serve exactly this purpose. --} -- Making all the fields strict gives us a couple of percent in benchmarks -- See Note [Term constructor ordering and numbers] data Term name uni fun ann - = Var !ann !name - | LamAbs !ann !name !(Term name uni fun ann) - | Apply !ann !(Term name uni fun ann) !(Term name uni fun ann) - | Force !ann !(Term name uni fun ann) - | Delay !ann !(Term name uni fun ann) - | Constant !ann !(Some (ValueOf uni)) - | Builtin !ann !fun - -- This is the cutoff at which constructors won't get pointer tags + = Var !ann !name + | LamAbs !ann !name !(Term name uni fun ann) + | Apply !ann !(Term name uni fun ann) !(Term name uni fun ann) + | Force !ann !(Term name uni fun ann) + | Delay !ann !(Term name uni fun ann) + | Constant !ann !(Some (ValueOf uni)) + | Builtin !ann !fun + | -- This is the cutoff at which constructors won't get pointer tags -- See Note [Term constructor ordering and numbers] - | Error !ann - -- TODO: worry about overflow, maybe use an Integer + Error !ann + | -- TODO: worry about overflow, maybe use an Integer -- See Note [Constr tag type] - | Constr !ann !Word64 ![Term name uni fun ann] - -- See Note [Supported case-expressions]. - | Case !ann !(Term name uni fun ann) !(Vector (Term name uni fun ann)) - deriving stock (Functor, Generic) + Constr !ann !Word64 ![Term name uni fun ann] + | -- See Note [Supported case-expressions]. + Case !ann !(Term name uni fun ann) !(Vector (Term name uni fun ann)) + deriving stock (Functor, Generic) -deriving stock instance (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Term name uni fun ann) +deriving stock instance + (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (Term name uni fun ann) -deriving anyclass instance (NFData name, NFData fun, NFData ann, Everywhere uni NFData, Closed uni) - => NFData (Term name uni fun ann) +deriving anyclass instance + (NFData name, NFData fun, NFData ann, Everywhere uni NFData, Closed uni) => + NFData (Term name uni fun ann) -- | A 'Program' is simply a 'Term' coupled with a 'Version' of the core language. data Program name uni fun ann = Program - { _progAnn :: ann - , _progVer :: TPLC.Version - , _progTerm :: Term name uni fun ann - } - deriving stock (Functor, Generic) + { _progAnn :: ann + , _progVer :: TPLC.Version + , _progTerm :: Term name uni fun ann + } + deriving stock (Functor, Generic) + makeLenses ''Program -deriving stock instance (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Program name uni fun ann) +deriving stock instance + (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (Program name uni fun ann) -deriving anyclass instance (NFData name, Everywhere uni NFData, NFData fun, NFData ann, Closed uni) - => NFData (Program name uni fun ann) +deriving anyclass instance + (NFData name, Everywhere uni NFData, NFData fun, NFData ann, Closed uni) => + NFData (Program name uni fun ann) type instance TPLC.UniOf (Term name uni fun ann) = uni instance TermLike (Term name uni fun) TPLC.TyName name uni fun where - var = Var - tyAbs = \ann _ _ -> Delay ann - lamAbs = \ann name _ -> LamAbs ann name - apply = Apply - constant = Constant - builtin = Builtin - tyInst = \ann term _ -> Force ann term - unwrap = const id - iWrap = \_ _ _ -> id - error = \ann _ -> Error ann - constr = \ann _ i es -> Constr ann i es - kase = \ann _ arg cs -> Case ann arg (fromList cs) + var = Var + tyAbs = \ann _ _ -> Delay ann + lamAbs = \ann name _ -> LamAbs ann name + apply = Apply + constant = Constant + builtin = Builtin + tyInst = \ann term _ -> Force ann term + unwrap = const id + iWrap = \_ _ _ -> id + error = \ann _ -> Error ann + constr = \ann _ i es -> Constr ann i es + kase = \ann _ arg cs -> Case ann arg (fromList cs) instance TPLC.HasConstant (Term name uni fun ()) where - asConstant (Constant _ val) = pure val - asConstant _ = throwError TPLC.notAConstant + asConstant (Constant _ val) = pure val + asConstant _ = throwError TPLC.notAConstant - fromConstant = Constant () + fromConstant = Constant () type instance TPLC.HasUniques (Term name uni fun ann) = TPLC.HasUnique name TPLC.TermUnique type instance TPLC.HasUniques (Program name uni fun ann) = TPLC.HasUniques (Term name uni fun ann) -- | An untyped "variable declaration", i.e. a name for a variable. data UVarDecl name ann = UVarDecl - { _uvarDeclAnn :: ann - , _uvarDeclName :: name - } deriving stock (Functor, Show, Generic) + { _uvarDeclAnn :: ann + , _uvarDeclName :: name + } + deriving stock (Functor, Show, Generic) + makeLenses ''UVarDecl -- | Return the outermost annotation of a 'Term'. termAnn :: Term name uni fun ann -> ann termAnn (Constant ann _) = ann -termAnn (Builtin ann _) = ann -termAnn (Var ann _) = ann +termAnn (Builtin ann _) = ann +termAnn (Var ann _) = ann termAnn (LamAbs ann _ _) = ann -termAnn (Apply ann _ _) = ann -termAnn (Delay ann _) = ann -termAnn (Force ann _) = ann -termAnn (Error ann) = ann +termAnn (Apply ann _ _) = ann +termAnn (Delay ann _) = ann +termAnn (Force ann _) = ann +termAnn (Error ann) = ann termAnn (Constr ann _ _) = ann -termAnn (Case ann _ _) = ann - -bindFunM - :: Monad m - => (ann -> fun -> m (Term name uni fun' ann)) - -> Term name uni fun ann - -> m (Term name uni fun' ann) -bindFunM f = go where - go (Constant ann val) = pure $ Constant ann val - go (Builtin ann fun) = f ann fun - go (Var ann name) = pure $ Var ann name +termAnn (Case ann _ _) = ann + +bindFunM :: + Monad m => + (ann -> fun -> m (Term name uni fun' ann)) -> + Term name uni fun ann -> + m (Term name uni fun' ann) +bindFunM f = go + where + go (Constant ann val) = pure $ Constant ann val + go (Builtin ann fun) = f ann fun + go (Var ann name) = pure $ Var ann name go (LamAbs ann name body) = LamAbs ann name <$> go body - go (Apply ann fun arg) = Apply ann <$> go fun <*> go arg - go (Delay ann term) = Delay ann <$> go term - go (Force ann term) = Force ann <$> go term - go (Error ann) = pure $ Error ann - go (Constr ann i args) = Constr ann i <$> traverse go args - go (Case ann arg cs) = Case ann <$> go arg <*> traverse go cs - -bindFun - :: (ann -> fun -> Term name uni fun' ann) - -> Term name uni fun ann - -> Term name uni fun' ann + go (Apply ann fun arg) = Apply ann <$> go fun <*> go arg + go (Delay ann term) = Delay ann <$> go term + go (Force ann term) = Force ann <$> go term + go (Error ann) = pure $ Error ann + go (Constr ann i args) = Constr ann i <$> traverse go args + go (Case ann arg cs) = Case ann <$> go arg <*> traverse go cs + +bindFun :: + (ann -> fun -> Term name uni fun' ann) -> + Term name uni fun ann -> + Term name uni fun' ann bindFun f = runIdentity . bindFunM (coerce f) mapFun :: (ann -> fun -> fun') -> Term name uni fun ann -> Term name uni fun' ann diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs index 4d2ce01731c..d1a89f5c216 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs @@ -1,12 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module UntypedPlutusCore.Core.Zip - ( pzipWith - , pzip - , tzipWith - , tzip - ) where +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module UntypedPlutusCore.Core.Zip ( + pzipWith, + pzip, + tzipWith, + tzip, +) where import Control.Monad (void, when) import Control.Monad.Except (MonadError, throwError) @@ -19,16 +20,17 @@ import UntypedPlutusCore.Core.Type -- Throws an error if the input programs are not "equal" modulo annotations. -- Note that the function is "left-biased", so in case that the 2 input programs contain `Name`s, -- the output program will contain just the `Name`s of the first input program. -pzipWith :: forall p name uni fun ann1 ann2 ann3 m. - (p ~ Program name uni fun, (Eq (Term name uni fun ())), MonadError String m) - => (ann1 -> ann2 -> ann3) - -> p ann1 - -> p ann2 - -> m (p ann3) +pzipWith :: + forall p name uni fun ann1 ann2 ann3 m. + (p ~ Program name uni fun, (Eq (Term name uni fun ())), MonadError String m) => + (ann1 -> ann2 -> ann3) -> + p ann1 -> + p ann2 -> + m (p ann3) pzipWith f (Program ann1 ver1 t1) (Program ann2 ver2 t2) = do - when (ver1 /= ver2) $ - throwError "zip: Versions do not match." - Program (f ann1 ann2) ver1 <$> tzipWith f t1 t2 + when (ver1 /= ver2) $ + throwError "zip: Versions do not match." + Program (f ann1 ann2) ver1 <$> tzipWith f t1 t2 -- | Zip two terms using a combinator function for annotations. -- @@ -36,51 +38,54 @@ pzipWith f (Program ann1 ver1 t1) (Program ann2 ver2 t2) = do -- Note that the function is "left-biased", so in case that the 2 input terms contain `Name`s, -- the output term will contain just the `Name`s of the first input term. -- TODO: this is not an optimal implementation -tzipWith :: forall t name uni fun ann1 ann2 ann3 m. - (t ~ Term name uni fun, Eq (t ()), MonadError String m) - => (ann1 -> ann2 -> ann3) - -> t ann1 - -> t ann2 - -> m (t ann3) +tzipWith :: + forall t name uni fun ann1 ann2 ann3 m. + (t ~ Term name uni fun, Eq (t ()), MonadError String m) => + (ann1 -> ann2 -> ann3) -> + t ann1 -> + t ann2 -> + m (t ann3) tzipWith f term1 term2 = do - -- Prior establishing t1==t2 avoids the need to check for Eq uni, Eq fun and alpha-equivalence. - -- Slower this way because we have to re-traverse the terms. - when (void term1 /= void term2) $ - throwError "zip: Terms do not match." - go term1 term2 - 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) - -- 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 (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 (Constr a1 i1 ts1) (Constr a2 _i2 ts2) = Constr (f a1 a2) i1 <$> zipExactWithM go ts1 ts2 - go (Case a1 t1 vs1) (Case a2 t2 vs2) = - Case (f a1 a2) <$> go t1 t2 <*> (fromList <$> zipExactWithM go (toList vs1) (toList vs2)) - go _ _ = - throwError "zip: This should not happen, because we prior established term equality." + -- Prior establishing t1==t2 avoids the need to check for Eq uni, Eq fun and alpha-equivalence. + -- Slower this way because we have to re-traverse the terms. + when (void term1 /= void term2) $ + throwError "zip: Terms do not match." + go term1 term2 + 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) + -- 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 (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 (Constr a1 i1 ts1) (Constr a2 _i2 ts2) = Constr (f a1 a2) i1 <$> zipExactWithM go ts1 ts2 + go (Case a1 t1 vs1) (Case a2 t2 vs2) = + Case (f a1 a2) <$> go t1 t2 <*> (fromList <$> zipExactWithM go (toList vs1) (toList vs2)) + go _ _ = + throwError "zip: This should not happen, because we prior established term equality." - zipExactWithM :: MonadError String n => (a -> b -> n c) -> [a] -> [b] -> n [c] - zipExactWithM g (a:as) (b:bs) = (:) <$> g a b <*> zipExactWithM g as bs - zipExactWithM _ [] [] = pure [] - zipExactWithM _ _ _ = throwError "zipExactWithM: not exact" + zipExactWithM :: MonadError String n => (a -> b -> n c) -> [a] -> [b] -> n [c] + zipExactWithM g (a : as) (b : bs) = (:) <$> g a b <*> zipExactWithM g as bs + zipExactWithM _ [] [] = pure [] + zipExactWithM _ _ _ = throwError "zipExactWithM: not exact" -- | Zip 2 programs by pairing their annotations -pzip :: (p ~ Program name uni fun, Eq (Term name uni fun ()), MonadError String m) - => p ann1 - -> p ann2 - -> m (p (ann1,ann2)) +pzip :: + (p ~ Program name uni fun, Eq (Term name uni fun ()), MonadError String m) => + p ann1 -> + p ann2 -> + m (p (ann1, ann2)) pzip = pzipWith (,) -- | Zip 2 terms by pairing their annotations -tzip :: (t ~ Term name uni fun, Eq (t ()), MonadError String m) - => t ann1 - -> t ann2 - -> m (t (ann1,ann2)) +tzip :: + (t ~ Term name uni fun, Eq (t ()), MonadError String m) => + t ann1 -> + t ann2 -> + m (t (ann1, ann2)) tzip = tzipWith (,) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs index f5d7960e413..c71da360a24 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs @@ -1,29 +1,31 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} + -- | Support for using de Bruijn indices for term names. -module UntypedPlutusCore.DeBruijn - ( Index (..) - , Level (..) - , LevelInfo (..) - , HasIndex (..) - , DeBruijn (..) - , NamedDeBruijn (..) - -- we follow the same approach as Renamed, expose the constructor from Internal module, - -- but hide it in the parent module. - , FakeNamedDeBruijn (unFakeNamedDeBruijn) - , FreeVariableError (..) - , deBruijnTerm - , unDeBruijnTerm - , unNameDeBruijn - , fakeNameDeBruijn - -- * unsafe api, use with care - , deBruijnTermWith - , unDeBruijnTermWith - , freeIndexAsConsistentLevel - , deBruijnInitIndex - ) where +module UntypedPlutusCore.DeBruijn ( + Index (..), + Level (..), + LevelInfo (..), + HasIndex (..), + DeBruijn (..), + NamedDeBruijn (..), + -- we follow the same approach as Renamed, expose the constructor from Internal module, + -- but hide it in the parent module. + FakeNamedDeBruijn (unFakeNamedDeBruijn), + FreeVariableError (..), + deBruijnTerm, + unDeBruijnTerm, + unNameDeBruijn, + fakeNameDeBruijn, + + -- * unsafe api, use with care + deBruijnTermWith, + unDeBruijnTermWith, + freeIndexAsConsistentLevel, + deBruijnInitIndex, +) where import PlutusCore.DeBruijn.Internal @@ -41,83 +43,83 @@ This module is just a boring port of the typed version. -- | Convert a 'Term' with 'Name's into a 'Term' with 'DeBruijn's. -- Will throw an error if a free variable is encountered. -deBruijnTerm - :: (MonadError FreeVariableError m) - => Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann) +deBruijnTerm :: + MonadError FreeVariableError m => + Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann) deBruijnTerm = deBruijnTermWith freeUniqueThrow -- | Convert a 'Term' with 'DeBruijn's into a 'Term' with 'Name's. -- Will throw an error if a free variable is encountered. -unDeBruijnTerm - :: (MonadQuote m, MonadError FreeVariableError m) - => Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann) +unDeBruijnTerm :: + (MonadQuote m, MonadError FreeVariableError m) => + Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann) unDeBruijnTerm = unDeBruijnTermWith freeIndexThrow -- | Takes a "handler" function to execute when encountering free variables. -deBruijnTermWith - :: Monad m - => (Unique -> ReaderT LevelInfo m Index) - -> Term Name uni fun ann - -> m (Term NamedDeBruijn uni fun ann) +deBruijnTermWith :: + Monad m => + (Unique -> ReaderT LevelInfo m Index) -> + Term Name uni fun ann -> + m (Term NamedDeBruijn uni fun ann) deBruijnTermWith = (runDeBruijnT .) . deBruijnTermWithM -- | Takes a "handler" function to execute when encountering free variables. -unDeBruijnTermWith - :: MonadQuote m - => (Index -> ReaderT LevelInfo m Unique) - -> Term NamedDeBruijn uni fun ann - -> m (Term Name uni fun ann) +unDeBruijnTermWith :: + MonadQuote m => + (Index -> ReaderT LevelInfo m Unique) -> + Term NamedDeBruijn uni fun ann -> + m (Term Name uni fun ann) unDeBruijnTermWith = (runDeBruijnT .) . unDeBruijnTermWithM -deBruijnTermWithM - :: MonadReader LevelInfo m - => (Unique -> m Index) - -> Term Name uni fun ann - -> m (Term NamedDeBruijn uni fun ann) +deBruijnTermWithM :: + MonadReader LevelInfo m => + (Unique -> m Index) -> + Term Name uni fun ann -> + m (Term NamedDeBruijn uni fun ann) deBruijnTermWithM h = go - where - go = \case - -- variable case - Var ann n -> Var ann <$> nameToDeBruijn h n - -- binder cases - LamAbs ann n t -> declareUnique n $ do - n' <- nameToDeBruijn h n - withScope $ LamAbs ann n' <$> go t - -- boring recursive cases - Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 - Delay ann t -> Delay ann <$> go t - Force ann t -> Force ann <$> go t - Constr ann i es -> Constr ann i <$> traverse go es - Case ann arg cs -> Case ann <$> go arg <*> traverse go cs - -- boring non-recursive cases - Constant ann con -> pure $ Constant ann con - Builtin ann bn -> pure $ Builtin ann bn - Error ann -> pure $ Error ann + where + go = \case + -- variable case + Var ann n -> Var ann <$> nameToDeBruijn h n + -- binder cases + LamAbs ann n t -> declareUnique n $ do + n' <- nameToDeBruijn h n + withScope $ LamAbs ann n' <$> go t + -- boring recursive cases + Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 + Delay ann t -> Delay ann <$> go t + Force ann t -> Force ann <$> go t + Constr ann i es -> Constr ann i <$> traverse go es + Case ann arg cs -> Case ann <$> go arg <*> traverse go cs + -- boring non-recursive cases + Constant ann con -> pure $ Constant ann con + Builtin ann bn -> pure $ Builtin ann bn + Error ann -> pure $ Error ann -- | Takes a "handler" function to execute when encountering free variables. -unDeBruijnTermWithM - :: (MonadReader LevelInfo m, MonadQuote m) - => (Index -> m Unique) - -> Term NamedDeBruijn uni fun ann - -> m (Term Name uni fun ann) +unDeBruijnTermWithM :: + (MonadReader LevelInfo m, MonadQuote m) => + (Index -> m Unique) -> + Term NamedDeBruijn uni fun ann -> + m (Term Name uni fun ann) unDeBruijnTermWithM h = go where go = \case - -- variable case - Var ann n -> Var ann <$> deBruijnToName h n - -- binder cases - LamAbs ann n t -> - -- See Note [DeBruijn indices of Binders] - declareBinder $ do - n' <- deBruijnToName h $ set index deBruijnInitIndex n - withScope $ LamAbs ann n' <$> go t - -- boring recursive cases - Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 - Delay ann t -> Delay ann <$> go t - Force ann t -> Force ann <$> go t - Constr ann i es -> Constr ann i <$> traverse go es - Case ann arg cs -> Case ann <$> go arg <*> traverse go cs - -- boring non-recursive cases - Constant ann con -> pure $ Constant ann con - Builtin ann bn -> pure $ Builtin ann bn - Error ann -> pure $ Error ann + -- variable case + Var ann n -> Var ann <$> deBruijnToName h n + -- binder cases + LamAbs ann n t -> + -- See Note [DeBruijn indices of Binders] + declareBinder $ do + n' <- deBruijnToName h $ set index deBruijnInitIndex n + withScope $ LamAbs ann n' <$> go t + -- boring recursive cases + Apply ann t1 t2 -> Apply ann <$> go t1 <*> go t2 + Delay ann t -> Delay ann <$> go t + Force ann t -> Force ann <$> go t + Constr ann i es -> Constr ann i <$> traverse go es + Case ann arg cs -> Case ann <$> go arg <*> traverse go cs + -- boring non-recursive cases + Constant ann con -> pure $ Constant ann con + Builtin ann bn -> pure $ Builtin ann bn + Error ann -> pure $ Error ann diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs index 16ab7502fbf..ef027505c6f 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs @@ -1,58 +1,62 @@ --- | The API to the CEK machine. {-# LANGUAGE TypeOperators #-} -module UntypedPlutusCore.Evaluation.Machine.Cek - ( - -- * Running the machine - runCek - , runCekDeBruijn - , runCekNoEmit - , evaluateCek - , evaluateCekNoEmit - , EvaluationResult(..) - , splitStructuralOperational - , unsafeSplitStructuralOperational - -- * Errors - , CekUserError(..) - , ErrorWithCause(..) - , CekEvaluationException - , EvaluationError(..) - -- * Costing - , ExBudgetCategory(..) - , CekBudgetSpender(..) - , ExBudgetMode(..) - , StepKind(..) - , CekExTally(..) - , CountingSt (..) - , TallyingSt (..) - , RestrictingSt (..) - , CekMachineCosts - -- ** Costing modes - , monoidalBudgeting - , counting - , tallying - , restricting - , restrictingLarge - , restrictingEnormous - , enormousBudget - -- * Emitter modes - , noEmitter - , logEmitter - , logWithTimeEmitter - , logWithBudgetEmitter - , logWithCallTraceEmitter - -- * Misc - , BuiltinsRuntime (..) - , CekResult (..) - , CekReport (..) - , cekResultToEither - , CekValue (..) - , DischargeResult(..) - , dischargeResultToTerm - , readKnownCek - , Hashable - , ThrowableBuiltins - ) +-- | The API to the CEK machine. +module UntypedPlutusCore.Evaluation.Machine.Cek ( + -- * Running the machine + runCek, + runCekDeBruijn, + runCekNoEmit, + evaluateCek, + evaluateCekNoEmit, + EvaluationResult (..), + splitStructuralOperational, + unsafeSplitStructuralOperational, + + -- * Errors + CekUserError (..), + ErrorWithCause (..), + CekEvaluationException, + EvaluationError (..), + + -- * Costing + ExBudgetCategory (..), + CekBudgetSpender (..), + ExBudgetMode (..), + StepKind (..), + CekExTally (..), + CountingSt (..), + TallyingSt (..), + RestrictingSt (..), + CekMachineCosts, + + -- ** Costing modes + monoidalBudgeting, + counting, + tallying, + restricting, + restrictingLarge, + restrictingEnormous, + enormousBudget, + + -- * Emitter modes + noEmitter, + logEmitter, + logWithTimeEmitter, + logWithBudgetEmitter, + logWithCallTraceEmitter, + + -- * Misc + BuiltinsRuntime (..), + CekResult (..), + CekReport (..), + cekResultToEither, + CekValue (..), + DischargeResult (..), + dischargeResultToTerm, + readKnownCek, + Hashable, + ThrowableBuiltins, +) where import UntypedPlutusCore.Core @@ -68,53 +72,52 @@ import PlutusCore.Name.Unique import Data.Text (Text) -{-| Evaluate a term using the CEK machine with logging enabled and keep track of costing. -A wrapper around the internal runCek to debruijn input and undebruijn output. -*THIS FUNCTION IS PARTIAL if the input term contains free variables* --} -runCek - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> Term Name uni fun ann - -> CekReport cost Name uni fun +-- | Evaluate a term using the CEK machine with logging enabled and keep track of costing. +-- A wrapper around the internal runCek to debruijn input and undebruijn output. +-- *THIS FUNCTION IS PARTIAL if the input term contains free variables* +runCek :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + Term Name uni fun ann -> + CekReport cost Name uni fun runCek = Common.runCek runCekDeBruijn -- | Evaluate a term using the CEK machine with logging disabled and keep track of costing. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -runCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) +runCekNoEmit :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + Term Name uni fun ann -> + (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) runCekNoEmit = Common.runCekNoEmit runCekDeBruijn -- | Evaluate a term using the CEK machine with logging enabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -evaluateCek - :: ThrowableBuiltins uni fun - => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) +evaluateCek :: + ThrowableBuiltins uni fun => + EmitterMode uni fun -> + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek = Common.evaluateCek runCekDeBruijn -- | Evaluate a term using the CEK machine with logging disabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -evaluateCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) +evaluateCekNoEmit :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit = Common.evaluateCekNoEmit runCekDeBruijn -- | Unlift a value using the CEK machine. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -readKnownCek - :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) a +readKnownCek :: + (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + Either (CekEvaluationException Name uni fun) a readKnownCek = Common.readKnownCek runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs index 9ed9697652e..1c553933d17 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs @@ -1,17 +1,17 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE UndecidableInstances #-} -module UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts - ( CekMachineCosts - , CekMachineCostsBase(..) - , cekMachineCostsPrefix - , unitCekMachineCosts - ) +module UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts ( + CekMachineCosts, + CekMachineCostsBase (..), + cekMachineCostsPrefix, + unitCekMachineCosts, +) where import PlutusCore.Evaluation.Machine.ExBudget @@ -31,37 +31,48 @@ cekMachineCostsPrefix :: Text.Text cekMachineCostsPrefix = "cek" -- | Costs for evaluating AST nodes. Times should be specified in picoseconds, memory sizes in bytes. - type CekMachineCosts = CekMachineCostsBase Identity -data CekMachineCostsBase f = - CekMachineCostsBase { - cekStartupCost :: f ExBudget -- General overhead - , cekVarCost :: f ExBudget - , cekConstCost :: f ExBudget - , cekLamCost :: f ExBudget - , cekDelayCost :: f ExBudget - , cekForceCost :: f ExBudget - , cekApplyCost :: f ExBudget - , cekBuiltinCost :: f ExBudget - -- ^ Just the cost of evaluating a Builtin node, not the builtin itself. - -- There's no entry for Error since we'll be exiting anyway; also, what would - -- happen if calling 'Error' caused the budget to be exceeded? - , cekConstrCost :: f ExBudget - , cekCaseCost :: f ExBudget - } - deriving stock (Generic) - deriving anyclass (FunctorB, TraversableB, ConstraintsB) +data CekMachineCostsBase f + = CekMachineCostsBase + { cekStartupCost :: f ExBudget -- General overhead + , cekVarCost :: f ExBudget + , cekConstCost :: f ExBudget + , cekLamCost :: f ExBudget + , cekDelayCost :: f ExBudget + , cekForceCost :: f ExBudget + , cekApplyCost :: f ExBudget + , cekBuiltinCost :: f ExBudget + -- ^ Just the cost of evaluating a Builtin node, not the builtin itself. + -- There's no entry for Error since we'll be exiting anyway; also, what would + -- happen if calling 'Error' caused the budget to be exceeded? + , cekConstrCost :: f ExBudget + , cekCaseCost :: f ExBudget + } + deriving stock (Generic) + deriving anyclass (FunctorB, TraversableB, ConstraintsB) -deriving via CustomJSON '[FieldLabelModifier LowerInitialCharacter] - (CekMachineCostsBase Identity) instance ToJSON (CekMachineCostsBase Identity) -deriving via CustomJSON '[FieldLabelModifier LowerInitialCharacter] - (CekMachineCostsBase Identity) instance FromJSON (CekMachineCostsBase Identity) +deriving via + CustomJSON + '[FieldLabelModifier LowerInitialCharacter] + (CekMachineCostsBase Identity) + instance + ToJSON (CekMachineCostsBase Identity) +deriving via + CustomJSON + '[FieldLabelModifier LowerInitialCharacter] + (CekMachineCostsBase Identity) + instance + FromJSON (CekMachineCostsBase Identity) -- This instance will omit the generation of JSON for Nothing fields, -- (any functors which have Maybe functor at the outer layer) -deriving via CustomJSON '[OmitNothingFields, FieldLabelModifier LowerInitialCharacter] - (CekMachineCostsBase Maybe) instance ToJSON (CekMachineCostsBase Maybe) +deriving via + CustomJSON + '[OmitNothingFields, FieldLabelModifier LowerInitialCharacter] + (CekMachineCostsBase Maybe) + instance + ToJSON (CekMachineCostsBase Maybe) deriving stock instance AllBF Show f CekMachineCostsBase => Show (CekMachineCostsBase f) deriving stock instance AllBF Eq f CekMachineCostsBase => Eq (CekMachineCostsBase f) @@ -74,17 +85,17 @@ deriving anyclass instance AllBF NoThunks f CekMachineCostsBase => NoThunks (Cek -- a different version of CekMachineCosts: see ExBudgetingDefaults.defaultCekMachineCosts. unitCekMachineCosts :: CekMachineCosts unitCekMachineCosts = - CekMachineCostsBase + CekMachineCostsBase { cekStartupCost = zeroCost - , cekVarCost = unitCost - , cekConstCost = unitCost - , cekLamCost = unitCost - , cekDelayCost = unitCost - , cekForceCost = unitCost - , cekApplyCost = unitCost + , cekVarCost = unitCost + , cekConstCost = unitCost + , cekLamCost = unitCost + , cekDelayCost = unitCost + , cekForceCost = unitCost + , cekApplyCost = unitCost , cekBuiltinCost = unitCost - , cekConstrCost = unitCost - , cekCaseCost = unitCost + , cekConstrCost = unitCost + , cekCaseCost = unitCost } where zeroCost = Identity $ ExBudget 0 0 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs index 9055082d85d..bf242b8695e 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs @@ -19,8 +19,8 @@ import Data.Csv.Builder qualified as CSV import Data.DList qualified as DList import Data.Fixed import Data.Functor -import Data.SatInt import Data.STRef (modifySTRef, newSTRef, readSTRef) +import Data.SatInt import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Time.Clock @@ -41,7 +41,7 @@ logEmitter = EmitterMode $ \_ -> do -- A wrapper around encoding a record. `cassava` insists on including a trailing newline, which is -- annoying since we're recording the output line-by-line. -encodeRecord :: (CSV.ToRecord a) => a -> T.Text +encodeRecord :: CSV.ToRecord a => a -> T.Text encodeRecord a = T.stripEnd $ T.decodeUtf8 $ BSL.toStrict $ BS.toLazyByteString $ CSV.encodeRecord a -- | Emits log with timestamp. @@ -71,20 +71,19 @@ logWithBudgetEmitter = EmitterMode $ \getBudget -> do modifySTRef logsRef (`DList.append` withBudget) pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) -{-| Emits log and, when script evaluation fails, call trace. - -This requires script to be compiled with `PlutusTx.Plugin:profile-all` turned on because this relies -on compiler-generated trace calls that notifies entrance and exit of a function call. These traces -that mark entrance and exit are ordinary traces like "-> rob:Example.hs:3:1-3:15" and "<- -bob:Example.hs:1:1-1:13" with "->" and "<-" prefixies, where "bob" and "rob" is the name -of the function with source span. If regular script with no entrance/exit marker is given, this -emitter will behave identically to 'logEmitter'. - -When script evaluation fails, this emitter will give call trace of the functions that led to the -evaluation failure. This is useful for pin-pointing specific area of the codebase that caused -failure when debugging a script. When script evaluation passes, every trace message generated by -`profile-all` flag will be removed, and this emitter will behave identically to 'logEmitter'. --} +-- | Emits log and, when script evaluation fails, call trace. +-- +-- This requires script to be compiled with `PlutusTx.Plugin:profile-all` turned on because this relies +-- on compiler-generated trace calls that notifies entrance and exit of a function call. These traces +-- that mark entrance and exit are ordinary traces like "-> rob:Example.hs:3:1-3:15" and "<- +-- bob:Example.hs:1:1-1:13" with "->" and "<-" prefixies, where "bob" and "rob" is the name +-- of the function with source span. If regular script with no entrance/exit marker is given, this +-- emitter will behave identically to 'logEmitter'. +-- +-- When script evaluation fails, this emitter will give call trace of the functions that led to the +-- evaluation failure. This is useful for pin-pointing specific area of the codebase that caused +-- failure when debugging a script. When script evaluation passes, every trace message generated by +-- `profile-all` flag will be removed, and this emitter will behave identically to 'logEmitter'. logWithCallTraceEmitter :: EmitterMode uni fun logWithCallTraceEmitter = EmitterMode $ \_ -> do logsRef <- newSTRef DList.empty @@ -92,14 +91,14 @@ logWithCallTraceEmitter = EmitterMode $ \_ -> do addTrace DList.Nil logs = logs addTrace newLogs DList.Nil = newLogs addTrace newLogs logs = DList.fromList $ go (DList.toList newLogs) (DList.toList logs) - where - go l [] = l - go [] l = l - go (x : xs) l = - -- See Note [Profiling Marker] - case (T.words (last l), T.words x) of - ("->" : enterRest, "<-" : exitRest) | enterRest == exitRest -> go xs (init l) - _ -> go xs (l <> [x]) + where + go l [] = l + go [] l = l + go (x : xs) l = + -- See Note [Profiling Marker] + case (T.words (last l), T.words x) of + ("->" : enterRest, "<-" : exitRest) | enterRest == exitRest -> go xs (init l) + _ -> go xs (l <> [x]) emitter logs = CekM $ modifySTRef logsRef (addTrace logs) pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs index d338709814c..f2de3dd788d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs @@ -1,28 +1,28 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - -module UntypedPlutusCore.Evaluation.Machine.Cek.ExBudgetMode - ( ExBudgetMode (..) - , CountingSt (..) - , CekExTally (..) - , TallyingSt (..) - , RestrictingSt (..) - , Hashable - , monoidalBudgeting - , counting - , enormousBudget - , tallying - , restricting - , restrictingLarge - , restrictingEnormous - ) +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module UntypedPlutusCore.Evaluation.Machine.Cek.ExBudgetMode ( + ExBudgetMode (..), + CountingSt (..), + CekExTally (..), + TallyingSt (..), + RestrictingSt (..), + Hashable, + monoidalBudgeting, + counting, + enormousBudget, + tallying, + restricting, + restrictingLarge, + restrictingEnormous, +) where import PlutusPrelude @@ -35,38 +35,38 @@ import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) import Control.Lens (imap) import Control.Monad (when) import Control.Monad.Except -import Data.Hashable (Hashable) import Data.HashMap.Monoidal as HashMap +import Data.Hashable (Hashable) import Data.Map.Strict qualified as Map import Data.Primitive.PrimArray +import Data.STRef import Data.SatInt import Data.Semigroup.Generic -import Data.STRef import Prettyprinter import Text.PrettyBy (IgnorePrettyConfig (..)) -- | Construct an 'ExBudgetMode' out of a function returning a value of the budgeting state type. -- The value then gets added to the current state via @(<>)@. -monoidalBudgeting - :: Monoid cost => (ExBudgetCategory fun -> ExBudget -> cost) -> ExBudgetMode cost uni fun +monoidalBudgeting :: + Monoid cost => (ExBudgetCategory fun -> ExBudget -> cost) -> ExBudgetMode cost uni fun monoidalBudgeting toCost = ExBudgetMode $ do - costRef <- newSTRef mempty - budgetRef <- newSTRef mempty - let spend key budgetToSpend = CekM $ do - modifySTRef' costRef (<> toCost key budgetToSpend) - modifySTRef' budgetRef (<> budgetToSpend) - spender = CekBudgetSpender spend - cumulative = readSTRef budgetRef - final = readSTRef costRef - pure $ ExBudgetInfo spender final cumulative + costRef <- newSTRef mempty + budgetRef <- newSTRef mempty + let spend key budgetToSpend = CekM $ do + modifySTRef' costRef (<> toCost key budgetToSpend) + modifySTRef' budgetRef (<> budgetToSpend) + spender = CekBudgetSpender spend + cumulative = readSTRef budgetRef + final = readSTRef costRef + pure $ ExBudgetInfo spender final cumulative -- | For calculating the cost of execution by counting up using the 'Monoid' instance of 'ExBudget'. newtype CountingSt = CountingSt ExBudget - deriving stock (Eq, Show) - deriving newtype (Semigroup, Monoid, PrettyBy config, NFData) + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid, PrettyBy config, NFData) instance Pretty CountingSt where - pretty (CountingSt budget) = parens $ "required budget:" <+> pretty budget <> line + pretty (CountingSt budget) = parens $ "required budget:" <+> pretty budget <> line -- | For calculating the cost of execution. counting :: ExBudgetMode CountingSt uni fun @@ -75,91 +75,101 @@ counting = monoidalBudgeting $ const CountingSt -- | For a detailed report on what costs how much + the same overall budget that 'Counting' gives. -- The (derived) 'Monoid' instance of 'CekExTally' is the main piece of the machinery. newtype CekExTally fun = CekExTally (MonoidalHashMap (ExBudgetCategory fun) ExBudget) - deriving stock (Eq, Generic, Show) - deriving (Semigroup, Monoid) via (GenericSemigroupMonoid (CekExTally fun)) - deriving anyclass (NFData) - deriving (PrettyBy config) via (IgnorePrettyConfig (CekExTally fun)) + deriving stock (Eq, Generic, Show) + deriving (Semigroup, Monoid) via (GenericSemigroupMonoid (CekExTally fun)) + deriving anyclass (NFData) + deriving (PrettyBy config) via (IgnorePrettyConfig (CekExTally fun)) instance (Show fun, Ord fun) => Pretty (CekExTally fun) where - pretty (CekExTally m) = - let om = Map.fromList $ HashMap.toList m - in parens $ encloseSep "{" "}" "| " $ fmap group $ - Map.elems $ imap (\k v -> (pretty k <+> "causes" <+> group (pretty v))) om + pretty (CekExTally m) = + let om = Map.fromList $ HashMap.toList m + in parens $ + encloseSep "{" "}" "| " $ + fmap group $ + Map.elems $ + imap (\k v -> (pretty k <+> "causes" <+> group (pretty v))) om data TallyingSt fun = TallyingSt (CekExTally fun) ExBudget - deriving stock (Eq, Show, Generic) - deriving (Semigroup, Monoid) via (GenericSemigroupMonoid (TallyingSt fun)) - deriving anyclass (NFData) - deriving (PrettyBy config) via (IgnorePrettyConfig (TallyingSt fun)) + deriving stock (Eq, Show, Generic) + deriving (Semigroup, Monoid) via (GenericSemigroupMonoid (TallyingSt fun)) + deriving anyclass (NFData) + deriving (PrettyBy config) via (IgnorePrettyConfig (TallyingSt fun)) instance (Show fun, Ord fun) => Pretty (TallyingSt fun) where - pretty (TallyingSt tally budget) = parens $ fold - [ "{ tally: ", pretty tally, line - , "| budget: ", pretty budget, line + pretty (TallyingSt tally budget) = + parens $ + fold + [ "{ tally: " + , pretty tally + , line + , "| budget: " + , pretty budget + , line , "}" ] -- | For a detailed report on what costs how much + the same overall budget that 'Counting' gives. -tallying :: (Hashable fun) => ExBudgetMode (TallyingSt fun) uni fun +tallying :: Hashable fun => ExBudgetMode (TallyingSt fun) uni fun tallying = - monoidalBudgeting $ \key budgetToSpend -> - TallyingSt (CekExTally $ singleton key budgetToSpend) budgetToSpend + monoidalBudgeting $ \key budgetToSpend -> + TallyingSt (CekExTally $ singleton key budgetToSpend) budgetToSpend newtype RestrictingSt = RestrictingSt ExRestrictingBudget - deriving stock (Eq, Show) - deriving newtype (Semigroup, Monoid, NFData) - deriving anyclass (PrettyBy config) + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid, NFData) + deriving anyclass (PrettyBy config) instance Pretty RestrictingSt where - pretty (RestrictingSt budget) = parens $ "final budget:" <+> pretty budget <> line + pretty (RestrictingSt budget) = parens $ "final budget:" <+> pretty budget <> line -- | For execution, to avoid overruns. -restricting - :: ThrowableBuiltins uni fun - => ExRestrictingBudget -> ExBudgetMode RestrictingSt uni fun +restricting :: + ThrowableBuiltins uni fun => + ExRestrictingBudget -> ExBudgetMode RestrictingSt uni fun restricting (ExRestrictingBudget initB@(ExBudget cpuInit memInit)) = ExBudgetMode $ do - -- We keep the counters in a PrimArray. This is better than an STRef since it stores its contents unboxed. - -- - -- If we don't specify the element type then GHC has difficulty inferring it, but it's - -- annoying to specify the monad, since it refers to the 's' which is not in scope. - ref <- newPrimArray @_ @SatInt 2 - let - cpuIx = 0 - memIx = 1 - readCpu = coerce @_ @ExCPU <$> readPrimArray ref cpuIx - writeCpu cpu = writePrimArray ref cpuIx $ coerce cpu - readMem = coerce @_ @ExMemory <$> readPrimArray ref memIx - writeMem mem = writePrimArray ref memIx $ coerce mem - - writeCpu cpuInit - writeMem memInit - let - spend _ (ExBudget cpuToSpend memToSpend) = do - cpuLeft <- CekM readCpu - memLeft <- CekM readMem - let cpuLeft' = cpuLeft - cpuToSpend - let memLeft' = memLeft - memToSpend - -- Note that even if we throw an out-of-budget error, we still need to record - -- what the final state was. - CekM $ writeCpu cpuLeft' - CekM $ writeMem memLeft' - when (cpuLeft' < 0 || memLeft' < 0) $ do - let -- You'd think whether the budget is computed strictly or not before throwing - -- an error isn't important, but GHC refuses to unbox the second argument of - -- @spend@ without this bang. Bangs on @cpuLeft'@ and @memLeft'@ don't help - -- either as those are forced by 'writeCpu' and 'writeMem' anyway. Go figure. - !budgetLeft = ExBudget cpuLeft' memLeft' - throwError $ - ErrorWithCause - (OperationalError (CekOutOfExError $ ExRestrictingBudget budgetLeft)) - Nothing - spender = CekBudgetSpender spend - remaining = ExBudget <$> readCpu <*> readMem - cumulative = do - r <- remaining - pure $ initB `minusExBudget` r - final = RestrictingSt . ExRestrictingBudget <$> remaining - pure $ ExBudgetInfo spender final cumulative + -- We keep the counters in a PrimArray. This is better than an STRef since it stores its contents unboxed. + -- + -- If we don't specify the element type then GHC has difficulty inferring it, but it's + -- annoying to specify the monad, since it refers to the 's' which is not in scope. + ref <- newPrimArray @_ @SatInt 2 + let + cpuIx = 0 + memIx = 1 + readCpu = coerce @_ @ExCPU <$> readPrimArray ref cpuIx + writeCpu cpu = writePrimArray ref cpuIx $ coerce cpu + readMem = coerce @_ @ExMemory <$> readPrimArray ref memIx + writeMem mem = writePrimArray ref memIx $ coerce mem + + writeCpu cpuInit + writeMem memInit + let + spend _ (ExBudget cpuToSpend memToSpend) = do + cpuLeft <- CekM readCpu + memLeft <- CekM readMem + let cpuLeft' = cpuLeft - cpuToSpend + let memLeft' = memLeft - memToSpend + -- Note that even if we throw an out-of-budget error, we still need to record + -- what the final state was. + CekM $ writeCpu cpuLeft' + CekM $ writeMem memLeft' + when (cpuLeft' < 0 || memLeft' < 0) $ do + let + -- You'd think whether the budget is computed strictly or not before throwing + -- an error isn't important, but GHC refuses to unbox the second argument of + -- @spend@ without this bang. Bangs on @cpuLeft'@ and @memLeft'@ don't help + -- either as those are forced by 'writeCpu' and 'writeMem' anyway. Go figure. + !budgetLeft = ExBudget cpuLeft' memLeft' + throwError $ + ErrorWithCause + (OperationalError (CekOutOfExError $ ExRestrictingBudget budgetLeft)) + Nothing + spender = CekBudgetSpender spend + remaining = ExBudget <$> readCpu <*> readMem + cumulative = do + r <- remaining + pure $ initB `minusExBudget` r + final = RestrictingSt . ExRestrictingBudget <$> remaining + pure $ ExBudgetInfo spender final cumulative -- | 'restricting' instantiated at 'largeBudget'. restrictingLarge :: ThrowableBuiltins uni fun => ExBudgetMode RestrictingSt uni fun diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index bb40daaf4f9..5517eefd79c 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -1,75 +1,74 @@ -- editorconfig-checker-disable-file --- | The CEK machine. - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NPlusKPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NPlusKPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | The CEK machine. module UntypedPlutusCore.Evaluation.Machine.Cek.Internal - -- See Note [Compilation peculiarities]. - ( EvaluationResult(..) - , CekResult(..) - , cekResultToEither - , mapTermCekResult - , CekReport(..) - , CekValue(..) - , DischargeResult(..) - , dischargeResultToTerm - , ArgStack(..) - , EmptyOrMultiStack(..) - , ArgStackNonEmpty(..) - , CekUserError(..) - , CekEvaluationException - , CekBudgetSpender(..) - , ExBudgetInfo(..) - , ExBudgetMode(..) - , CekEmitter - , CekEmitterInfo(..) - , EmitterMode(..) - , CekM (..) - , ErrorWithCause(..) - , EvaluationError(..) - , ExBudgetCategory(..) - , StepKind(..) - , ThrowableBuiltins - , splitStructuralOperational - , unsafeSplitStructuralOperational - , runCekDeBruijn - , dischargeCekValue - , Context (..) - , CekValEnv - , GivenCekReqs - , GivenCekSpender - , StepCounter - , NumberOfStepCounters - , CounterSize - , TotalCountIndex - , Slippage - , defaultSlippage - , NTerm - , runCekM - ) +-- See Note [Compilation peculiarities]. + ( + EvaluationResult (..), + CekResult (..), + cekResultToEither, + mapTermCekResult, + CekReport (..), + CekValue (..), + DischargeResult (..), + dischargeResultToTerm, + ArgStack (..), + EmptyOrMultiStack (..), + ArgStackNonEmpty (..), + CekUserError (..), + CekEvaluationException, + CekBudgetSpender (..), + ExBudgetInfo (..), + ExBudgetMode (..), + CekEmitter, + CekEmitterInfo (..), + EmitterMode (..), + CekM (..), + ErrorWithCause (..), + EvaluationError (..), + ExBudgetCategory (..), + StepKind (..), + ThrowableBuiltins, + splitStructuralOperational, + unsafeSplitStructuralOperational, + runCekDeBruijn, + dischargeCekValue, + Context (..), + CekValEnv, + GivenCekReqs, + GivenCekSpender, + StepCounter, + NumberOfStepCounters, + CounterSize, + TotalCountIndex, + Slippage, + defaultSlippage, + NTerm, + runCekM, +) where import PlutusPrelude @@ -82,14 +81,16 @@ import PlutusCore.Builtin import PlutusCore.DeBruijn import PlutusCore.Evaluation.Machine.ExBudget import PlutusCore.Evaluation.Machine.ExBudgetStream -import PlutusCore.Evaluation.Machine.Exception import PlutusCore.Evaluation.Machine.ExMemoryUsage +import PlutusCore.Evaluation.Machine.Exception import PlutusCore.Evaluation.Machine.MachineParameters import PlutusCore.Evaluation.Result import PlutusCore.Pretty -import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts, - CekMachineCostsBase (..)) +import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts ( + CekMachineCosts, + CekMachineCostsBase (..), + ) import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter import Control.Exception qualified as Exception @@ -173,72 +174,76 @@ type NTerm uni fun = Term NamedDeBruijn uni fun -- | The result of evaluating a term with the CEK machine. data CekResult name uni fun - = CekFailure (CekEvaluationException name uni fun) - | CekSuccessConstant (Some (ValueOf uni)) - | CekSuccessNonConstant (Term name uni fun ()) + = CekFailure (CekEvaluationException name uni fun) + | CekSuccessConstant (Some (ValueOf uni)) + | CekSuccessNonConstant (Term name uni fun ()) -- | All info produced by a CEK machine run. data CekReport cost name uni fun = CekReport - { _cekReportResult :: CekResult name uni fun -- ^ The result of evaluation. - , _cekReportCost :: cost -- ^ The final @cost@ value. - , _cekReportLogs :: [Text] -- ^ Logs emitted during evaluation. - } + { _cekReportResult :: CekResult name uni fun + -- ^ The result of evaluation. + , _cekReportCost :: cost + -- ^ The final @cost@ value. + , _cekReportLogs :: [Text] + -- ^ Logs emitted during evaluation. + } -- | Convert the given 'CekResult' into an 'Either'. -- This is useful, because in the ledger API we care whether the result is a constant or not, but in -- tests, executables etc we don't and so handling an either-error-or-term is more natural. -cekResultToEither - :: CekResult name uni fun - -> Either (CekEvaluationException name uni fun) (Term name uni fun ()) -cekResultToEither (CekFailure err) = Left err -cekResultToEither (CekSuccessConstant val) = Right $ Constant () val +cekResultToEither :: + CekResult name uni fun -> + Either (CekEvaluationException name uni fun) (Term name uni fun ()) +cekResultToEither (CekFailure err) = Left err +cekResultToEither (CekSuccessConstant val) = Right $ Constant () val cekResultToEither (CekSuccessNonConstant term) = Right term -- | Apply the given function to the 'Term' (if any) stored in the given 'CekResult'. -mapTermCekResult - :: (Term name uni fun () -> Term name' uni fun ()) - -> CekResult name uni fun - -> CekResult name' uni fun -mapTermCekResult f (CekFailure err) = CekFailure $ f <$> err -mapTermCekResult _ (CekSuccessConstant val) = CekSuccessConstant val +mapTermCekResult :: + (Term name uni fun () -> Term name' uni fun ()) -> + CekResult name uni fun -> + CekResult name' uni fun +mapTermCekResult f (CekFailure err) = CekFailure $ f <$> err +mapTermCekResult _ (CekSuccessConstant val) = CekSuccessConstant val mapTermCekResult f (CekSuccessNonConstant term) = CekSuccessNonConstant $ f term data StepKind - = BConst - | BVar - | BLamAbs - | BApply - | BDelay - | BForce - | BBuiltin -- Cost of evaluating a Builtin AST node, not the function itself - | BConstr - | BCase - deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) - deriving anyclass (NFData, Hashable) + = BConst + | BVar + | BLamAbs + | BApply + | BDelay + | BForce + | BBuiltin -- Cost of evaluating a Builtin AST node, not the function itself + | BConstr + | BCase + deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) + deriving anyclass (NFData, Hashable) cekStepCost :: CekMachineCosts -> StepKind -> ExBudget -cekStepCost costs = runIdentity . \case - BConst -> cekConstCost costs - BVar -> cekVarCost costs - BLamAbs -> cekLamCost costs - BApply -> cekApplyCost costs - BDelay -> cekDelayCost costs - BForce -> cekForceCost costs +cekStepCost costs = + runIdentity . \case + BConst -> cekConstCost costs + BVar -> cekVarCost costs + BLamAbs -> cekLamCost costs + BApply -> cekApplyCost costs + BDelay -> cekDelayCost costs + BForce -> cekForceCost costs BBuiltin -> cekBuiltinCost costs - BConstr -> cekConstrCost costs - BCase -> cekCaseCost costs + BConstr -> cekConstrCost costs + BCase -> cekCaseCost costs data ExBudgetCategory fun - = BStep StepKind - | BBuiltinApp fun -- Cost of evaluating a fully applied builtin function - | BStartup - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, Hashable) + = BStep StepKind + | BBuiltinApp fun -- Cost of evaluating a fully applied builtin function + | BStartup + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, Hashable) instance Show fun => Pretty (ExBudgetCategory fun) where - pretty = viaShow + pretty = viaShow instance ExBudgetBuiltin fun (ExBudgetCategory fun) where - exBudgetBuiltin = BBuiltinApp + exBudgetBuiltin = BBuiltinApp {- Note [Show instance for BuiltinRuntime] We need to be able to print 'CekValue's and for that we need a 'Show' instance for 'BuiltinRuntime', @@ -247,20 +252,20 @@ but functions are not printable and hence we provide a dummy instance. -- See Note [Show instance for BuiltinRuntime]. instance Show (BuiltinRuntime (CekValue uni fun ann)) where - show _ = "" + show _ = "" -- | A LIFO stack of 'CekValue's, used to record multiple arguments that need to be pushed -- onto the context in reverse order. Currently used by 'FrameConstr' for collecting the -- elements of a 'Constr' as it is cheap to prepend new elements in 'ArgStack'. -data ArgStack uni fun ann = - NilStack +data ArgStack uni fun ann + = NilStack | ConsStack !(CekValue uni fun ann) !(ArgStack uni fun ann) -- | A non-empty variant of 'ArgStack', used in 'FrameAwaitFunValueN' to store arguments -- that will be applied to a term. More efficient than 'ArgStack', since this saves one -- evaluation cycle by ensuring there is no 'NilStack'. -data ArgStackNonEmpty uni fun ann = - LastStackNonEmpty !(CekValue uni fun ann) +data ArgStackNonEmpty uni fun ann + = LastStackNonEmpty !(CekValue uni fun ann) | ConsStackNonEmpty !(CekValue uni fun ann) !(ArgStackNonEmpty uni fun ann) -- | An alternative version of 'ArgStack' that uses 'ArgNonEmptyStack' when non-empty. @@ -268,49 +273,53 @@ data ArgStackNonEmpty uni fun ann = -- in 'FrameConstr', the collected elements gets reversed and put into 'VConstr' as -- `EmptyOrMultiStack`. 'VConstr' using `EmptyOrMultiStack` is more efficient than 'ArgStack' when casing, -- since 'FrameAwaitFunValueN' can be dispatched with a single pattern match. -data EmptyOrMultiStack uni fun ann = - EmptyStack +data EmptyOrMultiStack uni fun ann + = EmptyStack | MultiStack !(ArgStackNonEmpty uni fun ann) -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (ArgStack uni fun ann) -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (EmptyOrMultiStack uni fun ann) -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (ArgStackNonEmpty uni fun ann) +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (ArgStack uni fun ann) +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (EmptyOrMultiStack uni fun ann) +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (ArgStackNonEmpty uni fun ann) -- 'Values' for the modified CEK machine. -data CekValue uni fun ann = - -- This bang gave us a 1-2% speed-up at the time of writing. +data CekValue uni fun ann + = -- This bang gave us a 1-2% speed-up at the time of writing. VCon !(Some (ValueOf uni)) | VDelay !(NTerm uni fun ann) !(CekValEnv uni fun ann) | VLamAbs !NamedDeBruijn !(NTerm uni fun ann) !(CekValEnv uni fun ann) - -- | A partial builtin application, accumulating arguments for eventual full application. + | -- | A partial builtin application, accumulating arguments for eventual full application. -- We don't need a 'CekValEnv' here unlike in the other constructors, because 'VBuiltin' -- values always store their corresponding 'Term's fully discharged, see the comments at -- the call sites (search for 'VBuiltin'). - | VBuiltin - !fun - -- ^ So that we know, for what builtin we're calculating the cost. We can sneak this into + VBuiltin + -- | So that we know, for what builtin we're calculating the cost. We can sneak this into -- 'BuiltinRuntime', so that we don't need to store it here, but somehow doing so was -- consistently slowing evaluation down by half a percent. Might be noise, might be not, but -- at least we know that removing this @fun@ is not helpful anyway. See this commit reversing -- the change: https://github.com/IntersectMBO/plutus/pull/4778/commits/86a3e24ca3c671cc27c6f4344da2bcd14f961706 - (NTerm uni fun ()) - -- ^ This must be lazy. It represents the fully discharged partial application of the builtin + !fun + -- | This must be lazy. It represents the fully discharged partial application of the builtin -- function that we're going to run when it's fully saturated. We need the 'Term' to be able -- to return it in case full saturation is never achieved and a partial application needs to -- be returned in the result. The laziness is important, because the arguments are discharged -- values and discharging is expensive, so we don't want to do it unless we really have -- to. Making this field strict resulted in a 3-4.5% slowdown at the time of writing. - !(BuiltinRuntime (CekValue uni fun ann)) - -- ^ The partial application and its costing function. + (NTerm uni fun ()) + -- | The partial application and its costing function. -- Check the docs of 'BuiltinRuntime' for details. - -- | A constructor value, including fully computed arguments and the tag. + -- | A constructor value, including fully computed arguments and the tag. + !(BuiltinRuntime (CekValue uni fun ann)) | VConstr {-# UNPACK #-} !Word64 !(EmptyOrMultiStack uni fun ann) -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (CekValue uni fun ann) +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (CekValue uni fun ann) type CekValEnv uni fun ann = Env.RAList (CekValue uni fun ann) @@ -318,24 +327,29 @@ type CekValEnv uni fun ann = Env.RAList (CekValue uni fun ann) -- and allows us to separate budgeting logic from evaluation logic and avoid branching on the union -- of all possible budgeting state types during evaluation. newtype CekBudgetSpender uni fun s = CekBudgetSpender - { unCekBudgetSpender :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () - } + { unCekBudgetSpender :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () + } -- General enough to be able to handle a spender having one, two or any number of 'STRef's -- under the hood. + -- | Runtime budgeting info. data ExBudgetInfo cost uni fun s = ExBudgetInfo - { _exBudgetModeSpender :: !(CekBudgetSpender uni fun s) -- ^ A spending function. - , _exBudgetModeGetFinal :: !(ST s cost) -- ^ For accessing the final state. - , _exBudgetModeGetCumulative :: !(ST s ExBudget) -- ^ For accessing the cumulative budget. - } + { _exBudgetModeSpender :: !(CekBudgetSpender uni fun s) + -- ^ A spending function. + , _exBudgetModeGetFinal :: !(ST s cost) + -- ^ For accessing the final state. + , _exBudgetModeGetCumulative :: !(ST s ExBudget) + -- ^ For accessing the cumulative budget. + } -- We make a separate data type here just to save the caller of the CEK machine from those pesky -- 'ST'-related details. + -- | A budgeting mode to execute the CEK machine in. newtype ExBudgetMode cost uni fun = ExBudgetMode - { unExBudgetMode :: forall s. ST s (ExBudgetInfo cost uni fun s) - } + { unExBudgetMode :: forall s. ST s (ExBudgetInfo cost uni fun s) + } {- Note [Cost slippage] Tracking the budget usage for every step in the machine adds a lot of overhead. To reduce this, @@ -381,28 +395,32 @@ the 'Enum' instance of 'StepKind', and the total counter in the last index. -- error-prone and has caused a bug in the past. type CountConstructorsEnum :: (GHC.Type -> GHC.Type) -> Nat type family CountConstructorsEnum rep where - CountConstructorsEnum U1 = 1 - CountConstructorsEnum (M1 _ _ f) = CountConstructorsEnum f - CountConstructorsEnum (f :+: g) = CountConstructorsEnum f + CountConstructorsEnum g - CountConstructorsEnum V1 = TypeError ('Text "Cannot be empty") - CountConstructorsEnum (f :*: g) = TypeError ('Text "Cannot be a non-enumeration type") - CountConstructorsEnum (K1 _ _) = TypeError ('Text "Cannot be a non-enumeration type") - CountConstructorsEnum (Rec1 _) = TypeError ('Text "Cannot be a non-enumeration type") - CountConstructorsEnum Par1 = - TypeError ('Text "If you really want a parameterized type, handle this clause") + CountConstructorsEnum U1 = 1 + CountConstructorsEnum (M1 _ _ f) = CountConstructorsEnum f + CountConstructorsEnum (f :+: g) = CountConstructorsEnum f + CountConstructorsEnum g + CountConstructorsEnum V1 = TypeError ('Text "Cannot be empty") + CountConstructorsEnum (f :*: g) = TypeError ('Text "Cannot be a non-enumeration type") + CountConstructorsEnum (K1 _ _) = TypeError ('Text "Cannot be a non-enumeration type") + CountConstructorsEnum (Rec1 _) = TypeError ('Text "Cannot be a non-enumeration type") + CountConstructorsEnum Par1 = + TypeError ('Text "If you really want a parameterized type, handle this clause") -- | The number of step counters that we need, should be the same as the number of constructors -- of 'StepKind'. type NumberOfStepCounters = CountConstructorsEnum (Rep StepKind) + -- | The total number of counters that we need, one extra for the total counter. -- See Note [Structure of the step counter] type CounterSize = NumberOfStepCounters + 1 + -- | The index at which the total step counter is kept. -- See Note [Structure of the step counter] type TotalCountIndex = NumberOfStepCounters type Slippage = Word8 + -- See Note [Cost slippage] + -- | The default number of slippage (in machine steps) to allow. defaultSlippage :: Slippage defaultSlippage = 200 @@ -416,19 +434,20 @@ https://github.com/IntersectMBO/plutus/pull/4421#issuecomment-1059186586 -} -- See Note [DList-based emitting]. + -- | The CEK machine is parameterized over an emitter function, similar to 'CekBudgetSpender'. type CekEmitter uni fun s = DList.DList Text -> CekM uni fun s () -- | Runtime emitter info, similar to 'ExBudgetInfo'. -data CekEmitterInfo uni fun s = CekEmitterInfo { - _cekEmitterInfoEmit :: !(CekEmitter uni fun s) - , _cekEmitterInfoGetFinal :: !(ST s [Text]) - } +data CekEmitterInfo uni fun s = CekEmitterInfo + { _cekEmitterInfoEmit :: !(CekEmitter uni fun s) + , _cekEmitterInfoGetFinal :: !(ST s [Text]) + } -- | An emitting mode to execute the CEK machine in, similar to 'ExBudgetMode'. newtype EmitterMode uni fun = EmitterMode - { unEmitterMode :: forall s. ST s ExBudget -> ST s (CekEmitterInfo uni fun s) - } + { unEmitterMode :: forall s. ST s ExBudget -> ST s (CekEmitterInfo uni fun s) + } {- Note [Implicit parameters in the machine] The traditional way to pass context into a function is to use 'ReaderT'. However, 'ReaderT' has some @@ -457,42 +476,51 @@ they don't actually take the context as an argument even at the source level. -- | Implicit parameter for the builtin runtime. type GivenCekRuntime uni fun ann = (?cekRuntime :: BuiltinsRuntime fun (CekValue uni fun ann)) + type GivenCekCaserBuiltin uni = (?cekCaserBuiltin :: CaserBuiltin uni) + -- | Implicit parameter for the log emitter reference. type GivenCekEmitter uni fun s = (?cekEmitter :: CekEmitter uni fun s) + -- | Implicit parameter for budget spender. type GivenCekSpender uni fun s = (?cekBudgetSpender :: CekBudgetSpender uni fun s) + type GivenCekSlippage = (?cekSlippage :: Slippage) type GivenCekStepCounter s = (?cekStepCounter :: StepCounter CounterSize s) type GivenCekCosts = (?cekCosts :: CekMachineCosts) -- | Constraint requiring all of the machine's implicit parameters. type GivenCekReqs uni fun ann s = - ( GivenCekRuntime uni fun ann - , GivenCekCaserBuiltin uni - , GivenCekEmitter uni fun s - , GivenCekSpender uni fun s - , GivenCekSlippage - , GivenCekStepCounter s - , GivenCekCosts - ) + ( GivenCekRuntime uni fun ann + , GivenCekCaserBuiltin uni + , GivenCekEmitter uni fun s + , GivenCekSpender uni fun s + , GivenCekSlippage + , GivenCekStepCounter s + , GivenCekCosts + ) data CekUserError - = CekCaseBuiltinError Text -- ^ 'Case' over a value of a built-in type failed. - | CekOutOfExError !ExRestrictingBudget -- ^ The final overspent (i.e. negative) budget. - | CekEvaluationFailure -- ^ Error has been called or a builtin application has failed - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) + = -- | 'Case' over a value of a built-in type failed. + CekCaseBuiltinError Text + | -- | The final overspent (i.e. negative) budget. + CekOutOfExError !ExRestrictingBudget + | -- | Error has been called or a builtin application has failed + CekEvaluationFailure + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) type CekM :: (GHC.Type -> GHC.Type) -> GHC.Type -> GHC.Type -> GHC.Type -> GHC.Type + -- | The monad the CEK machine runs in. newtype CekM uni fun s a = CekM - { unCekM :: ST s a - } deriving newtype (Functor, Applicative, Monad, PrimMonad) + { unCekM :: ST s a + } + deriving newtype (Functor, Applicative, Monad, PrimMonad) -- | The CEK machine-specific 'EvaluationException'. type CekEvaluationException name uni fun = - EvaluationException (MachineError fun) CekUserError (Term name uni fun ()) + EvaluationException (MachineError fun) CekUserError (Term name uni fun ()) instance BuiltinErrorToEvaluationError (MachineError fun) CekUserError where builtinErrorToEvaluationError (BuiltinUnliftingEvaluationError err) = @@ -530,195 +558,205 @@ But in our case this is okay, because: -- | Call 'dischargeCekValue' over the received 'CekVal' and feed the resulting 'Term' to -- 'throwErrorWithCause' as the cause of the failure. -throwErrorDischarged - :: ThrowableBuiltins uni fun - => EvaluationError (MachineError fun) CekUserError - -> CekValue uni fun ann - -> CekM uni fun s x +throwErrorDischarged :: + ThrowableBuiltins uni fun => + EvaluationError (MachineError fun) CekUserError -> + CekValue uni fun ann -> + CekM uni fun s x throwErrorDischarged err = throwErrorWithCause err . dischargeResultToTerm . dischargeCekValue -instance ThrowableBuiltins uni fun => - MonadError (CekEvaluationException NamedDeBruijn uni fun) (CekM uni fun s) where - -- See Note [Throwing exceptions in ST]. - throwError = CekM . throwM - - -- See Note [Catching exceptions in ST]. - catchError - :: forall a. - CekM uni fun s a - -> (CekEvaluationException NamedDeBruijn uni fun -> CekM uni fun s a) - -> CekM uni fun s a - a `catchError` h = - -- Here in addition to catching 'CekEvaluationException' we also catch common GHC exceptions - -- in case one of them somehow gets triggered during script execution (which would be a bug - -- on our side). We could probably use @enclosed-exceptions@, but spawning a thread per - -- script is expensive. We could also use type-based disambiguation like @unliftio@ does, - -- but it fails if an exception whose type indicates that it's a sync one gets thrown in an - -- async way. - -- Alexey Kuleshevich told us that the node catches exceptions anyway, so what we're doing - -- here is for easing debugging and error reporting, it's not a proper safety measure. Hence - -- catching several common exception types is enough. - CekM . unsafeIOToST $ aIO `catches` - [ Handler hIO - , panicHandler @IOError - , panicHandler @Exception.ErrorCall - , panicHandler @Exception.ArithException - , panicHandler @Exception.ArrayException - ] - where - aIO = unsafeRunCekM a - hIO = unsafeRunCekM . h - - -- Unsafely run a 'CekM' computation in the 'IO' monad by converting the underlying 'ST' to - -- it. - unsafeRunCekM :: CekM uni fun s a -> IO a - unsafeRunCekM = unsafeSTToIO . unCekM - - panicHandler :: forall e. Exception e => Handler IO a - panicHandler = - Handler $ \(err :: e) -> hIO $ - ErrorWithCause - (StructuralError . PanicMachineError $ displayException err) - Nothing +instance + ThrowableBuiltins uni fun => + MonadError (CekEvaluationException NamedDeBruijn uni fun) (CekM uni fun s) + where + -- See Note [Throwing exceptions in ST]. + throwError = CekM . throwM + + -- See Note [Catching exceptions in ST]. + catchError :: + forall a. + CekM uni fun s a -> + (CekEvaluationException NamedDeBruijn uni fun -> CekM uni fun s a) -> + CekM uni fun s a + a `catchError` h = + -- Here in addition to catching 'CekEvaluationException' we also catch common GHC exceptions + -- in case one of them somehow gets triggered during script execution (which would be a bug + -- on our side). We could probably use @enclosed-exceptions@, but spawning a thread per + -- script is expensive. We could also use type-based disambiguation like @unliftio@ does, + -- but it fails if an exception whose type indicates that it's a sync one gets thrown in an + -- async way. + -- Alexey Kuleshevich told us that the node catches exceptions anyway, so what we're doing + -- here is for easing debugging and error reporting, it's not a proper safety measure. Hence + -- catching several common exception types is enough. + CekM . unsafeIOToST $ + aIO + `catches` [ Handler hIO + , panicHandler @IOError + , panicHandler @Exception.ErrorCall + , panicHandler @Exception.ArithException + , panicHandler @Exception.ArrayException + ] + where + aIO = unsafeRunCekM a + hIO = unsafeRunCekM . h + + -- Unsafely run a 'CekM' computation in the 'IO' monad by converting the underlying 'ST' to + -- it. + unsafeRunCekM :: CekM uni fun s a -> IO a + unsafeRunCekM = unsafeSTToIO . unCekM + + panicHandler :: forall e. Exception e => Handler IO a + panicHandler = + Handler $ \(err :: e) -> + hIO $ + ErrorWithCause + (StructuralError . PanicMachineError $ displayException err) + Nothing instance Pretty CekUserError where - pretty (CekCaseBuiltinError err) = vcat - [ "'case' over a value of a built-in type failed with" - , pretty err - ] - pretty (CekOutOfExError (ExRestrictingBudget res)) = - cat - [ "The machine terminated part way through evaluation due to overspending the budget." - , "The budget when the machine terminated was:" - , pretty res - , "Negative numbers indicate the overspent budget; note that this only indicates the budget that was needed for the next step, not to run the program to completion." - ] - pretty CekEvaluationFailure = "The machine terminated because of an error, either from a built-in function or from an explicit use of 'error'." + pretty (CekCaseBuiltinError err) = + vcat + [ "'case' over a value of a built-in type failed with" + , pretty err + ] + pretty (CekOutOfExError (ExRestrictingBudget res)) = + cat + [ "The machine terminated part way through evaluation due to overspending the budget." + , "The budget when the machine terminated was:" + , pretty res + , "Negative numbers indicate the overspent budget; note that this only indicates the budget that was needed for the next step, not to run the program to completion." + ] + pretty CekEvaluationFailure = "The machine terminated because of an error, either from a built-in function or from an explicit use of 'error'." argNonEmptyStackToList :: ArgStackNonEmpty uni fun ann -> [CekValue uni fun ann] -argNonEmptyStackToList (LastStackNonEmpty val) = [val] +argNonEmptyStackToList (LastStackNonEmpty val) = [val] argNonEmptyStackToList (ConsStackNonEmpty val stack) = val : argNonEmptyStackToList stack -- | Convert the given 'EmptyOrMultiStack to a list. argStackToList :: EmptyOrMultiStack uni fun ann -> [CekValue uni fun ann] -argStackToList EmptyStack = [] +argStackToList EmptyStack = [] argStackToList (MultiStack stack) = argNonEmptyStackToList stack -- | The result of 'dischargeCekValue'. data DischargeResult uni fun - = DischargeConstant (Some (ValueOf uni)) - | DischargeNonConstant (NTerm uni fun ()) + = DischargeConstant (Some (ValueOf uni)) + | DischargeNonConstant (NTerm uni fun ()) -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Closed uni) - => Show (DischargeResult uni fun) +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Closed uni) => + Show (DischargeResult uni fun) -deriving stock instance (GEq uni, Everywhere uni Eq, Eq fun, Closed uni) - => Eq (DischargeResult uni fun) +deriving stock instance + (GEq uni, Everywhere uni Eq, Eq fun, Closed uni) => + Eq (DischargeResult uni fun) instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (DischargeResult uni fun) where - prettyBy cfg = prettyBy cfg . dischargeResultToTerm + prettyBy cfg = prettyBy cfg . dischargeResultToTerm dischargeResultToTerm :: DischargeResult uni fun -> NTerm uni fun () -dischargeResultToTerm (DischargeConstant val) = Constant () val +dischargeResultToTerm (DischargeConstant val) = Constant () val dischargeResultToTerm (DischargeNonConstant term) = term -- | Convert a 'CekValue' into a 'Term' by replacing all bound variables with the terms -- they're bound to (which themselves have to be obtained by recursively discharging values). dischargeCekValue :: forall uni fun ann. CekValue uni fun ann -> DischargeResult uni fun dischargeCekValue (VCon val) = DischargeConstant val -dischargeCekValue value0 = DischargeNonConstant $ goValue value0 where +dischargeCekValue value0 = DischargeNonConstant $ goValue value0 + where goValue :: CekValue uni fun ann -> NTerm uni fun () goValue = \case - VCon val -> Constant () val - VDelay body env -> Delay () $ goValEnv env 0 body - VLamAbs (NamedDeBruijn n _ix) body env -> - -- The index on the binder is meaningless, we put @0@ by convention, see 'Binder'. - LamAbs () (NamedDeBruijn n deBruijnInitIndex) $ goValEnv env 1 body - -- We only return a discharged builtin application when (a) it's being returned by the - -- machine, or (b) it's needed for an error message. - -- @term@ is fully discharged, so we can return it directly without any further discharging. - VBuiltin _ term _ -> term - VConstr ind args -> Constr () ind . map goValue $ argStackToList args + VCon val -> Constant () val + VDelay body env -> Delay () $ goValEnv env 0 body + VLamAbs (NamedDeBruijn n _ix) body env -> + -- The index on the binder is meaningless, we put @0@ by convention, see 'Binder'. + LamAbs () (NamedDeBruijn n deBruijnInitIndex) $ goValEnv env 1 body + -- We only return a discharged builtin application when (a) it's being returned by the + -- machine, or (b) it's needed for an error message. + -- @term@ is fully discharged, so we can return it directly without any further discharging. + VBuiltin _ term _ -> term + VConstr ind args -> Constr () ind . map goValue $ argStackToList args -- Instantiate all the free variables of a term by looking them up in an environment. -- Mutually recursive with @goValue@. goValEnv :: CekValEnv uni fun ann -> Word64 -> NTerm uni fun ann -> NTerm uni fun () - goValEnv env = go where + goValEnv env = go + where -- @shift@ is just a counter that measures how many lambda-abstractions we have descended -- into so far. go :: Word64 -> NTerm uni fun ann -> NTerm uni fun () - go !shift = \case + go !shift = \case LamAbs _ name body -> LamAbs () name $ go (shift + 1) body Var _ named@(NamedDeBruijn _ (coerce -> idx)) -> - if shift >= idx + if shift >= idx -- the index n is less-than-or-equal than the number of lambdas we have descended -- this means that n points to a bound variable, so we don't discharge it. then Var () named - else maybe - -- var is free, leave it alone - (Var () named) - -- var is in the env, discharge its value - goValue - -- index relative to (as seen from the point of view of) the environment - (Env.indexOne env $ idx - shift) - Apply _ fun arg -> Apply () (go shift fun) $ go shift arg - Delay _ term -> Delay () $ go shift term - Force _ term -> Force () $ go shift term - Constant _ val -> Constant () val - Builtin _ fun -> Builtin () fun - Error _ -> Error () - Constr _ ind args -> Constr () ind $ map (go shift) args - Case _ scrut alts -> Case () (go shift scrut) $ fmap (go shift) alts + else + maybe + -- var is free, leave it alone + (Var () named) + -- var is in the env, discharge its value + goValue + -- index relative to (as seen from the point of view of) the environment + (Env.indexOne env $ idx - shift) + Apply _ fun arg -> Apply () (go shift fun) $ go shift arg + Delay _ term -> Delay () $ go shift term + Force _ term -> Force () $ go shift term + Constant _ val -> Constant () val + Builtin _ fun -> Builtin () fun + Error _ -> Error () + Constr _ ind args -> Constr () ind $ map (go shift) args + Case _ scrut alts -> Case () (go shift scrut) $ fmap (go shift) alts instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (CekValue uni fun ann) where - prettyBy cfg = prettyBy cfg . dischargeResultToTerm . dischargeCekValue + prettyBy cfg = prettyBy cfg . dischargeResultToTerm . dischargeCekValue type instance UniOf (CekValue uni fun ann) = uni instance HasConstant (CekValue uni fun ann) where - asConstant (VCon val) = pure val - asConstant _ = throwError notAConstant - {-# INLINE asConstant #-} - - fromConstant = VCon - {-# INLINE fromConstant #-} - -{-| -The context in which the machine operates. - -Morally, this is a stack of frames, but we use the "intrusive list" representation so that -we can match on context and the top frame in a single, strict pattern match. --} + asConstant (VCon val) = pure val + asConstant _ = throwError notAConstant + {-# INLINE asConstant #-} + + fromConstant = VCon + {-# INLINE fromConstant #-} + +-- | +-- The context in which the machine operates. +-- +-- Morally, this is a stack of frames, but we use the "intrusive list" representation so that +-- we can match on context and the top frame in a single, strict pattern match. data Context uni fun ann - = FrameAwaitArg !(CekValue uni fun ann) !(Context uni fun ann) - -- ^ @[V _]@ - | FrameAwaitFunTerm !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) - -- ^ @[_ N]@ - | FrameAwaitFunConN !(Spine (Some (ValueOf uni))) !(Context uni fun ann) - -- ^ @[_ V]@ - | FrameAwaitFunValueN !(ArgStackNonEmpty uni fun ann) !(Context uni fun ann) - -- ^ @[_ V1 .. Vn]@ - | FrameForce !(Context uni fun ann) - -- ^ @(force _)@ + = -- | @[V _]@ + FrameAwaitArg !(CekValue uni fun ann) !(Context uni fun ann) + | -- | @[_ N]@ + FrameAwaitFunTerm !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) + | -- | @[_ V]@ + FrameAwaitFunConN !(Spine (Some (ValueOf uni))) !(Context uni fun ann) + | -- | @[_ V1 .. Vn]@ + FrameAwaitFunValueN !(ArgStackNonEmpty uni fun ann) !(Context uni fun ann) + | -- | @(force _)@ -- See Note [Accumulators for terms] - | FrameConstr !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) - -- ^ @(constr i V0 ... Vj-1 _ Nj ... Nn)@ - | FrameCases !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann) - -- ^ @(case _ C0 .. Cn)@ - | NoFrame + FrameForce !(Context uni fun ann) + | -- | @(constr i V0 ... Vj-1 _ Nj ... Nn)@ + FrameConstr !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) + | -- | @(case _ C0 .. Cn)@ + FrameCases !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann) + | NoFrame -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Context uni fun ann) +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (Context uni fun ann) -- See Note [ExMemoryUsage instances for non-constants]. instance (Closed uni, uni `Everywhere` ExMemoryUsage) => ExMemoryUsage (CekValue uni fun ann) where - memoryUsage = \case - VCon c -> memoryUsage c - VDelay {} -> singletonRose 1 - VLamAbs {} -> singletonRose 1 - VBuiltin {} -> singletonRose 1 - VConstr {} -> singletonRose 1 - {-# INLINE memoryUsage #-} + memoryUsage = \case + VCon c -> memoryUsage c + VDelay {} -> singletonRose 1 + VLamAbs {} -> singletonRose 1 + VBuiltin {} -> singletonRose 1 + VConstr {} -> singletonRose 1 + {-# INLINE memoryUsage #-} {- Note [ArgStack vs Spine] We use 'ArgStack' for collecting the arguments of a constructor to later pass it to the function in @@ -734,21 +772,21 @@ But in case of 'Spine' the builtins machinery directly produces values, not term directly to the head of the application. Which is why 'transferSpine' is a right fold. -} +runCekM :: + forall cost uni fun ann. + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + (forall s. GivenCekReqs uni fun ann s => CekM uni fun s (DischargeResult uni fun)) -> + CekReport cost NamedDeBruijn uni fun runCekM - :: forall cost uni fun ann - . ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> (forall s. GivenCekReqs uni fun ann s => CekM uni fun s (DischargeResult uni fun)) - -> CekReport cost NamedDeBruijn uni fun -runCekM - (MachineParameters caser (MachineVariantParameters costs runtime)) - (ExBudgetMode getExBudgetInfo) - (EmitterMode getEmitterMode) - a = runST $ do - ExBudgetInfo{_exBudgetModeSpender, _exBudgetModeGetFinal, _exBudgetModeGetCumulative} <- getExBudgetInfo - CekEmitterInfo{_cekEmitterInfoEmit, _cekEmitterInfoGetFinal} <- getEmitterMode _exBudgetModeGetCumulative + (MachineParameters caser (MachineVariantParameters costs runtime)) + (ExBudgetMode getExBudgetInfo) + (EmitterMode getEmitterMode) + a = runST $ do + ExBudgetInfo {_exBudgetModeSpender, _exBudgetModeGetFinal, _exBudgetModeGetCumulative} <- getExBudgetInfo + CekEmitterInfo {_cekEmitterInfoEmit, _cekEmitterInfoGetFinal} <- getEmitterMode _exBudgetModeGetCumulative ctr <- newCounter (Proxy @CounterSize) let ?cekRuntime = runtime ?cekCaserBuiltin = caser @@ -757,9 +795,10 @@ runCekM ?cekCosts = costs ?cekSlippage = defaultSlippage ?cekStepCounter = ctr - res <- unCekM (tryError a) <&> \case - Left err -> CekFailure err - Right (DischargeConstant val) -> CekSuccessConstant val + res <- + unCekM (tryError a) <&> \case + Left err -> CekFailure err + Right (DischargeConstant val) -> CekSuccessConstant val Right (DischargeNonConstant term) -> CekSuccessNonConstant term st <- _exBudgetModeGetFinal logs <- _cekEmitterInfoGetFinal @@ -767,100 +806,101 @@ runCekM {-# INLINE runCekM #-} -- See Note [Compilation peculiarities]. + -- | The entering point to the CEK machine's engine. -enterComputeCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (DischargeResult uni fun) +enterComputeCek :: + forall uni fun ann s. + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + Context uni fun ann -> + CekValEnv uni fun ann -> + NTerm uni fun ann -> + CekM uni fun s (DischargeResult uni fun) enterComputeCek = computeCek where - -- | The computing part of the CEK machine. + -- \| The computing part of the CEK machine. -- Either -- 1. adds a frame to the context and calls 'computeCek' ('Force', 'Apply') -- 2. calls 'returnCek' on values ('Delay', 'LamAbs', 'Constant', 'Builtin') -- 3. throws 'EvaluationFailure' ('Error') -- 4. looks up a variable in the environment and calls 'returnCek' ('Var') - computeCek - :: Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + computeCek :: + Context uni fun ann -> + CekValEnv uni fun ann -> + NTerm uni fun ann -> + CekM uni fun s (DischargeResult uni fun) -- s ; ρ ▻ {L A} ↦ s , {_ A} ; ρ ▻ L computeCek !ctx !env (Var _ varName) = do - stepAndMaybeSpend BVar - val <- lookupVarName varName env - returnCek ctx val + stepAndMaybeSpend BVar + val <- lookupVarName varName env + returnCek ctx val -- s ; ρ ▻ con c ↦ s ◅ con c computeCek !ctx !_ (Constant _ val) = do - stepAndMaybeSpend BConst - returnCek ctx (VCon val) + stepAndMaybeSpend BConst + returnCek ctx (VCon val) -- s ; ρ ▻ lam x L ↦ s ◅ lam x (L , ρ) computeCek !ctx !env (LamAbs _ name body) = do - stepAndMaybeSpend BLamAbs - returnCek ctx (VLamAbs name body env) + stepAndMaybeSpend BLamAbs + returnCek ctx (VLamAbs name body env) -- s ; ρ ▻ delay L ↦ s ◅ delay (L , ρ) computeCek !ctx !env (Delay _ body) = do - stepAndMaybeSpend BDelay - returnCek ctx (VDelay body env) + stepAndMaybeSpend BDelay + returnCek ctx (VDelay body env) -- s ; ρ ▻ force T ↦ s , force _ ; ρ ▻ L computeCek !ctx !env (Force _ body) = do - stepAndMaybeSpend BForce - computeCek (FrameForce ctx) env body + stepAndMaybeSpend BForce + computeCek (FrameForce ctx) env body -- s ; ρ ▻ [L M] ↦ s , [_ (M,ρ)] ; ρ ▻ L computeCek !ctx !env (Apply _ fun arg) = do - stepAndMaybeSpend BApply - computeCek (FrameAwaitFunTerm env arg ctx) env fun + stepAndMaybeSpend BApply + computeCek (FrameAwaitFunTerm env arg ctx) env fun -- s ; ρ ▻ builtin bn ↦ s ◅ builtin bn arity arity [] [] ρ computeCek !ctx !_ (Builtin _ bn) = do - stepAndMaybeSpend BBuiltin - let meaning = lookupBuiltin bn ?cekRuntime - -- 'Builtin' is fully discharged. - returnCek ctx (VBuiltin bn (Builtin () bn) meaning) + stepAndMaybeSpend BBuiltin + let meaning = lookupBuiltin bn ?cekRuntime + -- 'Builtin' is fully discharged. + returnCek ctx (VBuiltin bn (Builtin () bn) meaning) -- s ; ρ ▻ constr I T0 .. Tn ↦ s , constr I _ (T1 ... Tn, ρ) ; ρ ▻ T0 computeCek !ctx !env (Constr _ i es) = do - stepAndMaybeSpend BConstr - case es of - (t : rest) -> computeCek (FrameConstr env i rest NilStack ctx) env t - [] -> returnCek ctx $ VConstr i EmptyStack + stepAndMaybeSpend BConstr + case es of + (t : rest) -> computeCek (FrameConstr env i rest NilStack ctx) env t + [] -> returnCek ctx $ VConstr i EmptyStack -- s ; ρ ▻ case S C0 ... Cn ↦ s , case _ (C0 ... Cn, ρ) ; ρ ▻ S computeCek !ctx !env (Case _ scrut cs) = do - stepAndMaybeSpend BCase - computeCek (FrameCases env cs ctx) env scrut + stepAndMaybeSpend BCase + computeCek (FrameCases env cs ctx) env scrut -- s ; ρ ▻ error ↦ <> A computeCek !_ !_ (Error _) = - throwErrorWithCause (OperationalError CekEvaluationFailure) (Error ()) - - {- | The returning phase of the CEK machine. - Returns 'EvaluationSuccess' in case the context is empty, otherwise pops up one frame - from the context and uses it to decide how to proceed with the current value v. - - * 'FrameForce': call forceEvaluate - * 'FrameApplyArg': call 'computeCek' over the context extended with 'FrameApplyFun' - * 'FrameApplyFun': call 'applyEvaluate' to attempt to apply the function - stored in the frame to an argument. - -} - returnCek - :: Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + throwErrorWithCause (OperationalError CekEvaluationFailure) (Error ()) + + -- \| The returning phase of the CEK machine. + -- Returns 'EvaluationSuccess' in case the context is empty, otherwise pops up one frame + -- from the context and uses it to decide how to proceed with the current value v. + -- + -- * 'FrameForce': call forceEvaluate + -- * 'FrameApplyArg': call 'computeCek' over the context extended with 'FrameApplyFun' + -- * 'FrameApplyFun': call 'applyEvaluate' to attempt to apply the function + -- stored in the frame to an argument. + -- + returnCek :: + Context uni fun ann -> + CekValue uni fun ann -> + CekM uni fun s (DischargeResult uni fun) --- Instantiate all the free variable of the resulting term in case there are any. -- . ◅ V ↦ [] V returnCek NoFrame val = do - spendAccumulatedBudget - pure $ dischargeCekValue val + spendAccumulatedBudget + pure $ dischargeCekValue val -- s , {_ A} ◅ abs α M ↦ s ; ρ ▻ M [ α / A ]* returnCek (FrameForce ctx) fun = forceEvaluate ctx fun -- s , [_ (M,ρ)] ◅ V ↦ s , [V _] ; ρ ▻ M returnCek (FrameAwaitFunTerm argVarEnv arg ctx) fun = - computeCek (FrameAwaitArg fun ctx) argVarEnv arg + computeCek (FrameAwaitArg fun ctx) argVarEnv arg -- s , [(lam x (M,ρ)) _] ◅ V ↦ s ; ρ [ x ↦ V ] ▻ M -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1878): -- add rule for VBuiltin once it's in the specification. returnCek (FrameAwaitArg fun ctx) arg = - applyEvaluate ctx fun arg + applyEvaluate ctx fun arg -- s , [_ V] ◅ lam x (M,ρ) ↦ s ; ρ [ x ↦ V ] ▻ M returnCek (FrameAwaitFunConN args ctx) fun = -- In the future, if we want to revert back to more general @@ -869,108 +909,109 @@ enterComputeCek = computeCek -- performance improvement as using 'FrameAwaitFunConN' while keeping more general -- 'FrameAwaitFunValue'. case args of - SpineLast arg -> applyEvaluate ctx fun (VCon arg) + SpineLast arg -> applyEvaluate ctx fun (VCon arg) SpineCons arg rest -> applyEvaluate (FrameAwaitFunConN rest ctx) fun (VCon arg) -- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M returnCek (FrameAwaitFunValueN args ctx) fun = - case args of - LastStackNonEmpty arg -> - applyEvaluate ctx fun arg - ConsStackNonEmpty arg rest -> - applyEvaluate (FrameAwaitFunValueN rest ctx) fun arg + case args of + LastStackNonEmpty arg -> + applyEvaluate ctx fun arg + ConsStackNonEmpty arg rest -> + applyEvaluate (FrameAwaitFunValueN rest ctx) fun arg -- s , constr I V0 ... Vj-1 _ (Tj+1 ... Tn, ρ) ◅ Vj ↦ s , constr i V0 ... Vj _ (Tj+2... Tn, ρ) ; ρ ▻ Tj+1 returnCek (FrameConstr env i todo done ctx) e = do - case todo of - (next : todo') -> computeCek (FrameConstr env i todo' (ConsStack e done) ctx) env next - [] -> - let go acc NilStack = acc - go acc (ConsStack x xs) = go (ConsStackNonEmpty x acc) xs - in returnCek ctx $ VConstr i (MultiStack $ go (LastStackNonEmpty e) done) + case todo of + (next : todo') -> computeCek (FrameConstr env i todo' (ConsStack e done) ctx) env next + [] -> + let go acc NilStack = acc + go acc (ConsStack x xs) = go (ConsStackNonEmpty x acc) xs + in returnCek ctx $ VConstr i (MultiStack $ go (LastStackNonEmpty e) done) -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm ↦ s , [_ V1 ... Vm] ; ρ ▻ Ci returnCek (FrameCases env cs ctx) e = case e of - -- If the index is larger than the max bound of an Int, or negative, then it's a bad index - -- As it happens, this will currently never trigger, since i is a Word64, and the largest - -- Word64 value wraps to -1 as an Int64. So you can't wrap around enough to get an - -- "apparently good" value. - (VConstr i _) | fromIntegral @_ @Integer i > fromIntegral @Int @Integer maxBound -> - throwErrorDischarged (StructuralError (MissingCaseBranchMachineError i)) e - -- Otherwise, we can safely convert the index to an Int and use it. - (VConstr i args) -> case (V.!?) cs (fromIntegral i) of - Just t -> case args of - EmptyStack -> computeCek ctx env t - MultiStack rest -> computeCek (FrameAwaitFunValueN rest ctx) env t - Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e - -- Proceed with caser when expression given is not Constr. - VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of - Left err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e - Right (HeadOnly fX) -> computeCek ctx env fX - Right (HeadSpine f xs) -> computeCek (FrameAwaitFunConN xs ctx) env f - _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e - - -- | @force@ a term and proceed. + -- If the index is larger than the max bound of an Int, or negative, then it's a bad index + -- As it happens, this will currently never trigger, since i is a Word64, and the largest + -- Word64 value wraps to -1 as an Int64. So you can't wrap around enough to get an + -- "apparently good" value. + (VConstr i _) + | fromIntegral @_ @Integer i > fromIntegral @Int @Integer maxBound -> + throwErrorDischarged (StructuralError (MissingCaseBranchMachineError i)) e + -- Otherwise, we can safely convert the index to an Int and use it. + (VConstr i args) -> case (V.!?) cs (fromIntegral i) of + Just t -> case args of + EmptyStack -> computeCek ctx env t + MultiStack rest -> computeCek (FrameAwaitFunValueN rest ctx) env t + Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e + -- Proceed with caser when expression given is not Constr. + VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of + Left err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e + Right (HeadOnly fX) -> computeCek ctx env fX + Right (HeadSpine f xs) -> computeCek (FrameAwaitFunConN xs ctx) env f + _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e + + -- \| @force@ a term and proceed. -- If v is a delay then compute the body of v; -- if v is a builtin application then check that it's expecting a type argument, -- and either calculate the builtin application or stick a 'Force' on top of its 'Term' -- representation depending on whether the application is saturated or not, -- if v is anything else, fail. - forceEvaluate - :: Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + forceEvaluate :: + Context uni fun ann -> + CekValue uni fun ann -> + CekM uni fun s (DischargeResult uni fun) forceEvaluate !ctx (VDelay body env) = computeCek ctx env body forceEvaluate !ctx (VBuiltin fun term runtime) = do - -- @term@ is fully discharged, and so @term'@ is, hence we can put it in a 'VBuiltin'. - let term' = Force () term - case runtime of - -- It's only possible to force a builtin application if the builtin expects a type - -- argument next. - BuiltinExpectForce runtime' -> - -- We allow a type argument to appear last in the type of a built-in function, - -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the - -- application. - evalBuiltinApp ctx fun term' runtime' - _ -> - throwErrorWithCause (StructuralError BuiltinTermArgumentExpectedMachineError) term' + -- @term@ is fully discharged, and so @term'@ is, hence we can put it in a 'VBuiltin'. + let term' = Force () term + case runtime of + -- It's only possible to force a builtin application if the builtin expects a type + -- argument next. + BuiltinExpectForce runtime' -> + -- We allow a type argument to appear last in the type of a built-in function, + -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the + -- application. + evalBuiltinApp ctx fun term' runtime' + _ -> + throwErrorWithCause (StructuralError BuiltinTermArgumentExpectedMachineError) term' forceEvaluate !_ val = - throwErrorDischarged (StructuralError NonPolymorphicInstantiationMachineError) val + throwErrorDischarged (StructuralError NonPolymorphicInstantiationMachineError) val - -- | Apply a function to an argument and proceed. + -- \| Apply a function to an argument and proceed. -- If the function is a lambda 'lam x ty body' then extend the environment with a binding of @v@ -- to x@ and call 'computeCek' on the body. -- If the function is a builtin application then check that it's expecting a term argument, -- and either calculate the builtin application or stick a 'Apply' on top of its 'Term' -- representation depending on whether the application is saturated or not. -- If v is anything else, fail. - applyEvaluate - :: Context uni fun ann - -> CekValue uni fun ann -- lhs of application - -> CekValue uni fun ann -- rhs of application - -> CekM uni fun s (DischargeResult uni fun) + applyEvaluate :: + Context uni fun ann -> + CekValue uni fun ann -> -- lhs of application + CekValue uni fun ann -> -- rhs of application + CekM uni fun s (DischargeResult uni fun) applyEvaluate !ctx (VLamAbs _ body env) arg = - computeCek ctx (Env.cons arg env) body + computeCek ctx (Env.cons arg env) body -- Annotating @f@ and @exF@ with bangs gave us some speed-up, but only until we added a bang to -- 'VCon'. After that the bangs here were making things a tiny bit slower and so we removed them. applyEvaluate !ctx (VBuiltin fun funTerm runtime) arg = do - let argTerm = dischargeResultToTerm $ dischargeCekValue arg - -- @term@ and @argTerm@ are fully discharged, and so @term'@ is, hence we can put it - -- in a 'VBuiltin'. - term' = Apply () funTerm argTerm - case runtime of - -- It's only possible to apply a builtin application if the builtin expects a term - -- argument next. - BuiltinExpectArgument f -> - evalBuiltinApp ctx fun term' $ f arg - _ -> - throwErrorWithCause (StructuralError UnexpectedBuiltinTermArgumentMachineError) term' + let argTerm = dischargeResultToTerm $ dischargeCekValue arg + -- @term@ and @argTerm@ are fully discharged, and so @term'@ is, hence we can put it + -- in a 'VBuiltin'. + term' = Apply () funTerm argTerm + case runtime of + -- It's only possible to apply a builtin application if the builtin expects a term + -- argument next. + BuiltinExpectArgument f -> + evalBuiltinApp ctx fun term' $ f arg + _ -> + throwErrorWithCause (StructuralError UnexpectedBuiltinTermArgumentMachineError) term' applyEvaluate !_ val _ = - throwErrorDischarged (StructuralError NonFunctionalApplicationMachineError) val + throwErrorDischarged (StructuralError NonFunctionalApplicationMachineError) val - -- | Spend the budget that has been accumulated for a number of machine steps. + -- \| Spend the budget that has been accumulated for a number of machine steps. spendAccumulatedBudget :: CekM uni fun s () spendAccumulatedBudget = do - let ctr = ?cekStepCounter - iforCounter_ ctr spend - resetCounter ctr + let ctr = ?cekStepCounter + iforCounter_ ctr spend + resetCounter ctr -- It's very important for this definition not to get inlined. Inlining it caused performance to -- degrade by 16+%: https://github.com/IntersectMBO/plutus/pull/5931 {-# OPAQUE spendAccumulatedBudget #-} @@ -979,85 +1020,87 @@ enterComputeCek = computeCek -- some reason. -- Skip index 7, that's the total counter! -- See Note [Structure of the step counter] - spend !i !w = unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ - let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) + spend !i !w = + unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ + let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) {-# INLINE spend #-} - -- | Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. + -- \| Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. stepAndMaybeSpend :: StepKind -> CekM uni fun s () stepAndMaybeSpend !kind = do - -- See Note [Structure of the step counter] - -- This generates let-expressions in GHC Core, however all of them bind unboxed things and - -- so they don't survive further compilation, see https://stackoverflow.com/a/14090277 - let !counterIndex = fromEnum kind - ctr = ?cekStepCounter - !totalStepIndex = fromIntegral $ natVal (Proxy @TotalCountIndex) - !unbudgetedStepsTotal <- modifyCounter totalStepIndex (+1) ctr - _ <- modifyCounter counterIndex (+1) ctr - -- There's no risk of overflow here, since we only ever increment the total - -- steps by 1 and then check this condition. - when (unbudgetedStepsTotal >= ?cekSlippage) spendAccumulatedBudget + -- See Note [Structure of the step counter] + -- This generates let-expressions in GHC Core, however all of them bind unboxed things and + -- so they don't survive further compilation, see https://stackoverflow.com/a/14090277 + let !counterIndex = fromEnum kind + ctr = ?cekStepCounter + !totalStepIndex = fromIntegral $ natVal (Proxy @TotalCountIndex) + !unbudgetedStepsTotal <- modifyCounter totalStepIndex (+ 1) ctr + _ <- modifyCounter counterIndex (+ 1) ctr + -- There's no risk of overflow here, since we only ever increment the total + -- steps by 1 and then check this condition. + when (unbudgetedStepsTotal >= ?cekSlippage) spendAccumulatedBudget {-# INLINE stepAndMaybeSpend #-} - -- | Take a possibly partial builtin application and + -- \| Take a possibly partial builtin application and -- -- - either create a 'CekValue' by evaluating the application if it's saturated (emitting logs, -- if any, along the way), potentially failing evaluation -- - or create a partial builtin application otherwise -- -- and proceed with the returning phase of the CEK machine. - evalBuiltinApp - :: Context uni fun ann - -> fun - -> NTerm uni fun () - -> BuiltinRuntime (CekValue uni fun ann) - -> CekM uni fun s (DischargeResult uni fun) + evalBuiltinApp :: + Context uni fun ann -> + fun -> + NTerm uni fun () -> + BuiltinRuntime (CekValue uni fun ann) -> + CekM uni fun s (DischargeResult uni fun) evalBuiltinApp ctx fun term runtime = case runtime of - BuiltinCostedResult budgets0 getFXs -> do - let exCat = BBuiltinApp fun - spendBudgets (ExBudgetLast budget) = spendBudget exCat budget - spendBudgets (ExBudgetCons budget budgets) = - spendBudget exCat budget *> spendBudgets budgets - spendBudgets budgets0 - case getFXs of - BuiltinSuccess y -> - returnCek ctx y - BuiltinSuccessWithLogs logs y -> do - ?cekEmitter logs - returnCek ctx y - BuiltinFailure logs err -> do - ?cekEmitter logs - throwBuiltinErrorWithCause term err - _ -> returnCek ctx $ VBuiltin fun term runtime + BuiltinCostedResult budgets0 getFXs -> do + let exCat = BBuiltinApp fun + spendBudgets (ExBudgetLast budget) = spendBudget exCat budget + spendBudgets (ExBudgetCons budget budgets) = + spendBudget exCat budget *> spendBudgets budgets + spendBudgets budgets0 + case getFXs of + BuiltinSuccess y -> + returnCek ctx y + BuiltinSuccessWithLogs logs y -> do + ?cekEmitter logs + returnCek ctx y + BuiltinFailure logs err -> do + ?cekEmitter logs + throwBuiltinErrorWithCause term err + _ -> returnCek ctx $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} spendBudget :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () spendBudget = unCekBudgetSpender ?cekBudgetSpender {-# INLINE spendBudget #-} - -- | Look up a variable name in the environment. + -- \| Look up a variable name in the environment. lookupVarName :: NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = - Env.contIndexOne - (throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) $ Var () varName) - pure - varEnv - (coerce varIx) + Env.contIndexOne + (throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) $ Var () varName) + pure + varEnv + (coerce varIx) {-# INLINE lookupVarName #-} -- See Note [Compilation peculiarities]. + -- | Evaluate a term using the CEK machine and keep track of costing, logging is optional. -runCekDeBruijn - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> NTerm uni fun ann - -> CekReport cost NamedDeBruijn uni fun +runCekDeBruijn :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + NTerm uni fun ann -> + CekReport cost NamedDeBruijn uni fun runCekDeBruijn params mode emitMode term = - runCekM params mode emitMode $ do - unCekBudgetSpender ?cekBudgetSpender BStartup $ runIdentity $ cekStartupCost ?cekCosts - enterComputeCek NoFrame Env.empty term + runCekM params mode emitMode $ do + unCekBudgetSpender ?cekBudgetSpender BStartup $ runIdentity $ cekStartupCost ?cekCosts + enterComputeCek NoFrame Env.empty term {- Note [Accumulators for terms] At a couple of points in the CEK machine (notably building the arguments to a constructor value) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/StepCounter.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/StepCounter.hs index 10fa8460fe4..61fb120858f 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/StepCounter.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/StepCounter.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter where import Control.Monad.Primitive @@ -22,6 +23,7 @@ import GHC.TypeNats (KnownNat, Nat, natVal, type (-)) -- See Note [Step counter data structure] -- You might think that since we can store whatever we like in here we might as well -- use machine words (i.e. 'Word64'), but that is actually slower. + -- | A set of 'Word8' counters that is used in the CEK machine -- to count steps. newtype StepCounter (n :: Nat) s = StepCounter (P.MutablePrimArray s Word8) @@ -36,43 +38,43 @@ newCounter p = do {-# INLINE newCounter #-} -- | Reset all the counters in the given 'StepCounter' to zero. -resetCounter :: forall n m . (KnownNat n, PrimMonad m) => StepCounter n (PrimState m) -> m () +resetCounter :: forall n m. (KnownNat n, PrimMonad m) => StepCounter n (PrimState m) -> m () resetCounter (StepCounter arr) = let sz = fromIntegral $ natVal (Proxy @n) - in P.setPrimArray arr 0 sz 0 + in P.setPrimArray arr 0 sz 0 {-# INLINE resetCounter #-} -- | Read the value of a counter. -readCounter :: forall m n . PrimMonad m => StepCounter n (PrimState m) -> Int -> m Word8 +readCounter :: forall m n. PrimMonad m => StepCounter n (PrimState m) -> Int -> m Word8 readCounter = coerce - @(P.MutablePrimArray (PrimState m) Word8 -> Int -> m Word8) - @(StepCounter n (PrimState m) -> Int -> m Word8) - P.readPrimArray + @(P.MutablePrimArray (PrimState m) Word8 -> Int -> m Word8) + @(StepCounter n (PrimState m) -> Int -> m Word8) + P.readPrimArray {-# INLINE readCounter #-} -- | Write to a counter. -writeCounter - :: forall m n - . PrimMonad m - => StepCounter n (PrimState m) - -> Int - -> Word8 - -> m () +writeCounter :: + forall m n. + PrimMonad m => + StepCounter n (PrimState m) -> + Int -> + Word8 -> + m () writeCounter = coerce - @(P.MutablePrimArray (PrimState m) Word8 -> Int -> Word8 -> m ()) - @(StepCounter n (PrimState m) -> Int -> Word8 -> m ()) - P.writePrimArray + @(P.MutablePrimArray (PrimState m) Word8 -> Int -> Word8 -> m ()) + @(StepCounter n (PrimState m) -> Int -> Word8 -> m ()) + P.writePrimArray {-# INLINE writeCounter #-} -- | Modify the value of a counter. Returns the modified value. -modifyCounter - :: PrimMonad m - => Int - -> (Word8 -> Word8) - -> StepCounter n (PrimState m) - -> m Word8 +modifyCounter :: + PrimMonad m => + Int -> + (Word8 -> Word8) -> + StepCounter n (PrimState m) -> + m Word8 modifyCounter i f c = do v <- readCounter c i let modified = f v @@ -87,8 +89,8 @@ data Peano type NatToPeano :: Nat -> Peano type family NatToPeano n where - NatToPeano 0 = 'Z - NatToPeano n = 'S (NatToPeano (n - 1)) + NatToPeano 0 = 'Z + NatToPeano n = 'S (NatToPeano (n - 1)) type UpwardsM :: (Type -> Type) -> Peano -> Constraint class Applicative f => UpwardsM f n where @@ -106,12 +108,12 @@ instance UpwardsM f n => UpwardsM f ('S n) where {-# INLINE upwardsM #-} -- | Traverse the counters with an effectful function. -itraverseCounter_ - :: forall n m - . (UpwardsM m (NatToPeano n), PrimMonad m) - => (Int -> Word8 -> m ()) - -> StepCounter n (PrimState m) - -> m () +itraverseCounter_ :: + forall n m. + (UpwardsM m (NatToPeano n), PrimMonad m) => + (Int -> Word8 -> m ()) -> + StepCounter n (PrimState m) -> + m () itraverseCounter_ f (StepCounter arr) = do -- The safety of this operation is a little subtle. The frozen array is only -- safe to use if the underlying mutable array is not mutated 'afterwards'. @@ -124,11 +126,11 @@ itraverseCounter_ f (StepCounter arr) = do {-# INLINE itraverseCounter_ #-} -- | Traverse the counters with an effectful function. -iforCounter_ - :: (UpwardsM m (NatToPeano n), PrimMonad m) - => StepCounter n (PrimState m) - -> (Int -> Word8 -> m ()) - -> m () +iforCounter_ :: + (UpwardsM m (NatToPeano n), PrimMonad m) => + StepCounter n (PrimState m) -> + (Int -> Word8 -> m ()) -> + m () iforCounter_ = flip itraverseCounter_ {-# INLINE iforCounter_ #-} diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs index 057bf7c9ccf..0915616b920 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs @@ -1,54 +1,57 @@ -- editorconfig-checker-disable-file +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + -- | The API parameterized over some machine. +module UntypedPlutusCore.Evaluation.Machine.CommonAPI ( + -- * Running the machine + runCek, + runCekDeBruijn, + runCekNoEmit, + evaluateCek, + evaluateCekNoEmit, + EvaluationResult (..), + splitStructuralOperational, + unsafeSplitStructuralOperational, -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module UntypedPlutusCore.Evaluation.Machine.CommonAPI - ( - -- * Running the machine - runCek - , runCekDeBruijn - , runCekNoEmit - , evaluateCek - , evaluateCekNoEmit - , EvaluationResult(..) - , splitStructuralOperational - , unsafeSplitStructuralOperational - -- * Errors - , CekUserError(..) - , ErrorWithCause(..) - , CekEvaluationException - , EvaluationError(..) - -- * Costing - , ExBudgetCategory(..) - , CekBudgetSpender(..) - , ExBudgetMode(..) - , StepKind(..) - , CekExTally(..) - , CountingSt (..) - , TallyingSt (..) - , RestrictingSt (..) - , CekMachineCosts - -- ** Costing modes - , counting - , tallying - , restricting - , restrictingEnormous - , enormousBudget - -- * Emitter modes - , noEmitter - , logEmitter - , logWithTimeEmitter - , logWithBudgetEmitter - , logWithCallTraceEmitter - -- * Misc - , CekValue(..) - , readKnownCek - , Hashable - , ThrowableBuiltins - ) + -- * Errors + CekUserError (..), + ErrorWithCause (..), + CekEvaluationException, + EvaluationError (..), + + -- * Costing + ExBudgetCategory (..), + CekBudgetSpender (..), + ExBudgetMode (..), + StepKind (..), + CekExTally (..), + CountingSt (..), + TallyingSt (..), + RestrictingSt (..), + CekMachineCosts, + + -- ** Costing modes + counting, + tallying, + restricting, + restrictingEnormous, + enormousBudget, + + -- * Emitter modes + noEmitter, + logEmitter, + logWithTimeEmitter, + logWithBudgetEmitter, + logWithCallTraceEmitter, + + -- * Misc + CekValue (..), + readKnownCek, + Hashable, + ThrowableBuiltins, +) where import PlutusPrelude @@ -71,11 +74,11 @@ import Data.Text (Text) -- The type of the machine (runner function). type MachineRunner cost uni fun ann = - MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> NTerm uni fun ann - -> CekReport cost NamedDeBruijn uni fun + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + NTerm uni fun ann -> + CekReport cost NamedDeBruijn uni fun {- Note [CEK runners naming convention] A function whose name ends in @NoEmit@ does not perform logging and so does not return any logs. @@ -88,80 +91,80 @@ allow one to specify an 'ExBudgetMode'. I.e. such functions are only for fully e (and possibly returning logs). See also haddocks of 'enormousBudget'. -} -{-| Evaluate a term using a machine with logging enabled and keep track of costing. -A wrapper around the internal runCek to debruijn input and undebruijn output. -*THIS FUNCTION IS PARTIAL if the input term contains free variables* --} +-- | Evaluate a term using a machine with logging enabled and keep track of costing. +-- A wrapper around the internal runCek to debruijn input and undebruijn output. +-- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCek :: - MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> Term Name uni fun ann - -> CekReport cost Name uni fun + MachineRunner cost uni fun ann -> + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + Term Name uni fun ann -> + CekReport cost Name uni fun runCek runner params mode emitMode term = - -- translating input - case runExcept @FreeVariableError $ deBruijnTerm term of - Left fvError -> throw fvError - Right dbt -> do - -- Don't use 'let': https://github.com/IntersectMBO/plutus/issues/3876 - case runner params mode emitMode dbt of - -- translating back the output - CekReport res cost' logs -> - CekReport (mapTermCekResult gracefulUnDeBruijn res) cost' logs + -- translating input + case runExcept @FreeVariableError $ deBruijnTerm term of + Left fvError -> throw fvError + Right dbt -> do + -- Don't use 'let': https://github.com/IntersectMBO/plutus/issues/3876 + case runner params mode emitMode dbt of + -- translating back the output + CekReport res cost' logs -> + CekReport (mapTermCekResult gracefulUnDeBruijn res) cost' logs where - -- *GRACEFULLY* undebruijnifies: a) the error-cause-term (if it exists) or b) the success - -- *value-term. + -- \*GRACEFULLY* undebruijnifies: a) the error-cause-term (if it exists) or b) the success + -- \*value-term. -- 'Graceful' means that the (a) && (b) undebruijnifications do not throw an error upon a free -- variable encounter: free debruijn indices will be turned to free, consistent uniques gracefulUnDeBruijn :: Term NamedDeBruijn uni fun () -> Term Name uni fun () - gracefulUnDeBruijn t = runQuote - . flip evalStateT mempty - $ unDeBruijnTermWith freeIndexAsConsistentLevel t + gracefulUnDeBruijn t = + runQuote + . flip evalStateT mempty + $ unDeBruijnTermWith freeIndexAsConsistentLevel t -- | Evaluate a term using a machine with logging disabled and keep track of costing. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit :: - MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) -runCekNoEmit runner params mode - = -- throw away the logs - (\(CekReport res cost _logs) -> (cekResultToEither res, cost)) + MachineRunner cost uni fun ann -> + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + Term Name uni fun ann -> + (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) +runCekNoEmit runner params mode = + -- throw away the logs + (\(CekReport res cost _logs) -> (cekResultToEither res, cost)) . runCek runner params mode noEmitter -- | Evaluate a term using a machine with logging enabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -evaluateCek - :: ThrowableBuiltins uni fun - => MachineRunner RestrictingSt uni fun ann - -> EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) -evaluateCek runner emitMode params - = -- throw away the cost - (\(CekReport res _cost logs) -> (cekResultToEither res, logs)) +evaluateCek :: + ThrowableBuiltins uni fun => + MachineRunner RestrictingSt uni fun ann -> + EmitterMode uni fun -> + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) +evaluateCek runner emitMode params = + -- throw away the cost + (\(CekReport res _cost logs) -> (cekResultToEither res, logs)) . runCek runner params restrictingEnormous emitMode -- | Evaluate a term using a machine with logging disabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -evaluateCekNoEmit - :: ThrowableBuiltins uni fun - => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) +evaluateCekNoEmit :: + ThrowableBuiltins uni fun => + MachineRunner RestrictingSt uni fun ann -> + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit runner params = fst . runCekNoEmit runner params restrictingEnormous -- | Unlift a value using a machine. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -readKnownCek - :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) a +readKnownCek :: + (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) => + MachineRunner RestrictingSt uni fun ann -> + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + Either (CekEvaluationException Name uni fun) a readKnownCek runner params = evaluateCekNoEmit runner params >=> readKnownSelf diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs index 0cfeb29f3b9..11149c58509 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs @@ -1,50 +1,54 @@ --- | The API to the Steppable CEK machine. Provides the same interface to original CEK machine. {-# LANGUAGE TypeOperators #-} -module UntypedPlutusCore.Evaluation.Machine.SteppableCek - ( - -- * Running the machine - runCek - , runCekDeBruijn - , runCekNoEmit - , evaluateCek - , evaluateCekNoEmit - , EvaluationResult(..) - , splitStructuralOperational - , unsafeSplitStructuralOperational - -- * Errors - , CekUserError(..) - , ErrorWithCause(..) - , CekEvaluationException - , EvaluationError(..) - -- * Costing - , ExBudgetCategory(..) - , CekBudgetSpender(..) - , ExBudgetMode(..) - , StepKind(..) - , CekExTally(..) - , CountingSt (..) - , TallyingSt (..) - , RestrictingSt (..) - , CekMachineCosts - -- ** Costing modes - , counting - , tallying - , restricting - , restrictingEnormous - , enormousBudget - -- * Emitter modes - , noEmitter - , logEmitter - , logWithTimeEmitter - , logWithBudgetEmitter - , logWithCallTraceEmitter - -- * Misc - , CekValue(..) - , readKnownCek - , Hashable - , ThrowableBuiltins - ) +-- | The API to the Steppable CEK machine. Provides the same interface to original CEK machine. +module UntypedPlutusCore.Evaluation.Machine.SteppableCek ( + -- * Running the machine + runCek, + runCekDeBruijn, + runCekNoEmit, + evaluateCek, + evaluateCekNoEmit, + EvaluationResult (..), + splitStructuralOperational, + unsafeSplitStructuralOperational, + + -- * Errors + CekUserError (..), + ErrorWithCause (..), + CekEvaluationException, + EvaluationError (..), + + -- * Costing + ExBudgetCategory (..), + CekBudgetSpender (..), + ExBudgetMode (..), + StepKind (..), + CekExTally (..), + CountingSt (..), + TallyingSt (..), + RestrictingSt (..), + CekMachineCosts, + + -- ** Costing modes + counting, + tallying, + restricting, + restrictingEnormous, + enormousBudget, + + -- * Emitter modes + noEmitter, + logEmitter, + logWithTimeEmitter, + logWithBudgetEmitter, + logWithCallTraceEmitter, + + -- * Misc + CekValue (..), + readKnownCek, + Hashable, + ThrowableBuiltins, +) where import UntypedPlutusCore.Core @@ -60,54 +64,53 @@ import PlutusCore.Name.Unique import Data.Text (Text) -{-| Evaluate a term using the Steppable CEK machine with logging enabled and keep track of costing. -A wrapper around the internal runCek to debruijn input and undebruijn output. -*THIS FUNCTION IS PARTIAL if the input term contains free variables* --} -runCek - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> Term Name uni fun ann - -> CekReport cost Name uni fun +-- | Evaluate a term using the Steppable CEK machine with logging enabled and keep track of costing. +-- A wrapper around the internal runCek to debruijn input and undebruijn output. +-- *THIS FUNCTION IS PARTIAL if the input term contains free variables* +runCek :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + Term Name uni fun ann -> + CekReport cost Name uni fun runCek = Common.runCek S.runCekDeBruijn -- | Evaluate a term using the Steppable CEK machine with logging disabled and -- keep track of costing. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -runCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) +runCekNoEmit :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + Term Name uni fun ann -> + (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) runCekNoEmit = Common.runCekNoEmit S.runCekDeBruijn -- | Evaluate a term using the Steppable CEK machine with logging enabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -evaluateCek - :: ThrowableBuiltins uni fun - => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) +evaluateCek :: + ThrowableBuiltins uni fun => + EmitterMode uni fun -> + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek = Common.evaluateCek S.runCekDeBruijn -- | Evaluate a term using the Steppable CEK machine with logging disabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -evaluateCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) +evaluateCekNoEmit :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit = Common.evaluateCekNoEmit S.runCekDeBruijn -- | Unlift a value using the Steppable CEK machine. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* -readKnownCek - :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) a +readKnownCek :: + (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + Term Name uni fun ann -> + Either (CekEvaluationException Name uni fun) a readKnownCek = Common.readKnownCek S.runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs index 80f626d404a..7bf486baac8 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs @@ -1,25 +1,26 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -module UntypedPlutusCore.Evaluation.Machine.SteppableCek.DebugDriver - ( Breakpointable (..) - , CekState - , Cmd (..) - , runDriverT - , DebugF (..) - -- | Reexport some functions for convenience - , mkCekTrans - , CekTrans - , F.MonadFree - , F.iterM - , F.iterTM - , F.partialIterT - , F.cutoff - , FreeT - ) where +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module UntypedPlutusCore.Evaluation.Machine.SteppableCek.DebugDriver ( + Breakpointable (..), + CekState, + Cmd (..), + runDriverT, + DebugF (..), + -- | Reexport some functions for convenience + mkCekTrans, + CekTrans, + F.MonadFree, + F.iterM, + F.iterTM, + F.partialIterT, + F.cutoff, + FreeT, +) where import UntypedPlutusCore.Evaluation.Machine.SteppableCek.Internal @@ -51,55 +52,62 @@ The sensible interpretation to this is the CEK's state transition function (`cek (brick,repl,testing) just call`cekTrans`. -} - -- | Leave abstract the types of annotation and breakpoints. -- The only thing the driver requires is an inclusion relation of breakpoints into the Annotation class Breakpointable ann bps | ann -> bps where - -- MAYBE: we cannot know which breakpoint fired, return instead `Maybe Breakpoint`? - hasBreakpoints :: ann -> bps -> Bool + -- MAYBE: we cannot know which breakpoint fired, return instead `Maybe Breakpoint`? + hasBreakpoints :: ann -> bps -> Bool -- | The commands that the driver may receive from the client (tui,cli,test,etc) data Cmd bps - = Step -- ^ Instruct the driver to a *SINGLE* step. - -- Note: No need to pass breakpoints here because the stepping granularity is *minimal*. - | Continue bps -- ^ Instruct to multi-step until end-of-program or until breakpoint reached - | Next bps -- ^ Instruct to multi-step over the function call at point or until breakpoint reached - | Finish bps -- ^ Instruct to multi-step to end of current function or until breakpoint reached + = -- | Instruct the driver to a *SINGLE* step. + -- Note: No need to pass breakpoints here because the stepping granularity is *minimal*. + Step + | -- | Instruct to multi-step until end-of-program or until breakpoint reached + Continue bps + | -- | Instruct to multi-step over the function call at point or until breakpoint reached + Next bps + | -- | Instruct to multi-step to end of current function or until breakpoint reached + Finish bps deriving stock (Show, Read) -- | The drivers's suspension functor data DebugF uni fun ann bps a - -- | Await for the client (e.g. TUI) to tell what to do next (Cmd). - = InputF (Cmd bps -> a) - -- | The debug driver wants to log something - | DriverLogF Text a - -- | An enumeratee of Driver State (generator+iteratee): + = -- | Await for the client (e.g. TUI) to tell what to do next (Cmd). + InputF (Cmd bps -> a) + | -- | The debug driver wants to log something + DriverLogF Text a + | -- | An enumeratee of Driver State (generator+iteratee): -- Yield a state before doing a step, then await for a state to resume after the step. -- See Note [Stepping the driver]. - | StepF - (CekState uni fun ann) -- ^ yield with the current driver's state before running a step - (CekState uni fun ann -> a) -- ^ resume back with a state after the step interpretation - -- | A generator of CekState to yield to client (e.g. TUI) + StepF + -- | yield with the current driver's state before running a step + (CekState uni fun ann) + -- | resume back with a state after the step interpretation + -- | A generator of CekState to yield to client (e.g. TUI) + (CekState uni fun ann -> a) | UpdateClientF (CekState uni fun ann) a - deriving stock Functor + deriving stock (Functor) -- | The monad that the driver operates in type Driving m uni fun ann bps = - ( MonadReader (CekState uni fun ann) m -- the state of the debugger - , MonadFree (DebugF uni fun ann bps) m -- the effects of the driver - , Breakpointable ann bps - ) + ( MonadReader (CekState uni fun ann) m -- the state of the debugger + , MonadFree (DebugF uni fun ann bps) m -- the effects of the driver + , Breakpointable ann bps + ) -- | Entrypoint of the driver -runDriverT :: forall uni fun ann bps m. - (Breakpointable ann bps, MonadFree (DebugF uni fun ann bps) m) - => NTerm uni fun ann -> m () +runDriverT :: + forall uni fun ann bps m. + (Breakpointable ann bps, MonadFree (DebugF uni fun ann bps) m) => + NTerm uni fun ann -> m () runDriverT = void . runReaderT driver . initState - where - initState :: NTerm uni fun ann -> CekState uni fun ann - initState = Starting + where + initState :: NTerm uni fun ann -> CekState uni fun ann + initState = Starting -- | The driver action. The driver repeatedly: + --- -- 1) waits for a `Cmd` -- 2) runs one or more CEK steps @@ -107,56 +115,62 @@ runDriverT = void . runReaderT driver . initState --- -- The driver computation exits when it reaches a CEK `Terminating` state. driver :: Driving m uni fun ann bps => m () -driver = inputF >>= \case +driver = + inputF >>= \case -- Condition immediately satisfied Step -> multiStepUntil $ const True - Continue bs -> multiStepUntil $ maybe False (`hasBreakpoints` bs) . cekStateAnn - Next bs -> do - startState <- ask - multiStepUntil $ \curState -> - maybe False (`hasBreakpoints` bs) (cekStateAnn curState) || - -- has activation record length been restored? - let leCtx = onCtxLen (<) - in curState `leCtx` startState - + startState <- ask + multiStepUntil $ \curState -> + maybe False (`hasBreakpoints` bs) (cekStateAnn curState) + || + -- has activation record length been restored? + let leCtx = onCtxLen (<) + in curState `leCtx` startState Finish bs -> do - startState <- ask - multiStepUntil $ \curState -> - maybe False (`hasBreakpoints` bs) (cekStateAnn curState) || - -- has activation record length become smaller? - let ltCtx = onCtxLen (<=) - in curState `ltCtx` startState + startState <- ask + multiStepUntil $ \curState -> + maybe False (`hasBreakpoints` bs) (cekStateAnn curState) + || + -- has activation record length become smaller? + let ltCtx = onCtxLen (<=) + in curState `ltCtx` startState where - -- | Comparison on states' contexts - onCtxLen :: (state ~ CekState uni fun ann - , ctxLen ~ Maybe Word -- `Maybe` because ctx can be missing if terminating - ) - => (ctxLen -> ctxLen -> a) - -> state -> state -> a + -- \| Comparison on states' contexts + onCtxLen :: + ( state ~ CekState uni fun ann + , ctxLen ~ Maybe Word -- `Maybe` because ctx can be missing if terminating + ) => + (ctxLen -> ctxLen -> a) -> + state -> + state -> + a onCtxLen = (`on` preview (cekStateContext . to lenContext)) -- | Do one or more cek steps until Terminating state is reached or condition on 'CekState' is met. -multiStepUntil :: Driving m uni fun ann bp - => (CekState uni fun ann -> Bool) -> m () +multiStepUntil :: + Driving m uni fun ann bp => + (CekState uni fun ann -> Bool) -> m () multiStepUntil cond = do - driverLogF "Driver is going to do a single step" - newState <- stepF =<< ask - case newState of - Terminating{} -> - -- don't recurse to driver, but EXIT the driver + driverLogF "Driver is going to do a single step" + newState <- stepF =<< ask + case newState of + Terminating {} -> + -- don't recurse to driver, but EXIT the driver + updateClientF newState + _ -> + -- update state + local (const newState) $ + if cond newState + then do updateClientF newState - _ -> -- update state - local (const newState) $ - if cond newState - then do - updateClientF newState - driver -- tail recurse - else - multiStepUntil cond -- tail recurse + driver -- tail recurse + else + multiStepUntil cond -- tail recurse -- * boilerplate "suspension actions" + -- Being in 'Driving' monad here is too constraining, but it does not matter. inputF :: Driving m uni fun ann bps => m (Cmd bps) inputF = liftF $ InputF id diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 96789a7b012..d57d35fadfe 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -1,42 +1,42 @@ -- editorconfig-checker-disable-file +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NPlusKPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + -- | The CEK machine. -- The CEK machine relies on variables having non-equal 'Unique's whenever they have non-equal -- string names. I.e. 'Unique's are used instead of string names. This is for efficiency reasons. -- The CEK machines handles name capture by design. -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NPlusKPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module UntypedPlutusCore.Evaluation.Machine.SteppableCek.Internal - ( CekState (..) - , Context (..) - , contextAnn - , liftCek - , PrimMonad (..) - , lenContext - , cekStateContext - , cekStateAnn - , runCekDeBruijn - , computeCek - , returnCek - , mkCekTrans - , CekTrans - , nilSlippage - , module UntypedPlutusCore.Evaluation.Machine.Cek.Internal - ) +module UntypedPlutusCore.Evaluation.Machine.SteppableCek.Internal ( + CekState (..), + Context (..), + contextAnn, + liftCek, + PrimMonad (..), + lenContext, + cekStateContext, + cekStateAnn, + runCekDeBruijn, + computeCek, + returnCek, + mkCekTrans, + CekTrans, + nilSlippage, + module UntypedPlutusCore.Evaluation.Machine.Cek.Internal, +) where import PlutusCore.Builtin @@ -48,8 +48,10 @@ import PlutusCore.Evaluation.Machine.MachineParameters import PlutusCore.Evaluation.Result import PlutusPrelude import UntypedPlutusCore.Core -import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts, - CekMachineCostsBase (..)) +import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts ( + CekMachineCosts, + CekMachineCostsBase (..), + ) import UntypedPlutusCore.Evaluation.Machine.Cek.Internal hiding (Context (..), runCekDeBruijn) import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter @@ -75,150 +77,155 @@ return with the CEK's machine new state (`CekState`), whereas previously these t The interface otherwise remains the same. Moreover, the `Original.runCekDeBruijn` and `Debug.runCekDeBruijn` must behave equivalently. -} -data CekState uni fun ann = - -- loaded a term but not fired the cek yet +data CekState uni fun ann + = -- loaded a term but not fired the cek yet Starting (NTerm uni fun ann) - -- the next state is computing - | Computing (Context uni fun ann) (CekValEnv uni fun ann) (NTerm uni fun ann) - -- the next state is returning - | Returning (Context uni fun ann) (CekValue uni fun ann) - -- evaluation finished - | Terminating (DischargeResult uni fun) + | -- the next state is computing + Computing (Context uni fun ann) (CekValEnv uni fun ann) (NTerm uni fun ann) + | -- the next state is returning + Returning (Context uni fun ann) (CekValue uni fun ann) + | -- evaluation finished + Terminating (DischargeResult uni fun) instance Pretty (CekState uni fun ann) where - pretty = \case - Starting{} -> "Starting" - Computing{} -> "Computing" - Returning{} -> "Returning" - Terminating{} -> "Terminating" + pretty = \case + Starting {} -> "Starting" + Computing {} -> "Computing" + Returning {} -> "Returning" + Terminating {} -> "Terminating" -- | Similar to 'Cek.Internal.Context', but augmented with an 'ann' data Context uni fun ann - = FrameAwaitArg ann !(CekValue uni fun ann) !(Context uni fun ann) -- ^ @[V _]@ - | FrameAwaitFunTerm ann !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) -- ^ @[_ N]@ - | FrameAwaitFunConN ann !(Spine (Some (ValueOf uni))) !(Context uni fun ann) - | FrameAwaitFunValueN ann !(ArgStackNonEmpty uni fun ann) !(Context uni fun ann) - | FrameForce ann !(Context uni fun ann) -- ^ @(force _)@ - | FrameConstr ann !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) - | FrameCases ann !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann) - | NoFrame - -deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Context uni fun ann) - -computeCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (CekState uni fun ann) + = -- | @[V _]@ + FrameAwaitArg ann !(CekValue uni fun ann) !(Context uni fun ann) + | -- | @[_ N]@ + FrameAwaitFunTerm ann !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) + | FrameAwaitFunConN ann !(Spine (Some (ValueOf uni))) !(Context uni fun ann) + | FrameAwaitFunValueN ann !(ArgStackNonEmpty uni fun ann) !(Context uni fun ann) + | -- | @(force _)@ + FrameForce ann !(Context uni fun ann) + | FrameConstr ann !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) + | FrameCases ann !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann) + | NoFrame + +deriving stock instance + (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => + Show (Context uni fun ann) + +computeCek :: + forall uni fun ann s. + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + Context uni fun ann -> + CekValEnv uni fun ann -> + NTerm uni fun ann -> + CekM uni fun s (CekState uni fun ann) -- s ; ρ ▻ {L A} ↦ s , {_ A} ; ρ ▻ L computeCek !ctx !env (Var _ varName) = do - stepAndMaybeSpend BVar - val <- lookupVarName varName env - pure $ Returning ctx val + stepAndMaybeSpend BVar + val <- lookupVarName varName env + pure $ Returning ctx val computeCek !ctx !_ (Constant _ val) = do - stepAndMaybeSpend BConst - pure $ Returning ctx (VCon val) + stepAndMaybeSpend BConst + pure $ Returning ctx (VCon val) computeCek !ctx !env (LamAbs _ name body) = do - stepAndMaybeSpend BLamAbs - pure $ Returning ctx (VLamAbs name body env) + stepAndMaybeSpend BLamAbs + pure $ Returning ctx (VLamAbs name body env) computeCek !ctx !env (Delay _ body) = do - stepAndMaybeSpend BDelay - pure $ Returning ctx (VDelay body env) + stepAndMaybeSpend BDelay + pure $ Returning ctx (VDelay body env) -- s ; ρ ▻ lam x L ↦ s ◅ lam x (L , ρ) computeCek !ctx !env (Force _ body) = do - stepAndMaybeSpend BForce - pure $ Computing (FrameForce (termAnn body) ctx) env body + stepAndMaybeSpend BForce + pure $ Computing (FrameForce (termAnn body) ctx) env body -- s ; ρ ▻ [L M] ↦ s , [_ (M,ρ)] ; ρ ▻ L computeCek !ctx !env (Apply _ fun arg) = do - stepAndMaybeSpend BApply - pure $ Computing (FrameAwaitFunTerm (termAnn fun) env arg ctx) env fun + stepAndMaybeSpend BApply + pure $ Computing (FrameAwaitFunTerm (termAnn fun) env arg ctx) env fun -- s ; ρ ▻ abs α L ↦ s ◅ abs α (L , ρ) -- s ; ρ ▻ con c ↦ s ◅ con c -- s ; ρ ▻ builtin bn ↦ s ◅ builtin bn arity arity [] [] ρ computeCek !ctx !_ (Builtin _ bn) = do - stepAndMaybeSpend BBuiltin - let meaning = lookupBuiltin bn ?cekRuntime - -- 'Builtin' is fully discharged. - pure $ Returning ctx (VBuiltin bn (Builtin () bn) meaning) + stepAndMaybeSpend BBuiltin + let meaning = lookupBuiltin bn ?cekRuntime + -- 'Builtin' is fully discharged. + pure $ Returning ctx (VBuiltin bn (Builtin () bn) meaning) -- s ; ρ ▻ constr I T0 .. Tn ↦ s , constr I _ (T1 ... Tn, ρ) ; ρ ▻ T0 computeCek !ctx !env (Constr ann i es) = do - stepAndMaybeSpend BConstr - pure $ case es of - (t : rest) -> Computing (FrameConstr ann env i rest NilStack ctx) env t - [] -> Returning ctx $ VConstr i EmptyStack + stepAndMaybeSpend BConstr + pure $ case es of + (t : rest) -> Computing (FrameConstr ann env i rest NilStack ctx) env t + [] -> Returning ctx $ VConstr i EmptyStack -- s ; ρ ▻ case S C0 ... Cn ↦ s , case _ (C0 ... Cn, ρ) ; ρ ▻ S computeCek !ctx !env (Case ann scrut cs) = do - stepAndMaybeSpend BCase - pure $ Computing (FrameCases ann env cs ctx) env scrut + stepAndMaybeSpend BCase + pure $ Computing (FrameCases ann env cs ctx) env scrut -- s ; ρ ▻ error A ↦ <> A computeCek !_ !_ (Error _) = - throwErrorWithCause (OperationalError CekEvaluationFailure) (Error ()) - -returnCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (CekState uni fun ann) + throwErrorWithCause (OperationalError CekEvaluationFailure) (Error ()) + +returnCek :: + forall uni fun ann s. + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + Context uni fun ann -> + CekValue uni fun ann -> + CekM uni fun s (CekState uni fun ann) --- Instantiate all the free variable of the resulting term in case there are any. -- . ◅ V ↦ [] V returnCek NoFrame val = do - spendAccumulatedBudget - pure $ Terminating (dischargeCekValue val) + spendAccumulatedBudget + pure $ Terminating (dischargeCekValue val) -- s , {_ A} ◅ abs α M ↦ s ; ρ ▻ M [ α / A ]* returnCek (FrameForce _ ctx) fun = forceEvaluate ctx fun -- s , [_ (M,ρ)] ◅ V ↦ s , [V _] ; ρ ▻ M returnCek (FrameAwaitFunTerm _funAnn argVarEnv arg ctx) fun = - -- MAYBE: perhaps it is worth here to merge the _funAnn with argAnn - pure $ Computing (FrameAwaitArg (termAnn arg) fun ctx) argVarEnv arg + -- MAYBE: perhaps it is worth here to merge the _funAnn with argAnn + pure $ Computing (FrameAwaitArg (termAnn arg) fun ctx) argVarEnv arg -- s , [(lam x (M,ρ)) _] ◅ V ↦ s ; ρ [ x ↦ V ] ▻ M -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1878): -- add rule for VBuiltin once it's in the specification. returnCek (FrameAwaitArg _ fun ctx) arg = - applyEvaluate ctx fun arg + applyEvaluate ctx fun arg -- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M returnCek (FrameAwaitFunConN ann args ctx) fun = case args of - SpineLast arg -> applyEvaluate ctx fun (VCon arg) + SpineLast arg -> applyEvaluate ctx fun (VCon arg) SpineCons arg rest -> applyEvaluate (FrameAwaitFunConN ann rest ctx) fun (VCon arg) -- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M returnCek (FrameAwaitFunValueN ann args ctx) fun = - case args of - LastStackNonEmpty arg -> - applyEvaluate ctx fun arg - ConsStackNonEmpty arg rest -> - applyEvaluate (FrameAwaitFunValueN ann rest ctx) fun arg + case args of + LastStackNonEmpty arg -> + applyEvaluate ctx fun arg + ConsStackNonEmpty arg rest -> + applyEvaluate (FrameAwaitFunValueN ann rest ctx) fun arg -- s , constr I V0 ... Vj-1 _ (Tj+1 ... Tn, ρ) ◅ Vj ↦ s , constr i V0 ... Vj _ (Tj+2... Tn, ρ) ; ρ ▻ Tj+1 returnCek (FrameConstr ann env i todo done ctx) e = do - case todo of - (next : todo') -> - pure $ Computing (FrameConstr ann env i todo' (ConsStack e done) ctx) env next - [] -> - let go acc NilStack = acc - go acc (ConsStack x xs) = go (ConsStackNonEmpty x acc) xs - in pure $ Returning ctx $ VConstr i (MultiStack $ go (LastStackNonEmpty e) done) + case todo of + (next : todo') -> + pure $ Computing (FrameConstr ann env i todo' (ConsStack e done) ctx) env next + [] -> + let go acc NilStack = acc + go acc (ConsStack x xs) = go (ConsStackNonEmpty x acc) xs + in pure $ Returning ctx $ VConstr i (MultiStack $ go (LastStackNonEmpty e) done) -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm ↦ s , [_ V1 ... Vm] ; ρ ▻ Ci returnCek (FrameCases ann env cs ctx) e = case e of - -- If the index is larger than the max bound of an Int, or negative, then it's a bad index - -- As it happens, this will currently never trigger, since i is a Word64, and the largest - -- Word64 value wraps to -1 as an Int64. So you can't wrap around enough to get an - -- "apparently good" value. - (VConstr i _) | fromIntegral @_ @Integer i > fromIntegral @Int @Integer maxBound -> - throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e - (VConstr i args) -> case (V.!?) cs (fromIntegral i) of - Just t -> - case args of - EmptyStack -> computeCek ctx env t - MultiStack rest -> computeCek (FrameAwaitFunValueN ann rest ctx) env t - Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e - VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of - Left err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e - Right (HeadOnly fX) -> pure $ Computing ctx env fX - Right (HeadSpine f xs) -> pure $ Computing (FrameAwaitFunConN ann xs ctx) env f - _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e + -- If the index is larger than the max bound of an Int, or negative, then it's a bad index + -- As it happens, this will currently never trigger, since i is a Word64, and the largest + -- Word64 value wraps to -1 as an Int64. So you can't wrap around enough to get an + -- "apparently good" value. + (VConstr i _) + | fromIntegral @_ @Integer i > fromIntegral @Int @Integer maxBound -> + throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e + (VConstr i args) -> case (V.!?) cs (fromIntegral i) of + Just t -> + case args of + EmptyStack -> computeCek ctx env t + MultiStack rest -> computeCek (FrameAwaitFunValueN ann rest ctx) env t + Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e + VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of + Left err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e + Right (HeadOnly fX) -> pure $ Computing ctx env fX + Right (HeadSpine f xs) -> pure $ Computing (FrameAwaitFunConN ann xs ctx) env f + _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e -- | @force@ a term and proceed. -- If v is a delay then compute the body of v; @@ -226,29 +233,29 @@ returnCek (FrameCases ann env cs ctx) e = case e of -- and either calculate the builtin application or stick a 'Force' on top of its 'Term' -- representation depending on whether the application is saturated or not, -- if v is anything else, fail. -forceEvaluate - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (CekState uni fun ann) +forceEvaluate :: + forall uni fun ann s. + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + Context uni fun ann -> + CekValue uni fun ann -> + CekM uni fun s (CekState uni fun ann) forceEvaluate !ctx (VDelay body env) = - pure $ Computing ctx env body + pure $ Computing ctx env body forceEvaluate !ctx (VBuiltin fun term runtime) = do - -- @term@ is fully discharged, and so @term'@ is, hence we can put it in a 'VBuiltin'. - let term' = Force () term - case runtime of - -- It's only possible to force a builtin application if the builtin expects a type - -- argument next. - BuiltinExpectForce runtime' -> do - -- We allow a type argument to appear last in the type of a built-in function, - -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the - -- application. - evalBuiltinApp ctx fun term' runtime' - _ -> - throwErrorWithCause (StructuralError BuiltinTermArgumentExpectedMachineError) term' + -- @term@ is fully discharged, and so @term'@ is, hence we can put it in a 'VBuiltin'. + let term' = Force () term + case runtime of + -- It's only possible to force a builtin application if the builtin expects a type + -- argument next. + BuiltinExpectForce runtime' -> do + -- We allow a type argument to appear last in the type of a built-in function, + -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the + -- application. + evalBuiltinApp ctx fun term' runtime' + _ -> + throwErrorWithCause (StructuralError BuiltinTermArgumentExpectedMachineError) term' forceEvaluate !_ val = - throwErrorDischarged (StructuralError NonPolymorphicInstantiationMachineError) val + throwErrorDischarged (StructuralError NonPolymorphicInstantiationMachineError) val -- | Apply a function to an argument and proceed. -- If the function is a lambda 'lam x ty body' then extend the environment with a binding of @v@ @@ -257,61 +264,62 @@ forceEvaluate !_ val = -- and either calculate the builtin application or stick a 'Apply' on top of its 'Term' -- representation depending on whether the application is saturated or not. -- If v is anything else, fail. -applyEvaluate - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValue uni fun ann -- lhs of application - -> CekValue uni fun ann -- rhs of application - -> CekM uni fun s (CekState uni fun ann) +applyEvaluate :: + forall uni fun ann s. + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + Context uni fun ann -> + CekValue uni fun ann -> -- lhs of application + CekValue uni fun ann -> -- rhs of application + CekM uni fun s (CekState uni fun ann) applyEvaluate !ctx (VLamAbs _ body env) arg = - pure $ Computing ctx (Env.cons arg env) body + pure $ Computing ctx (Env.cons arg env) body -- Annotating @f@ and @exF@ with bangs gave us some speed-up, but only until we added a bang to -- 'VCon'. After that the bangs here were making things a tiny bit slower and so we removed them. applyEvaluate !ctx (VBuiltin fun term runtime) arg = do - let argTerm = dischargeResultToTerm $ dischargeCekValue arg - -- @term@ and @argTerm@ are fully discharged, and so @term'@ is, hence we can put it - -- in a 'VBuiltin'. - term' = Apply () term argTerm - case runtime of - -- It's only possible to apply a builtin application if the builtin expects a term - -- argument next. - BuiltinExpectArgument f -> evalBuiltinApp ctx fun term' $ f arg - _ -> - throwErrorWithCause (StructuralError UnexpectedBuiltinTermArgumentMachineError) term' + let argTerm = dischargeResultToTerm $ dischargeCekValue arg + -- @term@ and @argTerm@ are fully discharged, and so @term'@ is, hence we can put it + -- in a 'VBuiltin'. + term' = Apply () term argTerm + case runtime of + -- It's only possible to apply a builtin application if the builtin expects a term + -- argument next. + BuiltinExpectArgument f -> evalBuiltinApp ctx fun term' $ f arg + _ -> + throwErrorWithCause (StructuralError UnexpectedBuiltinTermArgumentMachineError) term' applyEvaluate !_ val _ = - throwErrorDischarged (StructuralError NonFunctionalApplicationMachineError) val + throwErrorDischarged (StructuralError NonFunctionalApplicationMachineError) val -- MAYBE: runCekDeBruijn can be shared between original&debug ceks by passing a `enterComputeCek` func. -runCekDeBruijn - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> NTerm uni fun ann - -> CekReport cost NamedDeBruijn uni fun +runCekDeBruijn :: + ThrowableBuiltins uni fun => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + NTerm uni fun ann -> + CekReport cost NamedDeBruijn uni fun runCekDeBruijn params mode emitMode term = - runCekM params mode emitMode $ do - spendBudget BStartup $ runIdentity $ cekStartupCost ?cekCosts - enterComputeCek NoFrame Env.empty term + runCekM params mode emitMode $ do + spendBudget BStartup $ runIdentity $ cekStartupCost ?cekCosts + enterComputeCek NoFrame Env.empty term -- See Note [Compilation peculiarities]. + -- | The entering point to the CEK machine's engine. -enterComputeCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (DischargeResult uni fun) +enterComputeCek :: + forall uni fun ann s. + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + Context uni fun ann -> + CekValEnv uni fun ann -> + NTerm uni fun ann -> + CekM uni fun s (DischargeResult uni fun) enterComputeCek ctx env term = iterToFinalState $ Computing ctx env term - where - iterToFinalState :: CekState uni fun ann -> CekM uni fun s (DischargeResult uni fun) - iterToFinalState = cekTrans - >=> - \case - Terminating t -> pure t - x -> iterToFinalState x + where + iterToFinalState :: CekState uni fun ann -> CekM uni fun s (DischargeResult uni fun) + iterToFinalState = + cekTrans + >=> \case + Terminating t -> pure t + x -> iterToFinalState x -- | A CEK parameter that turns the slippage optimization *off*. -- @@ -326,34 +334,37 @@ type Trans m state = state -> m state type CekTrans uni fun ann s = Trans (CekM uni fun s) (CekState uni fun ann) -- | The state transition function of the machine. -cekTrans :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => CekTrans uni fun ann s +cekTrans :: + forall uni fun ann s. + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + CekTrans uni fun ann s cekTrans = \case - Starting term -> pure $ Computing NoFrame Env.empty term - Computing ctx env term -> computeCek ctx env term - Returning ctx val -> returnCek ctx val - self@Terminating{} -> pure self -- FINAL STATE, idempotent + Starting term -> pure $ Computing NoFrame Env.empty term + Computing ctx env term -> computeCek ctx env term + Returning ctx val -> returnCek ctx val + self@Terminating {} -> pure self -- FINAL STATE, idempotent -- | Based on the supplied arguments, initialize the CEK environment and -- construct a state transition function. -- Returns the constructed transition function paired with the methods to live access the running budget. +mkCekTrans :: + forall cost uni fun ann m s. + ( ThrowableBuiltins uni fun + , PrimMonad m + , s ~ PrimState m -- the outer monad that initializes the transition function + ) => + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> + ExBudgetMode cost uni fun -> + EmitterMode uni fun -> + Slippage -> + m (CekTrans uni fun ann s, ExBudgetInfo cost uni fun s) mkCekTrans - :: forall cost uni fun ann m s - . ( ThrowableBuiltins uni fun - , PrimMonad m, s ~ PrimState m) -- the outer monad that initializes the transition function - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> Slippage - -> m (CekTrans uni fun ann s, ExBudgetInfo cost uni fun s) -mkCekTrans - (MachineParameters caser (MachineVariantParameters costs runtime)) - (ExBudgetMode getExBudgetInfo) - (EmitterMode getEmitterMode) - slippage = do - exBudgetInfo@ExBudgetInfo{_exBudgetModeSpender, _exBudgetModeGetCumulative} <- liftPrim getExBudgetInfo - CekEmitterInfo{_cekEmitterInfoEmit} <- liftPrim $ getEmitterMode _exBudgetModeGetCumulative + (MachineParameters caser (MachineVariantParameters costs runtime)) + (ExBudgetMode getExBudgetInfo) + (EmitterMode getEmitterMode) + slippage = do + exBudgetInfo@ExBudgetInfo {_exBudgetModeSpender, _exBudgetModeGetCumulative} <- liftPrim getExBudgetInfo + CekEmitterInfo {_cekEmitterInfoEmit} <- liftPrim $ getEmitterMode _exBudgetModeGetCumulative ctr <- newCounter (Proxy @CounterSize) let ?cekRuntime = runtime ?cekCaserBuiltin = caser @@ -362,92 +373,95 @@ mkCekTrans ?cekCosts = costs ?cekSlippage = slippage ?cekStepCounter = ctr - in pure (cekTrans, exBudgetInfo) - -- note that we do not call the final budget&emit getters like in `runCekM`, - -- since we do not need it for our usecase. + in pure (cekTrans, exBudgetInfo) + +-- note that we do not call the final budget&emit getters like in `runCekM`, +-- since we do not need it for our usecase. -- * Helpers + ------------ -- | Lift a CEK computation to a primitive.PrimMonad m -liftCek :: (PrimMonad m, PrimState m ~ s) => CekM uni fun s a -> m a -liftCek= liftPrim . unCekM +liftCek :: (PrimMonad m, PrimState m ~ s) => CekM uni fun s a -> m a +liftCek = liftPrim . unCekM cekStateContext :: Traversal' (CekState uni fun ann) (Context uni fun ann) cekStateContext f = \case - Computing k e t -> Computing <$> f k <*> pure e <*> pure t - Returning k v -> Returning <$> f k <*> pure v - x -> pure x + Computing k e t -> Computing <$> f k <*> pure e <*> pure t + Returning k v -> Returning <$> f k <*> pure v + x -> pure x cekStateAnn :: CekState uni fun ann -> Maybe ann cekStateAnn = \case - Computing _ _ t -> pure $ termAnn t - Returning ctx _ -> contextAnn ctx - _ -> empty + Computing _ _ t -> pure $ termAnn t + Returning ctx _ -> contextAnn ctx + _ -> empty contextAnn :: Context uni fun ann -> Maybe ann contextAnn = \case - FrameAwaitArg ann _ _ -> pure ann - FrameAwaitFunTerm ann _ _ _ -> pure ann - FrameAwaitFunConN ann _ _ -> pure ann - FrameAwaitFunValueN ann _ _ -> pure ann - FrameForce ann _ -> pure ann - FrameConstr ann _ _ _ _ _ -> pure ann - FrameCases ann _ _ _ -> pure ann - NoFrame -> empty + FrameAwaitArg ann _ _ -> pure ann + FrameAwaitFunTerm ann _ _ _ -> pure ann + FrameAwaitFunConN ann _ _ -> pure ann + FrameAwaitFunValueN ann _ _ -> pure ann + FrameForce ann _ -> pure ann + FrameConstr ann _ _ _ _ _ -> pure ann + FrameCases ann _ _ _ -> pure ann + NoFrame -> empty lenContext :: Context uni fun ann -> Word lenContext = go 0 - where - go :: Word -> Context uni fun ann -> Word - go !n = \case - FrameAwaitArg _ _ k -> go (n+1) k - FrameAwaitFunTerm _ _ _ k -> go (n+1) k - FrameAwaitFunConN _ _ k -> go (n+1) k - FrameAwaitFunValueN _ _ k -> go (n+1) k - FrameForce _ k -> go (n+1) k - FrameConstr _ _ _ _ _ k -> go (n+1) k - FrameCases _ _ _ k -> go (n+1) k - NoFrame -> 0 - + where + go :: Word -> Context uni fun ann -> Word + go !n = \case + FrameAwaitArg _ _ k -> go (n + 1) k + FrameAwaitFunTerm _ _ _ k -> go (n + 1) k + FrameAwaitFunConN _ _ k -> go (n + 1) k + FrameAwaitFunValueN _ _ k -> go (n + 1) k + FrameForce _ k -> go (n + 1) k + FrameConstr _ _ _ _ _ k -> go (n + 1) k + FrameCases _ _ _ k -> go (n + 1) k + NoFrame -> 0 -- * Duplicated functions from Cek.Internal module + -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1879): -- share these functions with Cek.Internal -- preliminary testing shows that sharing slows down original cek cekStepCost :: CekMachineCosts -> StepKind -> ExBudget -cekStepCost costs = runIdentity . \case - BConst -> cekConstCost costs - BVar -> cekVarCost costs - BLamAbs -> cekLamCost costs - BApply -> cekApplyCost costs - BDelay -> cekDelayCost costs - BForce -> cekForceCost costs +cekStepCost costs = + runIdentity . \case + BConst -> cekConstCost costs + BVar -> cekVarCost costs + BLamAbs -> cekLamCost costs + BApply -> cekApplyCost costs + BDelay -> cekDelayCost costs + BForce -> cekForceCost costs BBuiltin -> cekBuiltinCost costs - BConstr -> cekConstrCost costs - BCase -> cekCaseCost costs + BConstr -> cekConstrCost costs + BCase -> cekCaseCost costs -- | Call 'dischargeCekValue' over the received 'CekVal' and feed the resulting 'Term' to -- 'throwErrorWithCause' as the cause of the failure. -throwErrorDischarged - :: ThrowableBuiltins uni fun - => EvaluationError (MachineError fun) CekUserError - -> CekValue uni fun ann - -> CekM uni fun s x +throwErrorDischarged :: + ThrowableBuiltins uni fun => + EvaluationError (MachineError fun) CekUserError -> + CekValue uni fun ann -> + CekM uni fun s x throwErrorDischarged err = throwErrorWithCause err . dischargeResultToTerm . dischargeCekValue -- | Look up a variable name in the environment. -lookupVarName - :: forall uni fun ann s . - ThrowableBuiltins uni fun - => NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) +lookupVarName :: + forall uni fun ann s. + ThrowableBuiltins uni fun => + NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = - Env.contIndexOne - (throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) $ Var () varName) - pure - varEnv - (coerce varIx) + Env.contIndexOne + (throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) $ Var () varName) + pure + varEnv + (coerce varIx) -- | Take a possibly partial builtin application and -- @@ -456,61 +470,62 @@ lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = -- - or create a partial builtin application otherwise -- -- and proceed with the returning phase of the CEK machine. -evalBuiltinApp - :: (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> fun - -> NTerm uni fun () - -> BuiltinRuntime (CekValue uni fun ann) - -> CekM uni fun s (CekState uni fun ann) +evalBuiltinApp :: + (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) => + Context uni fun ann -> + fun -> + NTerm uni fun () -> + BuiltinRuntime (CekValue uni fun ann) -> + CekM uni fun s (CekState uni fun ann) evalBuiltinApp ctx fun term runtime = case runtime of - BuiltinCostedResult budgets0 getFXs -> do - let exCat = BBuiltinApp fun - spendBudgets (ExBudgetLast budget) = spendBudget exCat budget - spendBudgets (ExBudgetCons budget budgets) = - spendBudget exCat budget *> spendBudgets budgets - spendBudgets budgets0 - case getFXs of - BuiltinSuccess y -> - returnCek ctx y - BuiltinSuccessWithLogs logs y -> do - ?cekEmitter logs - returnCek ctx y - BuiltinFailure logs err -> do - ?cekEmitter logs - throwBuiltinErrorWithCause term err - _ -> returnCek ctx $ VBuiltin fun term runtime + BuiltinCostedResult budgets0 getFXs -> do + let exCat = BBuiltinApp fun + spendBudgets (ExBudgetLast budget) = spendBudget exCat budget + spendBudgets (ExBudgetCons budget budgets) = + spendBudget exCat budget *> spendBudgets budgets + spendBudgets budgets0 + case getFXs of + BuiltinSuccess y -> + returnCek ctx y + BuiltinSuccessWithLogs logs y -> do + ?cekEmitter logs + returnCek ctx y + BuiltinFailure logs err -> do + ?cekEmitter logs + throwBuiltinErrorWithCause term err + _ -> returnCek ctx $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} spendBudget :: GivenCekSpender uni fun s => ExBudgetCategory fun -> ExBudget -> CekM uni fun s () spendBudget = unCekBudgetSpender ?cekBudgetSpender -- | Spend the budget that has been accumulated for a number of machine steps. -spendAccumulatedBudget :: (GivenCekReqs uni fun ann s) => CekM uni fun s () +spendAccumulatedBudget :: GivenCekReqs uni fun ann s => CekM uni fun s () spendAccumulatedBudget = do - let ctr = ?cekStepCounter - iforCounter_ ctr spend - resetCounter ctr + let ctr = ?cekStepCounter + iforCounter_ ctr spend + resetCounter ctr where -- Making this a definition of its own causes it to inline better than actually writing it inline, for -- some reason. -- Skip index 7, that's the total counter! -- See Note [Structure of the step counter] {-# INLINE spend #-} - spend !i !w = unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ - let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) + spend !i !w = + unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ + let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) -- | Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. -stepAndMaybeSpend :: (GivenCekReqs uni fun ann s) => StepKind -> CekM uni fun s () +stepAndMaybeSpend :: GivenCekReqs uni fun ann s => StepKind -> CekM uni fun s () stepAndMaybeSpend !kind = do - -- See Note [Structure of the step counter] - -- This generates let-expressions in GHC Core, however all of them bind unboxed things and - -- so they don't survive further compilation, see https://stackoverflow.com/a/14090277 - let !counterIndex = fromEnum kind - ctr = ?cekStepCounter - !totalStepIndex = fromIntegral $ natVal (Proxy @TotalCountIndex) - !unbudgetedStepsTotal <- modifyCounter totalStepIndex (+1) ctr - _ <- modifyCounter counterIndex (+1) ctr - -- There's no risk of overflow here, since we only ever increment the total - -- steps by 1 and then check this condition. - when (unbudgetedStepsTotal >= ?cekSlippage) spendAccumulatedBudget + -- See Note [Structure of the step counter] + -- This generates let-expressions in GHC Core, however all of them bind unboxed things and + -- so they don't survive further compilation, see https://stackoverflow.com/a/14090277 + let !counterIndex = fromEnum kind + ctr = ?cekStepCounter + !totalStepIndex = fromIntegral $ natVal (Proxy @TotalCountIndex) + !unbudgetedStepsTotal <- modifyCounter totalStepIndex (+ 1) ctr + _ <- modifyCounter counterIndex (+ 1) ctr + -- There's no risk of overflow here, since we only ever increment the total + -- steps by 1 and then check this condition. + when (unbudgetedStepsTotal >= ?cekSlippage) spendAccumulatedBudget diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs index ae68ad88c20..bcc4c13baee 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file -module UntypedPlutusCore.Mark - ( markNonFreshTerm - , markNonFreshProgram - ) where +module UntypedPlutusCore.Mark ( + markNonFreshTerm, + markNonFreshProgram, +) where import Data.Set.Lens (setOf) import PlutusCore.Core (HasUniques) @@ -12,15 +12,15 @@ import UntypedPlutusCore.Core -- | Marks all the 'Unique's in a term as used, so they will not be generated in future. Useful if you -- have a term which was not generated in 'Quote'. -markNonFreshTerm - :: (HasUniques (Term name uni fun ann), MonadQuote m) - => Term name uni fun ann -> m () +markNonFreshTerm :: + (HasUniques (Term name uni fun ann), MonadQuote m) => + Term name uni fun ann -> m () markNonFreshTerm = markNonFreshMax . setOf termUniquesDeep -- | Marks all the 'Unique's in a program as used, so they will not be generated in future. Useful if you -- have a program which was not generated in 'Quote'. -markNonFreshProgram - :: (HasUnique name TermUnique, MonadQuote m) - => Program name uni fun ann - -> m () +markNonFreshProgram :: + (HasUnique name TermUnique, MonadQuote m) => + Program name uni fun ann -> + m () markNonFreshProgram (Program _ _ body) = markNonFreshTerm body diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs index 1a972a5b00f..84ee05da269 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs @@ -1,5 +1,5 @@ -- editorconfig-checker-disable-file -module UntypedPlutusCore.MkUPlc (UVarDecl (..), uvarDeclName, uvarDeclAnn, mkVar, mkIterLamAbs, Def(..), UTermDef) where +module UntypedPlutusCore.MkUPlc (UVarDecl (..), uvarDeclName, uvarDeclAnn, mkVar, mkIterLamAbs, Def (..), UTermDef) where import PlutusCore.MkPlc (Def (..)) import UntypedPlutusCore.Core.Type @@ -12,9 +12,9 @@ mkVar :: ann -> UVarDecl name ann -> Term name uni fun ann mkVar ann = Var ann . _uvarDeclName -- | Lambda abstract a list of names. -mkIterLamAbs - :: [UVarDecl name ann] - -> Term name uni fun ann - -> Term name uni fun ann +mkIterLamAbs :: + [UVarDecl name ann] -> + Term name uni fun ann -> + Term name uni fun ann mkIterLamAbs args body = - foldr (\(UVarDecl ann name ) acc -> LamAbs ann name acc) body args + foldr (\(UVarDecl ann name) acc -> LamAbs ann name acc) body args diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs index 1e1de0484be..871efc01cfc 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs @@ -1,17 +1,17 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module UntypedPlutusCore.Parser - ( parse - , term - , program - , parseTerm - , parseProgram - , parseScoped - , Parser - , SourcePos - ) where +{-# LANGUAGE TupleSections #-} + +module UntypedPlutusCore.Parser ( + parse, + term, + program, + parseTerm, + parseProgram, + parseScoped, + Parser, + SourcePos, +) where import Prelude hiding (fail) @@ -42,82 +42,84 @@ type PTerm = UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan conTerm :: Parser PTerm conTerm = withSpan $ \sp -> - inParens $ UPLC.Constant sp <$> (symbol "con" *> constant) + inParens $ UPLC.Constant sp <$> (symbol "con" *> constant) builtinTerm :: Parser PTerm builtinTerm = withSpan $ \sp -> - inParens $ UPLC.Builtin sp <$> (symbol "builtin" *> builtinFunction) + inParens $ UPLC.Builtin sp <$> (symbol "builtin" *> builtinFunction) varTerm :: Parser PTerm varTerm = withSpan $ \sp -> - UPLC.Var sp <$> name + UPLC.Var sp <$> name lamTerm :: Parser PTerm lamTerm = withSpan $ \sp -> - inParens $ UPLC.LamAbs sp <$> (symbol "lam" *> trailingWhitespace name) <*> term + inParens $ UPLC.LamAbs sp <$> (symbol "lam" *> trailingWhitespace name) <*> term appTerm :: Parser PTerm appTerm = withSpan $ \sp -> - -- TODO: should not use the same `sp` for all arguments. - inBrackets $ mkIterApp <$> term <*> (fmap (sp,) <$> some term) + -- TODO: should not use the same `sp` for all arguments. + inBrackets $ mkIterApp <$> term <*> (fmap (sp,) <$> some term) delayTerm :: Parser PTerm delayTerm = withSpan $ \sp -> - inParens $ UPLC.Delay sp <$> (symbol "delay" *> term) + inParens $ UPLC.Delay sp <$> (symbol "delay" *> term) forceTerm :: Parser PTerm forceTerm = withSpan $ \sp -> - inParens $ UPLC.Force sp <$> (symbol "force" *> term) + inParens $ UPLC.Force sp <$> (symbol "force" *> term) errorTerm :: Parser PTerm errorTerm = withSpan $ \sp -> - inParens $ UPLC.Error sp <$ symbol "error" + inParens $ UPLC.Error sp <$ symbol "error" constrTerm :: Parser PTerm constrTerm = withSpan $ \sp -> - inParens $ do - let maxTag = fromIntegral (maxBound :: Word64) - tag :: Integer <- symbol "constr" *> lexeme Lex.decimal - args <- many term - whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0" - when (tag > maxTag) $ fail "constr tag too large: must be a legal Word64 value" - pure $ UPLC.Constr sp (fromIntegral tag) args + inParens $ do + let maxTag = fromIntegral (maxBound :: Word64) + tag :: Integer <- symbol "constr" *> lexeme Lex.decimal + args <- many term + whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0" + when (tag > maxTag) $ fail "constr tag too large: must be a legal Word64 value" + pure $ UPLC.Constr sp (fromIntegral tag) args caseTerm :: Parser PTerm caseTerm = withSpan $ \sp -> - inParens $ do - res <- UPLC.Case sp <$> (symbol "case" *> term) <*> (V.fromList <$> many term) - whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" - pure res + inParens $ do + res <- UPLC.Case sp <$> (symbol "case" *> term) <*> (V.fromList <$> many term) + whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" + pure res -- | Parser for all UPLC terms. term :: Parser PTerm term = leadingWhitespace go where go = - choice $ map try [ - conTerm - , builtinTerm - , varTerm - , lamTerm - , appTerm - , delayTerm - , forceTerm - , errorTerm - , constrTerm - , caseTerm - ] + choice $ + map + try + [ conTerm + , builtinTerm + , varTerm + , lamTerm + , appTerm + , delayTerm + , forceTerm + , errorTerm + , constrTerm + , caseTerm + ] -- | Parser for UPLC programs. program :: Parser (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) program = leadingWhitespace go where go = do - prog <- withSpan $ \sp -> inParens $ do - v <- symbol "program" *> version - withVersion v $ UPLC.Program sp v <$> term - notFollowedBy anySingle - pure prog + prog <- withSpan $ \sp -> inParens $ do + v <- symbol "program" *> version + withVersion v $ UPLC.Program sp v <$> term + notFollowedBy anySingle + pure prog -- | Parse a UPLC term. The resulting program will have fresh names. The underlying monad must be capable -- of handling any parse errors. @@ -129,19 +131,19 @@ parseTerm = parseGen term -- "test" to the parser as the name of the input stream; to supply a name -- explicity, use `parse program `.` parseProgram :: - (MonadError PLC.ParserErrorBundle m, PLC.MonadQuote m) - => Text - -> m (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) + (MonadError PLC.ParserErrorBundle m, PLC.MonadQuote m) => + Text -> + m (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) parseProgram = parseGen program -- | Parse and rewrite so that names are globally unique, not just unique within -- their scope. parseScoped :: - (MonadError (PLC.Error uni fun SrcSpan) m, PLC.MonadQuote m) - => Text - -> m (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) + (MonadError (PLC.Error uni fun SrcSpan) m, PLC.MonadQuote m) => + Text -> + m (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) -- don't require there to be no free variables at this point, we might be parsing an open term parseScoped = through (modifyError PLC.UniqueCoherencyErrorE . checkProgram (const True)) - <=< rename - <=< modifyError PLC.ParseErrorE . parseProgram + <=< rename + <=< modifyError PLC.ParseErrorE . parseProgram diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs index 471adc709d2..3bab4f9c732 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- Stripped-down version of PlutusIR.Purity -module UntypedPlutusCore.Purity - ( isPure - , isWorkFree - , EvalOrder - , unEvalOrder - , EvalTerm (..) - , Purity (..) - , WorkFreedom (..) - , termEvaluationOrder - ) where +module UntypedPlutusCore.Purity ( + isPure, + isWorkFree, + EvalOrder, + unEvalOrder, + EvalTerm (..), + Purity (..), + WorkFreedom (..), + termEvaluationOrder, +) where import Data.DList qualified as DList import Data.Typeable (Proxy (..)) @@ -37,7 +37,7 @@ data Purity = MaybeImpure | Pure instance Pretty Purity where pretty MaybeImpure = "impure?" - pretty Pure = "pure" + pretty Pure = "pure" -- | Is this term essentially work-free? Either yes, or maybe not. data WorkFreedom = MaybeWork | WorkFree @@ -45,38 +45,41 @@ data WorkFreedom = MaybeWork | WorkFree instance Pretty WorkFreedom where pretty MaybeWork = "maybe work?" - pretty WorkFree = "work-free" + pretty WorkFree = "work-free" -{- | Either the "next" term to be evaluated, along with its 'Purity' and 'WorkFreedom', -or we don't know what comes next. --} +-- | Either the "next" term to be evaluated, along with its 'Purity' and 'WorkFreedom', +-- or we don't know what comes next. data EvalTerm name uni fun a = Unknown | EvalTerm Purity WorkFreedom (Term name uni fun a) instance - ( Show name - , Everywhere uni Show - , Show fun - , Show a - , GShow uni - , Closed uni - ) => Show (EvalTerm name uni fun a) where + ( Show name + , Everywhere uni Show + , Show fun + , Show a + , GShow uni + , Closed uni + ) => + Show (EvalTerm name uni fun a) + where show = \case Unknown -> "" EvalTerm purity work t -> "EvalTerm " <> show purity <> " " <> show work <> " " <> show t -instance (PrettyBy config (Term name uni fun a)) - => PrettyBy config (EvalTerm name uni fun a) where +instance + PrettyBy config (Term name uni fun a) => + PrettyBy config (EvalTerm name uni fun a) + where prettyBy _ Unknown = "" prettyBy config (EvalTerm eff work t) = pretty eff <+> pretty work <> ":" <+> prettyBy config t instance Eq (Term name uni fun a) => Eq (EvalTerm name uni fun a) where - Unknown == Unknown = True + Unknown == Unknown = True (EvalTerm p1 w1 t1) == (EvalTerm p2 w2 t2) = p1 == p2 && w1 == w2 && t1 == t2 - _ == _ = False + _ == _ = False -- We use a DList here for efficient and lazy concatenation @@ -84,201 +87,195 @@ instance Eq (Term name uni fun a) => Eq (EvalTerm name uni fun a) where newtype EvalOrder name uni fun a = EvalOrder (DList.DList (EvalTerm name uni fun a)) deriving newtype (Semigroup, Monoid) -{- | Get the evaluation order as a list of 'EvalTerm's. Either terminates in a single -'Unknown', which means that we got to a point where evaluation continues but we don't -know where; or terminates normally, in which case we actually got to the end of the -evaluation order for the term. --} +-- | Get the evaluation order as a list of 'EvalTerm's. Either terminates in a single +-- 'Unknown', which means that we got to a point where evaluation continues but we don't +-- know where; or terminates normally, in which case we actually got to the end of the +-- evaluation order for the term. unEvalOrder :: EvalOrder name uni fun a -> [EvalTerm name uni fun a] unEvalOrder (EvalOrder ts) = -- This is where we avoid traversing the whole program beyond the first Unknown, -- since DList is lazy and we convert to a lazy list and then filter it. takeWhileInclusive (\case Unknown -> False; _ -> True) (DList.toList ts) - where - takeWhileInclusive :: (a -> Bool) -> [a] -> [a] - takeWhileInclusive p = foldr (\x ys -> if p x then x : ys else [x]) [] + where + takeWhileInclusive :: (a -> Bool) -> [a] -> [a] + takeWhileInclusive p = foldr (\x ys -> if p x then x : ys else [x]) [] evalThis :: EvalTerm name uni fun a -> EvalOrder name uni fun a evalThis = EvalOrder . DList.singleton -instance (PrettyBy config (Term name uni fun a)) => - PrettyBy config (EvalOrder name uni fun a) where +instance + PrettyBy config (Term name uni fun a) => + PrettyBy config (EvalOrder name uni fun a) + where prettyBy config eo = vsep $ fmap (prettyBy config) (unEvalOrder eo) -{- | Given a term, return the order in which it and its sub-terms will be evaluated. - -This aims to be a sound under-approximation: if we don't know, we just say 'Unknown'. -Typically there will be a sequence of terms that we do know, which will terminate -in 'Unknown' once we do something like call a function. - -This makes some assumptions about the evaluator, in particular about the order in -which we evaluate sub-terms, but these match the current evaluator and we are not -planning on changing it. --} -termEvaluationOrder - :: forall name uni fun a - . (ToBuiltinMeaning uni fun) - => BuiltinSemanticsVariant fun - -> Term name uni fun a - -> EvalOrder name uni fun a +-- | Given a term, return the order in which it and its sub-terms will be evaluated. +-- +-- This aims to be a sound under-approximation: if we don't know, we just say 'Unknown'. +-- Typically there will be a sequence of terms that we do know, which will terminate +-- in 'Unknown' once we do something like call a function. +-- +-- This makes some assumptions about the evaluator, in particular about the order in +-- which we evaluate sub-terms, but these match the current evaluator and we are not +-- planning on changing it. +termEvaluationOrder :: + forall name uni fun a. + ToBuiltinMeaning uni fun => + BuiltinSemanticsVariant fun -> + Term name uni fun a -> + EvalOrder name uni fun a termEvaluationOrder builtinSemanticsVariant = goTerm - where - goTerm :: Term name uni fun a -> EvalOrder name uni fun a - goTerm = \case - (splitAppCtx -> (builtin@(Builtin _ann fun), appCtx)) -> - appCtxEvalOrder appCtx <> go arity appCtx - where - arity = builtinArity @uni @fun (Proxy @uni) builtinSemanticsVariant fun - - appCtxEvalOrder :: AppCtx name uni fun a -> EvalOrder name uni fun a - appCtxEvalOrder = \case - AppCtxEnd -> mempty - AppCtxTerm _ t rest -> goTerm t <> appCtxEvalOrder rest - AppCtxType _ rest -> appCtxEvalOrder rest - - go :: [Param] -> AppCtx name uni fun a -> EvalOrder name uni fun a - go parameters appContext = - case parameters of - -- All builtin parameters have been applied, - -- (such term is considered impure). - [] -> maybeImpureWork - - -- A term parameter is waiting to be applied - TermParam : otherParams -> - case appContext of - AppCtxEnd -> - -- Builtin is not fully saturated with term arguments, thus pure. - pureWorkFree - AppCtxType _ann _remainingAppCtx -> - -- Term parameter expected, type argument applied. - -- Error is impure. - maybeImpureWork - AppCtxTerm _ann _argTerm remainingAppCtx -> - go otherParams remainingAppCtx - - -- A type parameter is waiting to be forced - TypeParam : otherParams -> - case appContext of - AppCtxEnd -> - -- Builtin is not fully saturated with type arguments, thus pure. - pureWorkFree - AppCtxTerm _ann _term _remainingAppCtx -> - -- Type parameter expected, term argument applied. - -- Error is impure. - maybeImpureWork - AppCtxType _ann remainingAppCtx -> - go otherParams remainingAppCtx - + where + goTerm :: Term name uni fun a -> EvalOrder name uni fun a + goTerm = \case + (splitAppCtx -> (builtin@(Builtin _ann fun), appCtx)) -> + appCtxEvalOrder appCtx <> go arity appCtx where - maybeImpureWork :: EvalOrder name uni fun a - maybeImpureWork = evalThis (EvalTerm MaybeImpure MaybeWork reconstructed) + arity = builtinArity @uni @fun (Proxy @uni) builtinSemanticsVariant fun - pureWorkFree :: EvalOrder name uni fun a - pureWorkFree = evalThis (EvalTerm Pure WorkFree reconstructed) + appCtxEvalOrder :: AppCtx name uni fun a -> EvalOrder name uni fun a + appCtxEvalOrder = \case + AppCtxEnd -> mempty + AppCtxTerm _ t rest -> goTerm t <> appCtxEvalOrder rest + AppCtxType _ rest -> appCtxEvalOrder rest - reconstructed :: Term name uni fun a - reconstructed = fillAppCtx builtin appCtx + go :: [Param] -> AppCtx name uni fun a -> EvalOrder name uni fun a + go parameters appContext = + case parameters of + -- All builtin parameters have been applied, + -- (such term is considered impure). + [] -> maybeImpureWork + -- A term parameter is waiting to be applied + TermParam : otherParams -> + case appContext of + AppCtxEnd -> + -- Builtin is not fully saturated with term arguments, thus pure. + pureWorkFree + AppCtxType _ann _remainingAppCtx -> + -- Term parameter expected, type argument applied. + -- Error is impure. + maybeImpureWork + AppCtxTerm _ann _argTerm remainingAppCtx -> + go otherParams remainingAppCtx + -- A type parameter is waiting to be forced + TypeParam : otherParams -> + case appContext of + AppCtxEnd -> + -- Builtin is not fully saturated with type arguments, thus pure. + pureWorkFree + AppCtxTerm _ann _term _remainingAppCtx -> + -- Type parameter expected, term argument applied. + -- Error is impure. + maybeImpureWork + AppCtxType _ann remainingAppCtx -> + go otherParams remainingAppCtx + where + maybeImpureWork :: EvalOrder name uni fun a + maybeImpureWork = evalThis (EvalTerm MaybeImpure MaybeWork reconstructed) - t@(Apply _ fun arg) -> - -- first the function - goTerm fun - -- then the arg - <> goTerm arg - -- then the whole term, which means environment manipulation, so work - <> evalThis (EvalTerm Pure MaybeWork t) - <> case fun of - -- known function body - LamAbs _ _ body -> goTerm body - -- unknown function body - _ -> evalThis Unknown - t@(Force _ dterm) -> - -- first delayed term - goTerm dterm - -- then the whole term, which will mean forcing, so work - <> evalThis (EvalTerm Pure MaybeWork t) - <> case dterm of - -- known delayed term - Delay _ body -> goTerm body - -- unknown delayed term - _ -> evalThis Unknown - t@(Constr _ _ ts) -> - -- first the arguments, in left-to-right order - foldMap goTerm ts - -- then the whole term, which means constructing the value, so work, unless there's no - -- arguments, in which case it's not more work than evaluating, say, a @Delay@ node - <> evalThis (EvalTerm Pure (if null ts then WorkFree else MaybeWork) t) - t@(Case _ scrut _) -> - -- first the scrutinee - goTerm scrut - -- then the whole term, which means finding the case so work - <> evalThis (EvalTerm Pure MaybeWork t) - -- then we go to an unknown scrutinee - <> evalThis Unknown - -- Leaf terms - t@Var{} -> - evalThis (EvalTerm Pure WorkFree t) - t@Error{} -> - -- definitely effectful! but not relevant from a work perspective - evalThis (EvalTerm MaybeImpure WorkFree t) - -- program terminates - <> evalThis Unknown - t@Builtin{} -> - evalThis (EvalTerm Pure WorkFree t) - t@Delay{} -> - evalThis (EvalTerm Pure WorkFree t) - t@LamAbs{} -> - evalThis (EvalTerm Pure WorkFree t) - t@Constant{} -> - evalThis (EvalTerm Pure WorkFree t) + pureWorkFree :: EvalOrder name uni fun a + pureWorkFree = evalThis (EvalTerm Pure WorkFree reconstructed) -{- | Will evaluating this term have side effects (looping or error)? -This is slightly wider than the definition of a value, as -it includes applications that are known to be pure, as well as -things that can't be returned from the machine (as they'd be ill-scoped). --} -isPure - :: (ToBuiltinMeaning uni fun) - => BuiltinSemanticsVariant fun - -> Term name uni fun a - -> Bool + reconstructed :: Term name uni fun a + reconstructed = fillAppCtx builtin appCtx + t@(Apply _ fun arg) -> + -- first the function + goTerm fun + -- then the arg + <> goTerm arg + -- then the whole term, which means environment manipulation, so work + <> evalThis (EvalTerm Pure MaybeWork t) + <> case fun of + -- known function body + LamAbs _ _ body -> goTerm body + -- unknown function body + _ -> evalThis Unknown + t@(Force _ dterm) -> + -- first delayed term + goTerm dterm + -- then the whole term, which will mean forcing, so work + <> evalThis (EvalTerm Pure MaybeWork t) + <> case dterm of + -- known delayed term + Delay _ body -> goTerm body + -- unknown delayed term + _ -> evalThis Unknown + t@(Constr _ _ ts) -> + -- first the arguments, in left-to-right order + foldMap goTerm ts + -- then the whole term, which means constructing the value, so work, unless there's no + -- arguments, in which case it's not more work than evaluating, say, a @Delay@ node + <> evalThis (EvalTerm Pure (if null ts then WorkFree else MaybeWork) t) + t@(Case _ scrut _) -> + -- first the scrutinee + goTerm scrut + -- then the whole term, which means finding the case so work + <> evalThis (EvalTerm Pure MaybeWork t) + -- then we go to an unknown scrutinee + <> evalThis Unknown + -- Leaf terms + t@Var {} -> + evalThis (EvalTerm Pure WorkFree t) + t@Error {} -> + -- definitely effectful! but not relevant from a work perspective + evalThis (EvalTerm MaybeImpure WorkFree t) + -- program terminates + <> evalThis Unknown + t@Builtin {} -> + evalThis (EvalTerm Pure WorkFree t) + t@Delay {} -> + evalThis (EvalTerm Pure WorkFree t) + t@LamAbs {} -> + evalThis (EvalTerm Pure WorkFree t) + t@Constant {} -> + evalThis (EvalTerm Pure WorkFree t) + +-- | Will evaluating this term have side effects (looping or error)? +-- This is slightly wider than the definition of a value, as +-- it includes applications that are known to be pure, as well as +-- things that can't be returned from the machine (as they'd be ill-scoped). +isPure :: + ToBuiltinMeaning uni fun => + BuiltinSemanticsVariant fun -> + Term name uni fun a -> + Bool isPure builtinSemanticsVariant term = -- to work out if the term is pure, we see if we can look through -- the whole evaluation order without hitting something that might be -- effectful go (unEvalOrder (termEvaluationOrder builtinSemanticsVariant term)) - where - go :: [EvalTerm name uni fun a] -> Bool - go [] = True - go (et : rest) = case et of - -- Might be an effect here! - EvalTerm MaybeImpure _ _ -> False - -- This term is fine, what about the rest? - EvalTerm Pure _ _ -> go rest - -- We don't know what will happen, so be conservative - Unknown -> False - -{- | Is the given term 'work-free'? + where + go :: [EvalTerm name uni fun a] -> Bool + go [] = True + go (et : rest) = case et of + -- Might be an effect here! + EvalTerm MaybeImpure _ _ -> False + -- This term is fine, what about the rest? + EvalTerm Pure _ _ -> go rest + -- We don't know what will happen, so be conservative + Unknown -> False -Note: The definition of 'work-free' is a little unclear, but the idea is that -evaluating this term should do very a trivial amount of work. --} -isWorkFree - :: (ToBuiltinMeaning uni fun) - => BuiltinSemanticsVariant fun - -> Term name uni fun a - -> Bool +-- | Is the given term 'work-free'? +-- +-- Note: The definition of 'work-free' is a little unclear, but the idea is that +-- evaluating this term should do very a trivial amount of work. +isWorkFree :: + ToBuiltinMeaning uni fun => + BuiltinSemanticsVariant fun -> + Term name uni fun a -> + Bool isWorkFree builtinSemanticsVariant term = -- to work out if the term is pure, we see if we can look through -- the whole evaluation order without hitting something that might be -- effectful go (unEvalOrder (termEvaluationOrder builtinSemanticsVariant term)) - where - go :: [EvalTerm name uni fun a] -> Bool - go [] = True - go (et : rest) = case et of - -- Might be an effect here! - EvalTerm _ MaybeWork _ -> False - -- This term is fine, what about the rest? - EvalTerm _ WorkFree _ -> go rest - -- We don't know what will happen, so be conservative - Unknown -> False + where + go :: [EvalTerm name uni fun a] -> Bool + go [] = True + go (et : rest) = case et of + -- Might be an effect here! + EvalTerm _ MaybeWork _ -> False + -- This term is fine, what about the rest? + EvalTerm _ WorkFree _ -> go rest + -- We don't know what will happen, so be conservative + Unknown -> False diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs index 03ead152f61..0dfe02c8f79 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs @@ -1,12 +1,11 @@ --- | The user-facing API of the untyped renamer. --- See PlutusCore.Rename for details. - {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module UntypedPlutusCore.Rename - ( Rename (..) - ) where +-- | The user-facing API of the untyped renamer. +-- See PlutusCore.Rename for details. +module UntypedPlutusCore.Rename ( + Rename (..), +) where import PlutusPrelude @@ -19,9 +18,9 @@ import PlutusCore.Name.Unique import PlutusCore.Rename (Rename (..)) instance HasUniques (Term name uni fun ann) => Rename (Term name uni fun ann) where - -- See Note [Marking]. - rename = through markNonFreshTerm >=> runRenameT . renameTermM + -- See Note [Marking]. + rename = through markNonFreshTerm >=> runRenameT . renameTermM instance HasUniques (Program name uni fun ann) => Rename (Program name uni fun ann) where - -- See Note [Marking]. - rename = through markNonFreshProgram >=> runRenameT . renameProgramM + -- See Note [Marking]. + rename = through markNonFreshProgram >=> runRenameT . renameProgramM diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs index 3389dda5e69..799f48ac83b 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs @@ -1,13 +1,12 @@ --- | The internal module of the renamer that defines the actual algorithms, --- but not the user-facing API. - {-# LANGUAGE ConstraintKinds #-} -module UntypedPlutusCore.Rename.Internal - ( module Export - , renameTermM - , renameProgramM - ) where +-- | The internal module of the renamer that defines the actual algorithms, +-- but not the user-facing API. +module UntypedPlutusCore.Rename.Internal ( + module Export, + renameTermM, + renameProgramM, +) where import UntypedPlutusCore.Core @@ -21,23 +20,23 @@ import Control.Monad.Reader (MonadReader) type MonadRename m = (MonadQuote m, MonadReader (Renaming TermUnique) m) -- | Rename a 'Term' in the 'RenameM' monad. -renameTermM - :: (MonadRename m, HasUniques (Term name uni fun ann)) - => Term name uni fun ann -> m (Term name uni fun ann) -renameTermM (LamAbs ann name body) = - withFreshenedName name $ \nameFr -> LamAbs ann nameFr <$> renameTermM body -renameTermM (Apply ann fun arg) = Apply ann <$> renameTermM fun <*> renameTermM arg -renameTermM err@Error{} = pure err -renameTermM (Var ann name) = Var ann <$> renameNameM name -renameTermM (Delay ann term) = Delay ann <$> renameTermM term -renameTermM (Force ann term) = Force ann <$> renameTermM term -renameTermM (Constr ann i es) = Constr ann i <$> traverse renameTermM es -renameTermM (Case ann arg cs) = Case ann <$> renameTermM arg <*> traverse renameTermM cs -renameTermM con@Constant{} = pure con -renameTermM bi@Builtin{} = pure bi +renameTermM :: + (MonadRename m, HasUniques (Term name uni fun ann)) => + Term name uni fun ann -> m (Term name uni fun ann) +renameTermM (LamAbs ann name body) = + withFreshenedName name $ \nameFr -> LamAbs ann nameFr <$> renameTermM body +renameTermM (Apply ann fun arg) = Apply ann <$> renameTermM fun <*> renameTermM arg +renameTermM err@Error {} = pure err +renameTermM (Var ann name) = Var ann <$> renameNameM name +renameTermM (Delay ann term) = Delay ann <$> renameTermM term +renameTermM (Force ann term) = Force ann <$> renameTermM term +renameTermM (Constr ann i es) = Constr ann i <$> traverse renameTermM es +renameTermM (Case ann arg cs) = Case ann <$> renameTermM arg <*> traverse renameTermM cs +renameTermM con@Constant {} = pure con +renameTermM bi@Builtin {} = pure bi -- | Rename a 'Program' in the 'RenameM' monad. -renameProgramM - :: (MonadRename m, HasUniques (Program name uni fun ann)) - => Program name uni fun ann -> m (Program name uni fun ann) +renameProgramM :: + (MonadRename m, HasUniques (Program name uni fun ann)) => + Program name uni fun ann -> m (Program name uni fun ann) renameProgramM (Program ann ver term) = Program ann ver <$> renameTermM term diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify.hs index 7bf41805b1b..9a11a1770de 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} module UntypedPlutusCore.Simplify ( - module Opts, - simplifyTerm, - simplifyProgram, - simplifyProgramWithTrace, - InlineHints (..), - termSimplifier, - module UntypedPlutusCore.Transform.Simplifier, + module Opts, + simplifyTerm, + simplifyProgram, + simplifyProgramWithTrace, + InlineHints (..), + termSimplifier, + module UntypedPlutusCore.Transform.Simplifier, ) where import PlutusCore.Compiler.Types @@ -33,54 +33,54 @@ import Data.Typeable import Data.Vector.Orphans () simplifyProgram :: - forall name uni fun m a. - (Compiling m uni fun name a) => - SimplifyOpts name a -> - BuiltinSemanticsVariant fun -> - Program name uni fun a -> - m (Program name uni fun a) + forall name uni fun m a. + Compiling m uni fun name a => + SimplifyOpts name a -> + BuiltinSemanticsVariant fun -> + Program name uni fun a -> + m (Program name uni fun a) simplifyProgram opts builtinSemanticsVariant (Program a v t) = Program a v <$> simplifyTerm opts builtinSemanticsVariant t simplifyProgramWithTrace :: - forall name uni fun m a. - (Compiling m uni fun name a) => - SimplifyOpts name a -> - BuiltinSemanticsVariant fun -> - Program name uni fun a -> - m (Program name uni fun a, SimplifierTrace name uni fun a) + forall name uni fun m a. + Compiling m uni fun name a => + SimplifyOpts name a -> + BuiltinSemanticsVariant fun -> + Program name uni fun a -> + m (Program name uni fun a, SimplifierTrace name uni fun a) simplifyProgramWithTrace opts builtinSemanticsVariant (Program a v t) = do (result, trace) <- - runSimplifierT - $ termSimplifier opts builtinSemanticsVariant t + runSimplifierT $ + termSimplifier opts builtinSemanticsVariant t pure (Program a v result, trace) simplifyTerm :: - forall name uni fun m a. - (Compiling m uni fun name a) => - SimplifyOpts name a -> - BuiltinSemanticsVariant fun -> - Term name uni fun a -> - m (Term name uni fun a) + forall name uni fun m a. + Compiling m uni fun name a => + SimplifyOpts name a -> + BuiltinSemanticsVariant fun -> + Term name uni fun a -> + m (Term name uni fun a) simplifyTerm opts builtinSemanticsVariant term = evalSimplifierT $ termSimplifier opts builtinSemanticsVariant term termSimplifier :: - forall name uni fun m a. - (Compiling m uni fun name a) => - SimplifyOpts name a -> - BuiltinSemanticsVariant fun -> - Term name uni fun a -> - SimplifierT name uni fun a m (Term name uni fun a) + forall name uni fun m a. + Compiling m uni fun name a => + SimplifyOpts name a -> + BuiltinSemanticsVariant fun -> + Term name uni fun a -> + SimplifierT name uni fun a m (Term name uni fun a) termSimplifier opts builtinSemanticsVariant = - simplifyNTimes (_soMaxSimplifierIterations opts) >=> cseNTimes cseTimes + simplifyNTimes (_soMaxSimplifierIterations opts) >=> cseNTimes cseTimes where -- Run the simplifier @n@ times simplifyNTimes :: Int -> Term name uni fun a -> SimplifierT name uni fun a m (Term name uni fun a) - simplifyNTimes n = List.foldl' (>=>) pure $ map simplifyStep [1..n] + simplifyNTimes n = List.foldl' (>=>) pure $ map simplifyStep [1 .. n] -- Run CSE @n@ times, interleaved with the simplifier. -- See Note [CSE] @@ -88,7 +88,7 @@ termSimplifier opts builtinSemanticsVariant = Int -> Term name uni fun a -> SimplifierT name uni fun a m (Term name uni fun a) - cseNTimes n = foldl' (>=>) pure $ concatMap (\i -> [cseStep i, simplifyStep i]) [1..n] + cseNTimes n = foldl' (>=>) pure $ concatMap (\i -> [cseStep i, simplifyStep i]) [1 .. n] -- generate simplification step simplifyStep :: @@ -96,26 +96,26 @@ termSimplifier opts builtinSemanticsVariant = Term name uni fun a -> SimplifierT name uni fun a m (Term name uni fun a) simplifyStep _ = - floatDelay + floatDelay >=> forceCaseDelay >=> case (eqT @uni @PLC.DefaultUni, eqT @fun @DefaultFun) of - (Just Refl, Just Refl) -> forceDelay builtinSemanticsVariant - _ -> pure + (Just Refl, Just Refl) -> forceDelay builtinSemanticsVariant + _ -> pure >=> caseOfCase' >=> caseReduce >=> inline - (_soInlineCallsiteGrowth opts) - (_soInlineConstants opts) - (_soPreserveLogging opts) - (_soInlineHints opts) - builtinSemanticsVariant + (_soInlineCallsiteGrowth opts) + (_soInlineConstants opts) + (_soPreserveLogging opts) + (_soInlineHints opts) + builtinSemanticsVariant caseOfCase' :: Term name uni fun a -> SimplifierT name uni fun a m (Term name uni fun a) caseOfCase' = case eqT @fun @DefaultFun of Just Refl -> caseOfCase - Nothing -> pure + Nothing -> pure cseStep :: Int -> @@ -124,6 +124,6 @@ termSimplifier opts builtinSemanticsVariant = cseStep _ = case (eqT @name @Name, eqT @uni @PLC.DefaultUni) of (Just Refl, Just Refl) -> cse builtinSemanticsVariant - _ -> pure + _ -> pure cseTimes = if _soConservativeOpts opts then 0 else _soMaxCseIterations opts diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify/Opts.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify/Opts.hs index e1ccfe46405..1ca81cbc668 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify/Opts.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Simplify/Opts.hs @@ -1,16 +1,16 @@ {-# LANGUAGE TemplateHaskell #-} -module UntypedPlutusCore.Simplify.Opts - ( SimplifyOpts (..) - , soMaxSimplifierIterations - , soMaxCseIterations - , soInlineHints - , soConservativeOpts - , soInlineConstants - , soInlineCallsiteGrowth - , soPreserveLogging - , defaultSimplifyOpts - ) where +module UntypedPlutusCore.Simplify.Opts ( + SimplifyOpts (..), + soMaxSimplifierIterations, + soMaxCseIterations, + soInlineHints, + soConservativeOpts, + soInlineConstants, + soInlineCallsiteGrowth, + soPreserveLogging, + defaultSimplifyOpts, +) where import Control.Lens.TH (makeLenses) import Data.Default.Class @@ -20,12 +20,12 @@ import PlutusCore.AstSize data SimplifyOpts name a = SimplifyOpts { _soMaxSimplifierIterations :: Int - , _soMaxCseIterations :: Int - , _soConservativeOpts :: Bool - , _soInlineHints :: InlineHints name a - , _soInlineConstants :: Bool - , _soInlineCallsiteGrowth :: AstSize - , _soPreserveLogging :: Bool + , _soMaxCseIterations :: Int + , _soConservativeOpts :: Bool + , _soInlineHints :: InlineHints name a + , _soInlineConstants :: Bool + , _soInlineCallsiteGrowth :: AstSize + , _soPreserveLogging :: Bool } deriving stock (Show) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs index e6495a113ad..10129973fd0 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs @@ -1,19 +1,20 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module UntypedPlutusCore.Subst - ( substVarA - , substVar - , termSubstNamesM - , termSubstNames - , termMapNames - , programMapNames - , substConstantA - , substConstant - , termSubstConstantsM - , termSubstConstants - , vTerm - ) where + +module UntypedPlutusCore.Subst ( + substVarA, + substVar, + termSubstNamesM, + termSubstNames, + termMapNames, + programMapNames, + substConstantA, + substConstant, + termSubstConstantsM, + termSubstConstants, + vTerm, +) where import PlutusPrelude @@ -23,99 +24,98 @@ import Control.Lens import Universe -- | Applicatively replace a variable using the given function. -substVarA - :: Applicative f - => (name -> f (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> f (Term name uni fun ann) +substVarA :: + Applicative f => + (name -> f (Maybe (Term name uni fun ann))) -> + Term name uni fun ann -> + f (Term name uni fun ann) substVarA nameF t@(Var _ name) = fromMaybe t <$> nameF name -substVarA _ t = pure t +substVarA _ t = pure t -- | Replace a variable using the given function. -substVar - :: (name -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann +substVar :: + (name -> Maybe (Term name uni fun ann)) -> + Term name uni fun ann -> + Term name uni fun ann substVar = purely substVarA -- | Naively monadically substitute names using the given function (i.e. do not substitute binders). -termSubstNamesM - :: Monad m - => (name -> m (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> m (Term name uni fun ann) +termSubstNamesM :: + Monad m => + (name -> m (Maybe (Term name uni fun ann))) -> + Term name uni fun ann -> + m (Term name uni fun ann) termSubstNamesM = transformMOf termSubterms . substVarA -- | Naively substitute names using the given function (i.e. do not substitute binders). -termSubstNames - :: (name -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann +termSubstNames :: + (name -> Maybe (Term name uni fun ann)) -> + Term name uni fun ann -> + Term name uni fun ann termSubstNames = purely termSubstNamesM -- | Completely replace the names with a new name type. -termMapNames - :: forall name name' uni fun ann - . (name -> name') - -> Term name uni fun ann - -> Term name' uni fun ann +termMapNames :: + forall name name' uni fun ann. + (name -> name') -> + Term name uni fun ann -> + Term name' uni fun ann termMapNames f = go - where - -- This is all a bit clunky because of the type-changing, I'm not sure of a nicer way to do it - go :: Term name uni fun ann -> Term name' uni fun ann - go = \case - LamAbs ann name body -> LamAbs ann (f name) (go body) - Var ann name -> Var ann (f name) - - Apply ann t1 t2 -> Apply ann (go t1) (go t2) - Delay ann t -> Delay ann (go t) - Force ann t -> Force ann (go t) - Constr ann i es -> Constr ann i (fmap go es) - Case ann arg cs -> Case ann (go arg) (fmap go cs) - - Constant ann c -> Constant ann c - Builtin ann b -> Builtin ann b - Error ann -> Error ann - -programMapNames - :: forall name name' uni fun ann - . (name -> name') - -> Program name uni fun ann - -> Program name' uni fun ann + where + -- This is all a bit clunky because of the type-changing, I'm not sure of a nicer way to do it + go :: Term name uni fun ann -> Term name' uni fun ann + go = \case + LamAbs ann name body -> LamAbs ann (f name) (go body) + Var ann name -> Var ann (f name) + Apply ann t1 t2 -> Apply ann (go t1) (go t2) + Delay ann t -> Delay ann (go t) + Force ann t -> Force ann (go t) + Constr ann i es -> Constr ann i (fmap go es) + Case ann arg cs -> Case ann (go arg) (fmap go cs) + Constant ann c -> Constant ann c + Builtin ann b -> Builtin ann b + Error ann -> Error ann + +programMapNames :: + forall name name' uni fun ann. + (name -> name') -> + Program name uni fun ann -> + Program name' uni fun ann programMapNames f (Program a v term) = Program a v (termMapNames f term) -- TODO: this could be a Traversal + -- | Get all the term variables in a term. vTerm :: Fold (Term name uni fun ann) name vTerm = termSubtermsDeep . termVars -- | Applicatively replace a constant using the given function. -substConstantA - :: Applicative f - => (ann -> Some (ValueOf uni) -> f (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> f (Term name uni fun ann) +substConstantA :: + Applicative f => + (ann -> Some (ValueOf uni) -> f (Maybe (Term name uni fun ann))) -> + Term name uni fun ann -> + f (Term name uni fun ann) substConstantA valF t@(Constant ann val) = fromMaybe t <$> valF ann val -substConstantA _ t = pure t +substConstantA _ t = pure t -- | Replace a constant using the given function. -substConstant - :: (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann +substConstant :: + (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun ann)) -> + Term name uni fun ann -> + Term name uni fun ann substConstant = purely (substConstantA . curry) . uncurry -- | Monadically substitute constants using the given function. -termSubstConstantsM - :: Monad m - => (ann -> Some (ValueOf uni) -> m (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> m (Term name uni fun ann) +termSubstConstantsM :: + Monad m => + (ann -> Some (ValueOf uni) -> m (Maybe (Term name uni fun ann))) -> + Term name uni fun ann -> + m (Term name uni fun ann) termSubstConstantsM = transformMOf termSubterms . substConstantA -- | Substitute constants using the given function. -termSubstConstants - :: (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann +termSubstConstants :: + (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun ann)) -> + Term name uni fun ann -> + Term name uni fun ann termSubstConstants = purely (termSubstConstantsM . curry) . uncurry diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs index a2261d35a93..cd114cfe7c5 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs @@ -1,39 +1,38 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{- | -Perform the case-of-case transformation. This pushes -case expressions into the case branches of other case -expressions, which can often yield optimization opportunities. - -Example: -@ - case (case s of { C1 a -> x; C2 b -> y; }) of - D1 -> w - D2 -> z - - --> - - case s of - C1 a -> case x of { D1 -> w; D2 -> z; } - C2 b -> case y of { D1 -> w; D2 -> z; } -@ - -We also transform - -@ - case ((force ifThenElse) b (constr t) (constr f)) alts -@ - -into - -@ - force (force ifThenElse b (delay (case (constr t) alts)) (delay (case (constr f) alts))) -@ - -This is always an improvement. --} +-- | +-- Perform the case-of-case transformation. This pushes +-- case expressions into the case branches of other case +-- expressions, which can often yield optimization opportunities. +-- +-- Example: +-- @ +-- case (case s of { C1 a -> x; C2 b -> y; }) of +-- D1 -> w +-- D2 -> z +-- +-- --> +-- +-- case s of +-- C1 a -> case x of { D1 -> w; D2 -> z; } +-- C2 b -> case y of { D1 -> w; D2 -> z; } +-- @ +-- +-- We also transform +-- +-- @ +-- case ((force ifThenElse) b (constr t) (constr f)) alts +-- @ +-- +-- into +-- +-- @ +-- force (force ifThenElse b (delay (case (constr t) alts)) (delay (case (constr f) alts))) +-- @ +-- +-- This is always an improvement. module UntypedPlutusCore.Transform.CaseOfCase (caseOfCase) where import PlutusPrelude @@ -43,56 +42,67 @@ import PlutusCore.Builtin (CaseBuiltin (..)) import PlutusCore.MkPlc (mkIterApp) import UntypedPlutusCore.Core import UntypedPlutusCore.Transform.CaseReduce qualified as CaseReduce -import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (CaseOfCase), SimplifierT, - recordSimplification) +import UntypedPlutusCore.Transform.Simplifier ( + SimplifierStage (CaseOfCase), + SimplifierT, + recordSimplification, + ) import Control.Lens import Data.List (nub) -caseOfCase - :: ( fun ~ PLC.DefaultFun, Monad m, CaseBuiltin uni - , PLC.GEq uni, PLC.Closed uni, uni `PLC.Everywhere` Eq - ) - => Term name uni fun a - -> SimplifierT name uni fun a m (Term name uni fun a) +caseOfCase :: + ( fun ~ PLC.DefaultFun + , Monad m + , CaseBuiltin uni + , PLC.GEq uni + , PLC.Closed uni + , uni `PLC.Everywhere` Eq + ) => + Term name uni fun a -> + SimplifierT name uni fun a m (Term name uni fun a) caseOfCase term = do let result = transformOf termSubterms processTerm term recordSimplification term CaseOfCase result return result -processTerm - :: ( fun ~ PLC.DefaultFun, CaseBuiltin uni - , PLC.GEq uni, PLC.Closed uni, uni `PLC.Everywhere` Eq - ) - => Term name uni fun a -> Term name uni fun a +processTerm :: + ( fun ~ PLC.DefaultFun + , CaseBuiltin uni + , PLC.GEq uni + , PLC.Closed uni + , uni `PLC.Everywhere` Eq + ) => + Term name uni fun a -> Term name uni fun a processTerm = \case Case ann scrut alts | ( ite@(Force a (Builtin _ PLC.IfThenElse)) - , [cond, (trueAnn, true@Constr{}), (falseAnn, false@Constr{})] + , [cond, (trueAnn, true@Constr {}), (falseAnn, false@Constr {})] ) <- splitApplication scrut -> Force a $ mkIterApp ite [ cond - -- Here we call a single step of case-reduce in order to immediately clean up the - -- duplication of @alts@. Otherwise optimizing case-of-case-of-case-of... would create - -- exponential blowup of the case branches, which would eventually get deduplicated - -- with case-reduce, but only after that exponential blowup has already slowed the - -- optimizer down unnecessarily. - , (trueAnn, Delay trueAnn . CaseReduce.processTerm $ Case ann true alts) + , -- Here we call a single step of case-reduce in order to immediately clean up the + -- duplication of @alts@. Otherwise optimizing case-of-case-of-case-of... would create + -- exponential blowup of the case branches, which would eventually get deduplicated + -- with case-reduce, but only after that exponential blowup has already slowed the + -- optimizer down unnecessarily. + (trueAnn, Delay trueAnn . CaseReduce.processTerm $ Case ann true alts) , (falseAnn, Delay falseAnn . CaseReduce.processTerm $ Case ann false alts) ] original@(Case annOuter (Case annInner scrut altsInner) altsOuter) -> maybe original (Case annInner scrut) - (do - constrs <- for altsInner $ \case - c@(Constr _ i _) -> Just (Left i, c) - c@(Constant _ val) -> Just (Right val, c) - _ -> Nothing - -- See Note [Case-of-case and duplicating code]. - guard $ length (nub . toList $ fmap fst constrs) == length constrs - pure $ constrs <&> \(_, c) -> CaseReduce.processTerm $ Case annOuter c altsOuter) + ( do + constrs <- for altsInner $ \case + c@(Constr _ i _) -> Just (Left i, c) + c@(Constant _ val) -> Just (Right val, c) + _ -> Nothing + -- See Note [Case-of-case and duplicating code]. + guard $ length (nub . toList $ fmap fst constrs) == length constrs + pure $ constrs <&> \(_, c) -> CaseReduce.processTerm $ Case annOuter c altsOuter + ) other -> other diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs index 4d9d04643c2..82162e7a757 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} -module UntypedPlutusCore.Transform.CaseReduce - ( caseReduce - , processTerm - ) where + +module UntypedPlutusCore.Transform.CaseReduce ( + caseReduce, + processTerm, +) where import Control.Lens (transformOf) import Data.Bifunctor (second) @@ -11,26 +12,30 @@ import Data.Vector qualified as V import PlutusCore.Builtin (CaseBuiltin (..)) import PlutusCore.MkPlc import UntypedPlutusCore.Core -import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (CaseReduce), SimplifierT, - recordSimplification) +import UntypedPlutusCore.Transform.Simplifier ( + SimplifierStage (CaseReduce), + SimplifierT, + recordSimplification, + ) -caseReduce - :: (Monad m, CaseBuiltin uni) - => Term name uni fun a - -> SimplifierT name uni fun a m (Term name uni fun a) +caseReduce :: + (Monad m, CaseBuiltin uni) => + Term name uni fun a -> + SimplifierT name uni fun a m (Term name uni fun a) caseReduce term = do - let result = transformOf termSubterms processTerm term - recordSimplification term CaseReduce result - return result + let result = transformOf termSubterms processTerm term + recordSimplification term CaseReduce result + return result processTerm :: CaseBuiltin uni => Term name uni fun a -> Term name uni fun a processTerm = \case - -- We could've rewritten those patterns as 'Error' in the 'Nothing' cases, but that would turn a - -- structural error into an operational one, which would be unfortunate, so instead we decided - -- not to fully optimize such scripts, since they aren't valid anyway. - Case ann (Constr _ i args) cs | Just c <- (V.!?) cs (fromIntegral i) -> - mkIterApp c ((ann,) <$> args) - Case ann (Constant _ con) cs | Right fXs <- caseBuiltin con cs -> - headSpineToTerm ann (second (Constant ann) fXs) - - t -> t + -- We could've rewritten those patterns as 'Error' in the 'Nothing' cases, but that would turn a + -- structural error into an operational one, which would be unfortunate, so instead we decided + -- not to fully optimize such scripts, since they aren't valid anyway. + Case ann (Constr _ i args) cs + | Just c <- (V.!?) cs (fromIntegral i) -> + mkIterApp c ((ann,) <$> args) + Case ann (Constant _ con) cs + | Right fXs <- caseBuiltin con cs -> + headSpineToTerm ann (second (Constant ann) fXs) + t -> t diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs index 78d83017307..f758072367b 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module UntypedPlutusCore.Transform.Cse (cse) where import PlutusCore (MonadQuote, Name, Rename, freshName, rename) import PlutusCore.Builtin (ToBuiltinMeaning (BuiltinSemanticsVariant)) +import UntypedPlutusCore.AstSize (termAstSize) import UntypedPlutusCore.Core import UntypedPlutusCore.Purity (isWorkFree) -import UntypedPlutusCore.AstSize (termAstSize) -import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (CSE), SimplifierT, - recordSimplification) +import UntypedPlutusCore.Transform.Simplifier ( + SimplifierStage (CSE), + SimplifierT, + recordSimplification, + ) import Control.Arrow ((>>>)) import Control.Lens (foldrOf, transformOf) @@ -21,9 +24,9 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask, local) import Control.Monad.Trans.State.Strict (State, evalState, get, put) import Data.Foldable as Foldable (foldl') -import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as Map +import Data.Hashable (Hashable) import Data.List.Extra (isSuffixOf, sortOn) import Data.Ord (Down (..)) import Data.Proxy (Proxy (..)) @@ -198,8 +201,8 @@ isAncestorOrSelf :: Path -> Path -> Bool isAncestorOrSelf = isSuffixOf data CseCandidate uni fun ann = CseCandidate - { ccFreshName :: Name - , ccTerm :: Term Name uni fun () + { ccFreshName :: Name + , ccTerm :: Term Name uni fun () , ccAnnotatedTerm :: Term Name uni fun (Path, ann) -- ^ `ccTerm` is needed for equality comparison, while `ccAnnotatedTerm` is needed -- for the actual substitution. They are always the same term barring the annotations. @@ -286,8 +289,8 @@ countOccs builtinSemanticsVariant = foldrOf termSubtermsDeep addToMap Map.empty -- have a size benefit, but certainly doesn't have any cost benefit (the cost -- will in fact be slightly higher due to the additional application). | isWorkFree builtinSemanticsVariant t0 - || not (isBuiltinSaturated t0) - || isForcingBuiltin t0 = + || not (isBuiltinSaturated t0) + || isForcingBuiltin t0 = id | otherwise = Map.alter @@ -307,7 +310,7 @@ countOccs builtinSemanticsVariant = foldrOf termSubtermsDeep addToMap Map.empty _term -> True isForcingBuiltin = \case - Builtin{} -> True + Builtin {} -> True Force _ t -> isForcingBuiltin t _ -> False @@ -350,7 +353,7 @@ mkCseTerm ts t = do applyCse :: forall uni fun ann. - (Eq (Term Name uni fun ())) => + Eq (Term Name uni fun ()) => CseCandidate uni fun ann -> Term Name uni fun (Path, ann) -> Term Name uni fun (Path, ann) @@ -375,15 +378,15 @@ applyCse c = mkLamApp . transformOf termSubterms substCseVarForTerm (LamAbs (termAnn t) (ccFreshName c) t) (ccAnnotatedTerm c) | currPath `isAncestorOrSelf` candidatePath = case t of - Var ann name -> Var ann name - LamAbs ann name body -> LamAbs ann name (mkLamApp body) - Apply ann fun arg -> Apply ann (mkLamApp fun) (mkLamApp arg) - Force ann body -> Force ann (mkLamApp body) - Delay ann body -> Delay ann (mkLamApp body) - Constant ann val -> Constant ann val - Builtin ann fun -> Builtin ann fun - Error ann -> Error ann - Constr ann i ts -> Constr ann i (mkLamApp <$> ts) + Var ann name -> Var ann name + LamAbs ann name body -> LamAbs ann name (mkLamApp body) + Apply ann fun arg -> Apply ann (mkLamApp fun) (mkLamApp arg) + Force ann body -> Force ann (mkLamApp body) + Delay ann body -> Delay ann (mkLamApp body) + Constant ann val -> Constant ann val + Builtin ann fun -> Builtin ann fun + Error ann -> Error ann + Constr ann i ts -> Constr ann i (mkLamApp <$> ts) Case ann scrut branches -> Case ann (mkLamApp scrut) (mkLamApp <$> branches) | otherwise = t where @@ -392,7 +395,7 @@ applyCse c = mkLamApp . transformOf termSubterms substCseVarForTerm -- | Generate a fresh variable for the common subexpression. mkCseCandidate :: forall uni fun ann m. - (MonadQuote m) => + MonadQuote m => Term Name uni fun (Path, ann) -> m (CseCandidate uni fun ann) mkCseCandidate t = CseCandidate <$> freshName "cse" <*> pure (void t) <*> pure t diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs index 4070d3d0fed..a1fe827bdf7 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs @@ -1,58 +1,57 @@ {-# LANGUAGE LambdaCase #-} -{- | The Float Delay optimization floats `Delay` from arguments into function bodies, -if possible. It turns @(\n -> ...Force n...Force n...) (Delay arg)@ into -@(\n -> ...Force (Delay n)...Force (Delay n)...) arg@. - -The above transformation is performed if: - - * All occurrences of @arg@ are under @Force@. - - * @arg@ is essentially work-free. - -This achieves a similar effect to Plutonomy's "Split Delay" optimization. The difference -is that Split Delay simply splits the @Delay@ argument into multiple arguments, turning the -above example into @(\m -> (\n -> ...Force n...Force n...) (Delay m)) arg@, and then relies -on other optimizations to simplify it further. Specifically, once the inliner inlines -@Delay m@, it will be identical to the result of Float Delay. - -The advantages of Float Delay are: - - * It doesn't rely on the inliner. In this example, Split Delay relies on the inliner to - inline @Delay m@, but there's no guarantee that the inliner will do so, because inlining - it may increase the program size. - - We can potentially modify the inliner such that it is aware of Float Delay and - Force-Delay Cancel, and makes inlining decisions with these other optimizations in mind. - The problem is that, not only does this makes the inlining heuristics much more - complex, but it could easily lead to code duplication. Other optimizations often - need to do some calculation in order to make certain optimization decisions (e.g., in - this case, we want to check whether all occurrences of @arg@ are under @Force@), and - if we rely on the inliner to inline the @Delay@, then the same check would need to be - performed by the inliner. - - * Because Force Delay requires that all occurrences of @arg@ are under @Force@, it - guarantees to not increase the size or the cost of the program. This is not the case - with Split Delay: in this example, if the occurrences of @n@ are not under @Force@, - then Split Delay may increase the size of the program, regardless of whether or not - @Delay m@ is inlined. If @Delay m@ is not inlined, then it will also increase the - cost of the program, due to the additional application. - -The alternative approach that always floats the @Delay@ regardless of whether or not all -occurences of @arg@ are under @Force@ was implemented and tested, and it is strictly worse than -Float Delay on our current test suite (specifically, Split Delay causes one test case -to have a slightly bigger program, and everything else is equal). - -Why is this optimization performed on UPLC, not PIR? - - 1. Not only are the types and let-bindings in PIR not useful for this optimization, - they can also get in the way. For example, we cannot transform - @let f = /\a. ...a... in ...{f t1}...{f t2}...@ into - @ket f = ...a... in ...f...f...@. - - 2. This optimization mainly interacts with ForceDelayCancel and the inliner, and - both are part of the UPLC simplifier. --} +-- | The Float Delay optimization floats `Delay` from arguments into function bodies, +-- if possible. It turns @(\n -> ...Force n...Force n...) (Delay arg)@ into +-- @(\n -> ...Force (Delay n)...Force (Delay n)...) arg@. +-- +-- The above transformation is performed if: +-- +-- * All occurrences of @arg@ are under @Force@. +-- +-- * @arg@ is essentially work-free. +-- +-- This achieves a similar effect to Plutonomy's "Split Delay" optimization. The difference +-- is that Split Delay simply splits the @Delay@ argument into multiple arguments, turning the +-- above example into @(\m -> (\n -> ...Force n...Force n...) (Delay m)) arg@, and then relies +-- on other optimizations to simplify it further. Specifically, once the inliner inlines +-- @Delay m@, it will be identical to the result of Float Delay. +-- +-- The advantages of Float Delay are: +-- +-- * It doesn't rely on the inliner. In this example, Split Delay relies on the inliner to +-- inline @Delay m@, but there's no guarantee that the inliner will do so, because inlining +-- it may increase the program size. +-- +-- We can potentially modify the inliner such that it is aware of Float Delay and +-- Force-Delay Cancel, and makes inlining decisions with these other optimizations in mind. +-- The problem is that, not only does this makes the inlining heuristics much more +-- complex, but it could easily lead to code duplication. Other optimizations often +-- need to do some calculation in order to make certain optimization decisions (e.g., in +-- this case, we want to check whether all occurrences of @arg@ are under @Force@), and +-- if we rely on the inliner to inline the @Delay@, then the same check would need to be +-- performed by the inliner. +-- +-- * Because Force Delay requires that all occurrences of @arg@ are under @Force@, it +-- guarantees to not increase the size or the cost of the program. This is not the case +-- with Split Delay: in this example, if the occurrences of @n@ are not under @Force@, +-- then Split Delay may increase the size of the program, regardless of whether or not +-- @Delay m@ is inlined. If @Delay m@ is not inlined, then it will also increase the +-- cost of the program, due to the additional application. +-- +-- The alternative approach that always floats the @Delay@ regardless of whether or not all +-- occurences of @arg@ are under @Force@ was implemented and tested, and it is strictly worse than +-- Float Delay on our current test suite (specifically, Split Delay causes one test case +-- to have a slightly bigger program, and everything else is equal). +-- +-- Why is this optimization performed on UPLC, not PIR? +-- +-- 1. Not only are the types and let-bindings in PIR not useful for this optimization, +-- they can also get in the way. For example, we cannot transform +-- @let f = /\a. ...a... in ...{f t1}...{f t2}...@ into +-- @ket f = ...a... in ...f...f...@. +-- +-- 2. This optimization mainly interacts with ForceDelayCancel and the inliner, and +-- both are part of the UPLC simplifier. module UntypedPlutusCore.Transform.FloatDelay (floatDelay) where import PlutusCore qualified as PLC @@ -61,8 +60,11 @@ import PlutusCore.Name.UniqueMap qualified as UMap import PlutusCore.Name.UniqueSet qualified as USet import UntypedPlutusCore.Core.Plated (termSubterms) import UntypedPlutusCore.Core.Type (Term (..)) -import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (FloatDelay), SimplifierT, - recordSimplification) +import UntypedPlutusCore.Transform.Simplifier ( + SimplifierStage (FloatDelay), + SimplifierT, + recordSimplification, + ) import Control.Lens (forOf, forOf_, transformOf) import Control.Monad.Trans.Writer.CPS (Writer, execWriter, runWriter, tell) @@ -77,32 +79,30 @@ floatDelay :: floatDelay term = do result <- PLC.rename term >>= \t -> - pure . uncurry (flip simplifyBodies) $ simplifyArgs (unforcedVars t) t + pure . uncurry (flip simplifyBodies) $ simplifyArgs (unforcedVars t) t recordSimplification term FloatDelay result return result -{- | First pass. Returns the names of all variables, at least one occurrence -of which is not under `Force`. --} +-- | First pass. Returns the names of all variables, at least one occurrence +-- of which is not under `Force`. unforcedVars :: - forall name uni fun a - . (PLC.HasUnique name PLC.TermUnique) - => Term name uni fun a - -> PLC.UniqueSet PLC.TermUnique + forall name uni fun a. + PLC.HasUnique name PLC.TermUnique => + Term name uni fun a -> + PLC.UniqueSet PLC.TermUnique unforcedVars = execWriter . go where go :: Term name uni fun a -> Writer (PLC.UniqueSet PLC.TermUnique) () go = \case - Var _ n -> tell (USet.singletonName n) - Force _ Var{} -> pure () - t -> forOf_ termSubterms t go + Var _ n -> tell (USet.singletonName n) + Force _ Var {} -> pure () + t -> forOf_ termSubterms t go -{- | Second pass. Removes `Delay` from eligible arguments, and returns -the names of variables whose corresponding arguments are modified. --} +-- | Second pass. Removes `Delay` from eligible arguments, and returns +-- the names of variables whose corresponding arguments are modified. simplifyArgs :: forall name uni fun a. - (PLC.HasUnique name PLC.TermUnique) => + PLC.HasUnique name PLC.TermUnique => -- | The set of variables returned by `unforcedVars`. PLC.UniqueSet PLC.TermUnique -> Term name uni fun a -> @@ -119,33 +119,32 @@ simplifyArgs blacklist = runWriter . go t -> forOf termSubterms t go -- | Third pass. Turns @Force n@ into @Force (Delay n)@ for all eligibile @n@. -simplifyBodies - :: (PLC.HasUnique name PLC.TermUnique) - => PLC.UniqueMap PLC.TermUnique a - -> Term name uni fun a - -> Term name uni fun a +simplifyBodies :: + PLC.HasUnique name PLC.TermUnique => + PLC.UniqueMap PLC.TermUnique a -> + Term name uni fun a -> + Term name uni fun a simplifyBodies whitelist = transformOf termSubterms $ \case var@(Var _ n) | Just ann <- UMap.lookupName n whitelist -> Delay ann var t -> t -{- | Whether evaluating the given `Term` is pure and essentially work-free -(barring the CEK machine overhead). --} +-- | Whether evaluating the given `Term` is pure and essentially work-free +-- (barring the CEK machine overhead). --- This should be the erased version of 'PlutusIR.Transform.LetFloat.isEssentiallyWorkFree'. isEssentiallyWorkFree :: Term name uni fun a -> Bool isEssentiallyWorkFree = \case - LamAbs{} -> True - Constant{} -> True - Delay{} -> True - Constr{} -> True - Builtin{} -> True - Var{} -> False - Force{} -> False + LamAbs {} -> True + Constant {} -> True + Delay {} -> True + Constr {} -> True + Builtin {} -> True + Var {} -> False + Force {} -> False -- Unsaturated builtin applications should also be essentially work-free, -- but this is currently not implemented for UPLC. -- `UntypedPlutusCore.Transform.Inline.isPure` has the same problem. - Apply{} -> False - Case{} -> False - Error{} -> False + Apply {} -> False + Case {} -> False + Error {} -> False diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs index 746385cf093..3c37ac44a48 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} + {- Note [Applying force to delays in case branches] Often, the following pattern occurs in UPLC terms: @@ -28,21 +29,24 @@ We should, however, formally define what "well-formed" means, and this is left a FIXME(https://github.com/IntersectMBO/plutus-private/issues/1644). -} -module UntypedPlutusCore.Transform.ForceCaseDelay - ( forceCaseDelay, - ) +module UntypedPlutusCore.Transform.ForceCaseDelay ( + forceCaseDelay, +) where import UntypedPlutusCore.Core -import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (ForceCaseDelay), SimplifierT, - recordSimplification) +import UntypedPlutusCore.Transform.Simplifier ( + SimplifierStage (ForceCaseDelay), + SimplifierT, + recordSimplification, + ) import Control.Lens -forceCaseDelay - :: Monad m - => Term name uni fun a - -> SimplifierT name uni fun a m (Term name uni fun a) +forceCaseDelay :: + Monad m => + Term name uni fun a -> + SimplifierT name uni fun a m (Term name uni fun a) forceCaseDelay term = do let result = transformOf termSubterms processTerm term recordSimplification term ForceCaseDelay result @@ -61,5 +65,5 @@ processTerm = \case findDelayUnderLambdas :: Term name uni fun a -> Maybe (Term name uni fun a) findDelayUnderLambdas = \case LamAbs ann var body -> LamAbs ann var <$> findDelayUnderLambdas body - Delay _ term -> Just term - _ -> Nothing + Delay _ term -> Just term + _ -> Nothing diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs index 8199af10b38..c4a60836c77 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs @@ -140,116 +140,121 @@ if both @x@ and @y@ are pure and work-free. -} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -module UntypedPlutusCore.Transform.ForceDelay - ( forceDelay - ) where +{-# LANGUAGE ViewPatterns #-} + +module UntypedPlutusCore.Transform.ForceDelay ( + forceDelay, +) where import PlutusCore.Builtin (BuiltinSemanticsVariant) import PlutusCore.Default (DefaultFun (IfThenElse), DefaultUni) import PlutusCore.MkPlc (mkIterApp) import UntypedPlutusCore.Core import UntypedPlutusCore.Purity (isPure, isWorkFree) -import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (ForceDelay), SimplifierT, - recordSimplification) +import UntypedPlutusCore.Transform.Simplifier ( + SimplifierStage (ForceDelay), + SimplifierT, + recordSimplification, + ) import Control.Lens (transformOf) import Control.Monad (guard) import Data.Foldable as Foldable (foldl') -{- | Traverses the term, for each node applying the optimisation - detailed above. For implementation details see 'optimisationProcedure'. --} -forceDelay - :: (uni ~ DefaultUni, fun ~ DefaultFun, Monad m) - => BuiltinSemanticsVariant fun - -> Term name uni fun a - -> SimplifierT name uni fun a m (Term name uni fun a) +-- | Traverses the term, for each node applying the optimisation +-- detailed above. For implementation details see 'optimisationProcedure'. +forceDelay :: + (uni ~ DefaultUni, fun ~ DefaultFun, Monad m) => + BuiltinSemanticsVariant fun -> + Term name uni fun a -> + SimplifierT name uni fun a m (Term name uni fun a) forceDelay semVar term = do - let result = transformOf termSubterms (processTerm semVar) term - recordSimplification term ForceDelay result - return result - -{- | Checks whether the term is of the right form, and "pushes" - the 'Force' down into the underlying lambda abstractions. --} -processTerm - :: (uni ~ DefaultUni, fun ~ DefaultFun) - => BuiltinSemanticsVariant fun -> Term name uni fun a -> Term name uni fun a + let result = transformOf termSubterms (processTerm semVar) term + recordSimplification term ForceDelay result + return result + +-- | Checks whether the term is of the right form, and "pushes" +-- the 'Force' down into the underlying lambda abstractions. +processTerm :: + (uni ~ DefaultUni, fun ~ DefaultFun) => + BuiltinSemanticsVariant fun -> Term name uni fun a -> Term name uni fun a processTerm semVar = \case - Force _ (Delay _ t) -> t - -- Remove @Delay@s from @ifThenElse@ branches if the latter is @Force@d and the delayed term are - -- pure and work-free anyway. - Force _ (splitApplication -> + Force _ (Delay _ t) -> t + -- Remove @Delay@s from @ifThenElse@ branches if the latter is @Force@d and the delayed term are + -- pure and work-free anyway. + Force + _ + ( splitApplication -> ( forceIfThenElse@(Force _ (Builtin _ IfThenElse)) - , [cond, (trueAnn, (Delay _ trueAlt)), (falseAnn, (Delay _ falseAlt))] - )) | all (\alt -> isPure semVar alt && isWorkFree semVar alt) [trueAlt, falseAlt] -> - mkIterApp - forceIfThenElse - [cond, (trueAnn, trueAlt), (falseAnn, falseAlt)] - original@(Force _ subTerm) -> - case optimisationProcedure subTerm of - Just result -> result - Nothing -> original - t -> t - -{- | Converts the subterm of a 'Force' into specialised types for representing - multiple applications on top of multiple abstractions. Checks whether the lambda - will eventually get "exactly reduced" and applies the optimisation. - Returns 'Nothing' if the optimisation cannot be applied. --} + , [cond, (trueAnn, (Delay _ trueAlt)), (falseAnn, (Delay _ falseAlt))] + ) + ) + | all (\alt -> isPure semVar alt && isWorkFree semVar alt) [trueAlt, falseAlt] -> + mkIterApp + forceIfThenElse + [cond, (trueAnn, trueAlt), (falseAnn, falseAlt)] + original@(Force _ subTerm) -> + case optimisationProcedure subTerm of + Just result -> result + Nothing -> original + t -> t + +-- | Converts the subterm of a 'Force' into specialised types for representing +-- multiple applications on top of multiple abstractions. Checks whether the lambda +-- will eventually get "exactly reduced" and applies the optimisation. +-- Returns 'Nothing' if the optimisation cannot be applied. optimisationProcedure :: Term name uni fun a -> Maybe (Term name uni fun a) optimisationProcedure term = do - asMultiApply <- toMultiApply term - innerMultiAbs <- toMultiAbs . appHead $ asMultiApply - guard $ length (appSpineRev asMultiApply) == length (absVars innerMultiAbs) - case absRhs innerMultiAbs of - Delay _ subTerm -> - let optimisedInnerMultiAbs = innerMultiAbs { absRhs = subTerm} - optimisedMultiApply = - asMultiApply { appHead = fromMultiAbs optimisedInnerMultiAbs } - in pure . fromMultiApply $ optimisedMultiApply - _ -> Nothing + asMultiApply <- toMultiApply term + innerMultiAbs <- toMultiAbs . appHead $ asMultiApply + guard $ length (appSpineRev asMultiApply) == length (absVars innerMultiAbs) + case absRhs innerMultiAbs of + Delay _ subTerm -> + let optimisedInnerMultiAbs = innerMultiAbs {absRhs = subTerm} + optimisedMultiApply = + asMultiApply {appHead = fromMultiAbs optimisedInnerMultiAbs} + in pure . fromMultiApply $ optimisedMultiApply + _ -> Nothing data MultiApply name uni fun a = MultiApply - { appHead :: Term name uni fun a - , appSpineRev :: [(a, Term name uni fun a)] - } + { appHead :: Term name uni fun a + , appSpineRev :: [(a, Term name uni fun a)] + } toMultiApply :: Term name uni fun a -> Maybe (MultiApply name uni fun a) toMultiApply term = - case term of - Apply _ _ _ -> run [] term - _ -> Nothing + case term of + Apply _ _ _ -> run [] term + _ -> Nothing where run acc (Apply a t1 t2) = - run ((a, t2) : acc) t1 + run ((a, t2) : acc) t1 run acc t = - pure $ MultiApply t acc + pure $ MultiApply t acc fromMultiApply :: MultiApply name uni fun a -> Term name uni fun a fromMultiApply (MultiApply term ts) = - Foldable.foldl' (\acc (ann, arg) -> Apply ann acc arg) term ts + Foldable.foldl' (\acc (ann, arg) -> Apply ann acc arg) term ts data MultiAbs name uni fun a = MultiAbs - { absVars :: [(a, name)] - , absRhs :: Term name uni fun a - } + { absVars :: [(a, name)] + , absRhs :: Term name uni fun a + } toMultiAbs :: Term name uni fun a -> Maybe (MultiAbs name uni fun a) toMultiAbs term = - case term of - LamAbs _ _ _ -> run [] term - _ -> Nothing + case term of + LamAbs _ _ _ -> run [] term + _ -> Nothing where run acc (LamAbs a name t) = - run ((a, name) : acc) t + run ((a, name) : acc) t run acc t = - pure $ MultiAbs acc t + pure $ MultiAbs acc t fromMultiAbs :: MultiAbs name uni fun a -> Term name uni fun a fromMultiAbs (MultiAbs vars term) = - Foldable.foldl' (\acc (ann, name) -> LamAbs ann name acc) term vars + Foldable.foldl' (\acc (ann, name) -> LamAbs ann name acc) term vars diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs index 188e40694c8..e16dd83e682 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs @@ -1,25 +1,24 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -{-| An inlining pass. - -This pass is essentially a copy of the PIR inliner, and should be KEPT IN SYNC -with it. It's hard to do this with true abstraction, so we just have to keep -two copies reasonably similar. - -However, there are some differences. In the interests of making it easier -to keep things in sync, these are explicitly listed in -Note [Differences from PIR inliner]. If you add another difference, -please note it there! Obviously fewer differences is better. - -See Note [The problem of inlining destructors] for why this pass exists. --} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +-- | An inlining pass. +-- +-- This pass is essentially a copy of the PIR inliner, and should be KEPT IN SYNC +-- with it. It's hard to do this with true abstraction, so we just have to keep +-- two copies reasonably similar. +-- +-- However, there are some differences. In the interests of making it easier +-- to keep things in sync, these are explicitly listed in +-- Note [Differences from PIR inliner]. If you add another difference, +-- please note it there! Obviously fewer differences is better. +-- +-- See Note [The problem of inlining destructors] for why this pass exists. module UntypedPlutusCore.Transform.Inline ( inline, InlineHints (..), @@ -50,17 +49,25 @@ import PlutusCore.Quote (MonadQuote (..), Quote) import PlutusCore.Rename (Dupable, dupable, liftDupable) import PlutusPrelude (Generic, fromMaybe) import UntypedPlutusCore.Analysis.Usages qualified as Usages +import UntypedPlutusCore.AstSize (AstSize, termAstSize) import UntypedPlutusCore.Core qualified as UPLC import UntypedPlutusCore.Core.Plated (termSubterms) import UntypedPlutusCore.Core.Type (Term (..), termAnn) import UntypedPlutusCore.MkUPlc (Def (..), UTermDef, UVarDecl (..)) -import UntypedPlutusCore.Purity (EvalTerm (EvalTerm, Unknown), Purity (MaybeImpure, Pure), isPure, - termEvaluationOrder, unEvalOrder) +import UntypedPlutusCore.Purity ( + EvalTerm (EvalTerm, Unknown), + Purity (MaybeImpure, Pure), + isPure, + termEvaluationOrder, + unEvalOrder, + ) import UntypedPlutusCore.Rename () -import UntypedPlutusCore.AstSize (AstSize, termAstSize) import UntypedPlutusCore.Subst (termSubstNamesM) -import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (Inline), SimplifierT, - recordSimplification) +import UntypedPlutusCore.Transform.Simplifier ( + SimplifierStage (Inline), + SimplifierT, + recordSimplification, + ) import Witherable (wither) {- Note [Differences from PIR inliner] @@ -79,16 +86,14 @@ the PIR inliner. -- | Substitution range, 'SubstRng' in the paper. newtype InlineTerm name uni fun a = Done (Dupable (Term name uni fun a)) -{-| Term substitution, 'Subst' in the paper. -A map of unprocessed variable and its substitution range. --} +-- | Term substitution, 'Subst' in the paper. +-- A map of unprocessed variable and its substitution range. newtype TermEnv name uni fun a = TermEnv {_unTermEnv :: PLC.UniqueMap TermUnique (InlineTerm name uni fun a)} deriving newtype (Semigroup, Monoid) -{-| Wrapper of term substitution so that it's similar to the PIR inliner. -See Note [Differences from PIR inliner] 1 --} +-- | Wrapper of term substitution so that it's similar to the PIR inliner. +-- See Note [Differences from PIR inliner] 1 newtype Subst name uni fun a = Subst {_termEnv :: TermEnv name uni fun a} deriving stock (Generic) deriving newtype (Semigroup, Monoid) @@ -99,12 +104,11 @@ makeLenses ''Subst data VarInfo name uni fun ann = VarInfo { _varBinders :: [name] -- ^ Lambda binders in the RHS (definition) of the variable. - , _varRhs :: Term name uni fun ann + , _varRhs :: Term name uni fun ann -- ^ The RHS (definition) of the variable. , _varRhsBody :: InlineTerm name uni fun ann - {- ^ The body of the RHS of the variable (i.e., RHS minus the binders). - Using 'InlineTerm' here to ensure the body is renamed when inlined. - -} + -- ^ The body of the RHS of the variable (i.e., RHS minus the binders). + -- Using 'InlineTerm' here to ensure the body is renamed when inlined. } makeLenses ''VarInfo @@ -112,7 +116,7 @@ makeLenses ''VarInfo -- | UPLC inliner state data S name uni fun a = S { _subst :: Subst name uni fun a - , _vars :: PLC.UniqueMap TermUnique (VarInfo name uni fun a) + , _vars :: PLC.UniqueMap TermUnique (VarInfo name uni fun a) } makeLenses ''S @@ -138,12 +142,12 @@ type InliningConstraints name uni fun = -- See Note [Differences from PIR inliner] 2 data InlineInfo name fun a = InlineInfo - { _iiUsages :: Usages.Usages - , _iiHints :: InlineHints name a + { _iiUsages :: Usages.Usages + , _iiHints :: InlineHints name a , _iiBuiltinSemanticsVariant :: PLC.BuiltinSemanticsVariant fun - , _iiInlineConstants :: Bool - , _iiInlineCallsiteGrowth :: AstSize - , _iiPreserveLogging :: Bool + , _iiInlineConstants :: Bool + , _iiInlineCallsiteGrowth :: AstSize + , _iiPreserveLogging :: Bool } makeLenses ''InlineInfo @@ -156,57 +160,56 @@ type InlineM name uni fun a = ReaderT (InlineInfo name fun a) (StateT (S name uni fun a) Quote) -- | Look up the unprocessed variable in the substitution. -lookupTerm - :: (HasUnique name TermUnique) - => name - -> S name uni fun a - -> Maybe (InlineTerm name uni fun a) +lookupTerm :: + HasUnique name TermUnique => + name -> + S name uni fun a -> + Maybe (InlineTerm name uni fun a) lookupTerm n s = UMap.lookupName n $ s ^. subst . termEnv . unTermEnv -- | Insert the unprocessed variable into the substitution. -extendTerm - :: (HasUnique name TermUnique) - => name - -- ^ The name of the variable. - -> InlineTerm name uni fun a - -- ^ The substitution range. - -> S name uni fun a - -- ^ The substitution. - -> S name uni fun a +extendTerm :: + HasUnique name TermUnique => + -- | The name of the variable. + name -> + -- | The substitution range. + InlineTerm name uni fun a -> + -- | The substitution. + S name uni fun a -> + S name uni fun a extendTerm n clos s = s & subst . termEnv . unTermEnv %~ UMap.insertByName n clos -lookupVarInfo - :: (HasUnique name TermUnique) - => name - -> S name uni fun a - -> Maybe (VarInfo name uni fun a) +lookupVarInfo :: + HasUnique name TermUnique => + name -> + S name uni fun a -> + Maybe (VarInfo name uni fun a) lookupVarInfo n s = UMap.lookupName n $ s ^. vars -extendVarInfo - :: (HasUnique name TermUnique) - => name - -> VarInfo name uni fun a - -> S name uni fun a - -> S name uni fun a +extendVarInfo :: + HasUnique name TermUnique => + name -> + VarInfo name uni fun a -> + S name uni fun a -> + S name uni fun a extendVarInfo n info s = s & vars %~ UMap.insertByName n info -{-| Inline simple bindings. Relies on global uniqueness, and preserves it. -See Note [Inlining and global uniqueness] --} -inline - :: forall name uni fun m a - . (ExternalConstraints name uni fun m) - => AstSize - -- ^ inline threshold - -> Bool - -- ^ inline constants - -> Bool - -- ^ preserve logging - -> InlineHints name a - -> PLC.BuiltinSemanticsVariant fun - -> Term name uni fun a - -> SimplifierT name uni fun a m (Term name uni fun a) +-- | Inline simple bindings. Relies on global uniqueness, and preserves it. +-- See Note [Inlining and global uniqueness] +inline :: + forall name uni fun m a. + ExternalConstraints name uni fun m => + -- | inline threshold + AstSize -> + -- | inline constants + Bool -> + -- | preserve logging + Bool -> + InlineHints name a -> + PLC.BuiltinSemanticsVariant fun -> + Term name uni fun a -> + SimplifierT name uni fun a m (Term name uni fun a) inline callsiteGrowth inlineConstants @@ -232,83 +235,82 @@ inline -- See Note [Differences from PIR inliner] 3 -{-| Extract the list of applications from a term, -a bit like a "multi-beta" reduction. - -Some examples will help: -[(\x . t) a] -> Just ([(x, a)], t) - -[[[(\x . (\y . (\z . t))) a] b] c] -> Just ([(x, a), (y, b), (z, c)]) t) - -[[(\x . t) a] b] -> Nothing --} -extractApps - :: Term name uni fun a - -> Maybe ([UTermDef name uni fun a], Term name uni fun a) +-- | Extract the list of applications from a term, +-- a bit like a "multi-beta" reduction. +-- +-- Some examples will help: +-- [(\x . t) a] -> Just ([(x, a)], t) +-- +-- [[[(\x . (\y . (\z . t))) a] b] c] -> Just ([(x, a), (y, b), (z, c)]) t) +-- +-- [[(\x . t) a] b] -> Nothing +extractApps :: + Term name uni fun a -> + Maybe ([UTermDef name uni fun a], Term name uni fun a) extractApps = go [] - where - go argStack (Apply _ f arg) = go (arg : argStack) f - go argStack t = matchArgs argStack [] t - matchArgs (arg : rest) acc (LamAbs a n body) = - matchArgs rest (Def (UVarDecl a n) arg : acc) body - matchArgs [] acc t = - if null acc then Nothing else Just (reverse acc, t) - matchArgs (_ : _) _ _ = Nothing + where + go argStack (Apply _ f arg) = go (arg : argStack) f + go argStack t = matchArgs argStack [] t + matchArgs (arg : rest) acc (LamAbs a n body) = + matchArgs rest (Def (UVarDecl a n) arg : acc) body + matchArgs [] acc t = + if null acc then Nothing else Just (reverse acc, t) + matchArgs (_ : _) _ _ = Nothing -- | The inverse of 'extractApps'. -restoreApps - :: [UTermDef name uni fun a] - -> Term name uni fun a - -> Term name uni fun a +restoreApps :: + [UTermDef name uni fun a] -> + Term name uni fun a -> + Term name uni fun a restoreApps defs t = makeLams [] t (reverse defs) - where - makeLams args acc (Def (UVarDecl a n) rhs : rest) = - makeLams (rhs : args) (LamAbs a n acc) rest - makeLams args acc [] = - makeApps args acc - -- This isn't the best annotation, but it will do - makeApps (arg : args) acc = - makeApps args (Apply (termAnn acc) acc arg) - makeApps [] acc = acc + where + makeLams args acc (Def (UVarDecl a n) rhs : rest) = + makeLams (rhs : args) (LamAbs a n acc) rest + makeLams args acc [] = + makeApps args acc + -- This isn't the best annotation, but it will do + makeApps (arg : args) acc = + makeApps args (Apply (termAnn acc) acc arg) + makeApps [] acc = acc -- | Run the inliner on a `UntypedPlutusCore.Core.Type.Term`. -processTerm - :: forall name uni fun a - . (InliningConstraints name uni fun) - => Term name uni fun a - -> InlineM name uni fun a (Term name uni fun a) +processTerm :: + forall name uni fun a. + InliningConstraints name uni fun => + Term name uni fun a -> + InlineM name uni fun a (Term name uni fun a) processTerm = handleTerm - where - handleTerm - :: Term name uni fun a - -> InlineM name uni fun a (Term name uni fun a) - handleTerm = \case - v@(Var _ n) -> fromMaybe v <$> substName n - -- See Note [Differences from PIR inliner] 3 - (extractApps -> Just (bs, t)) -> do - bs' <- wither (processSingleBinding t) bs - t' <- processTerm t - pure $ restoreApps bs' t' - t -> inlineSaturatedApp =<< forMOf termSubterms t processTerm - - -- See Note [Renaming strategy] - substName :: name -> InlineM name uni fun a (Maybe (Term name uni fun a)) - substName name = gets (lookupTerm name) >>= traverse renameTerm - - -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] - renameTerm - :: InlineTerm name uni fun a - -> InlineM name uni fun a (Term name uni fun a) - renameTerm = \case - -- Already processed term, just rename and put it in, don't do any - -- further optimization here. - Done t -> liftDupable t - -processSingleBinding - :: (InliningConstraints name uni fun) - => Term name uni fun a - -> UTermDef name uni fun a - -> InlineM name uni fun a (Maybe (UTermDef name uni fun a)) + where + handleTerm :: + Term name uni fun a -> + InlineM name uni fun a (Term name uni fun a) + handleTerm = \case + v@(Var _ n) -> fromMaybe v <$> substName n + -- See Note [Differences from PIR inliner] 3 + (extractApps -> Just (bs, t)) -> do + bs' <- wither (processSingleBinding t) bs + t' <- processTerm t + pure $ restoreApps bs' t' + t -> inlineSaturatedApp =<< forMOf termSubterms t processTerm + + -- See Note [Renaming strategy] + substName :: name -> InlineM name uni fun a (Maybe (Term name uni fun a)) + substName name = gets (lookupTerm name) >>= traverse renameTerm + + -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] + renameTerm :: + InlineTerm name uni fun a -> + InlineM name uni fun a (Term name uni fun a) + renameTerm = \case + -- Already processed term, just rename and put it in, don't do any + -- further optimization here. + Done t -> liftDupable t + +processSingleBinding :: + InliningConstraints name uni fun => + Term name uni fun a -> + UTermDef name uni fun a -> + InlineM name uni fun a (Maybe (UTermDef name uni fun a)) processSingleBinding body (Def vd@(UVarDecl a n) rhs0) = do maybeAddSubst body a n rhs0 >>= \case Just rhs -> do @@ -322,21 +324,20 @@ processSingleBinding body (Def vd@(UVarDecl a n) rhs0) = do pure . Just $ Def vd rhs Nothing -> pure Nothing -{-| Check against the heuristics we have for inlining and either inline -the term binding or not. The arguments to this function are the fields of the -'TermBinding' being processed. -Nothing means that we are inlining the term: - * we have extended the substitution, and - * we are removing the binding (hence we return Nothing). --} -maybeAddSubst - :: forall name uni fun a - . (InliningConstraints name uni fun) - => Term name uni fun a - -> a - -> name - -> Term name uni fun a - -> InlineM name uni fun a (Maybe (Term name uni fun a)) +-- | Check against the heuristics we have for inlining and either inline +-- the term binding or not. The arguments to this function are the fields of the +-- 'TermBinding' being processed. +-- Nothing means that we are inlining the term: +-- * we have extended the substitution, and +-- * we are removing the binding (hence we return Nothing). +maybeAddSubst :: + forall name uni fun a. + InliningConstraints name uni fun => + Term name uni fun a -> + a -> + name -> + Term name uni fun a -> + InlineM name uni fun a (Maybe (Term name uni fun a)) maybeAddSubst body a n rhs0 = do rhs <- processTerm rhs0 @@ -352,121 +353,119 @@ maybeAddSubst body a n rhs0 = do (shouldUnconditionallyInline safeToInline n rhs body) (extendAndDrop (Done $ dupable rhs)) (pure $ Just rhs) - where - extendAndDrop - :: forall b - . InlineTerm name uni fun a - -> InlineM name uni fun a (Maybe b) - extendAndDrop t = modify' (extendTerm n t) >> pure Nothing - -shouldUnconditionallyInline - :: (InliningConstraints name uni fun) - => Bool - {- ^ Whether we know that the binding is safe to inline. - If so, bypass the purity check. - -} - -> name - -> Term name uni fun a - -> Term name uni fun a - -> InlineM name uni fun a Bool + where + extendAndDrop :: + forall b. + InlineTerm name uni fun a -> + InlineM name uni fun a (Maybe b) + extendAndDrop t = modify' (extendTerm n t) >> pure Nothing + +shouldUnconditionallyInline :: + InliningConstraints name uni fun => + -- | Whether we know that the binding is safe to inline. + -- If so, bypass the purity check. + Bool -> + name -> + Term name uni fun a -> + Term name uni fun a -> + InlineM name uni fun a Bool shouldUnconditionallyInline safe n rhs body = do isTermPure <- checkPurity rhs inlineConstants <- view iiInlineConstants preUnconditional isTermPure ||^ postUnconditional inlineConstants isTermPure - where - -- similar to the paper, preUnconditional inlining checks that the binder - -- is 'OnceSafe'. I.e., it's used at most once AND it neither duplicate code - -- or work. While we don't check for lambda etc like in the paper, - -- 'effectSafe' ensures that it isn't doing any substantial work. - -- We actually also inline 'Dead' binders (i.e., remove dead code) here. - preUnconditional isTermPure = - nameUsedAtMostOnce n &&^ (pure safe ||^ effectSafe body n isTermPure) - -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] and - -- [Inlining and purity]. This is the case where we don't know that the number - -- of occurrences is exactly one, so there's no point checking if the term is - -- immediately evaluated. - postUnconditional inlineConstants isTermPure = - pure (safe || isTermPure) &&^ acceptable inlineConstants rhs + where + -- similar to the paper, preUnconditional inlining checks that the binder + -- is 'OnceSafe'. I.e., it's used at most once AND it neither duplicate code + -- or work. While we don't check for lambda etc like in the paper, + -- 'effectSafe' ensures that it isn't doing any substantial work. + -- We actually also inline 'Dead' binders (i.e., remove dead code) here. + preUnconditional isTermPure = + nameUsedAtMostOnce n &&^ (pure safe ||^ effectSafe body n isTermPure) + -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] and + -- [Inlining and purity]. This is the case where we don't know that the number + -- of occurrences is exactly one, so there's no point checking if the term is + -- immediately evaluated. + postUnconditional inlineConstants isTermPure = + pure (safe || isTermPure) &&^ acceptable inlineConstants rhs -- | Check if term is pure. See Note [Inlining and purity] -checkPurity - :: (PLC.ToBuiltinMeaning uni fun) - => Term name uni fun a - -> InlineM name uni fun a Bool +checkPurity :: + PLC.ToBuiltinMeaning uni fun => + Term name uni fun a -> + InlineM name uni fun a Bool checkPurity t = do builtinSemanticsVariant <- view iiBuiltinSemanticsVariant pure $ isPure builtinSemanticsVariant t -nameUsedAtMostOnce - :: forall name uni fun a - . (InliningConstraints name uni fun) - => name - -> InlineM name uni fun a Bool +nameUsedAtMostOnce :: + forall name uni fun a. + InliningConstraints name uni fun => + name -> + InlineM name uni fun a Bool nameUsedAtMostOnce n = do usgs <- view iiUsages -- 'inlining' terms used 0 times is a cheap way to remove dead code -- while we're here pure $ Usages.getUsageCount n usgs <= 1 -isFirstVarBeforeEffects - :: forall name uni fun ann - . (InliningConstraints name uni fun) - => BuiltinSemanticsVariant fun - -> name - -> Term name uni fun ann - -> Bool +isFirstVarBeforeEffects :: + forall name uni fun ann. + InliningConstraints name uni fun => + BuiltinSemanticsVariant fun -> + name -> + Term name uni fun ann -> + Bool isFirstVarBeforeEffects builtinSemanticsVariant n t = -- This can in the worst case traverse a lot of the term, which could lead to -- us doing ~quadratic work as we process the program. However in practice -- most terms have a relatively short evaluation order before we hit Unknown, -- so it's not too bad. go (unEvalOrder (termEvaluationOrder builtinSemanticsVariant t)) - where - -- Found the variable we're looking for! - go ((EvalTerm _ _ (Var _ n')) : _) | n == n' = True - -- Found a pure term, ignore it and continue - go ((EvalTerm Pure _ _) : rest) = go rest - -- Found a possibly impure term, our variable is definitely not first - go ((EvalTerm MaybeImpure _ _) : _) = False - -- Don't know, be conservative - go (Unknown : _) = False - go [] = False - -{-| Check if the given name is strict in the given term. - This means that at least one occurrence of the name is found outside of the following: - * 'delay' term - * lambda body - * case branch --} -isStrictIn - :: forall name uni fun a - . (Eq name) - => name - -> Term name uni fun a - -> Bool + where + -- Found the variable we're looking for! + go ((EvalTerm _ _ (Var _ n')) : _) | n == n' = True + -- Found a pure term, ignore it and continue + go ((EvalTerm Pure _ _) : rest) = go rest + -- Found a possibly impure term, our variable is definitely not first + go ((EvalTerm MaybeImpure _ _) : _) = False + -- Don't know, be conservative + go (Unknown : _) = False + go [] = False + +-- | Check if the given name is strict in the given term. +-- This means that at least one occurrence of the name is found outside of the following: +-- * 'delay' term +-- * lambda body +-- * case branch +isStrictIn :: + forall name uni fun a. + Eq name => + name -> + Term name uni fun a -> + Bool isStrictIn name = go - where - go :: Term name uni fun a -> Bool - go = \case - Var _ann name' -> name == name' - LamAbs _ann _paramName _body -> False - Apply _ann t1 t2 -> go t1 || go t2 - Force _ann t -> go t - Delay _ann _term -> False - Constant{} -> False - Builtin{} -> False - Error{} -> False - Constr _ann _idx terms -> any go terms - Case _ann scrut _branches -> go scrut - -effectSafe - :: forall name uni fun a - . (InliningConstraints name uni fun) - => Term name uni fun a - -> name - -> Bool - -- ^ is it pure? See Note [Inlining and purity] - -> InlineM name uni fun a Bool + where + go :: Term name uni fun a -> Bool + go = \case + Var _ann name' -> name == name' + LamAbs _ann _paramName _body -> False + Apply _ann t1 t2 -> go t1 || go t2 + Force _ann t -> go t + Delay _ann _term -> False + Constant {} -> False + Builtin {} -> False + Error {} -> False + Constr _ann _idx terms -> any go terms + Case _ann scrut _branches -> go scrut + +effectSafe :: + forall name uni fun a. + InliningConstraints name uni fun => + Term name uni fun a -> + name -> + -- | is it pure? See Note [Inlining and purity] + Bool -> + InlineM name uni fun a Bool effectSafe body n termIsPure = do preserveLogging <- view iiPreserveLogging builtinSemantics <- view iiBuiltinSemanticsVariant @@ -475,85 +474,82 @@ effectSafe body n termIsPure = do || isFirstVarBeforeEffects builtinSemantics n body || (not preserveLogging && isStrictIn n body) -{-| Should we inline? Should only inline things that won't duplicate work -or code. See Note [Inlining approach and 'Secrets of the GHC Inliner'] --} -acceptable - :: Bool - -- ^ inline constants - -> Term name uni fun a - -> InlineM name uni fun a Bool +-- | Should we inline? Should only inline things that won't duplicate work +-- or code. See Note [Inlining approach and 'Secrets of the GHC Inliner'] +acceptable :: + -- | inline constants + Bool -> + Term name uni fun a -> + InlineM name uni fun a Bool acceptable inlineConstants t = -- See Note [Inlining criteria] pure $ costIsAcceptable t && sizeIsAcceptable inlineConstants t -{-| Is the cost increase (in terms of evaluation work) of inlining a variable -whose RHS is the given term acceptable? --} +-- | Is the cost increase (in terms of evaluation work) of inlining a variable +-- whose RHS is the given term acceptable? costIsAcceptable :: Term name uni fun a -> Bool costIsAcceptable = \case - Builtin{} -> True - Var{} -> True - Constant{} -> True - Error{} -> True + Builtin {} -> True + Var {} -> True + Constant {} -> True + Error {} -> True -- This will mean that we create closures at each use site instead of -- once, but that's a very low cost which we're okay rounding to 0. - LamAbs{} -> True - Apply{} -> False + LamAbs {} -> True + Apply {} -> False -- Inlining constructors of size 1 or 0 seems okay, but does result in doing -- the work for the elements at each use site. Constr _ _ es -> case es of - [] -> True + [] -> True [e] -> costIsAcceptable e - _ -> False + _ -> False -- Inlining a case means redoing the match at each use site - Case{} -> False - Force{} -> False - Delay{} -> True - -{-| Is the size increase (in the AST) of inlining a variable whose RHS is -the given term acceptable? --} -sizeIsAcceptable - :: Bool - -- ^ inline constants - -> Term name uni fun a - -> Bool + Case {} -> False + Force {} -> False + Delay {} -> True + +-- | Is the size increase (in the AST) of inlining a variable whose RHS is +-- the given term acceptable? +sizeIsAcceptable :: + -- | inline constants + Bool -> + Term name uni fun a -> + Bool sizeIsAcceptable inlineConstants = \case - Builtin{} -> True - Var{} -> True - Error{} -> True + Builtin {} -> True + Var {} -> True + Error {} -> True -- See Note [Differences from PIR inliner] 4 - LamAbs{} -> False + LamAbs {} -> False -- Inlining constructors of size 1 or 0 seems okay Constr _ _ es -> case es of - [] -> True + [] -> True [e] -> sizeIsAcceptable inlineConstants e - _ -> False + _ -> False -- Cases are pretty big, due to the case branches - Case{} -> False + Case {} -> False -- Inlining constants is deemed acceptable if the 'inlineConstants' -- flag is turned on, see Note [Inlining constants]. - Constant{} -> inlineConstants - Apply{} -> False + Constant {} -> inlineConstants + Apply {} -> False Force _ t -> sizeIsAcceptable inlineConstants t Delay _ t -> sizeIsAcceptable inlineConstants t -- | Fully apply and beta reduce. -fullyApplyAndBetaReduce - :: forall name uni fun a - . (InliningConstraints name uni fun) - => VarInfo name uni fun a - -> [(a, Term name uni fun a)] - -> InlineM name uni fun a (Maybe (Term name uni fun a)) +fullyApplyAndBetaReduce :: + forall name uni fun a. + InliningConstraints name uni fun => + VarInfo name uni fun a -> + [(a, Term name uni fun a)] -> + InlineM name uni fun a (Maybe (Term name uni fun a)) fullyApplyAndBetaReduce info args0 = do rhsBody <- liftDupable (let Done rhsBody = info ^. varRhsBody in rhsBody) - let go - :: Term name uni fun a - -> [name] - -> [(a, Term name uni fun a)] - -> InlineM name uni fun a (Maybe (Term name uni fun a)) + let go :: + Term name uni fun a -> + [name] -> + [(a, Term name uni fun a)] -> + InlineM name uni fun a (Maybe (Term name uni fun a)) go acc bs args = case (bs, args) of ([], _) -> pure . Just $ mkIterApp acc args (param : params, (_ann, arg) : args') -> do @@ -575,22 +571,21 @@ fullyApplyAndBetaReduce info args0 = do -- Is it safe to turn `(\a -> body) arg` into `body [a := arg]`? -- The criteria is the same as the criteria for unconditionally -- inlining `a`, since inlining is the same as beta reduction. - safeToBetaReduce - :: name - -> Term name uni fun a - -> InlineM name uni fun a Bool + safeToBetaReduce :: + name -> + Term name uni fun a -> + InlineM name uni fun a Bool safeToBetaReduce a arg = shouldUnconditionallyInline False a arg rhsBody go rhsBody (info ^. varBinders) args0 -{-| This works in the same way as -'PlutusIR.Transform.Inline.CallSiteInline.inlineSaturatedApp'. -See Note [Inlining and beta reduction of functions]. --} -inlineSaturatedApp - :: forall name uni fun a - . (InliningConstraints name uni fun) - => Term name uni fun a - -> InlineM name uni fun a (Term name uni fun a) +-- | This works in the same way as +-- 'PlutusIR.Transform.Inline.CallSiteInline.inlineSaturatedApp'. +-- See Note [Inlining and beta reduction of functions]. +inlineSaturatedApp :: + forall name uni fun a. + InliningConstraints name uni fun => + Term name uni fun a -> + InlineM name uni fun a (Term name uni fun a) inlineSaturatedApp t | (Var _ann name, args) <- UPLC.splitApplication t = gets (lookupVarInfo name) >>= \case diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Simplifier.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Simplifier.hs index 1bc15c5a97e..de56efb2c8f 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Simplifier.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Simplifier.hs @@ -1,19 +1,19 @@ {-# LANGUAGE NamedFieldPuns #-} module UntypedPlutusCore.Transform.Simplifier ( - SimplifierT (..), - SimplifierTrace (..), - SimplifierStage (..), - Simplification (..), - runSimplifierT, - evalSimplifierT, - execSimplifierT, - Simplifier, - runSimplifier, - evalSimplifier, - execSimplifier, - initSimplifierTrace, - recordSimplification, + SimplifierT (..), + SimplifierTrace (..), + SimplifierStage (..), + Simplification (..), + runSimplifierT, + evalSimplifierT, + execSimplifierT, + Simplifier, + runSimplifier, + evalSimplifier, + execSimplifier, + initSimplifierTrace, + recordSimplification, ) where import Control.Monad.State (MonadTrans, StateT) @@ -23,25 +23,25 @@ import Control.Monad.Identity (Identity, runIdentity) import PlutusCore.Quote (MonadQuote) import UntypedPlutusCore.Core.Type (Term) -newtype SimplifierT name uni fun ann m a = - SimplifierT - { getSimplifierT :: StateT (SimplifierTrace name uni fun ann) m a - } +newtype SimplifierT name uni fun ann m a + = SimplifierT + { getSimplifierT :: StateT (SimplifierTrace name uni fun ann) m a + } deriving newtype (Functor, Applicative, Monad, MonadTrans) instance MonadQuote m => MonadQuote (SimplifierT name uni fun ann m) -runSimplifierT - :: SimplifierT name uni fun ann m a - -> m (a, SimplifierTrace name uni fun ann) +runSimplifierT :: + SimplifierT name uni fun ann m a -> + m (a, SimplifierTrace name uni fun ann) runSimplifierT = flip State.runStateT initSimplifierTrace . getSimplifierT -evalSimplifierT - :: Monad m => SimplifierT name uni fun ann m a -> m a +evalSimplifierT :: + Monad m => SimplifierT name uni fun ann m a -> m a evalSimplifierT = flip State.evalStateT initSimplifierTrace . getSimplifierT -execSimplifierT - :: Monad m => SimplifierT name uni fun ann m a -> m (SimplifierTrace name uni fun ann) +execSimplifierT :: + Monad m => SimplifierT name uni fun ann m a -> m (SimplifierTrace name uni fun ann) execSimplifierT = flip State.execStateT initSimplifierTrace . getSimplifierT type Simplifier name uni fun ann = SimplifierT name uni fun ann Identity @@ -64,34 +64,33 @@ data SimplifierStage | Inline | CSE -data Simplification name uni fun a = - Simplification - { beforeAST :: Term name uni fun a - , stage :: SimplifierStage - , afterAST :: Term name uni fun a - } +data Simplification name uni fun a + = Simplification + { beforeAST :: Term name uni fun a + , stage :: SimplifierStage + , afterAST :: Term name uni fun a + } -- TODO2: we probably don't want this in memory so after MVP -- we should consider serializing this to disk -newtype SimplifierTrace name uni fun a = - SimplifierTrace - { simplifierTrace - :: [Simplification name uni fun a] - } +newtype SimplifierTrace name uni fun a + = SimplifierTrace + { simplifierTrace :: + [Simplification name uni fun a] + } initSimplifierTrace :: SimplifierTrace name uni fun a initSimplifierTrace = SimplifierTrace [] -recordSimplification - :: Monad m - => Term name uni fun a - -> SimplifierStage - -> Term name uni fun a - -> SimplifierT name uni fun a m () +recordSimplification :: + Monad m => + Term name uni fun a -> + SimplifierStage -> + Term name uni fun a -> + SimplifierT name uni fun a m () recordSimplification beforeAST stage afterAST = - let simplification = Simplification { beforeAST, stage, afterAST } - in - modify $ \st -> - st { simplifierTrace = simplification : simplifierTrace st } + let simplification = Simplification {beforeAST, stage, afterAST} + in modify $ \st -> + st {simplifierTrace = simplification : simplifierTrace st} where modify f = SimplifierT $ State.modify' f diff --git a/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs index fbba9d415d5..172df89b89e 100644 --- a/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs @@ -75,21 +75,21 @@ testSomeTypeSomeTermArgsLeft :: TestTree testSomeTypeSomeTermArgsLeft = testCase "some type args and some term args are unapplied" $ map (isPure builtinSemantics) terms @?= [True, True] - where - terms :: [Term Name DefaultUni DefaultFun ()] = - [ Builtin () Trace -- 1 type arg and 2 term args are unapplied - , Force () (Builtin () FstPair) -- 2 type args, 1 applied and 1 left - ] + where + terms :: [Term Name DefaultUni DefaultFun ()] = + [ Builtin () Trace -- 1 type arg and 2 term args are unapplied + , Force () (Builtin () FstPair) -- 2 type args, 1 applied and 1 left + ] testNoTypeSomeTermArgsLeft :: TestTree testNoTypeSomeTermArgsLeft = testCase "no type args and some term args are unapplied" $ map (isPure builtinSemantics) terms @?= [True, True] - where - terms :: [Term Name DefaultUni DefaultFun ()] = - [ Builtin () EncodeUtf8 -- no type args, 1 term arg left to apply - , Force () (Builtin () Trace) -- 1 type arg applied, 2 term args left - ] + where + terms :: [Term Name DefaultUni DefaultFun ()] = + [ Builtin () EncodeUtf8 -- no type args, 1 term arg left to apply + , Force () (Builtin () Trace) -- 1 type arg applied, 2 term args left + ] testNoTypeNoTermArgsLeft :: TestTree testNoTypeNoTermArgsLeft = @@ -98,16 +98,16 @@ testNoTypeNoTermArgsLeft = [ testAddInteger , testIfThenElse ] - where - testAddInteger :: TestTree = - testCase "AddInteger" $ isPure builtinSemantics term @?= False - where - term :: Term Name DefaultUni DefaultFun () = - Apply () (Apply () (Builtin () AddInteger) (termVar 1)) (termVar 2) + where + testAddInteger :: TestTree = + testCase "AddInteger" $ isPure builtinSemantics term @?= False + where + term :: Term Name DefaultUni DefaultFun () = + Apply () (Apply () (Builtin () AddInteger) (termVar 1)) (termVar 2) - testIfThenElse :: TestTree = - testCase "IfThenElseApplied" $ - isPure builtinSemantics termIfThenElse @?= False + testIfThenElse :: TestTree = + testCase "IfThenElseApplied" $ + isPure builtinSemantics termIfThenElse @?= False testForceNoTypeParam :: TestTree testForceNoTypeParam = @@ -123,8 +123,8 @@ testApplyNoTermParam = , testCase "when a builtin is saturated" $ isPure builtinSemantics termSaturated @?= False ] - where - termExpectingType :: Term Name DefaultUni DefaultFun () = - Apply () (Builtin () Trace) (termVar 1) - termSaturated :: Term Name DefaultUni DefaultFun () = - Apply () (Builtin () EncodeUtf8) (termVar 1) + where + termExpectingType :: Term Name DefaultUni DefaultFun () = + Apply () (Builtin () Trace) (termVar 1) + termSaturated :: Term Name DefaultUni DefaultFun () = + Apply () (Builtin () EncodeUtf8) (termVar 1) diff --git a/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs b/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs index d99a6a3894d..784864f7623 100644 --- a/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs +++ b/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} + -- | Check compatibility of Flat Natural to Flat Word64 -- needed for Index (de)serialization see Note [DeBruijn Index serialization] module DeBruijn.FlatNatWord (test_flatNatWord) where @@ -17,100 +18,101 @@ import PlutusCore.Flat import PlutusCore.Flat.Encoder import Test.Tasty import Test.Tasty.Extras -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog -- test that Natural and Word64 are compatible inside -- the (minBound,maxBound) bounds of Word64 prop_CompatInBounds :: TestTree prop_CompatInBounds = testProperty "compatible inside bounds" $ property $ do - -- test that their encodings are byte-to-byte the same - w <- forAll $ Gen.word64 Range.linearBounded - let n :: Natural = fromIntegral w - flat w === flat n + -- test that their encodings are byte-to-byte the same + w <- forAll $ Gen.word64 Range.linearBounded + let n :: Natural = fromIntegral w + flat w === flat n - -- Tripping from encoded as natural to decoded as word - tripping w (flat @Natural . fromIntegral) unflat + -- Tripping from encoded as natural to decoded as word + tripping w (flat @Natural . fromIntegral) unflat - -- Tripping from encoded as word to decoded as natural - tripping n (flat @Word64 . fromIntegral) unflat + -- Tripping from encoded as word to decoded as natural + tripping n (flat @Word64 . fromIntegral) unflat prop_DecLarger :: TestTree prop_DecLarger = testProperty "dec outside bounds" $ property $ do - n <- forAll $ Gen.integral $ Range.linear (maxWord64AsNat+1) (maxWord64AsNat*10) - Hedgehog.assert $ isLeft $ unflat @Word64 $ flat @Natural n + n <- forAll $ Gen.integral $ Range.linear (maxWord64AsNat + 1) (maxWord64AsNat * 10) + Hedgehog.assert $ isLeft $ unflat @Word64 $ flat @Natural n test_MinBound :: TestTree test_MinBound = testCase "compatible minbound" $ do - let w = minBound @Word64 - n :: Natural = fromIntegral w - flat w == flat n @? "enc minbound does not match" - -- Tripping from encoded as natural to decoded as word - Right w == (unflat $ flat n) @? "tripping1 minbound failed" - -- Tripping from encoded as word to decoded as natural - Right n == (unflat $ flat w) @? "tripping1 minbound failed" + let w = minBound @Word64 + n :: Natural = fromIntegral w + flat w == flat n @? "enc minbound does not match" + -- Tripping from encoded as natural to decoded as word + Right w == (unflat $ flat n) @? "tripping1 minbound failed" + -- Tripping from encoded as word to decoded as natural + Right n == (unflat $ flat w) @? "tripping1 minbound failed" test_MaxBound :: TestTree test_MaxBound = testCase "compatible maxbound" $ do - let w = maxBound @Word64 - n :: Natural = fromIntegral w - flat w == flat n @? "enc maxbound does not match" - -- Tripping from encoded as natural to decoded as word - Right w == (unflat $ flat n) @? "tripping1 maxbound failed" - -- Tripping from encoded as word to decoded as natural - Right n == (unflat $ flat w) @? "tripping1 maxbound failed" - + let w = maxBound @Word64 + n :: Natural = fromIntegral w + flat w == flat n @? "enc maxbound does not match" + -- Tripping from encoded as natural to decoded as word + Right w == (unflat $ flat n) @? "tripping1 maxbound failed" + -- Tripping from encoded as word to decoded as natural + Right n == (unflat $ flat w) @? "tripping1 maxbound failed" prop_OldVsNewIndex :: TestTree prop_OldVsNewIndex = testProperty "oldVsNew Index" $ property $ do - n <- forAll $ Gen.integral $ Range.linear minWord64AsNat (maxWord64AsNat*10) - let encoded = flat @Natural n - isCompatible = curry $ \case - (Right (Index newDecoded), Right (OldIndex oldDecoded)) -> newDecoded == oldDecoded - (Left _, Left _) -> True - _ -> False + n <- forAll $ Gen.integral $ Range.linear minWord64AsNat (maxWord64AsNat * 10) + let encoded = flat @Natural n + isCompatible = curry $ \case + (Right (Index newDecoded), Right (OldIndex oldDecoded)) -> newDecoded == oldDecoded + (Left _, Left _) -> True + _ -> False - Hedgehog.assert $ unflat @Index encoded `isCompatible` unflat @OldIndex encoded + Hedgehog.assert $ unflat @Index encoded `isCompatible` unflat @OldIndex encoded test_flatNatWord :: TestNested test_flatNatWord = - testNested "FlatNatWord" $ map embed - [ test_MinBound - , test_MaxBound - , prop_CompatInBounds - , prop_DecLarger - , prop_OldVsNewIndex - ] + testNested "FlatNatWord" $ + map + embed + [ test_MinBound + , test_MaxBound + , prop_CompatInBounds + , prop_DecLarger + , prop_OldVsNewIndex + ] -- * Old implementation of Flat Index copy-pasted and renamed to OldIndex -{- | -The old implementation relied on this function which is safe -*only* for 64-bit systems. There were previously safety checks to fail compilation -on other systems, but we removed them since we only test on 64-bit systems afterall. --} +-- | +-- The old implementation relied on this function which is safe +-- *only* for 64-bit systems. There were previously safety checks to fail compilation +-- on other systems, but we removed them since we only test on 64-bit systems afterall. naturalToWord64Maybe :: Natural -> Maybe Word64 naturalToWord64Maybe n = fromIntegral <$> naturalToWordMaybe n -{-# INLINABLE naturalToWord64Maybe #-} +{-# INLINEABLE naturalToWord64Maybe #-} newtype OldIndex = OldIndex {unOldIndex :: Word64} deriving stock (Generic) deriving newtype (Show, Num, Enum, Ord, Real, Integral, Eq) instance Flat OldIndex where - -- encode from word64 to natural - encode = encode @Natural . fromIntegral - -- decode from natural to word64 - decode = do - n <- decode @Natural - case naturalToWord64Maybe n of - Nothing -> fail $ "Index outside representable range: " ++ show n - Just w64 -> pure $ OldIndex w64 - -- to be exact, we must not let this be generically derived, - -- because the `gsize` would derive the size of the underlying Word64, - -- whereas we want the size of Natural - size = sNatural . fromIntegral - + -- encode from word64 to natural + encode = encode @Natural . fromIntegral + + -- decode from natural to word64 + decode = do + n <- decode @Natural + case naturalToWord64Maybe n of + Nothing -> fail $ "Index outside representable range: " ++ show n + Just w64 -> pure $ OldIndex w64 + + -- to be exact, we must not let this be generically derived, + -- because the `gsize` would derive the size of the underlying Word64, + -- whereas we want the size of Natural + size = sNatural . fromIntegral -- * helpers diff --git a/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs b/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs index f6b08829132..52687350e71 100644 --- a/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs +++ b/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-} + -- | The point of these tests is that *both* binders with wrong indices and -- variables with wrong indices (e.g. out of scope) will fail the scope-check pass. module DeBruijn.Scope (test_scope) where @@ -19,37 +20,38 @@ type T = Term DeBruijn DefaultUni DefaultFun () testsOk :: [(String, T)] testsOk = - [("idFun0", idFun0) - ,("deepFun0", deepFun0 10) - ,("deeperFun0", deeperFun0 10) - ] + [ ("idFun0", idFun0) + , ("deepFun0", deepFun0 10) + , ("deeperFun0", deeperFun0 10) + ] testsFail :: [(String, T)] testsFail = - [("delay0", Delay () var0) - ,("top0", var0) - ,("top1", Var () $ DeBruijn 1) - ,("fun1var1", fun1var1) - ,("fun0var0", fun0var0) - ,("fun1var0", fun1var0) - ,("const0var0", const0 @@ [unitval, fun0var0]) - ,("const0var1", const0 @@ [unitval, fun1var1]) - ,("ite10", ite10) - ,("deepOut0", deepOut0 10) - ,("deepFun1", deepFun1 10) - ,("deepMix0_1", deepMix0_1 10) - ,("deepOutMix1_0", deepOutMix1_0 10) - ,("manyFree01", manyFree01) - ] + [ ("delay0", Delay () var0) + , ("top0", var0) + , ("top1", Var () $ DeBruijn 1) + , ("fun1var1", fun1var1) + , ("fun0var0", fun0var0) + , ("fun1var0", fun1var0) + , ("const0var0", const0 @@ [unitval, fun0var0]) + , ("const0var1", const0 @@ [unitval, fun1var1]) + , ("ite10", ite10) + , ("deepOut0", deepOut0 10) + , ("deepFun1", deepFun1 10) + , ("deepMix0_1", deepMix0_1 10) + , ("deepOutMix1_0", deepOutMix1_0 10) + , ("manyFree01", manyFree01) + ] test_scope :: TestNested -test_scope = testNested "Scope" $ embed . uncurry testCase <$> - (second testPasses <$> testsOk) - <> (second testThrows <$> testsFail) - where - testPasses t = isRight (runScope t) @? "scope checking failed unexpectedly" - - testThrows t = isLeft (runScope t) @? "scope checking passed unexpectedly" +test_scope = + testNested "Scope" $ + embed . uncurry testCase + <$> (second testPasses <$> testsOk) + <> (second testThrows <$> testsFail) + where + testPasses t = isRight (runScope t) @? "scope checking failed unexpectedly" - runScope = runExcept @FreeVariableError . checkScope + testThrows t = isLeft (runScope t) @? "scope checking passed unexpectedly" + runScope = runExcept @FreeVariableError . checkScope diff --git a/plutus-core/untyped-plutus-core/testlib/DeBruijn/Spec.hs b/plutus-core/untyped-plutus-core/testlib/DeBruijn/Spec.hs index 9d3dc471891..9fb1e578ef4 100644 --- a/plutus-core/untyped-plutus-core/testlib/DeBruijn/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/DeBruijn/Spec.hs @@ -8,8 +8,8 @@ import Test.Tasty.Extras test_debruijn :: TestTree test_debruijn = - runTestNested ["untyped-plutus-core", "test", "DeBruijn"] $ - [ test_undebruijnify - , test_scope - , test_flatNatWord - ] + runTestNested ["untyped-plutus-core", "test", "DeBruijn"] $ + [ test_undebruijnify + , test_scope + , test_flatNatWord + ] diff --git a/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs b/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs index 4822b52cdd1..8abe108232b 100644 --- a/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs +++ b/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-} + -- | The point of these tests is that binders with wrong indices will be undebruijnified -- successfully, whereas variables with wrong indices (e.g. out of scope) will fail. module DeBruijn.UnDeBruijnify (test_undebruijnify) where @@ -22,66 +23,72 @@ type T = Term DeBruijn DefaultUni DefaultFun () -- | (lam0 [2 1 4 (lam1 [1 4 3 5])]) graceElaborate :: T -graceElaborate = lamAbs0 $ - v 2 @@ [ v 1 - , v 4 - , lamAbs1 $ v 1 @@ [ v 4 - , v 3 - , v 5 - ] - ] - where - v = Var () . DeBruijn +graceElaborate = + lamAbs0 $ + v 2 + @@ [ v 1 + , v 4 + , lamAbs1 $ + v 1 + @@ [ v 4 + , v 3 + , v 5 + ] + ] + where + v = Var () . DeBruijn testsDefault :: [(String, T)] testsDefault = - [("okId0", idFun0) - ,("okId99", fun1var1) - ,("okConst", const0 @@ [true, fun1var1]) - ,("okDeep0", deepFun0 10) - ,("okDeep99", deepFun1 10) - ,("okMix1", deepMix0_1 10) - ,("okMix2", deepMix1_0 10) - ,("failTop", Delay () var0) - ,("failDeep", deepOut0 10) - ,("failBody0", fun0var0) - ,("failBody99", fun1var0) - ,("failConst", const0 @@ [true, fun0var0]) - ,("failITE", ite10) - ,("failMix", deepOutMix1_0 10) - ,("failTop0", var0) - ,("failTop1", Var () $ DeBruijn 1) - ,("failApply01", manyFree01) - ] + [ ("okId0", idFun0) + , ("okId99", fun1var1) + , ("okConst", const0 @@ [true, fun1var1]) + , ("okDeep0", deepFun0 10) + , ("okDeep99", deepFun1 10) + , ("okMix1", deepMix0_1 10) + , ("okMix2", deepMix1_0 10) + , ("failTop", Delay () var0) + , ("failDeep", deepOut0 10) + , ("failBody0", fun0var0) + , ("failBody99", fun1var0) + , ("failConst", const0 @@ [true, fun0var0]) + , ("failITE", ite10) + , ("failMix", deepOutMix1_0 10) + , ("failTop0", var0) + , ("failTop1", Var () $ DeBruijn 1) + , ("failApply01", manyFree01) + ] -- | This is testing the (non-default) behavior of undebruijnification where -- free debruijn indices are gracefully (without throwing an error) converted to fresh uniques. -- See `freeIndexAsConsistentLevel` testsGrace :: [(String, T)] testsGrace = - [("graceTop", Delay () var0) - ,("graceDeep", deepOut0 5) - ,("graceConst", const0 @@ [true, fun0var0]) - ,("graceElaborate", graceElaborate) - ] + [ ("graceTop", Delay () var0) + , ("graceDeep", deepOut0 5) + , ("graceConst", const0 @@ [true, fun0var0]) + , ("graceElaborate", graceElaborate) + ] test_undebruijnify :: TestNested -test_undebruijnify = testNested "Golden" - [testNested "Default" $ - fmap (nestedGoldenVsPretty actDefault) testsDefault - ,testNested "Graceful" $ - fmap (nestedGoldenVsPretty actGrace) testsGrace - ] +test_undebruijnify = + testNested + "Golden" + [ testNested "Default" $ + fmap (nestedGoldenVsPretty actDefault) testsDefault + , testNested "Graceful" $ + fmap (nestedGoldenVsPretty actGrace) testsGrace + ] where - nestedGoldenVsPretty act (n,t) = - nestedGoldenVsDoc n ".uplc" $ toPretty $ act $ mkProg t + nestedGoldenVsPretty act (n, t) = + nestedGoldenVsDoc n ".uplc" $ toPretty $ act $ mkProg t actDefault = progTerm $ modifyError FreeVariableErrorE . unDeBruijnTerm - actGrace = flip evalStateT mempty - . progTerm (unDeBruijnTermWith freeIndexAsConsistentLevel) + actGrace = + flip evalStateT mempty + . progTerm (unDeBruijnTermWith freeIndexAsConsistentLevel) mkProg = Program () PLC.latestVersion . termMapNames fakeNameDeBruijn toPretty = prettyPlcClassicSimple . runExcept @(Error DefaultUni DefaultFun ()) . runQuoteT - diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins.hs index b3609602339..a4e56031a54 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins.hs @@ -8,8 +8,9 @@ import Test.Tasty test_builtins :: TestTree test_builtins = - testGroup "builtins" - [ test_definition - , test_makeRead - , test_costing - ] + testGroup + "builtins" + [ test_definition + , test_makeRead + , test_costing + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381.hs index bd4e9dd6e30..ce8ac1dee26 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381.hs @@ -1,20 +1,27 @@ -- editorconfig-checker-disable {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -{- | Property tests for the BLS12-381 builtins -} +-- | Property tests for the BLS12-381 builtins module Evaluation.Builtins.BLS12_381 where import Evaluation.Builtins.BLS12_381.TestClasses import Evaluation.Builtins.BLS12_381.Utils -import Evaluation.Builtins.Common (PlcTerm, TypeErrorOrCekResult (..), bytestring, cekSuccessFalse, - cekSuccessTrue, evalTerm, integer, mkApp2) +import Evaluation.Builtins.Common ( + PlcTerm, + TypeErrorOrCekResult (..), + bytestring, + cekSuccessFalse, + cekSuccessTrue, + evalTerm, + integer, + mkApp2, + ) import PlutusCore.Crypto.BLS12_381.G1 qualified as G1 import PlutusCore.Crypto.BLS12_381.G2 qualified as G2 import PlutusCore.Default @@ -41,7 +48,6 @@ mkTestName s = printf "%s_%s" (groupName @g) s withNTests :: Testable prop => prop -> Property withNTests = withMaxSuccess 200 - -- QuickCheck generators for scalars and group elements as PLC terms -- Convert objects to terms, just for convenience. @@ -55,9 +61,12 @@ asPlc = mkConstant () -} arbitraryScalar :: Gen Integer arbitraryScalar = - frequency [ (1, arbitraryBuiltin @Integer) - , (4, choose (-b, b))] - where b = (2::Integer)^(10000::Integer) + frequency + [ (1, arbitraryBuiltin @Integer) + , (4, choose (-b, b)) + ] + where + b = (2 :: Integer) ^ (10000 :: Integer) -- Arbitrary scalar as PLC constant arbitraryPlcScalar :: Gen PlcTerm @@ -79,9 +88,10 @@ arbitraryNonZeroPlcConst = asPlc <$> arbitraryNonZero @g -- | Group addition is associative. test_add_assoc :: forall g. TestableAbelianGroup g => TestTree test_add_assoc = - testProperty - (mkTestName @g "add_assoc") . - withNTests $ do + testProperty + (mkTestName @g "add_assoc") + . withNTests + $ do p1 <- arbitraryPlcConst @g p2 <- arbitraryPlcConst @g p3 <- arbitraryPlcConst @g @@ -91,20 +101,22 @@ test_add_assoc = -- | Zero is an identity for addition. test_add_zero :: forall g. TestableAbelianGroup g => TestTree test_add_zero = - testProperty - (mkTestName @g "add_zero") . - withNTests $ do + testProperty + (mkTestName @g "add_zero") + . withNTests + $ do p <- arbitraryPlcConst @g - let e = eqTerm @g (addTerm @g p $ zeroTerm @g) p + let e = eqTerm @g (addTerm @g p $ zeroTerm @g) p pure $ evalTerm e === cekSuccessTrue -- | Every element has an inverse -- | a+(-a) = 0 for all group elements. test_neg :: forall g. TestableAbelianGroup g => TestTree test_neg = - testProperty - (mkTestName @g "additive_inverse") . - withNTests $ do + testProperty + (mkTestName @g "additive_inverse") + . withNTests + $ do p <- arbitraryPlcConst @g let e = eqTerm @g (addTerm @g p (negTerm @g p)) $ zeroTerm @g pure $ evalTerm e === cekSuccessTrue @@ -112,9 +124,10 @@ test_neg = -- | Group addition is commutative. test_add_commutative :: forall g. TestableAbelianGroup g => TestTree test_add_commutative = - testProperty - (mkTestName @g "add_commutative") . - withNTests $ do + testProperty + (mkTestName @g "add_commutative") + . withNTests + $ do p1 <- arbitraryPlcConst @g p2 <- arbitraryPlcConst @g let e = eqTerm @g (addTerm @g p1 p2) (addTerm @g p2 p1) @@ -122,21 +135,23 @@ test_add_commutative = test_is_an_abelian_group :: forall g. TestableAbelianGroup g => TestTree test_is_an_abelian_group = - testGroup (mkTestName @g "is_an_abelian_group") - [ test_add_assoc @g - , test_add_zero @g - , test_neg @g - , test_add_commutative @g - ] + testGroup + (mkTestName @g "is_an_abelian_group") + [ test_add_assoc @g + , test_add_zero @g + , test_neg @g + , test_add_commutative @g + ] ---------------- Z acts on G correctly ---------------- -- | (ab)p = a(bp) for all scalars a and b and all group elements p. test_scalarMul_assoc :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_assoc = - testProperty - (mkTestName @g "scalarMul_mul_assoc") . - withNTests $ do + testProperty + (mkTestName @g "scalarMul_mul_assoc") + . withNTests + $ do m <- arbitraryPlcScalar n <- arbitraryPlcScalar p <- arbitraryPlcConst @g @@ -148,9 +163,10 @@ test_scalarMul_assoc = -- | (a+b)p = ap +bp for all scalars a and b and all group elements p. test_scalarMul_distributive_left :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_distributive_left = - testProperty - (mkTestName @g "scalarMul_distributive_left") . - withNTests $ do + testProperty + (mkTestName @g "scalarMul_distributive_left") + . withNTests + $ do m <- arbitraryPlcScalar n <- arbitraryPlcScalar p <- arbitraryPlcConst @g @@ -162,9 +178,10 @@ test_scalarMul_distributive_left = -- | a(p+q) = ap + aq for all scalars a and all group elements p and q. test_scalarMul_distributive_right :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_distributive_right = - testProperty - (mkTestName @g "scalarMul_distributive_right") . - withNTests $ do + testProperty + (mkTestName @g "scalarMul_distributive_right") + . withNTests + $ do n <- arbitraryPlcScalar p <- arbitraryPlcConst @g q <- arbitraryPlcConst @g @@ -176,9 +193,10 @@ test_scalarMul_distributive_right = -- | 0p = 0 for all group elements p. test_scalarMul_zero :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_zero = - testProperty - (mkTestName @g "scalarMul_zero") . - withNTests $ do + testProperty + (mkTestName @g "scalarMul_zero") + . withNTests + $ do p <- arbitraryPlcConst @g let e = eqTerm @g (scalarMulTerm @g (integer 0) p) $ zeroTerm @g pure $ evalTerm e === cekSuccessTrue @@ -186,9 +204,10 @@ test_scalarMul_zero = -- | 1p = p for all group elements p. test_scalarMul_one :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_one = - testProperty - (mkTestName @g "scalarMul_one") . - withNTests $ do + testProperty + (mkTestName @g "scalarMul_one") + . withNTests + $ do p <- arbitraryPlcConst @g let e = eqTerm @g (scalarMulTerm @g (integer 1) p) p pure $ evalTerm e === cekSuccessTrue @@ -196,9 +215,10 @@ test_scalarMul_one = -- | (-1)p = -p for all group elements p. test_scalarMul_inverse :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_inverse = - testProperty - (mkTestName @g "scalarMul_inverse") . - withNTests $ do + testProperty + (mkTestName @g "scalarMul_inverse") + . withNTests + $ do p <- arbitraryPlcConst @g let e = eqTerm @g (scalarMulTerm @g (integer (-1)) p) (negTerm @g p) pure $ evalTerm e == cekSuccessTrue @@ -209,28 +229,30 @@ test_scalarMul_inverse = -- has 256 bits (about 5*10^76). test_scalarMul_repeated_addition :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_repeated_addition = - testProperty - (mkTestName @g "scalarMul_repeated_addition") . - withNTests $ do - n <- resize 100 arbitrary -- number of additions + testProperty + (mkTestName @g "scalarMul_repeated_addition") + . withNTests + $ do + n <- resize 100 arbitrary -- number of additions p <- arbitraryPlcConst @g let e1 = repeatedAdd n p e2 = eqTerm @g (scalarMulTerm @g (integer n) p) e1 pure $ evalTerm e2 === cekSuccessTrue - where - repeatedAdd :: Integer -> PlcTerm -> PlcTerm - repeatedAdd n t = - if n>=0 - then List.foldl' (addTerm @g) (zeroTerm @g) $ genericReplicate n t - else repeatedAdd (-n) (negTerm @g t) + where + repeatedAdd :: Integer -> PlcTerm -> PlcTerm + repeatedAdd n t = + if n >= 0 + then List.foldl' (addTerm @g) (zeroTerm @g) $ genericReplicate n t + else repeatedAdd (-n) (negTerm @g t) -- (m + n|G|)p = mp for all group elements p and integers m and n. -- We have |G1| = |G2| = scalarPeriod test_scalarMul_periodic :: forall g. TestableAbelianGroup g => TestTree test_scalarMul_periodic = - testProperty - (mkTestName @g "scalarMul_periodic") . - withNTests $ do + testProperty + (mkTestName @g "scalarMul_periodic") + . withNTests + $ do m <- arbitraryPlcScalar n <- arbitraryPlcScalar p <- arbitraryPlcConst @g @@ -242,16 +264,17 @@ test_scalarMul_periodic = test_Z_action_good :: forall g. TestableAbelianGroup g => TestTree test_Z_action_good = - testGroup (printf "Z acts correctly on %s" $ groupName @g) - [ test_scalarMul_assoc @g - , test_scalarMul_distributive_left @g - , test_scalarMul_distributive_right @g - , test_scalarMul_zero @g - , test_scalarMul_one @g - , test_scalarMul_inverse @g - , test_scalarMul_repeated_addition @g - , test_scalarMul_periodic @g - ] + testGroup + (printf "Z acts correctly on %s" $ groupName @g) + [ test_scalarMul_assoc @g + , test_scalarMul_distributive_left @g + , test_scalarMul_distributive_right @g + , test_scalarMul_zero @g + , test_scalarMul_one @g + , test_scalarMul_inverse @g + , test_scalarMul_repeated_addition @g + , test_scalarMul_periodic @g + ] ---------------- Multi-scalar multiplication behaves correctly ---------------- @@ -261,39 +284,42 @@ test_Z_action_good = test_multiScalarMul_correct :: forall g. TestableAbelianGroup g => TestTree test_multiScalarMul_correct = testProperty - (mkTestName @g "multiScalarMul_is_iterated_mul_and_add") . - withNTests $ do - scalars <- listOf arbitraryScalar - points <- listOf (arbitrary @g) - let e1 = multiScalarMulTerm @g (asPlc scalars) (asPlc points) - mkMulAdd acc (s, x) = addTerm @g acc (scalarMulTerm @g s x) - scalarTerms = fmap asPlc scalars - pointTerms = fmap asPlc points - e2 = List.foldl' mkMulAdd (zeroTerm @g) (zip scalarTerms pointTerms) - -- ^ Remember that zip truncates the longer list and `multiScalarMul` - -- is supposed to disregard extra elements if the inputs have different - -- lengths. - pure $ evalTerm e1 === evalTerm e2 + (mkTestName @g "multiScalarMul_is_iterated_mul_and_add") + . withNTests + $ do + scalars <- listOf arbitraryScalar + points <- listOf (arbitrary @g) + let e1 = multiScalarMulTerm @g (asPlc scalars) (asPlc points) + mkMulAdd acc (s, x) = addTerm @g acc (scalarMulTerm @g s x) + scalarTerms = fmap asPlc scalars + pointTerms = fmap asPlc points + e2 = List.foldl' mkMulAdd (zeroTerm @g) (zip scalarTerms pointTerms) + -- \^ Remember that zip truncates the longer list and `multiScalarMul` + -- is supposed to disregard extra elements if the inputs have different + -- lengths. + pure $ evalTerm e1 === evalTerm e2 -- Check that multiScalarMul returns the zero point if the list of scalars is empty test_multiScalarMul_no_scalars :: forall g. TestableAbelianGroup g => TestTree test_multiScalarMul_no_scalars = testProperty - (mkTestName @g "multiScalarMul_returns_zero_if_no_scalars") . - withNTests $ do - points <- listOf (arbitrary @g) - let e = multiScalarMulTerm @g (asPlc ([] @Integer)) (asPlc points) - pure $ evalTerm e === evalTerm (zeroTerm @g) + (mkTestName @g "multiScalarMul_returns_zero_if_no_scalars") + . withNTests + $ do + points <- listOf (arbitrary @g) + let e = multiScalarMulTerm @g (asPlc ([] @Integer)) (asPlc points) + pure $ evalTerm e === evalTerm (zeroTerm @g) -- Check that multiScalarMul returns the zero point if the list of points is empty test_multiScalarMul_no_points :: forall g. TestableAbelianGroup g => TestTree test_multiScalarMul_no_points = testProperty - (mkTestName @g "multiScalarMul_returns_zero_if_no_points") . - withNTests $ do - scalars <- listOf arbitraryScalar - let e = multiScalarMulTerm @g (asPlc scalars) (asPlc ([] @g)) - pure $ evalTerm e === evalTerm (zeroTerm @g) + (mkTestName @g "multiScalarMul_returns_zero_if_no_points") + . withNTests + $ do + scalars <- listOf arbitraryScalar + let e = multiScalarMulTerm @g (asPlc scalars) (asPlc ([] @g)) + pure $ evalTerm e === evalTerm (zeroTerm @g) {- Check that the result of multiScalarMul doesn't change if you permute the input pairs (disregarding extra inputs when the two input lists are of different @@ -302,34 +328,36 @@ test_multiScalarMul_no_points = test_multiScalarMul_permutation :: forall g. TestableAbelianGroup g => TestTree test_multiScalarMul_permutation = testProperty - (mkTestName @g "multiScalarMul_invariant_under_permutation") . - withNTests $ do - l <- listOf ((,) <$> arbitraryScalar <*> arbitrary @g) - l' <- shuffle l - let (scalars, points) = unzip l - (scalars', points') = unzip l' - e1 = multiScalarMulTerm @g (asPlc scalars) (asPlc points) - e2 = multiScalarMulTerm @g (asPlc scalars') (asPlc points') - pure $ evalTerm e1 === evalTerm e2 - + (mkTestName @g "multiScalarMul_invariant_under_permutation") + . withNTests + $ do + l <- listOf ((,) <$> arbitraryScalar <*> arbitrary @g) + l' <- shuffle l + let (scalars, points) = unzip l + (scalars', points') = unzip l' + e1 = multiScalarMulTerm @g (asPlc scalars) (asPlc points) + e2 = multiScalarMulTerm @g (asPlc scalars') (asPlc points') + pure $ evalTerm e1 === evalTerm e2 test_multiScalarMul :: forall g. TestableAbelianGroup g => TestTree test_multiScalarMul = - testGroup (printf "Multi-scalar multiplication behaves correctly for %s" $ groupName @g) - [ test_multiScalarMul_correct @g - , test_multiScalarMul_no_scalars @g - , test_multiScalarMul_no_points @g - , test_multiScalarMul_permutation @g - ] + testGroup + (printf "Multi-scalar multiplication behaves correctly for %s" $ groupName @g) + [ test_multiScalarMul_correct @g + , test_multiScalarMul_no_scalars @g + , test_multiScalarMul_no_points @g + , test_multiScalarMul_permutation @g + ] {- Generic tests for the HashAndCompress class. Later these are instantiated at the G1 and G2 types. -} test_roundtrip_compression :: forall g. HashAndCompress g => TestTree test_roundtrip_compression = - testProperty - (mkTestName @g "roundtrip_compression") . - withNTests $ do + testProperty + (mkTestName @g "roundtrip_compression") + . withNTests + $ do p <- arbitraryPlcConst @g let e = eqTerm @g (uncompressTerm @g (compressTerm @g p)) p pure $ evalTerm e === cekSuccessTrue @@ -342,13 +370,15 @@ test_roundtrip_compression = -- 3.1*10^152 for G2). test_uncompression_wrong_size :: forall g. HashAndCompress g => TestTree test_uncompression_wrong_size = - testProperty - (mkTestName @g "uncompression_wrong_size") . - withNTests $ do + testProperty + (mkTestName @g "uncompression_wrong_size") + . withNTests + $ do b <- suchThat (resize 128 arbitrary) incorrectSize let e = uncompressTerm @g (bytestring b) pure $ evalTerm e === CekError - where incorrectSize s = BS.length s /= compressedSize @g + where + incorrectSize s = BS.length s /= compressedSize @g -- | This tests the case we've omitted in the previous test, and should fail -- with very high probablity. It's quite difficult to test this with random @@ -360,33 +390,37 @@ test_uncompression_wrong_size = -- encoding. Maybe this just isn't a very good test. test_uncompress_out_of_group :: forall g. HashAndCompress g => TestTree test_uncompress_out_of_group = - testProperty - (mkTestName @g "uncompress_out_of_group") . - withMaxSuccess 99 $ do - b <- suchThat (resize 128 arbitrary) correctSize + testProperty + (mkTestName @g "uncompress_out_of_group") + . withMaxSuccess 99 + $ do + b <- suchThat (resize 128 arbitrary) correctSize let b' = setBits compressionBit $ clearBits infinityBit b let e = uncompressTerm @g (bytestring b') pure $ evalTerm e === CekError - where correctSize s = BS.length s == compressedSize @g + where + correctSize s = BS.length s == compressedSize @g -- | Check that the most significant bit is set for all compressed points test_compression_bit_set :: forall g. HashAndCompress g => TestTree test_compression_bit_set = - testProperty - (mkTestName @g "compression_bit_set") . - withNTests $ do + testProperty + (mkTestName @g "compression_bit_set") + . withNTests + $ do p <- arbitraryPlcConst @g case evalTerm (compressTerm @g p) of - CekSuccess (UPLC.Constant _ (Some (ValueOf DefaultUniByteString bs))) - -> pure $ isSet compressionBit bs + CekSuccess (UPLC.Constant _ (Some (ValueOf DefaultUniByteString bs))) -> + pure $ isSet compressionBit bs _ -> pure False -- | Check that bytestrings with the compression bit clear fail to uncompress. test_clear_compression_bit :: forall g. HashAndCompress g => TestTree test_clear_compression_bit = - testProperty - (mkTestName @g "clear_compression_bit") . - withNTests $ do + testProperty + (mkTestName @g "clear_compression_bit") + . withNTests + $ do p <- arbitrary @g let b = clearBits compressionBit $ compress @g p e = uncompressTerm @g (bytestring b) @@ -396,29 +430,30 @@ test_clear_compression_bit = -- inverse of the point. test_flip_sign_bit :: forall g. HashAndCompress g => TestTree test_flip_sign_bit = - testProperty - (mkTestName @g "flip_sign_bit") . - withNTests $ do + testProperty + (mkTestName @g "flip_sign_bit") + . withNTests + $ do p <- arbitraryNonZero @g let b1 = compress @g p b2 = flipBits signBit b1 e1 = uncompressTerm @g (bytestring b1) e2 = uncompressTerm @g (bytestring b2) - e = eqTerm @g e2 (negTerm @g e1) + e = eqTerm @g e2 (negTerm @g e1) pure $ evalTerm e === cekSuccessTrue -- | Check that bytestrings with the infinity bit set fail to uncompress. test_set_infinity_bit :: forall g. HashAndCompress g => TestTree test_set_infinity_bit = - testProperty - (mkTestName @g "set_infinity_bit") . - withNTests $ do - p <- arbitraryNonZero @g -- This will have the infinity bit set. + testProperty + (mkTestName @g "set_infinity_bit") + . withNTests + $ do + p <- arbitraryNonZero @g -- This will have the infinity bit set. let b = setBits infinityBit $ compress @g p e = uncompressTerm @g (bytestring b) pure $ evalTerm e === CekError - -- We test for hash collisions by generating a list of `numHashCollisionTests` -- bytestrings, discarding duplicates, hashing the remaining bytestrings, and -- then checking that no two of the resulting group elements are equal. The time @@ -432,15 +467,17 @@ numHashCollisionInputs = 200 -- but always use an empty Domain Separation Tag. test_no_hash_collisions :: forall g. HashAndCompress g => TestTree test_no_hash_collisions = - let emptyBS = bytestring BS.empty - in testProperty - (mkTestName @g "no_hash_collisions") . withMaxSuccess 1 $ do - msgs <- nub <$> replicateM numHashCollisionInputs arbitrary - let terms = fmap (\msg -> hashToGroupTerm @g (bytestring msg) emptyBS) msgs - hashed = fmap evalTerm terms - noErrors = property $ all (/= CekError) hashed -- Just in case - noDuplicates = List.length hashed === List.length (nub hashed) - pure $ noErrors .&. noDuplicates + let emptyBS = bytestring BS.empty + in testProperty + (mkTestName @g "no_hash_collisions") + . withMaxSuccess 1 + $ do + msgs <- nub <$> replicateM numHashCollisionInputs arbitrary + let terms = fmap (\msg -> hashToGroupTerm @g (bytestring msg) emptyBS) msgs + hashed = fmap evalTerm terms + noErrors = property $ all (/= CekError) hashed -- Just in case + noDuplicates = List.length hashed === List.length (nub hashed) + pure $ noErrors .&. noDuplicates -- | Test that we get no collisions if we keep the message constant but vary the -- DST. DSTs can be at most 255 bytes long in Plutus Core; there's a test @@ -449,31 +486,33 @@ test_no_hash_collisions = -- the final list could contain multiple occurrences of CekError. test_no_hash_collisions_dst :: forall g. HashAndCompress g => TestTree test_no_hash_collisions_dst = - let msg = bytestring $ pack [0x01, 0x02] - maxDstSize = 255 - in testProperty - (mkTestName @g "no_hash_collisions_dst") . withMaxSuccess 1 $ do - dsts <- nub <$> replicateM numHashCollisionInputs (resize maxDstSize arbitrary) - let terms = fmap (\dst -> hashToGroupTerm @g msg (bytestring dst)) dsts - hashed = fmap evalTerm terms - noErrors = property $ all (/= CekError) hashed - noDuplicates = List.length hashed === List.length (nub hashed) - pure $ noErrors .&. noDuplicates + let msg = bytestring $ pack [0x01, 0x02] + maxDstSize = 255 + in testProperty + (mkTestName @g "no_hash_collisions_dst") + . withMaxSuccess 1 + $ do + dsts <- nub <$> replicateM numHashCollisionInputs (resize maxDstSize arbitrary) + let terms = fmap (\dst -> hashToGroupTerm @g msg (bytestring dst)) dsts + hashed = fmap evalTerm terms + noErrors = property $ all (/= CekError) hashed + noDuplicates = List.length hashed === List.length (nub hashed) + pure $ noErrors .&. noDuplicates test_compress_hash :: forall g. HashAndCompress g => TestTree test_compress_hash = - testGroup (printf "Uncompression and hashing behave properly for %s" $ groupName @g) - [ test_roundtrip_compression @g - , test_uncompression_wrong_size @g - , test_compression_bit_set @g - , test_clear_compression_bit @g - , test_flip_sign_bit @g - , test_set_infinity_bit @g - , test_uncompress_out_of_group @g - , test_no_hash_collisions @g - , test_no_hash_collisions_dst @g - ] - + testGroup + (printf "Uncompression and hashing behave properly for %s" $ groupName @g) + [ test_roundtrip_compression @g + , test_uncompression_wrong_size @g + , test_compression_bit_set @g + , test_clear_compression_bit @g + , test_flip_sign_bit @g + , test_set_infinity_bit @g + , test_uncompress_out_of_group @g + , test_no_hash_collisions @g + , test_no_hash_collisions_dst @g + ] ---------------- Pairing properties ---------------- @@ -491,12 +530,13 @@ finalVerifyTerm = mkApp2 Bls12_381_finalVerify -- = . test_pairing_left_additive :: TestTree test_pairing_left_additive = - testProperty - "pairing_left_additive" . - withNTests $ do + testProperty + "pairing_left_additive" + . withNTests + $ do p1 <- arbitraryPlcConst @G1.Element p2 <- arbitraryPlcConst @G1.Element - q <- arbitraryPlcConst @G2.Element + q <- arbitraryPlcConst @G2.Element let e1 = millerLoopTerm (addTerm @G1.Element p1 p2) q e2 = mulMlResultTerm (millerLoopTerm p1 q) (millerLoopTerm p2 q) e3 = finalVerifyTerm e1 e2 @@ -505,10 +545,11 @@ test_pairing_left_additive = -- = . test_pairing_right_additive :: TestTree test_pairing_right_additive = - testProperty - "pairing_right_additive" . - withNTests $ do - p <- arbitraryPlcConst @G1.Element + testProperty + "pairing_right_additive" + . withNTests + $ do + p <- arbitraryPlcConst @G1.Element q1 <- arbitraryPlcConst @G2.Element q2 <- arbitraryPlcConst @G2.Element let e1 = millerLoopTerm p (addTerm @G2.Element q1 q2) @@ -519,9 +560,10 @@ test_pairing_right_additive = -- <[n]p,q> = test_pairing_balanced :: TestTree test_pairing_balanced = - testProperty - "pairing_balanced" . - withNTests $ do + testProperty + "pairing_balanced" + . withNTests + $ do n <- arbitraryPlcScalar p <- arbitraryPlcConst @G1.Element q <- arbitraryPlcConst @G2.Element @@ -534,38 +576,44 @@ test_pairing_balanced = -- zero points because `millerLoop` returns 1 if either of its inputs is zero. test_random_pairing :: TestTree test_random_pairing = - testProperty - "pairing_random_unequal" . - withNTests $ do - p1 <- arbitraryNonZeroPlcConst @G1.Element - p2 <- arbitraryNonZeroPlcConst @G1.Element - q1 <- arbitraryNonZeroPlcConst @G2.Element - q2 <- arbitraryNonZeroPlcConst @G2.Element - pure $ p1 /= p2 && q1 /= q2 ==> - let e = finalVerifyTerm (millerLoopTerm p1 q1) (millerLoopTerm p2 q2) - in evalTerm e === cekSuccessFalse - + testProperty + "pairing_random_unequal" + . withNTests + $ do + p1 <- arbitraryNonZeroPlcConst @G1.Element + p2 <- arbitraryNonZeroPlcConst @G1.Element + q1 <- arbitraryNonZeroPlcConst @G2.Element + q2 <- arbitraryNonZeroPlcConst @G2.Element + pure $ + p1 /= p2 && q1 /= q2 ==> + let e = finalVerifyTerm (millerLoopTerm p1 q1) (millerLoopTerm p2 q2) + in evalTerm e === cekSuccessFalse -- All of the tests test_BLS12_381 :: TestTree -test_BLS12_381 = testGroup "BLS12-381" [ - testGroup "G1 properties" - [ test_is_an_abelian_group @G1.Element - , test_Z_action_good @G1.Element - , test_multiScalarMul @G1.Element - , test_compress_hash @G1.Element - ] - , testGroup "G2 properties" - [ test_is_an_abelian_group @G2.Element - , test_Z_action_good @G2.Element - , test_multiScalarMul @G2.Element - , test_compress_hash @G2.Element - ] - , testGroup "Pairing properties" - [ test_pairing_left_additive - , test_pairing_right_additive - , test_pairing_balanced - , test_random_pairing - ] +test_BLS12_381 = + testGroup + "BLS12-381" + [ testGroup + "G1 properties" + [ test_is_an_abelian_group @G1.Element + , test_Z_action_good @G1.Element + , test_multiScalarMul @G1.Element + , test_compress_hash @G1.Element + ] + , testGroup + "G2 properties" + [ test_is_an_abelian_group @G2.Element + , test_Z_action_good @G2.Element + , test_multiScalarMul @G2.Element + , test_compress_hash @G2.Element + ] + , testGroup + "Pairing properties" + [ test_pairing_left_additive + , test_pairing_right_additive + , test_pairing_balanced + , test_random_pairing ] + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/TestClasses.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/TestClasses.hs index bad1be351ea..05d6a3802a0 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/TestClasses.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/TestClasses.hs @@ -1,7 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Evaluation.Builtins.BLS12_381.TestClasses @@ -20,22 +20,21 @@ import Test.QuickCheck (Arbitrary (..), Gen, frequency, suchThat) ---------------- Typeclasses for groups ---------------- -{- | The code for the property tests for G1 and G2 is essentially identical, so - it's worth abstracting over the common features. The blst Haskell FFI uses a - phantom type to do this but unfortunately we have to hide that to stop the - builtin machinery spotting it and then we have to re-abstract here. -} +-- | The code for the property tests for G1 and G2 is essentially identical, so +-- it's worth abstracting over the common features. The blst Haskell FFI uses a +-- phantom type to do this but unfortunately we have to hide that to stop the +-- builtin machinery spotting it and then we have to re-abstract here. -- We could re-use the AbelianGroup class here, but that uses <> and `mempty` -- and that's confusing. -class (Eq a, Show a, Arbitrary a, ArbitraryBuiltin a, DefaultUni `Contains` a) => TestableAbelianGroup a - where - groupName :: String - zero :: a - addTerm :: PlcTerm -> PlcTerm -> PlcTerm - negTerm :: PlcTerm -> PlcTerm - scalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm - multiScalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm - eqTerm :: PlcTerm -> PlcTerm -> PlcTerm +class (Eq a, Show a, Arbitrary a, ArbitraryBuiltin a, DefaultUni `Contains` a) => TestableAbelianGroup a where + groupName :: String + zero :: a + addTerm :: PlcTerm -> PlcTerm -> PlcTerm + negTerm :: PlcTerm -> PlcTerm + scalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm + multiScalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm + eqTerm :: PlcTerm -> PlcTerm -> PlcTerm zeroTerm :: forall g. TestableAbelianGroup g => PlcTerm zeroTerm = mkConstant () $ zero @g @@ -45,76 +44,75 @@ zeroTerm = mkConstant () $ zero @g arbitraryNonZero :: forall g. TestableAbelianGroup g => Gen g arbitraryNonZero = (arbitrary @g) `suchThat` ((/=) (zero @g)) -class TestableAbelianGroup a => HashAndCompress a - where - compressedSize :: Int - compress :: a -> ByteString - compressTerm :: PlcTerm -> PlcTerm - uncompressTerm :: PlcTerm -> PlcTerm - hashToGroupTerm :: PlcTerm -> PlcTerm -> PlcTerm +class TestableAbelianGroup a => HashAndCompress a where + compressedSize :: Int + compress :: a -> ByteString + compressTerm :: PlcTerm -> PlcTerm + uncompressTerm :: PlcTerm -> PlcTerm + hashToGroupTerm :: PlcTerm -> PlcTerm -> PlcTerm ---------- Instances for G1 ---------- -{- | Generate an arbitrary element of G1. It's tricky to construct such an - element directly without using quite low-level operations on the curve - because a random point on the curve is highly unlikely to be in the subgroup - G1, but fortunately `hashToGroup` always produces an element of the subgroup, - so we can produce random elements of G1 by hashing random bytestrings. -} -instance Arbitrary G1.Element - where - arbitrary = frequency [ (9, arbitraryElement) - , (1, pure $ G1.offchain_zero) - ] - where arbitraryElement = - G1.hashToGroup <$> arbitrary <*> pure BS.empty >>= \case - Left err -> error $ "Arbitrary instance for G1.Element:" ++ show err - Right p -> pure p - -instance TestableAbelianGroup G1.Element +-- | Generate an arbitrary element of G1. It's tricky to construct such an +-- element directly without using quite low-level operations on the curve +-- because a random point on the curve is highly unlikely to be in the subgroup +-- G1, but fortunately `hashToGroup` always produces an element of the subgroup, +-- so we can produce random elements of G1 by hashing random bytestrings. +instance Arbitrary G1.Element where + arbitrary = + frequency + [ (9, arbitraryElement) + , (1, pure $ G1.offchain_zero) + ] where - groupName = "G1" - zero = G1.offchain_zero - addTerm = mkApp2 Bls12_381_G1_add - negTerm = mkApp1 Bls12_381_G1_neg - scalarMulTerm = mkApp2 Bls12_381_G1_scalarMul - multiScalarMulTerm = mkApp2 Bls12_381_G1_multiScalarMul - eqTerm = mkApp2 Bls12_381_G1_equal - -instance HashAndCompress G1.Element - where - compressedSize = 48 - compress = G1.compress - compressTerm = mkApp1 Bls12_381_G1_compress - uncompressTerm = mkApp1 Bls12_381_G1_uncompress - hashToGroupTerm = mkApp2 Bls12_381_G1_hashToGroup + arbitraryElement = + G1.hashToGroup <$> arbitrary <*> pure BS.empty >>= \case + Left err -> error $ "Arbitrary instance for G1.Element:" ++ show err + Right p -> pure p + +instance TestableAbelianGroup G1.Element where + groupName = "G1" + zero = G1.offchain_zero + addTerm = mkApp2 Bls12_381_G1_add + negTerm = mkApp1 Bls12_381_G1_neg + scalarMulTerm = mkApp2 Bls12_381_G1_scalarMul + multiScalarMulTerm = mkApp2 Bls12_381_G1_multiScalarMul + eqTerm = mkApp2 Bls12_381_G1_equal + +instance HashAndCompress G1.Element where + compressedSize = 48 + compress = G1.compress + compressTerm = mkApp1 Bls12_381_G1_compress + uncompressTerm = mkApp1 Bls12_381_G1_uncompress + hashToGroupTerm = mkApp2 Bls12_381_G1_hashToGroup ---------- Instances for G2 ---------- -- | See the comment for the Arbitrary instance for G1. -instance Arbitrary G2.Element - where - arbitrary = frequency [ (9, arbitraryElement) - , (1, pure $ G2.offchain_zero) - ] - where arbitraryElement = - G2.hashToGroup <$> arbitrary <*> pure BS.empty >>= \case - Left err -> error $ "Arbitrary instance for G2.Element:" ++ show err - Right p -> pure p - -instance TestableAbelianGroup G2.Element - where - groupName = "G2" - zero = G2.offchain_zero - addTerm = mkApp2 Bls12_381_G2_add - negTerm = mkApp1 Bls12_381_G2_neg - scalarMulTerm = mkApp2 Bls12_381_G2_scalarMul - multiScalarMulTerm = mkApp2 Bls12_381_G2_multiScalarMul - eqTerm = mkApp2 Bls12_381_G2_equal - -instance HashAndCompress G2.Element +instance Arbitrary G2.Element where + arbitrary = + frequency + [ (9, arbitraryElement) + , (1, pure $ G2.offchain_zero) + ] where - compressedSize = 96 - compress = G2.compress - compressTerm = mkApp1 Bls12_381_G2_compress - uncompressTerm = mkApp1 Bls12_381_G2_uncompress - hashToGroupTerm = mkApp2 Bls12_381_G2_hashToGroup + arbitraryElement = + G2.hashToGroup <$> arbitrary <*> pure BS.empty >>= \case + Left err -> error $ "Arbitrary instance for G2.Element:" ++ show err + Right p -> pure p + +instance TestableAbelianGroup G2.Element where + groupName = "G2" + zero = G2.offchain_zero + addTerm = mkApp2 Bls12_381_G2_add + negTerm = mkApp1 Bls12_381_G2_neg + scalarMulTerm = mkApp2 Bls12_381_G2_scalarMul + multiScalarMulTerm = mkApp2 Bls12_381_G2_multiScalarMul + eqTerm = mkApp2 Bls12_381_G2_equal + +instance HashAndCompress G2.Element where + compressedSize = 96 + compress = G2.compress + compressTerm = mkApp1 Bls12_381_G2_compress + uncompressTerm = mkApp1 Bls12_381_G2_uncompress + hashToGroupTerm = mkApp2 Bls12_381_G2_hashToGroup diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/Utils.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/Utils.hs index ef538f36cda..0f907e1bff3 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/Utils.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/BLS12_381/Utils.hs @@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Evaluation.Builtins.BLS12_381.Utils where @@ -8,9 +8,9 @@ import Data.Bits (complement, xor, (.&.), (.|.)) import Data.ByteString as BS (ByteString, cons, uncons) import Data.Word (Word8) -{- | ByteString utilities. These are used in tests to check that the format of - compressed points conforms to the specification at - https://github.com/supranational/blst#serialization-format . -} +-- | ByteString utilities. These are used in tests to check that the format of +-- compressed points conforms to the specification at +-- https://github.com/supranational/blst#serialization-format . -- The most signiificant bit of a serialised curve point is set if the -- serialised point is in compressed form (x-coordinate only) @@ -31,15 +31,15 @@ signBit = 0x20 unsafeUnconsBS :: ByteString -> (Word8, ByteString) unsafeUnconsBS b = - case BS.uncons b of - Nothing -> error "Tried to uncons empty bytestring" - Just p -> p + case BS.uncons b of + Nothing -> error "Tried to uncons empty bytestring" + Just p -> p -- | Apply some function to the most significant byte of a bytestring modifyMSB :: (Word8 -> Word8) -> ByteString -> ByteString modifyMSB f s = - let (w,rest) = unsafeUnconsBS s - in BS.cons (f w) rest + let (w, rest) = unsafeUnconsBS s + in BS.cons (f w) rest -- | Flip a specified set of bits in the most significant byte of a bytestring. flipBits :: Word8 -> ByteString -> ByteString @@ -57,5 +57,5 @@ setBits mask = modifyMSB (mask .|.) -- bytestring. isSet :: Word8 -> ByteString -> Bool isSet mask s = - let (w,_) = unsafeUnconsBS s - in w .&. mask == mask + let (w, _) = unsafeUnconsBS s + in w .&. mask == mask diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0122.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0122.hs index a4e9b39c3f4..a0702ae25ff 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0122.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0122.hs @@ -1,6 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for [CIP-0122](https://cips.cardano.org/cip/CIP-0122) (the first -- batch of bitwise builtins) @@ -19,8 +19,8 @@ module Evaluation.Builtins.Bitwise.CIP0122 ( setSet, writeBitsHomomorphismLaws, replicateHomomorphismLaws, - replicateIndex - ) where + replicateIndex, +) where import PlutusCore qualified as PLC import PlutusCore.MkPlc (builtin, mkConstant, mkIterAppNoAnn) @@ -29,8 +29,12 @@ import UntypedPlutusCore qualified as UPLC import Data.ByteString (ByteString) import Data.ByteString qualified as BS -import Evaluation.Helpers (evaluateTheSame, evaluateToHaskell, evaluatesToConstant, - forAllByteString) +import Evaluation.Helpers ( + evaluateTheSame, + evaluateToHaskell, + evaluatesToConstant, + forAllByteString, + ) import GHC.Exts (fromString) import Hedgehog (Gen, Property, PropertyT, forAll, forAllWith, property) import Hedgehog.Gen qualified as Gen @@ -46,14 +50,18 @@ replicateIndex = testPropertyNamed "every byte is the same" "replicate_all_match n <- forAll . Gen.integral . Range.linear 1 $ 512 b <- forAll . Gen.integral . Range.constant 0 $ 255 i <- forAll . Gen.integral . Range.linear 0 $ n - 1 - let lhsInner = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - mkConstant @Integer () n, - mkConstant @Integer () b - ] - let lhs = mkIterAppNoAnn (builtin () PLC.IndexByteString) [ - lhsInner, - mkConstant @Integer () i - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ mkConstant @Integer () n + , mkConstant @Integer () b + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.IndexByteString) + [ lhsInner + , mkConstant @Integer () i + ] evaluatesToConstant @Integer b lhs -- | If you retrieve a bit value at an index, then write that same value to @@ -63,16 +71,20 @@ getSet = testPropertyNamed "get-set" "get_set" . mapTestLimitAtLeast 50 (`div` 20) . property $ do bs <- forAllByteString 1 512 i <- forAllIndexOf bs - let lookupExp = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - mkConstant @ByteString () bs, - mkConstant @Integer () i - ] + let lookupExp = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ mkConstant @ByteString () bs + , mkConstant @Integer () i + ] b <- evaluateToHaskell lookupExp - let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - mkConstant @ByteString () bs, - mkConstant @[Integer] () [i], - mkConstant @Bool () b - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ mkConstant @ByteString () bs + , mkConstant @[Integer] () [i] + , mkConstant @Bool () b + ] evaluatesToConstant bs lhs -- | If you write a bit value to an index, then retrieve the bit value at the @@ -83,15 +95,19 @@ setGet = bs <- forAllByteString 1 512 i <- forAllIndexOf bs b <- forAll Gen.bool - let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - mkConstant @ByteString () bs, - mkConstant @[Integer] () [i], - mkConstant @Bool () b - ] - let lhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - lhsInner, - mkConstant @Integer () i - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ mkConstant @ByteString () bs + , mkConstant @[Integer] () [i] + , mkConstant @Bool () b + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ lhsInner + , mkConstant @Integer () i + ] evaluatesToConstant b lhs -- | If you write twice to the same bit index, the second write should win. @@ -102,21 +118,27 @@ setSet = i <- forAllIndexOf bs b1 <- forAll Gen.bool b2 <- forAll Gen.bool - let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - mkConstant @ByteString () bs, - mkConstant @[Integer] () [i, i], - mkConstant @Bool () b1 - ] - let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - lhsInner, - mkConstant @[Integer] () [i, i], - mkConstant @Bool () b2 - ] - let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - mkConstant @ByteString () bs, - mkConstant @[Integer] () [i], - mkConstant @Bool () b2 - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ mkConstant @ByteString () bs + , mkConstant @[Integer] () [i, i] + , mkConstant @Bool () b1 + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ lhsInner + , mkConstant @[Integer] () [i, i] + , mkConstant @Bool () b2 + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ mkConstant @ByteString () bs + , mkConstant @[Integer] () [i] + , mkConstant @Bool () b2 + ] evaluateTheSame lhs rhs -- | Checks that: @@ -126,47 +148,56 @@ setSet = -- * writing b with their concatenation. writeBitsHomomorphismLaws :: TestTree writeBitsHomomorphismLaws = - testGroup "homomorphism to lists" [ - testPropertyNamed "identity -> []" "write_bits_h_1_false" $ - mapTestLimitAtLeast 99 (`div` 20) (identityProp False), - testPropertyNamed "identity -> []" "write_bits_h_1_true" $ - mapTestLimitAtLeast 99 (`div` 20) (identityProp True), - testPropertyNamed "composition -> concatenation" "write_bits_h_2_false" $ - mapTestLimitAtLeast 50 (`div` 20) (compositionProp False), - testPropertyNamed "composition -> concatenation" "write_bits_h_2_true" $ - mapTestLimitAtLeast 50 (`div` 20) (compositionProp True) + testGroup + "homomorphism to lists" + [ testPropertyNamed "identity -> []" "write_bits_h_1_false" $ + mapTestLimitAtLeast 99 (`div` 20) (identityProp False) + , testPropertyNamed "identity -> []" "write_bits_h_1_true" $ + mapTestLimitAtLeast 99 (`div` 20) (identityProp True) + , testPropertyNamed "composition -> concatenation" "write_bits_h_2_false" $ + mapTestLimitAtLeast 50 (`div` 20) (compositionProp False) + , testPropertyNamed "composition -> concatenation" "write_bits_h_2_true" $ + mapTestLimitAtLeast 50 (`div` 20) (compositionProp True) ] - where - identityProp :: Bool -> Property - identityProp b = property $ do - bs <- forAllByteString 1 512 - let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - mkConstant @ByteString () bs, - mkConstant @[Integer] () [], - mkConstant @Bool () b + where + identityProp :: Bool -> Property + identityProp b = property $ do + bs <- forAllByteString 1 512 + let lhs = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ mkConstant @ByteString () bs + , mkConstant @[Integer] () [] + , mkConstant @Bool () b ] - evaluatesToConstant bs lhs - compositionProp :: Bool -> Property - compositionProp b = property $ do - bs <- forAllByteString 1 512 - ixes1 <- forAllListsOfIndices bs - ixes2 <- forAllListsOfIndices bs - let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - mkConstant @ByteString () bs, - mkConstant @[Integer] () ixes1, - mkConstant @Bool () b + evaluatesToConstant bs lhs + compositionProp :: Bool -> Property + compositionProp b = property $ do + bs <- forAllByteString 1 512 + ixes1 <- forAllListsOfIndices bs + ixes2 <- forAllListsOfIndices bs + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ mkConstant @ByteString () bs + , mkConstant @[Integer] () ixes1 + , mkConstant @Bool () b ] - let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - lhsInner, - mkConstant @[Integer] () ixes2, - mkConstant @Bool () b + let lhs = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ lhsInner + , mkConstant @[Integer] () ixes2 + , mkConstant @Bool () b ] - let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ - mkConstant @ByteString () bs, - mkConstant @[Integer] () (ixes1 <> ixes2), - mkConstant @Bool () b + let rhs = + mkIterAppNoAnn + (builtin () PLC.WriteBits) + [ mkConstant @ByteString () bs + , mkConstant @[Integer] () (ixes1 <> ixes2) + , mkConstant @Bool () b ] - evaluateTheSame lhs rhs + evaluateTheSame lhs rhs -- | Checks that: -- @@ -176,42 +207,53 @@ writeBitsHomomorphismLaws = -- times. replicateHomomorphismLaws :: TestTree replicateHomomorphismLaws = - testGroup "homomorphism" [ - testPropertyNamed "0 -> empty" "replicate_h_1" $ - mapTestLimitAtLeast 99 (`div` 20) identityProp, - testPropertyNamed "+ -> concat" "replicate_h_2" $ - mapTestLimitAtLeast 50 (`div` 20) compositionProp + testGroup + "homomorphism" + [ testPropertyNamed "0 -> empty" "replicate_h_1" $ + mapTestLimitAtLeast 99 (`div` 20) identityProp + , testPropertyNamed "+ -> concat" "replicate_h_2" $ + mapTestLimitAtLeast 50 (`div` 20) compositionProp ] where identityProp :: Property identityProp = property $ do b <- forAll . Gen.integral . Range.constant 0 $ 255 - let lhs = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - mkConstant @Integer () 0, - mkConstant @Integer () b - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ mkConstant @Integer () 0 + , mkConstant @Integer () b + ] evaluatesToConstant @ByteString "" lhs compositionProp :: Property compositionProp = property $ do b <- forAll . Gen.integral . Range.constant 0 $ 255 n1 <- forAll . Gen.integral . Range.linear 0 $ 512 n2 <- forAll . Gen.integral . Range.linear 0 $ 512 - let lhsInner1 = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - mkConstant @Integer () n1, - mkConstant @Integer () b - ] - let lhsInner2 = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - mkConstant @Integer () n2, - mkConstant @Integer () b - ] - let lhs = mkIterAppNoAnn (builtin () PLC.AppendByteString) [ - lhsInner1, - lhsInner2 - ] - let rhs = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - mkConstant @Integer () (n1 + n2), - mkConstant @Integer () b - ] + let lhsInner1 = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ mkConstant @Integer () n1 + , mkConstant @Integer () b + ] + let lhsInner2 = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ mkConstant @Integer () n2 + , mkConstant @Integer () b + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.AppendByteString) + [ lhsInner1 + , lhsInner2 + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ mkConstant @Integer () (n1 + n2) + , mkConstant @Integer () b + ] evaluateTheSame lhs rhs -- | If you complement a 'ByteString' twice, nothing should change. @@ -220,12 +262,16 @@ complementSelfInverse = testPropertyNamed "self-inverse" "self_inverse" $ mapTestLimitAtLeast 99 (`div` 20) . property $ do bs <- forAllByteString 0 512 - let lhsInner = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ - mkConstant @ByteString () bs - ] - let lhs = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ - lhsInner - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.ComplementByteString) + [ mkConstant @ByteString () bs + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ComplementByteString) + [ lhsInner + ] evaluatesToConstant bs lhs -- | Checks that: @@ -233,35 +279,47 @@ complementSelfInverse = -- * The complement of an AND is an OR of complements; and -- * The complement of an OR is an AND of complements. deMorgan :: TestTree -deMorgan = testGroup "De Morgan's laws" [ - testPropertyNamed "NOT AND -> OR" "demorgan_and" . go PLC.AndByteString $ PLC.OrByteString, - testPropertyNamed "NOT OR -> AND" "demorgan_or" . go PLC.OrByteString $ PLC.AndByteString - ] +deMorgan = + testGroup + "De Morgan's laws" + [ testPropertyNamed "NOT AND -> OR" "demorgan_and" . go PLC.AndByteString $ PLC.OrByteString + , testPropertyNamed "NOT OR -> AND" "demorgan_or" . go PLC.OrByteString $ PLC.AndByteString + ] where go :: UPLC.DefaultFun -> UPLC.DefaultFun -> Property go f g = mapTestLimitAtLeast 50 (`div` 10) . property $ do semantics <- forAllWith showSemantics Gen.bool bs1 <- forAllByteString 0 512 bs2 <- forAllByteString 0 512 - let lhsInner = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () semantics, - mkConstant @ByteString () bs1, - mkConstant @ByteString () bs2 - ] - let lhs = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ - lhsInner - ] - let rhsInner1 = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ - mkConstant @ByteString () bs1 - ] - let rhsInner2 = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ - mkConstant @ByteString () bs2 - ] - let rhs = mkIterAppNoAnn (builtin () g) [ - mkConstant @Bool () semantics, - rhsInner1, - rhsInner2 - ] + let lhsInner = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () semantics + , mkConstant @ByteString () bs1 + , mkConstant @ByteString () bs2 + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ComplementByteString) + [ lhsInner + ] + let rhsInner1 = + mkIterAppNoAnn + (builtin () PLC.ComplementByteString) + [ mkConstant @ByteString () bs1 + ] + let rhsInner2 = + mkIterAppNoAnn + (builtin () PLC.ComplementByteString) + [ mkConstant @ByteString () bs2 + ] + let rhs = + mkIterAppNoAnn + (builtin () g) + [ mkConstant @Bool () semantics + , rhsInner1 + , rhsInner2 + ] evaluateTheSame lhs rhs -- | If you XOR any 'ByteString' with itself twice, nothing should change. @@ -270,16 +328,20 @@ xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" $ mapTestLimitAtLeast 99 (`div` 20) . property $ do bs <- forAllByteString 0 512 semantics <- forAllWith showSemantics Gen.bool - let lhsInner = mkIterAppNoAnn (builtin () PLC.XorByteString) [ - mkConstant @Bool () semantics, - mkConstant @ByteString () bs, - mkConstant @ByteString () bs - ] - let lhs = mkIterAppNoAnn (builtin () PLC.XorByteString) [ - mkConstant @Bool () semantics, - mkConstant @ByteString () bs, - lhsInner - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.XorByteString) + [ mkConstant @Bool () semantics + , mkConstant @ByteString () bs + , mkConstant @ByteString () bs + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.XorByteString) + [ mkConstant @Bool () semantics + , mkConstant @ByteString () bs + , lhsInner + ] evaluatesToConstant bs lhs -- | Checks that the first 'DefaultFun' distributes over the second from the @@ -287,60 +349,74 @@ xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" $ -- 'DefaultFun's @f@ and @g@, checks that @f x (g y z) = g (f x y) (f x z)@. leftDistributiveLaw :: String -> String -> UPLC.DefaultFun -> UPLC.DefaultFun -> Bool -> TestTree leftDistributiveLaw name distOpName f distOp isPadding = - testPropertyNamed ("left distribution (" <> name <> ") over " <> distOpName) - ("left_distribution_" <> fromString name <> "_" <> fromString distOpName) - (mapTestLimitAtLeast 50 (`div` 10) $ leftDistProp f distOp isPadding) + testPropertyNamed + ("left distribution (" <> name <> ") over " <> distOpName) + ("left_distribution_" <> fromString name <> "_" <> fromString distOpName) + (mapTestLimitAtLeast 50 (`div` 10) $ leftDistProp f distOp isPadding) -- | Checks that the given function self-distributes both left and right. distributiveLaws :: String -> UPLC.DefaultFun -> Bool -> TestTree distributiveLaws name f isPadding = - testGroup ("distributivity over itself (" <> name <> ")") [ - testPropertyNamed "left distribution" "left_distribution" $ - mapTestLimitAtLeast 50 (`div` 10) $ leftDistProp f f isPadding, - testPropertyNamed "right distribution" "right_distribution" $ - mapTestLimitAtLeast 50 (`div` 10) $ rightDistProp f isPadding + testGroup + ("distributivity over itself (" <> name <> ")") + [ testPropertyNamed "left distribution" "left_distribution" $ + mapTestLimitAtLeast 50 (`div` 10) $ + leftDistProp f f isPadding + , testPropertyNamed "right distribution" "right_distribution" $ + mapTestLimitAtLeast 50 (`div` 10) $ + rightDistProp f isPadding ] -- | Checks that the given 'DefaultFun', under the given semantics, forms an -- abelian semigroup: that is, the operation both commutes and associates. abelianSemigroupLaws :: String -> UPLC.DefaultFun -> Bool -> TestTree abelianSemigroupLaws name f isPadding = - testGroup ("abelian semigroup (" <> name <> ")") [ - testPropertyNamed "commutativity" "commutativity" $ - mapTestLimitAtLeast 50 (`div` 10) $ commProp f isPadding, - testPropertyNamed "associativity" "associativity" $ - mapTestLimitAtLeast 50 (`div` 10) $ assocProp f isPadding + testGroup + ("abelian semigroup (" <> name <> ")") + [ testPropertyNamed "commutativity" "commutativity" $ + mapTestLimitAtLeast 50 (`div` 10) $ + commProp f isPadding + , testPropertyNamed "associativity" "associativity" $ + mapTestLimitAtLeast 50 (`div` 10) $ + assocProp f isPadding ] -- | As 'abelianSemigroupLaws', but also checks that the provided 'ByteString' -- is both a left and right identity. abelianMonoidLaws :: String -> UPLC.DefaultFun -> Bool -> ByteString -> TestTree abelianMonoidLaws name f isPadding unit = - testGroup ("abelian monoid (" <> name <> ")") [ - testPropertyNamed "commutativity" "commutativity" $ - mapTestLimitAtLeast 50 (`div` 10) $ commProp f isPadding, - testPropertyNamed "associativity" "associativity" $ - mapTestLimitAtLeast 50 (`div` 10) $ assocProp f isPadding, - testPropertyNamed "unit" "unit" $ - mapTestLimitAtLeast 75 (`div` 15) $ unitProp f isPadding unit + testGroup + ("abelian monoid (" <> name <> ")") + [ testPropertyNamed "commutativity" "commutativity" $ + mapTestLimitAtLeast 50 (`div` 10) $ + commProp f isPadding + , testPropertyNamed "associativity" "associativity" $ + mapTestLimitAtLeast 50 (`div` 10) $ + assocProp f isPadding + , testPropertyNamed "unit" "unit" $ + mapTestLimitAtLeast 75 (`div` 15) $ + unitProp f isPadding unit ] -- | Checks that the provided 'DefaultFun', under the given semantics, is -- idempotent; namely, that @f x x = x@ for any @x@. idempotenceLaw :: String -> UPLC.DefaultFun -> Bool -> TestTree idempotenceLaw name f isPadding = - testPropertyNamed ("idempotence (" <> name <> ")") - ("idempotence_" <> fromString name) - (mapTestLimitAtLeast 75 (`div` 15) idempProp) + testPropertyNamed + ("idempotence (" <> name <> ")") + ("idempotence_" <> fromString name) + (mapTestLimitAtLeast 75 (`div` 15) idempProp) where idempProp :: Property idempProp = property $ do bs <- forAllByteString 0 512 - let lhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () bs, - mkConstant @ByteString () bs - ] + let lhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () bs + , mkConstant @ByteString () bs + ] evaluatesToConstant bs lhs -- | Checks that the provided 'ByteString' is an absorbing element for the @@ -349,57 +425,71 @@ idempotenceLaw name f isPadding = -- @f x 0 = f 0 x = 0@. absorbtionLaw :: String -> UPLC.DefaultFun -> Bool -> ByteString -> TestTree absorbtionLaw name f isPadding absorber = - testPropertyNamed ("absorbing element (" <> name <> ")") - ("absorbing_element_" <> fromString name) - (mapTestLimitAtLeast 75 (`div` 15) absorbProp) + testPropertyNamed + ("absorbing element (" <> name <> ")") + ("absorbing_element_" <> fromString name) + (mapTestLimitAtLeast 75 (`div` 15) absorbProp) where absorbProp :: Property absorbProp = property $ do bs <- forAllByteString 0 512 - let lhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () bs, - mkConstant @ByteString () absorber - ] + let lhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () bs + , mkConstant @ByteString () absorber + ] evaluatesToConstant absorber lhs -- Helpers showSemantics :: Bool -> String -showSemantics b = if b - then "padding semantics" - else "truncation semantics" +showSemantics b = + if b + then "padding semantics" + else "truncation semantics" leftDistProp :: UPLC.DefaultFun -> UPLC.DefaultFun -> Bool -> Property leftDistProp f distOp isPadding = property $ do x <- forAllByteString 0 512 y <- forAllByteString 0 512 z <- forAllByteString 0 512 - let distLhs = mkIterAppNoAnn (builtin () distOp) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () y, - mkConstant @ByteString () z - ] - let lhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () x, - distLhs - ] - let distRhs1 = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () x, - mkConstant @ByteString () y - ] - let distRhs2 = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () x, - mkConstant @ByteString () z - ] - let rhs = mkIterAppNoAnn (builtin () distOp) [ - mkConstant @Bool () isPadding, - distRhs1, - distRhs2 - ] + let distLhs = + mkIterAppNoAnn + (builtin () distOp) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () y + , mkConstant @ByteString () z + ] + let lhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () x + , distLhs + ] + let distRhs1 = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () x + , mkConstant @ByteString () y + ] + let distRhs2 = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () x + , mkConstant @ByteString () z + ] + let rhs = + mkIterAppNoAnn + (builtin () distOp) + [ mkConstant @Bool () isPadding + , distRhs1 + , distRhs2 + ] evaluateTheSame lhs rhs rightDistProp :: UPLC.DefaultFun -> Bool -> Property @@ -407,47 +497,61 @@ rightDistProp f isPadding = property $ do x <- forAllByteString 0 512 y <- forAllByteString 0 512 z <- forAllByteString 0 512 - let lhsInner = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () x, - mkConstant @ByteString () y - ] - let lhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - lhsInner, - mkConstant @ByteString () z - ] - let rhsInner1 = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () x, - mkConstant @ByteString () z - ] - let rhsInner2 = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () y, - mkConstant @ByteString () z - ] - let rhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - rhsInner1, - rhsInner2 - ] + let lhsInner = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () x + , mkConstant @ByteString () y + ] + let lhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , lhsInner + , mkConstant @ByteString () z + ] + let rhsInner1 = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () x + , mkConstant @ByteString () z + ] + let rhsInner2 = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () y + , mkConstant @ByteString () z + ] + let rhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , rhsInner1 + , rhsInner2 + ] evaluateTheSame lhs rhs commProp :: UPLC.DefaultFun -> Bool -> Property commProp f isPadding = property $ do data1 <- forAllByteString 0 512 data2 <- forAllByteString 0 512 - let lhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () data1, - mkConstant @ByteString () data2 - ] - let rhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () data2, - mkConstant @ByteString () data1 - ] + let lhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () data1 + , mkConstant @ByteString () data2 + ] + let rhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () data2 + , mkConstant @ByteString () data1 + ] evaluateTheSame lhs rhs assocProp :: UPLC.DefaultFun -> Bool -> Property @@ -455,36 +559,46 @@ assocProp f isPadding = property $ do data1 <- forAllByteString 0 512 data2 <- forAllByteString 0 512 data3 <- forAllByteString 0 512 - let data12 = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () data1, - mkConstant @ByteString () data2 - ] - let lhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - data12, - mkConstant @ByteString () data3 - ] - let data23 = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () data2, - mkConstant @ByteString () data3 - ] - let rhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () data1, - data23 - ] + let data12 = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () data1 + , mkConstant @ByteString () data2 + ] + let lhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , data12 + , mkConstant @ByteString () data3 + ] + let data23 = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () data2 + , mkConstant @ByteString () data3 + ] + let rhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () data1 + , data23 + ] evaluateTheSame lhs rhs unitProp :: UPLC.DefaultFun -> Bool -> ByteString -> Property unitProp f isPadding unit = property $ do bs <- forAllByteString 0 512 - let lhs = mkIterAppNoAnn (builtin () f) [ - mkConstant @Bool () isPadding, - mkConstant @ByteString () bs, - mkConstant @ByteString () unit - ] + let lhs = + mkIterAppNoAnn + (builtin () f) + [ mkConstant @Bool () isPadding + , mkConstant @ByteString () bs + , mkConstant @ByteString () unit + ] evaluatesToConstant bs lhs forAllIndexOf :: ByteString -> PropertyT IO Integer diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0123.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0123.hs index 439a9e57423..30db0616a16 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0123.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Bitwise/CIP0123.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for [CIP-0123](https://cips.cardano.org/cip/CIP-0123)(the second -- batch of bitwise builtins). @@ -22,11 +22,17 @@ module Evaluation.Builtins.Bitwise.CIP0123 ( ffsZero, shiftMinBound, rotateMinBound, - ffs6453 - ) where + ffs6453, +) where -import Evaluation.Helpers (assertEvaluatesToConstant, evaluateTheSame, evaluateToHaskell, - evaluatesToConstant, forAllByteString, forAllByteStringThat) +import Evaluation.Helpers ( + assertEvaluatesToConstant, + evaluateTheSame, + evaluateToHaskell, + evaluatesToConstant, + forAllByteString, + forAllByteStringThat, + ) import PlutusCore qualified as PLC import PlutusCore.MkPlc (builtin, mkConstant, mkIterAppNoAnn) @@ -40,8 +46,8 @@ import Hedgehog (Property, forAll, property) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testPropertyNamed) import Test.Tasty.HUnit (testCase) +import Test.Tasty.Hedgehog (testPropertyNamed) -- | Test for a regression found [here](https://github.com/IntersectMBO/plutus/pull/6453). ffs6453 :: Property @@ -52,9 +58,11 @@ ffs6453 = property $ do -- Generate a prefix nonzero byte prefix <- forAll . Gen.word8 . Range.constant 0x01 $ 0xFF let expected = 8 * BS.length suffix + Bits.countTrailingZeros prefix - let lhs = mkIterAppNoAnn (builtin () PLC.FindFirstSetBit) [ - mkConstant @ByteString () . BS.cons prefix $ suffix - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.FindFirstSetBit) + [ mkConstant @ByteString () . BS.cons prefix $ suffix + ] evaluatesToConstant @Integer (fromIntegral expected) lhs -- | If given 'Int' 'minBound' as an argument, rotations behave sensibly. @@ -68,14 +76,18 @@ rotateMinBound = property $ do -- rotation using this reduced argument versus the actual argument. let minBoundInt = fromIntegral (minBound :: Int) let minBoundIntReduced = negate (abs minBoundInt `rem` bitLen) - let lhs = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () minBoundInt - ] - let rhs = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () minBoundIntReduced - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () minBoundInt + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () minBoundIntReduced + ] evaluateTheSame lhs rhs -- | If given 'Int' 'minBound' as an argument, shifts behave sensibly. @@ -83,10 +95,12 @@ shiftMinBound :: Property shiftMinBound = property $ do bs <- forAllByteString 0 512 let len = BS.length bs - let shiftExp = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () . fromIntegral $ (minBound :: Int) - ] + let shiftExp = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () . fromIntegral $ (minBound :: Int) + ] evaluatesToConstant @ByteString (BS.replicate len 0x00) shiftExp -- | Finding the first set bit in a bytestring with only zero bytes should always give -1. @@ -94,9 +108,11 @@ ffsZero :: Property ffsZero = property $ do len <- forAll . Gen.integral . Range.linear 0 $ 512 let bs = BS.replicate len 0x00 - let rhs = mkIterAppNoAnn (builtin () PLC.FindFirstSetBit) [ - mkConstant @ByteString () bs - ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.FindFirstSetBit) + [ mkConstant @ByteString () bs + ] evaluatesToConstant @Integer (negate 1) rhs -- | If we find a valid index for the first set bit, then: @@ -109,21 +125,27 @@ ffsZero = property $ do ffsIndex :: Property ffsIndex = property $ do bs <- forAllByteStringThat (BS.any (/= 0x00)) 0 512 - let ffsExp = mkIterAppNoAnn (builtin () PLC.FindFirstSetBit) [ - mkConstant @ByteString () bs - ] + let ffsExp = + mkIterAppNoAnn + (builtin () PLC.FindFirstSetBit) + [ mkConstant @ByteString () bs + ] ix <- evaluateToHaskell ffsExp - let hitIxExp = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - mkConstant @ByteString () bs, - mkConstant @Integer () ix - ] + let hitIxExp = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ mkConstant @ByteString () bs + , mkConstant @Integer () ix + ] evaluatesToConstant True hitIxExp unless (ix == 0) $ do i <- forAll . Gen.integral . Range.linear 0 $ ix - 1 - let missIxExp = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - mkConstant @ByteString () bs, - mkConstant @Integer () i - ] + let missIxExp = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ mkConstant @ByteString () bs + , mkConstant @Integer () i + ] evaluatesToConstant False missIxExp -- | For any choice of bytestring, if we XOR it with itself, there should be no set bits; that is, @@ -132,14 +154,18 @@ ffsXor :: Property ffsXor = property $ do bs <- forAllByteString 0 512 semantics <- forAll Gen.bool - let rhsInner = mkIterAppNoAnn (builtin () PLC.XorByteString) [ - mkConstant @Bool () semantics, - mkConstant @ByteString () bs, - mkConstant @ByteString () bs - ] - let rhs = mkIterAppNoAnn (builtin () PLC.FindFirstSetBit) [ - rhsInner - ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.XorByteString) + [ mkConstant @Bool () semantics + , mkConstant @ByteString () bs + , mkConstant @ByteString () bs + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.FindFirstSetBit) + [ rhsInner + ] evaluatesToConstant @Integer (negate 1) rhs -- | If we replicate any byte any (positive) number of times, the first set bit @@ -148,20 +174,28 @@ ffsReplicate :: Property ffsReplicate = property $ do n <- forAll . Gen.integral . Range.linear 1 $ 512 w8 <- forAll . Gen.integral . Range.linear 0 $ 255 - let lhsInner = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - mkConstant @Integer () n, - mkConstant @Integer () w8 - ] - let lhs = mkIterAppNoAnn (builtin () PLC.FindFirstSetBit) [ - lhsInner - ] - let rhsInner = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - mkConstant @Integer () 1, - mkConstant @Integer () w8 - ] - let rhs = mkIterAppNoAnn (builtin () PLC.FindFirstSetBit) [ - rhsInner - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ mkConstant @Integer () n + , mkConstant @Integer () w8 + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.FindFirstSetBit) + [ lhsInner + ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ mkConstant @Integer () 1 + , mkConstant @Integer () w8 + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.FindFirstSetBit) + [ rhsInner + ] evaluateTheSame lhs rhs -- | For any bytestring whose bit length is @n@ and has @k@ set bits, its complement should have @@ -170,19 +204,27 @@ csbComplement :: Property csbComplement = property $ do bs <- forAllByteString 0 512 let bitLen = BS.length bs * 8 - let lhs = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - mkConstant @ByteString () bs - ] - let rhsComplement = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ - mkConstant @ByteString () bs - ] - let rhsCount = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - rhsComplement - ] - let rhs = mkIterAppNoAnn (builtin () PLC.SubtractInteger) [ - mkConstant @Integer () (fromIntegral bitLen), - rhsCount - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ mkConstant @ByteString () bs + ] + let rhsComplement = + mkIterAppNoAnn + (builtin () PLC.ComplementByteString) + [ mkConstant @ByteString () bs + ] + let rhsCount = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ rhsComplement + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.SubtractInteger) + [ mkConstant @Integer () (fromIntegral bitLen) + , rhsCount + ] evaluateTheSame lhs rhs -- | The inclusion-exclusion principle: specifically, for any @x@ and @y@, the number of set bits in @@ -191,34 +233,48 @@ csbInclusionExclusion :: Property csbInclusionExclusion = property $ do x <- forAllByteString 0 512 y <- forAllByteString 0 512 - let lhsInner = mkIterAppNoAnn (builtin () PLC.XorByteString) [ - mkConstant @Bool () False, - mkConstant @ByteString () x, - mkConstant @ByteString () y - ] - let lhs = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - lhsInner - ] - let rhsOr = mkIterAppNoAnn (builtin () PLC.OrByteString) [ - mkConstant @Bool () False, - mkConstant @ByteString () x, - mkConstant @ByteString () y - ] - let rhsAnd = mkIterAppNoAnn (builtin () PLC.AndByteString) [ - mkConstant @Bool () False, - mkConstant @ByteString () x, - mkConstant @ByteString () y - ] - let rhsCountOr = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - rhsOr - ] - let rhsCountAnd = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - rhsAnd - ] - let rhs = mkIterAppNoAnn (builtin () PLC.SubtractInteger) [ - rhsCountOr, - rhsCountAnd - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.XorByteString) + [ mkConstant @Bool () False + , mkConstant @ByteString () x + , mkConstant @ByteString () y + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ lhsInner + ] + let rhsOr = + mkIterAppNoAnn + (builtin () PLC.OrByteString) + [ mkConstant @Bool () False + , mkConstant @ByteString () x + , mkConstant @ByteString () y + ] + let rhsAnd = + mkIterAppNoAnn + (builtin () PLC.AndByteString) + [ mkConstant @Bool () False + , mkConstant @ByteString () x + , mkConstant @ByteString () y + ] + let rhsCountOr = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ rhsOr + ] + let rhsCountAnd = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ rhsAnd + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.SubtractInteger) + [ rhsCountOr + , rhsCountAnd + ] evaluateTheSame lhs rhs -- | For any bytestring @x@, the number of set bits in @x XOR x@ should be 0. @@ -226,162 +282,206 @@ csbXor :: Property csbXor = property $ do bs <- forAllByteString 0 512 semantics <- forAll Gen.bool - let rhsInner = mkIterAppNoAnn (builtin () PLC.XorByteString) [ - mkConstant @Bool () semantics, - mkConstant @ByteString () bs, - mkConstant @ByteString () bs - ] - let rhs = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - rhsInner - ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.XorByteString) + [ mkConstant @Bool () semantics + , mkConstant @ByteString () bs + , mkConstant @ByteString () bs + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ rhsInner + ] evaluatesToConstant @Integer 0 rhs -- | There should exist a monoid homomorphism between natural number addition -- and function composition for shifts over a fixed bytestring argument. shiftHomomorphism :: [TestTree] -shiftHomomorphism = [ - testPropertyNamed "zero shift is identity" "zero_shift_id" $ - mapTestLimitAtLeast 99 (`div` 10) idProp, - -- Because the homomorphism on shifts is more restrictive than on rotations (namely, it is for - -- naturals and their negative equivalents, not integers), we separate the composition property - -- into two: one dealing with non-negative, the other with non-positive. This helps a bit with - -- coverage, as otherwise, we wouldn't necessarily cover both paths equally well, as we'd have to - -- either discard mismatched signs (which are likely) or 'hack them in-place', which would skew - -- distributions. - testPropertyNamed "non-negative addition of shifts is composition" "plus_shift_pos_comp" $ - mapTestLimitAtLeast 50 (`div` 20) plusCompProp, - testPropertyNamed "non-positive addition of shifts is composition" "plus_shift_neg_comp" $ - mapTestLimitAtLeast 50 (`div` 20) minusCompProp +shiftHomomorphism = + [ testPropertyNamed "zero shift is identity" "zero_shift_id" $ + mapTestLimitAtLeast 99 (`div` 10) idProp + , -- Because the homomorphism on shifts is more restrictive than on rotations (namely, it is for + -- naturals and their negative equivalents, not integers), we separate the composition property + -- into two: one dealing with non-negative, the other with non-positive. This helps a bit with + -- coverage, as otherwise, we wouldn't necessarily cover both paths equally well, as we'd have to + -- either discard mismatched signs (which are likely) or 'hack them in-place', which would skew + -- distributions. + testPropertyNamed "non-negative addition of shifts is composition" "plus_shift_pos_comp" $ + mapTestLimitAtLeast 50 (`div` 20) plusCompProp + , testPropertyNamed "non-positive addition of shifts is composition" "plus_shift_neg_comp" $ + mapTestLimitAtLeast 50 (`div` 20) minusCompProp ] where idProp :: Property idProp = property $ do bs <- forAllByteString 0 512 - let lhs = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () 0 - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () 0 + ] evaluatesToConstant bs lhs plusCompProp :: Property plusCompProp = property $ do bs <- forAllByteString 0 512 i <- forAll . Gen.integral . Range.linear 0 $ 512 j <- forAll . Gen.integral . Range.linear 0 $ 512 - let lhsInner = mkIterAppNoAnn (builtin () PLC.AddInteger) [ - mkConstant @Integer () i, - mkConstant @Integer () j - ] - let lhs = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - lhsInner - ] - let rhsInner = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () i - ] - let rhs = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - rhsInner, - mkConstant @Integer () j - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.AddInteger) + [ mkConstant @Integer () i + , mkConstant @Integer () j + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , lhsInner + ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () i + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ rhsInner + , mkConstant @Integer () j + ] evaluateTheSame lhs rhs minusCompProp :: Property minusCompProp = property $ do bs <- forAllByteString 0 512 i <- forAll . Gen.integral . Range.linear 0 $ negate 512 j <- forAll . Gen.integral . Range.linear 0 $ negate 512 - let lhsInner = mkIterAppNoAnn (builtin () PLC.AddInteger) [ - mkConstant @Integer () i, - mkConstant @Integer () j - ] - let lhs = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - lhsInner - ] - let rhsInner = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () i - ] - let rhs = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - rhsInner, - mkConstant @Integer () j - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.AddInteger) + [ mkConstant @Integer () i + , mkConstant @Integer () j + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , lhsInner + ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () i + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ rhsInner + , mkConstant @Integer () j + ] evaluateTheSame lhs rhs -- | There should exist a monoid homomorphism between integer addition and function composition for -- rotations over a fixed bytestring argument. rotateHomomorphism :: [TestTree] -rotateHomomorphism = [ - testPropertyNamed "zero rotation is identity" "zero_rotate_id" $ - mapTestLimitAtLeast 99 (`div` 10) idProp, - testPropertyNamed "addition of rotations is composition" "plus_rotate_comp" $ - mapTestLimitAtLeast 50 (`div` 20) compProp +rotateHomomorphism = + [ testPropertyNamed "zero rotation is identity" "zero_rotate_id" $ + mapTestLimitAtLeast 99 (`div` 10) idProp + , testPropertyNamed "addition of rotations is composition" "plus_rotate_comp" $ + mapTestLimitAtLeast 50 (`div` 20) compProp ] where idProp :: Property idProp = property $ do bs <- forAllByteString 0 512 - let lhs = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () 0 - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () 0 + ] evaluatesToConstant bs lhs compProp :: Property compProp = property $ do bs <- forAllByteString 0 512 i <- forAll . Gen.integral . Range.linear (negate 512) $ 512 j <- forAll . Gen.integral . Range.linear (negate 512) $ 512 - let lhsInner = mkIterAppNoAnn (builtin () PLC.AddInteger) [ - mkConstant @Integer () i, - mkConstant @Integer () j - ] - let lhs = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - lhsInner - ] - let rhsInner = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () i - ] - let rhs = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - rhsInner, - mkConstant @Integer () j - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.AddInteger) + [ mkConstant @Integer () i + , mkConstant @Integer () j + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , lhsInner + ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () i + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ rhsInner + , mkConstant @Integer () j + ] evaluateTheSame lhs rhs -- | There should exist a monoid homomorphism between bytestring concatenation and natural number -- addition. csbHomomorphism :: [TestTree] -csbHomomorphism = [ - testCase "count of empty is zero" $ do - let lhs = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - mkConstant @ByteString () "" - ] - assertEvaluatesToConstant @Integer 0 lhs, - testPropertyNamed "count of concat is addition" "concat_count_plus" $ - mapTestLimitAtLeast 50 (`div` 20) compProp +csbHomomorphism = + [ testCase "count of empty is zero" $ do + let lhs = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ mkConstant @ByteString () "" + ] + assertEvaluatesToConstant @Integer 0 lhs + , testPropertyNamed "count of concat is addition" "concat_count_plus" $ + mapTestLimitAtLeast 50 (`div` 20) compProp ] where compProp :: Property compProp = property $ do bs1 <- forAllByteString 0 512 bs2 <- forAllByteString 0 512 - let lhsInner = mkIterAppNoAnn (builtin () PLC.AppendByteString) [ - mkConstant @ByteString () bs1, - mkConstant @ByteString () bs2 - ] - let lhs = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - lhsInner - ] - let rhsLeft = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - mkConstant @ByteString () bs1 - ] - let rhsRight = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - mkConstant @ByteString () bs2 - ] - let rhs = mkIterAppNoAnn (builtin () PLC.AddInteger) [ - rhsLeft, - rhsRight - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.AppendByteString) + [ mkConstant @ByteString () bs1 + , mkConstant @ByteString () bs2 + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ lhsInner + ] + let rhsLeft = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ mkConstant @ByteString () bs1 + ] + let rhsRight = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ mkConstant @ByteString () bs2 + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.AddInteger) + [ rhsLeft + , rhsRight + ] evaluateTheSame lhs rhs -- | Shifting by more than the bit length (either positive or negative) clears the result. @@ -393,19 +493,25 @@ shiftClear = property $ do adjustment <- case signum i of (-1) -> pure $ negate bitLen + i -- Here, we shift by the length exactly, so we randomly pick negative or positive - 0 -> forAll . Gen.element $ [bitLen, negate bitLen] - _ -> pure $ bitLen + i - let lhs = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () (fromIntegral adjustment) - ] - let rhsInner = mkIterAppNoAnn (builtin () PLC.LengthOfByteString) [ - mkConstant @ByteString () bs - ] - let rhs = mkIterAppNoAnn (builtin () PLC.ReplicateByte) [ - rhsInner, - mkConstant @Integer () 0 - ] + 0 -> forAll . Gen.element $ [bitLen, negate bitLen] + _ -> pure $ bitLen + i + let lhs = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () (fromIntegral adjustment) + ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.LengthOfByteString) + [ mkConstant @ByteString () bs + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.ReplicateByte) + [ rhsInner + , mkConstant @Integer () 0 + ] evaluateTheSame lhs rhs -- | Positive shifts clear low-index bits. @@ -415,14 +521,18 @@ shiftPosClearLow = property $ do let bitLen = 8 * BS.length bs n <- forAll . Gen.integral . Range.linear 1 $ bitLen - 1 i <- forAll . Gen.integral . Range.linear 0 $ n - 1 - let lhsInner = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () (fromIntegral n) - ] - let lhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - lhsInner, - mkConstant @Integer () (fromIntegral i) - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () (fromIntegral n) + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ lhsInner + , mkConstant @Integer () (fromIntegral i) + ] evaluatesToConstant False lhs -- | Negative shifts clear high-index bits. @@ -432,14 +542,18 @@ shiftNegClearHigh = property $ do let bitLen = 8 * BS.length bs n <- forAll . Gen.integral . Range.linear 1 $ bitLen - 1 i <- forAll . Gen.integral . Range.linear 0 $ n - 1 - let lhsInner = mkIterAppNoAnn (builtin () PLC.ShiftByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () (fromIntegral . negate $ n) - ] - let lhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - lhsInner, - mkConstant @Integer () (fromIntegral $ bitLen - i - 1) - ] + let lhsInner = + mkIterAppNoAnn + (builtin () PLC.ShiftByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () (fromIntegral . negate $ n) + ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ lhsInner + , mkConstant @Integer () (fromIntegral $ bitLen - i - 1) + ] evaluatesToConstant False lhs -- | Rotations by more than the bit length 'roll over' bits. @@ -448,16 +562,23 @@ rotateRollover = property $ do bs <- forAllByteString 0 512 let bitLen = 8 * BS.length bs i <- forAll . Gen.integral . Range.linear (negate 512) $ 512 - let lhs = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () (case signum i of - (-1) -> (negate . fromIntegral $ bitLen) + i - _ -> fromIntegral bitLen + i) - ] - let rhs = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () i - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer + () + ( case signum i of + (-1) -> (negate . fromIntegral $ bitLen) + i + _ -> fromIntegral bitLen + i + ) + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () i + ] evaluateTheSame lhs rhs -- | Rotations move bits, but don't change them. @@ -467,22 +588,30 @@ rotateMoveBits = property $ do let bitLen = 8 * BS.length bs i <- forAll . Gen.integral . Range.linear 0 $ bitLen - 1 j <- forAll . Gen.integral . Range.linear (negate 256) $ 256 - let lhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - mkConstant @ByteString () bs, - mkConstant @Integer () (fromIntegral i) - ] - let rhsRotation = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () (fromIntegral j) - ] - let rhsIndex = mkIterAppNoAnn (builtin () PLC.ModInteger) [ - mkConstant @Integer () (fromIntegral $ i + j), - mkConstant @Integer () (fromIntegral bitLen) - ] - let rhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [ - rhsRotation, - rhsIndex - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ mkConstant @ByteString () bs + , mkConstant @Integer () (fromIntegral i) + ] + let rhsRotation = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () (fromIntegral j) + ] + let rhsIndex = + mkIterAppNoAnn + (builtin () PLC.ModInteger) + [ mkConstant @Integer () (fromIntegral $ i + j) + , mkConstant @Integer () (fromIntegral bitLen) + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.ReadBit) + [ rhsRotation + , rhsIndex + ] evaluateTheSame lhs rhs -- | Rotations do not change how many set (and clear) bits there are. @@ -490,14 +619,20 @@ csbRotate :: Property csbRotate = property $ do bs <- forAllByteString 0 512 i <- forAll . Gen.integral . Range.linear (negate 512) $ 512 - let lhs = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - mkConstant @ByteString () bs - ] - let rhsInner = mkIterAppNoAnn (builtin () PLC.RotateByteString) [ - mkConstant @ByteString () bs, - mkConstant @Integer () i - ] - let rhs = mkIterAppNoAnn (builtin () PLC.CountSetBits) [ - rhsInner - ] + let lhs = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ mkConstant @ByteString () bs + ] + let rhsInner = + mkIterAppNoAnn + (builtin () PLC.RotateByteString) + [ mkConstant @ByteString () bs + , mkConstant @Integer () i + ] + let rhs = + mkIterAppNoAnn + (builtin () PLC.CountSetBits) + [ rhsInner + ] evaluateTheSame lhs rhs diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs index a35d5cae8ee..7b5fece9b41 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs @@ -1,37 +1,37 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Evaluation.Builtins.Common - ( unsafeSplitStructuralOperational - , evaluateCek - , evaluateCekNoEmit - , readKnownCek - , typecheckAnd - , typecheckEvaluateCek - , typecheckEvaluateCekNoEmit - , typecheckReadKnownCek - , PlcType - , PlcTerm - , UplcTerm - , TypeErrorOrCekResult (..) - , evalTerm - , mkApp1 - , mkApp2 - , ok - , fails - , evalOkEq - , evalOkTrue - , integer - , bytestring - , zero - , one - , true - , false - , cekSuccessFalse - , cekSuccessTrue - ) +{-# LANGUAGE TypeOperators #-} + +module Evaluation.Builtins.Common ( + unsafeSplitStructuralOperational, + evaluateCek, + evaluateCekNoEmit, + readKnownCek, + typecheckAnd, + typecheckEvaluateCek, + typecheckEvaluateCekNoEmit, + typecheckReadKnownCek, + PlcType, + PlcTerm, + UplcTerm, + TypeErrorOrCekResult (..), + evalTerm, + mkApp1, + mkApp2, + ok, + fails, + evalOkEq, + evalOkTrue, + integer, + bytestring, + zero, + one, + true, + false, + cekSuccessFalse, + cekSuccessTrue, +) where import PlutusCore qualified as TPLC @@ -58,90 +58,110 @@ import Data.Text (Text) import Test.Tasty.QuickCheck (Property, property, (===)) -- | Type check and evaluate a term. -typecheckAnd - :: ( MonadError (TypeErrorPlc uni fun ()) m, TPLC.Typecheckable uni fun, GEq uni - , CaseBuiltin uni, Closed uni, uni `Everywhere` ExMemoryUsage - ) - => BuiltinSemanticsVariant fun - -> (MachineParameters CekMachineCosts fun (CekValue uni fun ()) -> - UPLC.Term Name uni fun () -> a) - -> CostingPart uni fun -> TPLC.Term TyName Name uni fun () -> m a +typecheckAnd :: + ( MonadError (TypeErrorPlc uni fun ()) m + , TPLC.Typecheckable uni fun + , GEq uni + , CaseBuiltin uni + , Closed uni + , uni `Everywhere` ExMemoryUsage + ) => + BuiltinSemanticsVariant fun -> + ( MachineParameters CekMachineCosts fun (CekValue uni fun ()) -> + UPLC.Term Name uni fun () -> + a + ) -> + CostingPart uni fun -> + TPLC.Term TyName Name uni fun () -> + m a typecheckAnd semvar action costingPart term = TPLC.runQuoteT $ do - -- Here we don't use 'getDefTypeCheckConfig', to cover the absurd case where - -- builtins can change their type according to their 'BuiltinSemanticsVariant'. - tcConfig <- TypeCheckConfig defKindCheckConfig <$> builtinMeaningsToTypes semvar () - _ <- TPLC.inferType tcConfig term - return . action runtime $ TPLC.eraseTerm term - where - runtime = MachineParameters def . mkMachineVariantParameters semvar $ - -- FIXME: make sure we have the the correct cost model for the semantics variant. - CostModel defaultCekMachineCostsForTesting costingPart + -- Here we don't use 'getDefTypeCheckConfig', to cover the absurd case where + -- builtins can change their type according to their 'BuiltinSemanticsVariant'. + tcConfig <- TypeCheckConfig defKindCheckConfig <$> builtinMeaningsToTypes semvar () + _ <- TPLC.inferType tcConfig term + return . action runtime $ TPLC.eraseTerm term + where + runtime = + MachineParameters def . mkMachineVariantParameters semvar $ + -- FIXME: make sure we have the the correct cost model for the semantics variant. + CostModel defaultCekMachineCostsForTesting costingPart -- | Type check and evaluate a term, logging enabled. -typecheckEvaluateCek - :: ( MonadError (TypeErrorPlc uni fun ()) m, TPLC.Typecheckable uni fun, GEq uni - , uni `Everywhere` ExMemoryUsage, PrettyUni uni, Pretty fun - , CaseBuiltin uni - ) - => BuiltinSemanticsVariant fun - -> CostingPart uni fun - -> TPLC.Term TyName Name uni fun () - -> m (EvaluationResult (UPLC.Term Name uni fun ()), [Text]) +typecheckEvaluateCek :: + ( MonadError (TypeErrorPlc uni fun ()) m + , TPLC.Typecheckable uni fun + , GEq uni + , uni `Everywhere` ExMemoryUsage + , PrettyUni uni + , Pretty fun + , CaseBuiltin uni + ) => + BuiltinSemanticsVariant fun -> + CostingPart uni fun -> + TPLC.Term TyName Name uni fun () -> + m (EvaluationResult (UPLC.Term Name uni fun ()), [Text]) typecheckEvaluateCek semvar = - typecheckAnd semvar $ \params -> - first unsafeSplitStructuralOperational . evaluateCek logEmitter params + typecheckAnd semvar $ \params -> + first unsafeSplitStructuralOperational . evaluateCek logEmitter params -- | Type check and evaluate a term, logging disabled. -typecheckEvaluateCekNoEmit - :: ( MonadError (TypeErrorPlc uni fun ()) m, TPLC.Typecheckable uni fun, GEq uni - , uni `Everywhere` ExMemoryUsage, PrettyUni uni, Pretty fun - , CaseBuiltin uni - ) - => BuiltinSemanticsVariant fun - -> CostingPart uni fun - -> TPLC.Term TyName Name uni fun () - -> m (EvaluationResult (UPLC.Term Name uni fun ())) +typecheckEvaluateCekNoEmit :: + ( MonadError (TypeErrorPlc uni fun ()) m + , TPLC.Typecheckable uni fun + , GEq uni + , uni `Everywhere` ExMemoryUsage + , PrettyUni uni + , Pretty fun + , CaseBuiltin uni + ) => + BuiltinSemanticsVariant fun -> + CostingPart uni fun -> + TPLC.Term TyName Name uni fun () -> + m (EvaluationResult (UPLC.Term Name uni fun ())) typecheckEvaluateCekNoEmit semvar = - typecheckAnd semvar $ \params -> - unsafeSplitStructuralOperational . evaluateCekNoEmit params + typecheckAnd semvar $ \params -> + unsafeSplitStructuralOperational . evaluateCekNoEmit params -- | Type check and convert a Plutus Core term to a Haskell value. -typecheckReadKnownCek - :: ( MonadError (TypeErrorPlc uni fun ()) m, TPLC.Typecheckable uni fun, GEq uni - , uni `Everywhere` ExMemoryUsage, PrettyUni uni, Pretty fun - , CaseBuiltin uni - , ReadKnown (UPLC.Term Name uni fun ()) a - ) - => BuiltinSemanticsVariant fun - -> CostingPart uni fun - -> TPLC.Term TyName Name uni fun () - -> m (Either (CekEvaluationException Name uni fun) a) +typecheckReadKnownCek :: + ( MonadError (TypeErrorPlc uni fun ()) m + , TPLC.Typecheckable uni fun + , GEq uni + , uni `Everywhere` ExMemoryUsage + , PrettyUni uni + , Pretty fun + , CaseBuiltin uni + , ReadKnown (UPLC.Term Name uni fun ()) a + ) => + BuiltinSemanticsVariant fun -> + CostingPart uni fun -> + TPLC.Term TyName Name uni fun () -> + m (Either (CekEvaluationException Name uni fun) a) typecheckReadKnownCek semvar = - typecheckAnd semvar readKnownCek - + typecheckAnd semvar readKnownCek -- TPLC/UPLC utilities type PlcType = TPLC.Type TPLC.TyName TPLC.DefaultUni () -type PlcTerm = TPLC.Term TPLC.TyName TPLC.Name TPLC.DefaultUni TPLC.DefaultFun () +type PlcTerm = TPLC.Term TPLC.TyName TPLC.Name TPLC.DefaultUni TPLC.DefaultFun () type PlcError = TypeErrorPlc TPLC.DefaultUni TPLC.DefaultFun () type UplcTerm = UPLC.Term TPLC.Name TPLC.DefaultUni TPLC.DefaultFun () -- Possible CEK evluation results, flattened out -data TypeErrorOrCekResult = - TypeCheckError PlcError +data TypeErrorOrCekResult + = TypeCheckError PlcError | CekError | CekSuccess UplcTerm - deriving stock (Eq, Show) + deriving stock (Eq, Show) evalTerm :: PlcTerm -> TypeErrorOrCekResult evalTerm term = - case typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term - of Left e -> TypeCheckError e - Right x -> - case x of - TPLC.EvaluationFailure -> CekError - TPLC.EvaluationSuccess s -> CekSuccess s + case typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term of + Left e -> TypeCheckError e + Right x -> + case x of + TPLC.EvaluationFailure -> CekError + TPLC.EvaluationSuccess s -> CekSuccess s integer :: Integer -> PlcTerm integer = mkConstant () @@ -171,16 +191,16 @@ mkApp1 :: TPLC.DefaultFun -> PlcTerm -> PlcTerm mkApp1 b x = mkIterAppNoAnn (builtin () b) [x] mkApp2 :: TPLC.DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm -mkApp2 b x y = mkIterAppNoAnn (builtin () b) [x,y] +mkApp2 b x y = mkIterAppNoAnn (builtin () b) [x, y] -- QuickCheck utilities -- | Term evaluates successfully ok :: PlcTerm -> Property ok t = property $ - case evalTerm t of - CekSuccess _ -> True - _ -> False + case evalTerm t of + CekSuccess _ -> True + _ -> False -- | Term fails to evaluate successfully fails :: PlcTerm -> Property @@ -189,11 +209,9 @@ fails t = evalTerm t === CekError -- Check that two terms evaluate successfully and return the same result evalOkEq :: PlcTerm -> PlcTerm -> Property evalOkEq t1 t2 = - case evalTerm t1 of - r@(CekSuccess _) -> r === evalTerm t2 - _ -> property False + case evalTerm t1 of + r@(CekSuccess _) -> r === evalTerm t2 + _ -> property False evalOkTrue :: PlcTerm -> Property evalOkTrue t = evalOkEq t true - - diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs index f212938aa9f..11cf1284708 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs @@ -1,7 +1,6 @@ -- editorconfig-checker-disable-file - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Evaluation.Builtins.Conversion ( i2bProperty1, @@ -16,8 +15,8 @@ module Evaluation.Builtins.Conversion ( b2iProperty3, i2bCipExamples, i2bLimitTests, - b2iCipExamples - ) where + b2iCipExamples, +) where import Evaluation.Builtins.Common (typecheckEvaluateCek) import PlutusCore qualified as PLC @@ -48,18 +47,24 @@ i2bProperty1 = do -- We limit this temporarily due to the limit imposed on lengths for the -- conversion primitive. d <- forAllWith ppShow $ Gen.integral (Range.constant 0 Bitwise.maximumOutputLength) - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () e, - mkConstant @Integer () d, - mkConstant @Integer () 0 - ] - let lenExp = mkIterAppNoAnn (builtin () PLC.LengthOfByteString) [ - actualExp - ] - let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsInteger) [ - mkConstant @Integer () d, - lenExp - ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () e + , mkConstant @Integer () d + , mkConstant @Integer () 0 + ] + let lenExp = + mkIterAppNoAnn + (builtin () PLC.LengthOfByteString) + [ actualExp + ] + let compareExp = + mkIterAppNoAnn + (builtin () PLC.EqualsInteger) + [ mkConstant @Integer () d + , lenExp + ] evaluateAndVerify (mkConstant @Bool () True) compareExp -- indexByteString (integerToByteString e k 0) j = 0 @@ -69,16 +74,20 @@ i2bProperty2 = do -- We limit this temporarily due to the limit imposed on lengths for the -- conversion primitive. k <- forAllWith ppShow $ Gen.integral (Range.constant 1 Bitwise.maximumOutputLength) - j <- forAllWith ppShow $ Gen.integral (Range.constant 0 (k-1)) - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () e, - mkConstant @Integer () k, - mkConstant @Integer () 0 - ] - let indexExp = mkIterAppNoAnn (builtin () PLC.IndexByteString) [ - actualExp, - mkConstant @Integer () j - ] + j <- forAllWith ppShow $ Gen.integral (Range.constant 0 (k - 1)) + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () e + , mkConstant @Integer () k + , mkConstant @Integer () 0 + ] + let indexExp = + mkIterAppNoAnn + (builtin () PLC.IndexByteString) + [ actualExp + , mkConstant @Integer () j + ] evaluateAndVerify (mkConstant @Integer () 0) indexExp -- lengthOfByteString (integerToByteString e 0 p) > 0 @@ -86,18 +95,24 @@ i2bProperty3 :: PropertyT IO () i2bProperty3 = do e <- forAllWith ppShow Gen.bool p <- forAllWith ppShow genP - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () e, - mkConstant @Integer () 0, - mkConstant @Integer () p - ] - let lengthExp = mkIterAppNoAnn (builtin () PLC.LengthOfByteString) [ - actualExp - ] - let compareExp = mkIterAppNoAnn (builtin () PLC.LessThanInteger) [ - mkConstant @Integer () 0, - lengthExp - ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () e + , mkConstant @Integer () 0 + , mkConstant @Integer () p + ] + let lengthExp = + mkIterAppNoAnn + (builtin () PLC.LengthOfByteString) + [ actualExp + ] + let compareExp = + mkIterAppNoAnn + (builtin () PLC.LessThanInteger) + [ mkConstant @Integer () 0 + , lengthExp + ] evaluateAndVerify (mkConstant @Bool () True) compareExp -- integerToByteString False 0 (multiplyInteger p 256) = consByteString @@ -105,24 +120,32 @@ i2bProperty3 = do i2bProperty4 :: PropertyT IO () i2bProperty4 = do p <- forAllWith ppShow genP - let pExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - mkConstant @Integer () p - ] - let pTimesExp = mkIterAppNoAnn (builtin () PLC.MultiplyInteger) [ - mkConstant @Integer () p, - mkConstant @Integer () 256 - ] - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - pTimesExp - ] - let expectedExp = mkIterAppNoAnn (builtin () PLC.ConsByteString) [ - mkConstant @Integer () 0, - pExp - ] + let pExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , mkConstant @Integer () p + ] + let pTimesExp = + mkIterAppNoAnn + (builtin () PLC.MultiplyInteger) + [ mkConstant @Integer () p + , mkConstant @Integer () 256 + ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , pTimesExp + ] + let expectedExp = + mkIterAppNoAnn + (builtin () PLC.ConsByteString) + [ mkConstant @Integer () 0 + , pExp + ] evaluateAndVerify2 expectedExp actualExp -- integerToByteString True 0 (multiplyInteger p 256) = appendByteString @@ -130,24 +153,32 @@ i2bProperty4 = do i2bProperty5 :: PropertyT IO () i2bProperty5 = do p <- forAllWith ppShow genP - let pExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - mkConstant @Integer () p - ] - let pTimesExp = mkIterAppNoAnn (builtin () PLC.MultiplyInteger) [ - mkConstant @Integer () p, - mkConstant @Integer () 256 - ] - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - pTimesExp - ] - let expectedExp = mkIterAppNoAnn (builtin () PLC.AppendByteString) [ - pExp, - mkConstant @ByteString () "\NUL" - ] + let pExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , mkConstant @Integer () p + ] + let pTimesExp = + mkIterAppNoAnn + (builtin () PLC.MultiplyInteger) + [ mkConstant @Integer () p + , mkConstant @Integer () 256 + ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , pTimesExp + ] + let expectedExp = + mkIterAppNoAnn + (builtin () PLC.AppendByteString) + [ pExp + , mkConstant @ByteString () "\NUL" + ] evaluateAndVerify2 expectedExp actualExp -- integerToByteString False 0 (plusInteger (multiplyInteger q 256) r) = @@ -156,33 +187,45 @@ i2bProperty6 :: PropertyT IO () i2bProperty6 = do q <- forAllWith ppShow genQ r <- forAllWith ppShow genR - let qTimesExp = mkIterAppNoAnn (builtin () PLC.MultiplyInteger) [ - mkConstant @Integer () q, - mkConstant @Integer () 256 - ] - let largeNumberExp = mkIterAppNoAnn (builtin () PLC.AddInteger) [ - qTimesExp, - mkConstant @Integer () r - ] - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - largeNumberExp - ] - let rBSExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - mkConstant @Integer () r - ] - let qBSExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - mkConstant @Integer () q - ] - let expectedExp = mkIterAppNoAnn (builtin () PLC.AppendByteString) [ - rBSExp, - qBSExp - ] + let qTimesExp = + mkIterAppNoAnn + (builtin () PLC.MultiplyInteger) + [ mkConstant @Integer () q + , mkConstant @Integer () 256 + ] + let largeNumberExp = + mkIterAppNoAnn + (builtin () PLC.AddInteger) + [ qTimesExp + , mkConstant @Integer () r + ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , largeNumberExp + ] + let rBSExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , mkConstant @Integer () r + ] + let qBSExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , mkConstant @Integer () q + ] + let expectedExp = + mkIterAppNoAnn + (builtin () PLC.AppendByteString) + [ rBSExp + , qBSExp + ] evaluateAndVerify2 expectedExp actualExp -- integerToByteString True 0 (plusInteger (multiplyInteger q 256) r) = @@ -192,33 +235,45 @@ i2bProperty7 :: PropertyT IO () i2bProperty7 = do q <- forAllWith ppShow genQ r <- forAllWith ppShow genR - let qTimesExp = mkIterAppNoAnn (builtin () PLC.MultiplyInteger) [ - mkConstant @Integer () q, - mkConstant @Integer () 256 - ] - let largeNumberExp = mkIterAppNoAnn (builtin () PLC.AddInteger) [ - qTimesExp, - mkConstant @Integer () r - ] - let rBSExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - mkConstant @Integer () r - ] - let qBSExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - mkConstant @Integer () q - ] - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - largeNumberExp - ] - let expectedExp = mkIterAppNoAnn (builtin () PLC.AppendByteString) [ - qBSExp, - rBSExp - ] + let qTimesExp = + mkIterAppNoAnn + (builtin () PLC.MultiplyInteger) + [ mkConstant @Integer () q + , mkConstant @Integer () 256 + ] + let largeNumberExp = + mkIterAppNoAnn + (builtin () PLC.AddInteger) + [ qTimesExp + , mkConstant @Integer () r + ] + let rBSExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , mkConstant @Integer () r + ] + let qBSExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , mkConstant @Integer () q + ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , largeNumberExp + ] + let expectedExp = + mkIterAppNoAnn + (builtin () PLC.AppendByteString) + [ qBSExp + , rBSExp + ] evaluateAndVerify2 expectedExp actualExp -- byteStringToInteger b (integerToByteString b 0 q) = q @@ -226,15 +281,19 @@ b2iProperty1 :: PropertyT IO () b2iProperty1 = do b <- forAllWith ppShow Gen.bool q <- forAllWith ppShow genQ - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () b, - mkConstant @Integer () 0, - mkConstant @Integer () q - ] - let convertedExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () b, - actualExp - ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () b + , mkConstant @Integer () 0 + , mkConstant @Integer () q + ] + let convertedExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () b + , actualExp + ] evaluateAndVerify (mkConstant @Integer () q) convertedExp -- byteStringToInteger b (consByteString w8 emptyByteString) = w8 @@ -242,14 +301,18 @@ b2iProperty2 :: PropertyT IO () b2iProperty2 = do w8 :: Integer <- fromIntegral <$> forAllWith ppShow (Gen.enumBounded @_ @Word8) b <- forAllWith ppShow Gen.bool - let consed = mkIterAppNoAnn (builtin () PLC.ConsByteString) [ - mkConstant @Integer () w8, - mkConstant @ByteString () "" - ] - let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () b, - consed - ] + let consed = + mkIterAppNoAnn + (builtin () PLC.ConsByteString) + [ mkConstant @Integer () w8 + , mkConstant @ByteString () "" + ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () b + , consed + ] evaluateAndVerify (mkConstant @Integer () w8) actualExp -- integerToByteString b (lengthOfByteString bs) (byteStringToInteger b bs) = bs @@ -257,262 +320,346 @@ b2iProperty3 :: PropertyT IO () b2iProperty3 = do b <- forAllWith ppShow Gen.bool bs <- forAllWith ppShow $ Gen.bytes (Range.linear 0 17) - let sized = mkIterAppNoAnn (builtin () PLC.LengthOfByteString) [ - mkConstant @ByteString () bs - ] - let converted = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () b, - mkConstant @ByteString () bs - ] - let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () b, - sized, - converted - ] + let sized = + mkIterAppNoAnn + (builtin () PLC.LengthOfByteString) + [ mkConstant @ByteString () bs + ] + let converted = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () b + , mkConstant @ByteString () bs + ] + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () b + , sized + , converted + ] evaluateAndVerify (mkConstant @ByteString () bs) actualExp i2bCipExamples :: [TestTree] -i2bCipExamples = [ - -- integerToByteString False 0 (-1) => failure - testCase "example 1" (let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - mkConstant @Integer () (-1) - ] - in evaluateShouldFail actualExp), - -- integerToByteString True 0 (-1) => failure - testCase "example 2" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - mkConstant @Integer () (-1) - ] - in evaluateShouldFail actualExp, - -- integerToByteString False 100 (-1) => failure - testCase "example 3" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 100, - mkConstant @Integer () (-1) - ] - in evaluateShouldFail actualExp, - -- integerToByteString False 0 0 => [ ] - testCase "example 4" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - mkConstant @Integer () 0 - ] - in evaluateAssertEqual (mkConstant @ByteString () "") actualExp, - -- integerToByteString True 0 0 => [ ] - testCase "example 5" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - mkConstant @Integer () 0 - ] - in evaluateAssertEqual (mkConstant @ByteString () "") actualExp, - -- integerToByteString False 5 0 => [ 0x00, 0x00, 0x00, 0x00, 0x00] - testCase "example 6" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 5, - mkConstant @Integer () 0 - ] - expectedExp = mkConstant @ByteString () "\NUL\NUL\NUL\NUL\NUL" - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString True 5 0 => [ 0x00, 0x00, 0x00, 0x00, 0x00] - testCase "example 7" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 5, - mkConstant @Integer () 0 - ] - expectedExp = mkConstant @ByteString () "\NUL\NUL\NUL\NUL\NUL" - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString False 536870912 0 => failure - testCase "example 8" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 536870912, - mkConstant @Integer () 0 - ] - in evaluateShouldFail actualExp, - -- integerToByteString True 536870912 0 => failure - testCase "example 9" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 536870912, - mkConstant @Integer () 0 - ] - in evaluateShouldFail actualExp, - -- integerToByteString False 1 404 => failure - testCase "example 10" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 1, - mkConstant @Integer () 404 - ] - in evaluateShouldFail actualExp, - -- integerToByteString True 1 404 => failure - testCase "example 11" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 1, - mkConstant @Integer () 404 - ] - in evaluateShouldFail actualExp, - -- integerToByteString False 2 404 => [ 0x94, 0x01 ] - testCase "example 12" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 2, - mkConstant @Integer () 404 - ] - expectedExp = mkConstant @ByteString () (fromList [0x94, 0x01]) - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString False 0 404 => [ 0x94, 0x01 ] - testCase "example 13" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 0, - mkConstant @Integer () 404 - ] - expectedExp = mkConstant @ByteString () (fromList [0x94, 0x01]) - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString True 2 404 => [ 0x01, 0x94 ] - testCase "example 14" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 2, - mkConstant @Integer () 404 - ] - expectedExp = mkConstant @ByteString () (fromList [0x01, 0x94]) - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString True 0 404 => [ 0x01, 0x94 ] - testCase "example 15" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 0, - mkConstant @Integer () 404 - ] - expectedExp = mkConstant @ByteString () (fromList [0x01, 0x94]) - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString False 5 404 => [ 0x94, 0x01, 0x00, 0x00, 0x00 ] - testCase "example 16" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () False, - mkConstant @Integer () 5, - mkConstant @Integer () 404 - ] - expectedExp = mkConstant @ByteString () (fromList [0x94, 0x01, 0x00, 0x00, 0x00]) - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString True 5 404 => [ 0x00, 0x00, 0x00, 0x01, 0x94 ] - testCase "example 17" $ let actualExp = mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () True, - mkConstant @Integer () 5, - mkConstant @Integer () 404 - ] - expectedExp = mkConstant @ByteString () (fromList [0x00, 0x00, 0x00, 0x01, 0x94]) - in evaluateAssertEqual expectedExp actualExp +i2bCipExamples = + [ -- integerToByteString False 0 (-1) => failure + testCase + "example 1" + ( let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , mkConstant @Integer () (-1) + ] + in evaluateShouldFail actualExp + ) + , -- integerToByteString True 0 (-1) => failure + testCase "example 2" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , mkConstant @Integer () (-1) + ] + in evaluateShouldFail actualExp + , -- integerToByteString False 100 (-1) => failure + testCase "example 3" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 100 + , mkConstant @Integer () (-1) + ] + in evaluateShouldFail actualExp + , -- integerToByteString False 0 0 => [ ] + testCase "example 4" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , mkConstant @Integer () 0 + ] + in evaluateAssertEqual (mkConstant @ByteString () "") actualExp + , -- integerToByteString True 0 0 => [ ] + testCase "example 5" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , mkConstant @Integer () 0 + ] + in evaluateAssertEqual (mkConstant @ByteString () "") actualExp + , -- integerToByteString False 5 0 => [ 0x00, 0x00, 0x00, 0x00, 0x00] + testCase "example 6" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 5 + , mkConstant @Integer () 0 + ] + expectedExp = mkConstant @ByteString () "\NUL\NUL\NUL\NUL\NUL" + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString True 5 0 => [ 0x00, 0x00, 0x00, 0x00, 0x00] + testCase "example 7" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 5 + , mkConstant @Integer () 0 + ] + expectedExp = mkConstant @ByteString () "\NUL\NUL\NUL\NUL\NUL" + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString False 536870912 0 => failure + testCase "example 8" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 536870912 + , mkConstant @Integer () 0 + ] + in evaluateShouldFail actualExp + , -- integerToByteString True 536870912 0 => failure + testCase "example 9" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 536870912 + , mkConstant @Integer () 0 + ] + in evaluateShouldFail actualExp + , -- integerToByteString False 1 404 => failure + testCase "example 10" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 1 + , mkConstant @Integer () 404 + ] + in evaluateShouldFail actualExp + , -- integerToByteString True 1 404 => failure + testCase "example 11" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 1 + , mkConstant @Integer () 404 + ] + in evaluateShouldFail actualExp + , -- integerToByteString False 2 404 => [ 0x94, 0x01 ] + testCase "example 12" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 2 + , mkConstant @Integer () 404 + ] + expectedExp = mkConstant @ByteString () (fromList [0x94, 0x01]) + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString False 0 404 => [ 0x94, 0x01 ] + testCase "example 13" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 0 + , mkConstant @Integer () 404 + ] + expectedExp = mkConstant @ByteString () (fromList [0x94, 0x01]) + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString True 2 404 => [ 0x01, 0x94 ] + testCase "example 14" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 2 + , mkConstant @Integer () 404 + ] + expectedExp = mkConstant @ByteString () (fromList [0x01, 0x94]) + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString True 0 404 => [ 0x01, 0x94 ] + testCase "example 15" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 0 + , mkConstant @Integer () 404 + ] + expectedExp = mkConstant @ByteString () (fromList [0x01, 0x94]) + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString False 5 404 => [ 0x94, 0x01, 0x00, 0x00, 0x00 ] + testCase "example 16" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () False + , mkConstant @Integer () 5 + , mkConstant @Integer () 404 + ] + expectedExp = mkConstant @ByteString () (fromList [0x94, 0x01, 0x00, 0x00, 0x00]) + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString True 5 404 => [ 0x00, 0x00, 0x00, 0x01, 0x94 ] + testCase "example 17" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () True + , mkConstant @Integer () 5 + , mkConstant @Integer () 404 + ] + expectedExp = mkConstant @ByteString () (fromList [0x00, 0x00, 0x00, 0x01, 0x94]) + in evaluateAssertEqual expectedExp actualExp ] -- Unit tests to make sure that `integerToByteString` behaves as expected for -- inputs close to the maximum size. -i2bLimitTests ::[TestTree] +i2bLimitTests :: [TestTree] i2bLimitTests = - let maxAcceptableInput = 2 ^ (8*Bitwise.maximumOutputLength) - 1 - maxOutput = fromList (take (fromIntegral Bitwise.maximumOutputLength) $ repeat 0xFF) - makeTests endianness = - let prefix = if endianness - then "Big-endian, " - else "Little-endian, " - mkIntegerToByteStringApp width input = - mkIterAppNoAnn (builtin () PLC.IntegerToByteString) [ - mkConstant @Bool () endianness, - mkConstant @Integer () width, - mkConstant @Integer () input - ] - in [ - -- integerToByteString 0 maxInput = 0xFF...FF - testCase (prefix ++ "maximum acceptable input, no length specified") $ - let actualExp = mkIntegerToByteStringApp 0 maxAcceptableInput - expectedExp = mkConstant @ByteString () maxOutput - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString maxLen maxInput = 0xFF...FF - testCase (prefix ++ "maximum acceptable input, maximum acceptable length argument") $ - let actualExp = mkIntegerToByteStringApp Bitwise.maximumOutputLength maxAcceptableInput - expectedExp = mkConstant @ByteString () maxOutput - in evaluateAssertEqual expectedExp actualExp, - -- integerToByteString 0 (maxInput+1) fails - testCase (prefix ++ "input too big, no length specified") $ - let actualExp = mkIntegerToByteStringApp 0 (maxAcceptableInput + 1) - in evaluateShouldFail actualExp, - -- integerToByteString maxLen (maxInput+1) fails - testCase (prefix ++ "input too big, maximum acceptable length argument") $ - let actualExp = mkIntegerToByteStringApp Bitwise.maximumOutputLength (maxAcceptableInput + 1) - in evaluateShouldFail actualExp, - -- integerToByteString (maxLen-1) maxInput fails - testCase (prefix ++ "maximum acceptable input, length argument not big enough") $ - let actualExp = mkIntegerToByteStringApp (Bitwise.maximumOutputLength - 1) maxAcceptableInput - in evaluateShouldFail actualExp, - -- integerToByteString _ (maxLen+1) 0 fails, just to make sure that - -- we can't go beyond the supposed limit - testCase (prefix ++ "input zero, length argument over limit") $ - let actualExp = mkIntegerToByteStringApp (Bitwise.maximumOutputLength + 1) 0 - in evaluateShouldFail actualExp + let maxAcceptableInput = 2 ^ (8 * Bitwise.maximumOutputLength) - 1 + maxOutput = fromList (take (fromIntegral Bitwise.maximumOutputLength) $ repeat 0xFF) + makeTests endianness = + let prefix = + if endianness + then "Big-endian, " + else "Little-endian, " + mkIntegerToByteStringApp width input = + mkIterAppNoAnn + (builtin () PLC.IntegerToByteString) + [ mkConstant @Bool () endianness + , mkConstant @Integer () width + , mkConstant @Integer () input + ] + in [ -- integerToByteString 0 maxInput = 0xFF...FF + testCase (prefix ++ "maximum acceptable input, no length specified") $ + let actualExp = mkIntegerToByteStringApp 0 maxAcceptableInput + expectedExp = mkConstant @ByteString () maxOutput + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString maxLen maxInput = 0xFF...FF + testCase (prefix ++ "maximum acceptable input, maximum acceptable length argument") $ + let actualExp = mkIntegerToByteStringApp Bitwise.maximumOutputLength maxAcceptableInput + expectedExp = mkConstant @ByteString () maxOutput + in evaluateAssertEqual expectedExp actualExp + , -- integerToByteString 0 (maxInput+1) fails + testCase (prefix ++ "input too big, no length specified") $ + let actualExp = mkIntegerToByteStringApp 0 (maxAcceptableInput + 1) + in evaluateShouldFail actualExp + , -- integerToByteString maxLen (maxInput+1) fails + testCase (prefix ++ "input too big, maximum acceptable length argument") $ + let actualExp = mkIntegerToByteStringApp Bitwise.maximumOutputLength (maxAcceptableInput + 1) + in evaluateShouldFail actualExp + , -- integerToByteString (maxLen-1) maxInput fails + testCase (prefix ++ "maximum acceptable input, length argument not big enough") $ + let actualExp = mkIntegerToByteStringApp (Bitwise.maximumOutputLength - 1) maxAcceptableInput + in evaluateShouldFail actualExp + , -- integerToByteString _ (maxLen+1) 0 fails, just to make sure that + -- we can't go beyond the supposed limit + testCase (prefix ++ "input zero, length argument over limit") $ + let actualExp = mkIntegerToByteStringApp (Bitwise.maximumOutputLength + 1) 0 + in evaluateShouldFail actualExp ] - in makeTests True ++ makeTests False + in makeTests True ++ makeTests False b2iCipExamples :: [TestTree] -b2iCipExamples = [ - -- byteStringToInteger False emptyByteString => 0 - testCase "example 1" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () False, - mkConstant @ByteString () "" - ] - expectedExp = mkConstant @Integer () 0 - in evaluateAssertEqual expectedExp actualExp, - -- byteStringToInteger True emptyByteString => 0 - testCase "example 2" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () True, - mkConstant @ByteString () "" - ] - expectedExp = mkConstant @Integer () 0 - in evaluateAssertEqual expectedExp actualExp, - -- byteStringToInteger False (consByteString 0x01 (consByteString 0x01 emptyByteString)) => - -- 257 - testCase "example 3" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () False, - mkConstant @ByteString () (fromList [0x01, 0x01]) - ] - expectedExp = mkConstant @Integer () 257 - in evaluateAssertEqual expectedExp actualExp, - -- byteStringToInteger True (consByteString 0x01 (consByteString 0x01 emptyByteString)) => - -- 257 - testCase "example 4" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () True, - mkConstant @ByteString () (fromList [0x01, 0x01]) - ] - expectedExp = mkConstant @Integer () 257 - in evaluateAssertEqual expectedExp actualExp, - -- byteStringToInteger True (consByteString 0x00 (consByteString 0x01 (consByteString 0x01 - -- emptyByteString))) => 257 - testCase "example 5" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () True, - mkConstant @ByteString () (fromList [0x00, 0x01, 0x01]) - ] - expectedExp = mkConstant @Integer () 257 - in evaluateAssertEqual expectedExp actualExp, - -- byteStringToInteger False (consByteString 0x00 (consByteString 0x01 (consByteString 0x01 - -- emptyByteString))) => 65792 - testCase "example 6" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () False, - mkConstant @ByteString () (fromList [0x00, 0x01, 0x01]) - ] - expectedExp = mkConstant @Integer () 65792 - in evaluateAssertEqual expectedExp actualExp, - -- byteStringToInteger False (consByteString 0x01 (consByteString 0x01 (consByteString 0x00 - -- emptyByteString))) => 257 - testCase "example 7" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () False, - mkConstant @ByteString () (fromList [0x01, 0x01, 0x00]) - ] - expectedExp = mkConstant @Integer () 257 - in evaluateAssertEqual expectedExp actualExp, - -- byteStringToInteger True (consByteString 0x01 (consByteString 0x01 (consByteString 0x00 - -- emptyByteString))) => 65792 - testCase "example 8" $ let actualExp = mkIterAppNoAnn (builtin () PLC.ByteStringToInteger) [ - mkConstant @Bool () True, - mkConstant @ByteString () (fromList [0x01, 0x01, 0x00]) - ] - expectedExp = mkConstant @Integer () 65792 - in evaluateAssertEqual expectedExp actualExp +b2iCipExamples = + [ -- byteStringToInteger False emptyByteString => 0 + testCase "example 1" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () False + , mkConstant @ByteString () "" + ] + expectedExp = mkConstant @Integer () 0 + in evaluateAssertEqual expectedExp actualExp + , -- byteStringToInteger True emptyByteString => 0 + testCase "example 2" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () True + , mkConstant @ByteString () "" + ] + expectedExp = mkConstant @Integer () 0 + in evaluateAssertEqual expectedExp actualExp + , -- byteStringToInteger False (consByteString 0x01 (consByteString 0x01 emptyByteString)) => + -- 257 + testCase "example 3" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () False + , mkConstant @ByteString () (fromList [0x01, 0x01]) + ] + expectedExp = mkConstant @Integer () 257 + in evaluateAssertEqual expectedExp actualExp + , -- byteStringToInteger True (consByteString 0x01 (consByteString 0x01 emptyByteString)) => + -- 257 + testCase "example 4" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () True + , mkConstant @ByteString () (fromList [0x01, 0x01]) + ] + expectedExp = mkConstant @Integer () 257 + in evaluateAssertEqual expectedExp actualExp + , -- byteStringToInteger True (consByteString 0x00 (consByteString 0x01 (consByteString 0x01 + -- emptyByteString))) => 257 + testCase "example 5" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () True + , mkConstant @ByteString () (fromList [0x00, 0x01, 0x01]) + ] + expectedExp = mkConstant @Integer () 257 + in evaluateAssertEqual expectedExp actualExp + , -- byteStringToInteger False (consByteString 0x00 (consByteString 0x01 (consByteString 0x01 + -- emptyByteString))) => 65792 + testCase "example 6" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () False + , mkConstant @ByteString () (fromList [0x00, 0x01, 0x01]) + ] + expectedExp = mkConstant @Integer () 65792 + in evaluateAssertEqual expectedExp actualExp + , -- byteStringToInteger False (consByteString 0x01 (consByteString 0x01 (consByteString 0x00 + -- emptyByteString))) => 257 + testCase "example 7" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () False + , mkConstant @ByteString () (fromList [0x01, 0x01, 0x00]) + ] + expectedExp = mkConstant @Integer () 257 + in evaluateAssertEqual expectedExp actualExp + , -- byteStringToInteger True (consByteString 0x01 (consByteString 0x01 (consByteString 0x00 + -- emptyByteString))) => 65792 + testCase "example 8" $ + let actualExp = + mkIterAppNoAnn + (builtin () PLC.ByteStringToInteger) + [ mkConstant @Bool () True + , mkConstant @ByteString () (fromList [0x01, 0x01, 0x00]) + ] + expectedExp = mkConstant @Integer () 65792 + in evaluateAssertEqual expectedExp actualExp ] -- Generators @@ -540,7 +687,7 @@ evaluateAndVerify expected actual = case typecheckEvaluateCek def defaultBuiltinCostModelForTesting actual of Left x -> annotateShow x >> failure Right (res, logs) -> case res of - PLC.EvaluationFailure -> annotateShow logs >> failure + PLC.EvaluationFailure -> annotateShow logs >> failure PLC.EvaluationSuccess r -> r === expected evaluateAndVerify2 :: @@ -550,13 +697,13 @@ evaluateAndVerify2 :: evaluateAndVerify2 expected actual = let expectedResult = typecheckEvaluateCek def defaultBuiltinCostModelForTesting expected actualResult = typecheckEvaluateCek def defaultBuiltinCostModelForTesting actual - in case (expectedResult, actualResult) of - (Left err, _) -> annotateShow err >> failure - (_, Left err) -> annotateShow err >> failure - (Right (eRes, eLogs), Right (aRes, aLogs)) -> case (eRes, aRes) of - (PLC.EvaluationFailure, _) -> annotateShow eLogs >> failure - (_, PLC.EvaluationFailure) -> annotateShow aLogs >> failure - (PLC.EvaluationSuccess eResult, PLC.EvaluationSuccess aResult) -> eResult === aResult + in case (expectedResult, actualResult) of + (Left err, _) -> annotateShow err >> failure + (_, Left err) -> annotateShow err >> failure + (Right (eRes, eLogs), Right (aRes, aLogs)) -> case (eRes, aRes) of + (PLC.EvaluationFailure, _) -> annotateShow eLogs >> failure + (_, PLC.EvaluationFailure) -> annotateShow aLogs >> failure + (PLC.EvaluationSuccess eResult, PLC.EvaluationSuccess aResult) -> eResult === aResult evaluateShouldFail :: PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> @@ -564,7 +711,7 @@ evaluateShouldFail :: evaluateShouldFail expr = case typecheckEvaluateCek def defaultBuiltinCostModelForTesting expr of Left _ -> assertFailure "unexpectedly failed to typecheck" Right (result, _) -> case result of - PLC.EvaluationFailure -> pure () + PLC.EvaluationFailure -> pure () PLC.EvaluationSuccess _ -> assertFailure "should have failed, but didn't" evaluateAssertEqual :: @@ -575,5 +722,5 @@ evaluateAssertEqual expected actual = case typecheckEvaluateCek def defaultBuiltinCostModelForTesting actual of Left _ -> assertFailure "unexpectedly failed to typecheck" Right (result, _) -> case result of - PLC.EvaluationFailure -> assertFailure "unexpectedly failed to evaluate" + PLC.EvaluationFailure -> assertFailure "unexpectedly failed to evaluate" PLC.EvaluationSuccess x -> assertEqual "" x expected diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Costing.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Costing.hs index 95491ba4231..14d27f2de12 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Costing.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Costing.hs @@ -1,9 +1,8 @@ -- editorconfig-checker-disable-file {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Evaluation.Builtins.Costing where @@ -25,7 +24,7 @@ import Test.QuickCheck.Gen import Test.Tasty import Test.Tasty.QuickCheck hiding (Some (..)) -deriving newtype instance Foldable NonEmptyList -- QuickCheck... +deriving newtype instance Foldable NonEmptyList -- QuickCheck... -- | Direct equality of two 'CostStream's. Same as @deriving stock Eq@. We don't want to do the -- latter, because the semantics of a 'CostStream' are those of the sum of its elements and the @@ -33,29 +32,32 @@ deriving newtype instance Foldable NonEmptyList -- QuickCheck... eqCostStream :: CostStream -> CostStream -> Bool eqCostStream (CostLast cost1) (CostLast cost2) = cost1 == cost2 eqCostStream (CostCons cost1 costs1) (CostCons cost2 costs2) = - cost1 == cost2 && eqCostStream costs1 costs2 + cost1 == cost2 && eqCostStream costs1 costs2 eqCostStream _ _ = False fromCostList :: NonEmptyList CostingInteger -> CostStream -fromCostList (NonEmpty []) = error "Panic: an empty non-empty list" -fromCostList (NonEmpty (cost0 : costs0)) = go cost0 costs0 where - go cost [] = CostLast cost +fromCostList (NonEmpty []) = error "Panic: an empty non-empty list" +fromCostList (NonEmpty (cost0 : costs0)) = go cost0 costs0 + where + go cost [] = CostLast cost go cost (cost' : costs) = CostCons cost $ go cost' costs toCostList :: CostStream -> NonEmptyList CostingInteger -toCostList = NonEmpty . go where - go (CostLast cost) = [cost] +toCostList = NonEmpty . go + where + go (CostLast cost) = [cost] go (CostCons cost costs) = cost : go costs toExBudgetList :: ExBudgetStream -> NonEmptyList ExBudget -toExBudgetList = NonEmpty . go where - go (ExBudgetLast budget) = [budget] +toExBudgetList = NonEmpty . go + where + go (ExBudgetLast budget) = [budget] go (ExBudgetCons budget budgets) = budget : go budgets -- | A list of ranges: @(0, 0), (1, 10) : (11, 100) : (101, 1000) : ... : [(10^18, maxBound)]@. magnitudes :: [(SatInt, SatInt)] -magnitudes - = map (bimap fromInteger fromInteger) +magnitudes = + map (bimap fromInteger fromInteger) . ((0, 0) :) . magnitudesPositive (* 10) $ fromSatInt (maxBound :: SatInt) @@ -67,7 +69,8 @@ magnitudes -- >>> toRange 1234 -- (1001,10000) toRange :: SatInt -> (SatInt, SatInt) -toRange cost = fromMaybe (error $ "Panic: an unexpected cost: " ++ show cost) $ +toRange cost = + fromMaybe (error $ "Panic: an unexpected cost: " ++ show cost) $ find ((>= cost) . snd) magnitudes -- | Generate a 'SatInt' in the given range. @@ -78,41 +81,44 @@ chooseSatInt = fmap unsafeToSatInt . chooseInt . bimap unSatInt unSatInt -- make the generator of 'CostStream' produce streams whose sums are more or less evenly distributed -- across 'magnitudes'. instance Arbitrary SatInt where - arbitrary = frequency . zip freqs . reverse $ map chooseSatInt magnitudes where - freqs = map floor $ iterate (* 1.3) (2 :: Double) + arbitrary = frequency . zip freqs . reverse $ map chooseSatInt magnitudes + where + freqs = map floor $ iterate (* 1.3) (2 :: Double) - -- See Note [QuickCheck and integral types]. - shrink = map fromIntegral . shrink @Int64 . fromSatInt + -- See Note [QuickCheck and integral types]. + shrink = map fromIntegral . shrink @Int64 . fromSatInt instance Arbitrary CostStream where - arbitrary = frequency - [ -- Single-element streams an important enough corner-case to justify tilting the - -- generator. - (1, CostLast <$> arbitrary) - , (6, fromCostList <$> arbitrary) - ] - - shrink (CostLast cost) = map CostLast $ shrink cost - shrink (CostCons cost costs) = CostLast cost : costs : do - -- Shrinking the recursive part first. - (costs', cost') <- shrink (costs, cost) - pure $ CostCons cost' costs' + arbitrary = + frequency + [ -- Single-element streams an important enough corner-case to justify tilting the + -- generator. + (1, CostLast <$> arbitrary) + , (6, fromCostList <$> arbitrary) + ] + + shrink (CostLast cost) = map CostLast $ shrink cost + shrink (CostCons cost costs) = + CostLast cost : costs : do + -- Shrinking the recursive part first. + (costs', cost') <- shrink (costs, cost) + pure $ CostCons cost' costs' instance CoArbitrary SatInt where - -- See Note [QuickCheck and integral types]. No idea what kind of coverages we get here though. - coarbitrary = coarbitrary . fromSatInt @Int64 + -- See Note [QuickCheck and integral types]. No idea what kind of coverages we get here though. + coarbitrary = coarbitrary . fromSatInt @Int64 instance Function SatInt where - -- See Note [QuickCheck and integral types]. No idea what kind of coverages we get here though. - function = functionMap fromSatInt $ fromIntegral @Int64 + -- See Note [QuickCheck and integral types]. No idea what kind of coverages we get here though. + function = functionMap fromSatInt $ fromIntegral @Int64 -- | Same as '(===)' except accepts a custom equality checking function. checkEqualsVia :: Show a => (a -> a -> Bool) -> a -> a -> Property checkEqualsVia eq x y = - counterexample (show x ++ interpret res ++ show y) res + counterexample (show x ++ interpret res ++ show y) res where res = eq x y - interpret True = " === " + interpret True = " === " interpret False = " =/= " -- | A value to use in tests to make sure what's not supposed to be forced isn't forced. @@ -122,100 +128,103 @@ bottom = error "this value wasn't supposed to be forced" -- | Test that 'magnitudes' has the correct bounds. test_magnitudes :: TestTree test_magnitudes = - testProperty "magnitudes" $ - let check (0, 0) (1, 10) = True - check (_, hi1) (lo2, hi2) = hi1 + 1 == lo2 && hi1 * 10 == hi2 - in and - [ fst (head magnitudes) == 0 - , snd (last magnitudes) == maxBound - , and . zipWith check magnitudes $ tail magnitudes - ] + testProperty "magnitudes" $ + let check (0, 0) (1, 10) = True + check (_, hi1) (lo2, hi2) = hi1 + 1 == lo2 && hi1 * 10 == hi2 + in and + [ fst (head magnitudes) == 0 + , snd (last magnitudes) == maxBound + , and . zipWith check magnitudes $ tail magnitudes + ] -- | Show the distribution of generated 'CostStream's as a diagnostic. test_CostStreamDistribution :: TestTree test_CostStreamDistribution = - testProperty "distribution of the generated CostStream values" . withMaxSuccess 10000 $ - \costs -> - let costsSum = sumCostStream costs - (low, high) = toRange costsSum - in label (show low ++ " - " ++ show high) True + testProperty "distribution of the generated CostStream values" . withMaxSuccess 10000 $ + \costs -> + let costsSum = sumCostStream costs + (low, high) = toRange costsSum + in label (show low ++ " - " ++ show high) True -- | Test that @fromCostList . toCostList@ is identity. test_toCostListRoundtrip :: TestTree test_toCostListRoundtrip = - testProperty "fromCostList cancels toCostList" . withMaxSuccess 5000 $ \costs -> - checkEqualsVia eqCostStream - (fromCostList $ toCostList costs) - costs + testProperty "fromCostList cancels toCostList" . withMaxSuccess 5000 $ \costs -> + checkEqualsVia + eqCostStream + (fromCostList $ toCostList costs) + costs -- | Test that @toCostList . fromCostList@ is identity. test_fromCostListRoundtrip :: TestTree test_fromCostListRoundtrip = - testProperty "toCostList cancels fromCostList" . withMaxSuccess 5000 $ \costs -> - toCostList (fromCostList costs) === - costs + testProperty "toCostList cancels fromCostList" . withMaxSuccess 5000 $ \costs -> + toCostList (fromCostList costs) + === costs -- | Test that @uncurry reconsCost . unconsCost@ is identity. test_unconsCostRoundtrip :: TestTree test_unconsCostRoundtrip = - testProperty "reconsCost cancels unconsCost" . withMaxSuccess 5000 $ \costs -> - checkEqualsVia eqCostStream - (uncurry reconsCost $ unconsCost costs) - costs + testProperty "reconsCost cancels unconsCost" . withMaxSuccess 5000 $ \costs -> + checkEqualsVia + eqCostStream + (uncurry reconsCost $ unconsCost costs) + costs -- | Test that 'sumCostStream' returns the sum of the elements of a 'CostStream'. test_sumCostStreamIsSum :: TestTree test_sumCostStreamIsSum = - testProperty "sumCostStream is sum" . withMaxSuccess 5000 $ \costs -> - sumCostStream costs === - sum (toCostList costs) + testProperty "sumCostStream is sum" . withMaxSuccess 5000 $ \costs -> + sumCostStream costs + === sum (toCostList costs) -- | Test that 'mapCostStream' applies a function to each element of a 'CostStream'. test_mapCostStreamIsMap :: TestTree test_mapCostStreamIsMap = - testProperty "mapCostStream is map" . withMaxSuccess 500 $ \(Fun _ f) costs -> - checkEqualsVia eqCostStream - (mapCostStream f $ fromCostList costs) - (fromCostList $ fmap f costs) + testProperty "mapCostStream is map" . withMaxSuccess 500 $ \(Fun _ f) costs -> + checkEqualsVia + eqCostStream + (mapCostStream f $ fromCostList costs) + (fromCostList $ fmap f costs) -- | Test that the sum of a stream returned by 'addCostStream' equals the sum of the sums of its two -- arguments. test_addCostStreamIsAdd :: TestTree test_addCostStreamIsAdd = - testProperty "addCostStream is add" . withMaxSuccess 5000 $ \costs1 costs2 -> - sumCostStream (addCostStream costs1 costs2) === - sumCostStream costs1 + sumCostStream costs2 + testProperty "addCostStream is add" . withMaxSuccess 5000 $ \costs1 costs2 -> + sumCostStream (addCostStream costs1 costs2) + === sumCostStream costs1 + sumCostStream costs2 -- | Test that the sum of a stream returned by 'minCostStream' equals the minimum of the sums of its -- two arguments. test_minCostStreamIsMin :: TestTree test_minCostStreamIsMin = - testProperty "minCostStream is min" . withMaxSuccess 5000 $ \costs1 costs2 -> - sumCostStream (minCostStream costs1 costs2) === - min (sumCostStream costs1) (sumCostStream costs2) + testProperty "minCostStream is min" . withMaxSuccess 5000 $ \costs1 costs2 -> + sumCostStream (minCostStream costs1 costs2) + === min (sumCostStream costs1) (sumCostStream costs2) -- | Test that the sum of a stream returned by 'zipCostStream' equals an 'ExBudget' containing the -- sums of its two arguments. test_zipCostStreamIsZip :: TestTree test_zipCostStreamIsZip = - testProperty "zipCostStream is zip" . withMaxSuccess 5000 $ \costs1 costs2 -> - sumExBudgetStream (zipCostStream costs1 costs2) === - ExBudget (ExCPU $ sumCostStream costs1) (ExMemory $ sumCostStream costs2) + testProperty "zipCostStream is zip" . withMaxSuccess 5000 $ \costs1 costs2 -> + sumExBudgetStream (zipCostStream costs1 costs2) + === ExBudget (ExCPU $ sumCostStream costs1) (ExMemory $ sumCostStream costs2) -- | Test that 'mapCostStream' preserves the length of the stream. test_mapCostStreamReasonableLength :: TestTree test_mapCostStreamReasonableLength = - testProperty "mapCostStream: reasonable length" . withMaxSuccess 500 $ \(Fun _ f) costs -> - length (toCostList (mapCostStream f costs)) === - length (toCostList costs) + testProperty "mapCostStream: reasonable length" . withMaxSuccess 500 $ \(Fun _ f) costs -> + length (toCostList (mapCostStream f costs)) + === length (toCostList costs) -- | Test that the length of the stream returned by 'addCostStream' equals the sum of the lengths of -- its two arguments. test_addCostStreamReasonableLength :: TestTree test_addCostStreamReasonableLength = - testProperty "addCostStream: reasonable length " . withMaxSuccess 5000 $ \costs1 costs2 -> - max 2 (length (toCostList (addCostStream costs1 costs2))) === - length (toCostList costs1) + length (toCostList costs2) + testProperty "addCostStream: reasonable length " . withMaxSuccess 5000 $ \costs1 costs2 -> + max 2 (length (toCostList (addCostStream costs1 costs2))) + === length (toCostList costs1) + length (toCostList costs2) -- | Test that the length of the stream returned by 'addCostStream' is -- @@ -223,58 +232,62 @@ test_addCostStreamReasonableLength = -- 2. smaller than or equal to the sum of the lengths of its two arguments. test_minCostStreamReasonableLength :: TestTree test_minCostStreamReasonableLength = - testProperty "minCostStream: reasonable length " . withMaxSuccess 5000 $ \costs1 costs2 -> - let len1 = length $ toCostList costs1 - len2 = length $ toCostList costs2 - lenMin = length . toCostList $ minCostStream costs1 costs2 - in lenMin >= min len1 len2 && lenMin <= len1 + len2 + testProperty "minCostStream: reasonable length " . withMaxSuccess 5000 $ \costs1 costs2 -> + let len1 = length $ toCostList costs1 + len2 = length $ toCostList costs2 + lenMin = length . toCostList $ minCostStream costs1 costs2 + in lenMin >= min len1 len2 && lenMin <= len1 + len2 -- | Test that the length of the stream returned by 'zipCostStream' equals the maximum of the -- lengths of its two arguments. test_zipCostStreamReasonableLength :: TestTree test_zipCostStreamReasonableLength = - testProperty "zipCostStream: reasonable length " . withMaxSuccess 5000 $ \costs1 costs2 -> - length (toExBudgetList (zipCostStream costs1 costs2)) === - max (length (toCostList costs1)) (length (toCostList costs2)) + testProperty "zipCostStream: reasonable length " . withMaxSuccess 5000 $ \costs1 costs2 -> + length (toExBudgetList (zipCostStream costs1 costs2)) + === max (length (toCostList costs1)) (length (toCostList costs2)) -- | Test that 'mapCostStream' preserves the laziness of its argument. test_mapCostStreamHandlesBottom :: TestTree test_mapCostStreamHandlesBottom = - testProperty "mapCostStream handles bottom suffixes" . withMaxSuccess 500 $ \(Fun _ f) xs -> - let n = length xs - -- 'fromCostList' forces an additional element, so we account for that here. - suff = 0 : bottom - costs = fromCostList . NonEmpty $ xs ++ suff - in length (take n . getNonEmpty . toCostList $ mapCostStream f costs) === n + testProperty "mapCostStream handles bottom suffixes" . withMaxSuccess 500 $ \(Fun _ f) xs -> + let n = length xs + -- 'fromCostList' forces an additional element, so we account for that here. + suff = 0 : bottom + costs = fromCostList . NonEmpty $ xs ++ suff + in length (take n . getNonEmpty . toCostList $ mapCostStream f costs) === n -- | Test that 'mapCostStream' preserves the laziness of its two arguments. test_addCostStreamHandlesBottom :: TestTree test_addCostStreamHandlesBottom = - testProperty "addCostStream handles bottom suffixes" . withMaxSuccess 5000 $ \(Positive n) -> - let interleave xs ys = concat $ transpose [xs, ys] - zeroToN = map unsafeToSatInt [0 .. n] ++ bottom - nPlus1To2NPlus1 = map unsafeToSatInt [n + 1 .. n * 2 + 1] ++ bottom - taken = take n . getNonEmpty . toCostList $ addCostStream - (fromCostList $ NonEmpty zeroToN) - (fromCostList $ NonEmpty nPlus1To2NPlus1) - in -- Every element in the resulting stream comes from one of the generated lists. - all (\cost -> cost `elem` interleave zeroToN nPlus1To2NPlus1) taken .&&. - -- No element is duplicated. - length (map head . group $ sort taken) === length taken + testProperty "addCostStream handles bottom suffixes" . withMaxSuccess 5000 $ \(Positive n) -> + let interleave xs ys = concat $ transpose [xs, ys] + zeroToN = map unsafeToSatInt [0 .. n] ++ bottom + nPlus1To2NPlus1 = map unsafeToSatInt [n + 1 .. n * 2 + 1] ++ bottom + taken = + take n . getNonEmpty . toCostList $ + addCostStream + (fromCostList $ NonEmpty zeroToN) + (fromCostList $ NonEmpty nPlus1To2NPlus1) + in -- Every element in the resulting stream comes from one of the generated lists. + all (\cost -> cost `elem` interleave zeroToN nPlus1To2NPlus1) taken + .&&. + -- No element is duplicated. + length (map head . group $ sort taken) === length taken -- | Test that 'minCostStream' preserves the laziness of its two arguments. test_minCostStreamHandlesBottom :: TestTree test_minCostStreamHandlesBottom = - testProperty "minCostStream handles bottom suffixes" . withMaxSuccess 5000 $ \xs ys -> - let m = min (sum xs) (sum ys) - -- 'minCostStream' can force only a single extra element of the stream. - suff = 0 : bottom - xsYsMin = minCostStream - (fromCostList . NonEmpty $ xs ++ suff) - (fromCostList . NonEmpty $ ys ++ suff) - in -- Rolling '(+)' over a list representing the minimum of two streams eventually - -- gives us the sum of the minimum stream before triggering any of the bottoms. - elem m . scanl' (+) 0 . getNonEmpty $ toCostList xsYsMin + testProperty "minCostStream handles bottom suffixes" . withMaxSuccess 5000 $ \xs ys -> + let m = min (sum xs) (sum ys) + -- 'minCostStream' can force only a single extra element of the stream. + suff = 0 : bottom + xsYsMin = + minCostStream + (fromCostList . NonEmpty $ xs ++ suff) + (fromCostList . NonEmpty $ ys ++ suff) + in -- Rolling '(+)' over a list representing the minimum of two streams eventually + -- gives us the sum of the minimum stream before triggering any of the bottoms. + elem m . scanl' (+) 0 . getNonEmpty $ toCostList xsYsMin -- | Pad the shortest of the given lists by appending the given element to it until the length of -- the result matches the length of the other list. @@ -284,53 +297,57 @@ test_minCostStreamHandlesBottom = -- >>> postAlignWith 'a' "b" "cdef" -- ("baaa","cdef") postAlignWith :: a -> [a] -> [a] -> ([a], [a]) -postAlignWith z xs ys = (align xs, align ys) where +postAlignWith z xs ys = (align xs, align ys) + where align zs = take (length xs `max` length ys) $ zs ++ repeat z -- | Test that 'zipCostStream' preserves the laziness of its two arguments. test_zipCostStreamHandlesBottom :: TestTree test_zipCostStreamHandlesBottom = - testProperty "zipCostStream handles bottom suffixes" . withMaxSuccess 5000 $ \xs ys -> - let z = ExBudget (ExCPU $ sum xs) (ExMemory $ sum ys) - (xsA, ysA) = postAlignWith 0 xs ys - -- 'fromCostList' forces an additional element, so we account for that here. - suff = 0 : bottom - xys = zipCostStream - (fromCostList . NonEmpty $ xsA ++ suff) - (fromCostList . NonEmpty $ ysA ++ suff) - in -- Rolling '(<>)' over a list representing the zipped cost streams eventually - -- gives us an 'ExBudget' containing the sums of the streams computed separately. - elem z . scanl' (<>) mempty . getNonEmpty $ toExBudgetList xys + testProperty "zipCostStream handles bottom suffixes" . withMaxSuccess 5000 $ \xs ys -> + let z = ExBudget (ExCPU $ sum xs) (ExMemory $ sum ys) + (xsA, ysA) = postAlignWith 0 xs ys + -- 'fromCostList' forces an additional element, so we account for that here. + suff = 0 : bottom + xys = + zipCostStream + (fromCostList . NonEmpty $ xsA ++ suff) + (fromCostList . NonEmpty $ ysA ++ suff) + in -- Rolling '(<>)' over a list representing the zipped cost streams eventually + -- gives us an 'ExBudget' containing the sums of the streams computed separately. + elem z . scanl' (<>) mempty . getNonEmpty $ toExBudgetList xys -- | The size 'sierpinskiRose' of the given depth. sierpinskiSize :: Int -> Int sierpinskiSize n - | n <= 1 = 1 - | otherwise = sierpinskiSize (n - 1) * 3 + 1 + | n <= 1 = 1 + | otherwise = sierpinskiSize (n - 1) * 3 + 1 -- | Return a finite balanced tree with each node (apart from the leaves) having exactly 3 children. -- The parameter is the depth of the tree. -- Named after https://en.wikipedia.org/wiki/Sierpi%C5%84ski_triangle sierpinskiRose :: Int -> CostRose sierpinskiRose n0 - | n0 <= 1 = singletonRose 1 - | otherwise = CostRose (fromIntegral n0) . map sierpinskiRose . replicate 3 $ n0 - 1 + | n0 <= 1 = singletonRose 1 + | otherwise = CostRose (fromIntegral n0) . map sierpinskiRose . replicate 3 $ n0 - 1 -- | Traverse a 'sierpinskiRose' of the given depth and display the total amount of elements -- processed. See 'test_flattenCostRoseIsLinear' for why we do this. test_flattenCostRoseIsLinearForSierpinskiRose :: Int -> TestTree test_flattenCostRoseIsLinearForSierpinskiRose depth = - let size = sierpinskiSize depth - in testProperty ("sierpinski rose: taking " ++ show size ++ " elements") $ + let size = sierpinskiSize depth + in testProperty ("sierpinski rose: taking " ++ show size ++ " elements") $ withMaxSuccess 1 $ - length (toCostList . flattenCostRose $ sierpinskiRose depth) === - size + length (toCostList . flattenCostRose $ sierpinskiRose depth) + === size -- | Test that traversing a larger 'CostRose' takes _linearly_ more time. The actual test can only -- be done with eyes unfortunately, because the tests are way too noisy for evaluation times to be -- reported even remotely accurately. test_flattenCostRoseIsLinear :: TestTree -test_flattenCostRoseIsLinear = testGroup "flattenCostRose is linear" +test_flattenCostRoseIsLinear = + testGroup + "flattenCostRose is linear" [ test_flattenCostRoseIsLinearForSierpinskiRose 12 , test_flattenCostRoseIsLinearForSierpinskiRose 13 , test_flattenCostRoseIsLinearForSierpinskiRose 14 @@ -351,26 +368,27 @@ generation strategy such as exponential growth of the generated objects. -} -- See Note [Generating a CostRose]. + -- | Generate a 'CostRose' from the given list by splitting the list into sublists and generating -- a 'CostRose' for each of them recursively. genCostRose :: NonEmptyList SatInt -> Gen CostRose -genCostRose (NonEmpty []) = error "Panic: an empty non-empty list" +genCostRose (NonEmpty []) = error "Panic: an empty non-empty list" genCostRose (NonEmpty (cost : costs)) = - CostRose cost <$> (traverse genCostRose =<< multiSplit1 costs) + CostRose cost <$> (traverse genCostRose =<< multiSplit1 costs) fromCostRose :: CostRose -> NonEmptyList SatInt fromCostRose (CostRose cost costs) = - NonEmpty $ cost : concatMap (getNonEmpty . fromCostRose) costs + NonEmpty $ cost : concatMap (getNonEmpty . fromCostRose) costs instance Arbitrary CostRose where - -- By default the lengt of generated lists is capped at 100, which would give us too small of - -- 'CostRose's, so we scale the size parameter. - arbitrary = scale (* 10) arbitrary >>= genCostRose + -- By default the lengt of generated lists is capped at 100, which would give us too small of + -- 'CostRose's, so we scale the size parameter. + arbitrary = scale (* 10) arbitrary >>= genCostRose - shrink (CostRose cost costs) = do - -- Shrinking the recursive part first. - (costs', cost') <- shrink (costs, cost) - pure $ CostRose cost' costs' + shrink (CostRose cost costs) = do + -- Shrinking the recursive part first. + (costs', cost') <- shrink (costs, cost) + pure $ CostRose cost' costs' -- | Return the lengths of all the forests in a 'CostRose'. collectListLengths :: CostRose -> [Int] @@ -379,63 +397,68 @@ collectListLengths (CostRose _ costs) = length costs : concatMap collectListLeng -- | Show the distribution of forest lengths in generated 'CostRose' values as a diagnostic. test_CostRoseListLengthsDistribution :: TestTree test_CostRoseListLengthsDistribution = - testProperty "distribution of list lengths in CostRose values" $ - withMaxSuccess 1000 $ \rose -> - let render n - | n <= 10 = show n - | otherwise = show m ++ " < n <= " ++ show (m + 10) - where m = head $ dropWhile (< n) [10, 20..] - in tabulate "n" (map render . filter (/= 0) $ collectListLengths rose) True + testProperty "distribution of list lengths in CostRose values" $ + withMaxSuccess 1000 $ \rose -> + let render n + | n <= 10 = show n + | otherwise = show m ++ " < n <= " ++ show (m + 10) + where + m = head $ dropWhile (< n) [10, 20 ..] + in tabulate "n" (map render . filter (/= 0) $ collectListLengths rose) True -- | Test that 'genCostRose' only takes costs from its argument when generating a 'CostRose'. test_genCostRoseSound :: TestTree test_genCostRoseSound = - testProperty "genCostRose puts 100% of its input and nothing else into the output" $ - withMaxSuccess 1000 $ \costs -> - forAll (genCostRose costs) $ \rose -> - fromCostRose rose === - costs + testProperty "genCostRose puts 100% of its input and nothing else into the output" $ + withMaxSuccess 1000 $ \costs -> + forAll (genCostRose costs) $ \rose -> + fromCostRose rose + === costs -- | Test that 'flattenCostRose' returns the elements of its argument. test_flattenCostRoseSound :: TestTree test_flattenCostRoseSound = - testProperty "flattenCostRose puts 100% of its input and nothing else into the output" $ - withMaxSuccess 1000 $ \rose -> - -- This assumes that 'flattenCostRose' is left-biased, which isn't really necessary, but - -- it doesn't seem like we're giving up on the assumption any time soon anyway, so why - -- not keep it simple instead of sorting the results. - checkEqualsVia eqCostStream - (flattenCostRose rose) - (fromCostList $ fromCostRose rose) + testProperty "flattenCostRose puts 100% of its input and nothing else into the output" $ + withMaxSuccess 1000 $ \rose -> + -- This assumes that 'flattenCostRose' is left-biased, which isn't really necessary, but + -- it doesn't seem like we're giving up on the assumption any time soon anyway, so why + -- not keep it simple instead of sorting the results. + checkEqualsVia + eqCostStream + (flattenCostRose rose) + (fromCostList $ fromCostRose rose) -- | Test that 'flattenCostRose' is lazy. test_flattenCostRoseHandlesBottom :: TestTree test_flattenCostRoseHandlesBottom = - testProperty "flattenCostRose handles bottom subtrees" . withMaxSuccess 5000 $ \xs ys -> - -- Create a 'CostRose' with a negative cost somewhere in it, then replace the subtree after - -- that cost with 'bottom' and check that we can get to the negative cost without forcing - -- the bottom. We could've implemented generation of 'CostRose's with bottoms in them, but - -- 'genCostRose' is already complicated enough, so it's easier to put a magical number into - -- its input and postprocess the generated rose. - forAll (genCostRose . NonEmpty $ xs ++ (-1) : ys) $ \rose -> - let spoilCostRose (CostRose cost forest) = - CostRose cost $ if cost == -1 - -- 'flattenCostRose' forces an additional constructor, which is why 'bottom' - -- is put into a list. - then [bottom] - else map spoilCostRose forest - in elem (-1) . toCostList . flattenCostRose $ spoilCostRose rose + testProperty "flattenCostRose handles bottom subtrees" . withMaxSuccess 5000 $ \xs ys -> + -- Create a 'CostRose' with a negative cost somewhere in it, then replace the subtree after + -- that cost with 'bottom' and check that we can get to the negative cost without forcing + -- the bottom. We could've implemented generation of 'CostRose's with bottoms in them, but + -- 'genCostRose' is already complicated enough, so it's easier to put a magical number into + -- its input and postprocess the generated rose. + forAll (genCostRose . NonEmpty $ xs ++ (-1) : ys) $ \rose -> + let spoilCostRose (CostRose cost forest) = + CostRose cost $ + if cost == -1 + -- 'flattenCostRose' forces an additional constructor, which is why 'bottom' + -- is put into a list. + then [bottom] + else map spoilCostRose forest + in elem (-1) . toCostList . flattenCostRose $ spoilCostRose rose -- | Test that 'memoryUsage' called over a value of a built-in type never returns a stream -- containing a negative cost. test_costsAreNeverNegative :: TestTree test_costsAreNeverNegative = - testProperty "costs coming from 'memoryUsage' are never negative" $ - withMaxSuccess 1000 $ \(val :: Some (ValueOf DefaultUni)) -> - all (>= 0) . toCostList . flattenCostRose $ memoryUsage val + testProperty "costs coming from 'memoryUsage' are never negative" $ + withMaxSuccess 1000 $ \(val :: Some (ValueOf DefaultUni)) -> + all (>= 0) . toCostList . flattenCostRose $ memoryUsage val test_costing :: TestTree -test_costing = testGroup "costing" +test_costing = + testGroup + "costing" [ test_magnitudes , test_CostStreamDistribution , test_toCostListRoundtrip diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs index 00f792a7b7e..45b27fc082b 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs @@ -1,37 +1,43 @@ -- editorconfig-checker-disable-file --- | Tests for all kinds of built-in functions. - -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- Sure GHC, I'm enabling the extension just so that you can warn me about its usages. {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} -module Evaluation.Builtins.Definition - ( test_definition - ) where +-- | Tests for all kinds of built-in functions. +module Evaluation.Builtins.Definition ( + test_definition, +) where import PlutusPrelude +import Evaluation.Builtins.BLS12_381 (test_BLS12_381) import Evaluation.Builtins.Bitwise.CIP0122 qualified as CIP0122 import Evaluation.Builtins.Bitwise.CIP0123 qualified as CIP0123 -import Evaluation.Builtins.BLS12_381 (test_BLS12_381) -import Evaluation.Builtins.Common (typecheckAnd, typecheckEvaluateCek, typecheckEvaluateCekNoEmit, - typecheckReadKnownCek) +import Evaluation.Builtins.Common ( + typecheckAnd, + typecheckEvaluateCek, + typecheckEvaluateCekNoEmit, + typecheckReadKnownCek, + ) import Evaluation.Builtins.Conversion qualified as Conversion import Evaluation.Builtins.Integer.DivModProperties (test_integer_div_mod_properties) import Evaluation.Builtins.Integer.ExpModIntegerProperties (test_integer_exp_mod_properties) import Evaluation.Builtins.Integer.OrderProperties (test_integer_order_properties) import Evaluation.Builtins.Integer.QuotRemProperties (test_integer_quot_rem_properties) import Evaluation.Builtins.Integer.RingProperties (test_integer_ring_properties) -import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_VariantAProp, - ed25519_VariantBProp, ed25519_VariantCProp, - schnorrSecp256k1Prop) +import Evaluation.Builtins.SignatureVerification ( + ecdsaSecp256k1Prop, + ed25519_VariantAProp, + ed25519_VariantBProp, + ed25519_VariantCProp, + schnorrSecp256k1Prop, + ) import PlutusCore hiding (Constr) import PlutusCore qualified as PLC @@ -78,14 +84,15 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Prettyprinter (vsep) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testPropertyNamed) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@=?), (@?=)) +import Test.Tasty.Hedgehog (testPropertyNamed) import Test.Tasty.QuickCheck qualified as QC type DefaultFunExt = Either DefaultFun ExtensionFun runTestNestedHere :: [TestNested] -> TestTree -runTestNestedHere = runTestNested +runTestNestedHere = + runTestNested ["untyped-plutus-core", "test", "Evaluation", "Builtins", "Golden"] defaultBuiltinCostModelExt :: CostingPart DefaultUni DefaultFunExt @@ -105,127 +112,141 @@ defaultBuiltinCostModelExt = (defaultBuiltinCostModelForTesting, ()) test_IntegerDistribution :: TestTree test_IntegerDistribution = - QC.testProperty "distribution of 'Integer' constants" . QC.withMaxSuccess 10000 $ - \(AsArbitraryBuiltin (i :: Integer)) -> - let magnitudes = magnitudesPositive nextInterestingBound highInterestingBound - (low, high) = - maybe (error "Panic: unknown integer") (bimap (* signum i) (* signum i)) $ - find ((>= abs i) . snd) magnitudes - bounds = map snd magnitudes - isInteresting = i `elem` concat - [ map (pred . negate) bounds - , map negate bounds - , [-1, 0, 1] - , bounds - , map succ bounds - ] - in (if i /= 0 - then QC.label $ "(" ++ show low ++ ", " ++ show high ++ ")" - else QC.property) - ((if isInteresting - then QC.label $ show i - else QC.property) - True) + QC.testProperty "distribution of 'Integer' constants" . QC.withMaxSuccess 10000 $ + \(AsArbitraryBuiltin (i :: Integer)) -> + let magnitudes = magnitudesPositive nextInterestingBound highInterestingBound + (low, high) = + maybe (error "Panic: unknown integer") (bimap (* signum i) (* signum i)) $ + find ((>= abs i) . snd) magnitudes + bounds = map snd magnitudes + isInteresting = + i + `elem` concat + [ map (pred . negate) bounds + , map negate bounds + , [-1, 0, 1] + , bounds + , map succ bounds + ] + in ( if i /= 0 + then QC.label $ "(" ++ show low ++ ", " ++ show high ++ ")" + else QC.property + ) + ( ( if isInteresting + then QC.label $ show i + else QC.property + ) + True + ) -- | Check that the 'Factorial' builtin computes to the same thing as factorial defined in PLC -- itself. test_Factorial :: TestTree test_Factorial = - testCase "Factorial" $ do - let ten = mkConstant @Integer @DefaultUni () 10 - lhs = typecheckEvaluateCek def defaultBuiltinCostModelExt $ - apply () (builtin () $ Right Factorial) ten - rhs = typecheckEvaluateCek def defaultBuiltinCostModelExt $ - apply () (mapFun Left factorial) ten - assertBool "type checks" $ isRight lhs - lhs @?= rhs + testCase "Factorial" $ do + let ten = mkConstant @Integer @DefaultUni () 10 + lhs = + typecheckEvaluateCek def defaultBuiltinCostModelExt $ + apply () (builtin () $ Right Factorial) ten + rhs = + typecheckEvaluateCek def defaultBuiltinCostModelExt $ + apply () (mapFun Left factorial) ten + assertBool "type checks" $ isRight lhs + lhs @?= rhs -- | Check that 'Const' from the above computes to the same thing as -- a const defined in PLC itself. test_Const :: TestTree test_Const = - testPropertyNamed "Const" "Const" . withTests 10 . property $ do - c <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode - b <- forAll Gen.bool - let tC = mkConstant () c - tB = mkConstant () b - text = toTypeAst @_ @_ @DefaultUni @Text Proxy - runConst con = mkIterAppNoAnn (mkIterInstNoAnn con [text, bool]) [tC, tB] - lhs = typecheckReadKnownCek def defaultBuiltinCostModelExt $ - runConst $ builtin () (Right Const) - rhs = typecheckReadKnownCek def defaultBuiltinCostModelExt $ - runConst $ mapFun @DefaultFun Left Plc.const - lhs === Right (Right c) - lhs === rhs + testPropertyNamed "Const" "Const" . withTests 10 . property $ do + c <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode + b <- forAll Gen.bool + let tC = mkConstant () c + tB = mkConstant () b + text = toTypeAst @_ @_ @DefaultUni @Text Proxy + runConst con = mkIterAppNoAnn (mkIterInstNoAnn con [text, bool]) [tC, tB] + lhs = + typecheckReadKnownCek def defaultBuiltinCostModelExt $ + runConst $ + builtin () (Right Const) + rhs = + typecheckReadKnownCek def defaultBuiltinCostModelExt $ + runConst $ + mapFun @DefaultFun Left Plc.const + lhs === Right (Right c) + lhs === rhs -- | Test that forcing a builtin accepting one type argument and no term arguments makes the -- builtin compute properly. test_ForallFortyTwo :: TestTree test_ForallFortyTwo = - testCase "ForallFortyTwo" $ do - let term = tyInst () (builtin () ForallFortyTwo) $ mkTyBuiltin @_ @() () - lhs = typecheckEvaluateCekNoEmit def () term - rhs = Right $ EvaluationSuccess $ mkConstant @Integer () 42 - lhs @?= rhs + testCase "ForallFortyTwo" $ do + let term = tyInst () (builtin () ForallFortyTwo) $ mkTyBuiltin @_ @() () + lhs = typecheckEvaluateCekNoEmit def () term + rhs = Right $ EvaluationSuccess $ mkConstant @Integer () 42 + lhs @?= rhs -- | Test that a polymorphic built-in function doesn't subvert the CEK machine. -- See https://github.com/IntersectMBO/plutus/issues/1882 test_Id :: TestTree test_Id = - testCase "Id" $ do - let zer = mkConstant @Integer @DefaultUni @DefaultFunExt () 0 - oneT = mkConstant @Integer @DefaultUni () 1 - oneU = mkConstant @Integer @DefaultUni () 1 - -- > id {integer -> integer} ((\(i : integer) (j : integer) -> i) 1) 0 - term = - mkIterAppNoAnn (tyInst () (builtin () $ Right Id) (TyFun () integer integer)) - [ apply () constIntegerInteger oneT - , zer - ] where - constIntegerInteger = runQuote $ do - i <- freshName "i" - j <- freshName "j" - return - . LamAbs () i integer - . LamAbs () j integer - $ Var () i - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term @?= - Right (EvaluationSuccess oneU) + testCase "Id" $ do + let zer = mkConstant @Integer @DefaultUni @DefaultFunExt () 0 + oneT = mkConstant @Integer @DefaultUni () 1 + oneU = mkConstant @Integer @DefaultUni () 1 + -- > id {integer -> integer} ((\(i : integer) (j : integer) -> i) 1) 0 + term = + mkIterAppNoAnn + (tyInst () (builtin () $ Right Id) (TyFun () integer integer)) + [ apply () constIntegerInteger oneT + , zer + ] + where + constIntegerInteger = runQuote $ do + i <- freshName "i" + j <- freshName "j" + return + . LamAbs () i integer + . LamAbs () j integer + $ Var () i + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + @?= Right (EvaluationSuccess oneU) -- | Test that a polymorphic built-in function can have a higher-kinded type variable in its -- signature. test_IdFInteger :: TestTree test_IdFInteger = - testCase "IdFInteger" $ do - let one = mkConstant @Integer @DefaultUni () 1 - ten = mkConstant @Integer @DefaultUni () 10 - res = mkConstant @Integer @DefaultUni () 55 - -- > sum (idFInteger {list} (enumFromTo 1 10)) - term - = apply () (mapFun Left Scott.sum) - . apply () (tyInst () (builtin () $ Right IdFInteger) Scott.listTy) - $ mkIterAppNoAnn (mapFun Left Scott.enumFromTo) [one, ten] - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term @?= - Right (EvaluationSuccess res) + testCase "IdFInteger" $ do + let one = mkConstant @Integer @DefaultUni () 1 + ten = mkConstant @Integer @DefaultUni () 10 + res = mkConstant @Integer @DefaultUni () 55 + -- > sum (idFInteger {list} (enumFromTo 1 10)) + term = + apply () (mapFun Left Scott.sum) + . apply () (tyInst () (builtin () $ Right IdFInteger) Scott.listTy) + $ mkIterAppNoAnn (mapFun Left Scott.enumFromTo) [one, ten] + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + @?= Right (EvaluationSuccess res) test_IdList :: TestTree test_IdList = - testCase "IdList" $ do - let tyAct = typeOfBuiltinFunction @DefaultUni def IdList - tyExp = let a = TyName . Name "a" $ Unique 0 - listA = TyApp () Scott.listTy (TyVar () a) - in TyForall () a (Type ()) $ TyFun () listA listA - one = mkConstant @Integer @DefaultUni () 1 - ten = mkConstant @Integer @DefaultUni () 10 - res = mkConstant @Integer @DefaultUni () 55 - -- > sum (idList {integer} (enumFromTo 1 10)) - term - = apply () (mapFun Left Scott.sum) - . apply () (tyInst () (builtin () $ Right IdList) integer) - $ mkIterAppNoAnn (mapFun Left Scott.enumFromTo) [one, ten] - tyAct @?= tyExp - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term @?= - Right (EvaluationSuccess res) + testCase "IdList" $ do + let tyAct = typeOfBuiltinFunction @DefaultUni def IdList + tyExp = + let a = TyName . Name "a" $ Unique 0 + listA = TyApp () Scott.listTy (TyVar () a) + in TyForall () a (Type ()) $ TyFun () listA listA + one = mkConstant @Integer @DefaultUni () 1 + ten = mkConstant @Integer @DefaultUni () 10 + res = mkConstant @Integer @DefaultUni () 55 + -- > sum (idList {integer} (enumFromTo 1 10)) + term = + apply () (mapFun Left Scott.sum) + . apply () (tyInst () (builtin () $ Right IdList) integer) + $ mkIterAppNoAnn (mapFun Left Scott.enumFromTo) [one, ten] + tyAct @?= tyExp + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + @?= Right (EvaluationSuccess res) {- Note [Higher-rank built-in functions] We can't unlift a monomorphic function passed to a built-in function, let alone unlift a polymorphic @@ -254,418 +275,448 @@ argument when it's a function, for another example). -- | Test that opaque terms with higher-rank types are allowed. test_IdRank2 :: TestTree test_IdRank2 = - testCase "IdRank2" $ do - let res = mkConstant @Integer @DefaultUni () 0 - -- > sum (idRank2 {list} nil {integer}) - term - = apply () (mapFun Left Scott.sum) - . tyInst () (apply () (tyInst () (builtin () $ Right IdRank2) Scott.listTy) Scott.nil) - $ integer - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term @?= - Right (EvaluationSuccess res) + testCase "IdRank2" $ do + let res = mkConstant @Integer @DefaultUni () 0 + -- > sum (idRank2 {list} nil {integer}) + term = + apply () (mapFun Left Scott.sum) + . tyInst () (apply () (tyInst () (builtin () $ Right IdRank2) Scott.listTy) Scott.nil) + $ integer + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + @?= Right (EvaluationSuccess res) -- | Test that a builtin can be applied to a non-constant term. test_ScottToMetaUnit :: TestTree test_ScottToMetaUnit = - testCase "ScottToMetaUnit" $ do - let res = EvaluationSuccess $ mkConstant @() @DefaultUni () () - applyTerm = apply () (builtin () ScottToMetaUnit) - -- @scottToMetaUnit Scott.unitval@ is well-typed and runs successfully. - typecheckEvaluateCekNoEmit def () (applyTerm Scott.unitval) @?= Right res - let runtime - = MachineParameters def . mkMachineVariantParameters def - $ CostModel defaultCekMachineCostsForTesting () - -- @scottToMetaUnit Scott.map@ is ill-typed, but still runs successfully, since the builtin - -- doesn't look at the argument. - unsafeSplitStructuralOperational (evaluateCekNoEmit runtime (eraseTerm $ applyTerm Scott.map)) @?= - res + testCase "ScottToMetaUnit" $ do + let res = EvaluationSuccess $ mkConstant @() @DefaultUni () () + applyTerm = apply () (builtin () ScottToMetaUnit) + -- @scottToMetaUnit Scott.unitval@ is well-typed and runs successfully. + typecheckEvaluateCekNoEmit def () (applyTerm Scott.unitval) @?= Right res + let runtime = + MachineParameters def . mkMachineVariantParameters def $ + CostModel defaultCekMachineCostsForTesting () + -- @scottToMetaUnit Scott.map@ is ill-typed, but still runs successfully, since the builtin + -- doesn't look at the argument. + unsafeSplitStructuralOperational (evaluateCekNoEmit runtime (eraseTerm $ applyTerm Scott.map)) + @?= res -- | Test that an exception thrown in the builtin application code does not get caught in the CEK -- machine and blows in the caller face instead. Uses a one-argument built-in function. test_FailingSucc :: TestTree test_FailingSucc = - testCase "FailingSucc" $ do - let term = - apply () (builtin () $ Right FailingSucc) $ - mkConstant @Integer @DefaultUni @DefaultFunExt () 0 - typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- - -- Here we rely on 'typecheckAnd' lazily running the action after type checking the - -- term. - traverse (try . evaluate) $ - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term - typeErrOrEvalExcOrRes @?= Right (Left BuiltinErrorCall) + testCase "FailingSucc" $ do + let term = + apply () (builtin () $ Right FailingSucc) $ + mkConstant @Integer @DefaultUni @DefaultFunExt () 0 + typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- + -- Here we rely on 'typecheckAnd' lazily running the action after type checking the + -- term. + traverse (try . evaluate) $ + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + typeErrOrEvalExcOrRes @?= Right (Left BuiltinErrorCall) -- | Test that evaluating a PLC builtin application that is expensive enough to exceed the budget -- does not result in actual evaluation of the application on the Haskell side and instead we get an -- 'EvaluationFailure'. Uses a one-argument built-in function. test_ExpensiveSucc :: TestTree test_ExpensiveSucc = - testCase "ExpensiveSucc" $ do - let term = - apply () (builtin () $ Right ExpensiveSucc) $ - mkConstant @Integer @DefaultUni @DefaultFunExt () 0 - typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- - traverse (try . evaluate) $ - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term - typeErrOrEvalExcOrRes @?= Right (Right EvaluationFailure) + testCase "ExpensiveSucc" $ do + let term = + apply () (builtin () $ Right ExpensiveSucc) $ + mkConstant @Integer @DefaultUni @DefaultFunExt () 0 + typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- + traverse (try . evaluate) $ + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + typeErrOrEvalExcOrRes @?= Right (Right EvaluationFailure) -- | Test that an exception thrown in the builtin application code does not get caught in the CEK -- machine and blows in the caller face instead. Uses a two-arguments built-in function. test_FailingPlus :: TestTree test_FailingPlus = - testCase "FailingPlus" $ do - let term = - mkIterAppNoAnn (builtin () $ Right FailingPlus) - [ mkConstant @Integer @DefaultUni @DefaultFunExt () 0 - , mkConstant @Integer @DefaultUni () 1 - ] - typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- - -- Here we rely on 'typecheckAnd' lazily running the action after type checking the - -- term. - traverse (try . evaluate) $ - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term - typeErrOrEvalExcOrRes @?= Right (Left BuiltinErrorCall) + testCase "FailingPlus" $ do + let term = + mkIterAppNoAnn + (builtin () $ Right FailingPlus) + [ mkConstant @Integer @DefaultUni @DefaultFunExt () 0 + , mkConstant @Integer @DefaultUni () 1 + ] + typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- + -- Here we rely on 'typecheckAnd' lazily running the action after type checking the + -- term. + traverse (try . evaluate) $ + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + typeErrOrEvalExcOrRes @?= Right (Left BuiltinErrorCall) -- | Test that evaluating a PLC builtin application that is expensive enough to exceed the budget -- does not result in actual evaluation of the application on the Haskell side and instead we get an -- 'EvaluationFailure'. Uses a two-arguments built-in function. test_ExpensivePlus :: TestTree test_ExpensivePlus = - testCase "ExpensivePlus" $ do - let term = - mkIterAppNoAnn (builtin () $ Right ExpensivePlus) - [ mkConstant @Integer @DefaultUni @DefaultFunExt () 0 - , mkConstant @Integer @DefaultUni () 1 - ] - typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- - traverse (try . evaluate) $ - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term - typeErrOrEvalExcOrRes @?= Right (Right EvaluationFailure) + testCase "ExpensivePlus" $ do + let term = + mkIterAppNoAnn + (builtin () $ Right ExpensivePlus) + [ mkConstant @Integer @DefaultUni @DefaultFunExt () 0 + , mkConstant @Integer @DefaultUni () 1 + ] + typeErrOrEvalExcOrRes :: Either _ (Either BuiltinErrorCall _) <- + traverse (try . evaluate) $ + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + typeErrOrEvalExcOrRes @?= Right (Right EvaluationFailure) -- | Test that @Null@, @Head@ and @Tail@ are enough to get pattern matching on built-in lists. test_BuiltinList :: TestTree test_BuiltinList = - testGroup "BuiltinList" $ enumerate <&> \optMatch -> - testCase (show optMatch) $ do - let xs = [1..10] - res = mkConstant @Integer @DefaultUni () $ foldr (-) 0 xs - term - = mkIterAppNoAnn - (mkIterInstNoAnn (Builtin.foldrList optMatch) [integer, integer]) - [ Builtin () SubtractInteger - , mkConstant @Integer () 0 - , mkConstant @[Integer] () xs - ] - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term @?= - Right (EvaluationSuccess res) + testGroup "BuiltinList" $ + enumerate <&> \optMatch -> + testCase (show optMatch) $ do + let xs = [1 .. 10] + res = mkConstant @Integer @DefaultUni () $ foldr (-) 0 xs + term = + mkIterAppNoAnn + (mkIterInstNoAnn (Builtin.foldrList optMatch) [integer, integer]) + [ Builtin () SubtractInteger + , mkConstant @Integer () 0 + , mkConstant @[Integer] () xs + ] + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + @?= Right (EvaluationSuccess res) -- | Test that right-folding a built-in list with built-in 'Cons' recreates that list. test_IdBuiltinList :: TestTree test_IdBuiltinList = - testGroup "IdBuiltinList" $ enumerate <&> \optMatch -> - testCase (show optMatch) $ do - let xsTerm :: TermLike term tyname name DefaultUni DefaultFunExt => term () - xsTerm = mkConstant @[Integer] () [1..10] - listOfInteger = mkTyBuiltin @_ @[Integer] () - term - = mkIterAppNoAnn - (mkIterInstNoAnn (mapFun Left $ Builtin.foldrList optMatch) - [integer, listOfInteger]) - [ tyInst () (builtin () $ Left MkCons) integer - , mkConstant @[Integer] () [] - , xsTerm - ] - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term @?= - Right (EvaluationSuccess xsTerm) + testGroup "IdBuiltinList" $ + enumerate <&> \optMatch -> + testCase (show optMatch) $ do + let xsTerm :: TermLike term tyname name DefaultUni DefaultFunExt => term () + xsTerm = mkConstant @[Integer] () [1 .. 10] + listOfInteger = mkTyBuiltin @_ @[Integer] () + term = + mkIterAppNoAnn + ( mkIterInstNoAnn + (mapFun Left $ Builtin.foldrList optMatch) + [integer, listOfInteger] + ) + [ tyInst () (builtin () $ Left MkCons) integer + , mkConstant @[Integer] () [] + , xsTerm + ] + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + @?= Right (EvaluationSuccess xsTerm) test_BuiltinArray :: TestTree test_BuiltinArray = - testGroup "BuiltinArray" [ - testCase "listToArray" do - let listOfInts = mkConstant @[Integer] @DefaultUni () [1..10] - let arrayOfInts = mkConstant @(Vector Integer) @DefaultUni () (Vector.fromList [1..10]) - let term = apply () (tyInst () (builtin () ListToArray) integer) listOfInts - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term @?= - Right (EvaluationSuccess arrayOfInts) + testGroup + "BuiltinArray" + [ testCase "listToArray" do + let listOfInts = mkConstant @[Integer] @DefaultUni () [1 .. 10] + let arrayOfInts = mkConstant @(Vector Integer) @DefaultUni () (Vector.fromList [1 .. 10]) + let term = apply () (tyInst () (builtin () ListToArray) integer) listOfInts + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + @?= Right (EvaluationSuccess arrayOfInts) , testCase "lengthOfArray" do - let arrayOfInts = mkConstant @(Vector Integer) @DefaultUni () (Vector.fromList [1..10]) - let expectedLength = mkConstant @Integer @DefaultUni () 10 - term = apply () (tyInst () (builtin () LengthOfArray) integer) arrayOfInts - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term @?= - Right (EvaluationSuccess expectedLength) + let arrayOfInts = mkConstant @(Vector Integer) @DefaultUni () (Vector.fromList [1 .. 10]) + let expectedLength = mkConstant @Integer @DefaultUni () 10 + term = apply () (tyInst () (builtin () LengthOfArray) integer) arrayOfInts + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + @?= Right (EvaluationSuccess expectedLength) , testCase "indexArray" do - let arrayOfInts = mkConstant @(Vector Integer) @DefaultUni () (Vector.fromList [1..10]) - let index = mkConstant @Integer @DefaultUni () 5 - expectedValue = mkConstant @Integer @DefaultUni () 6 - term = mkIterAppNoAnn (tyInst () (builtin () IndexArray) integer) [arrayOfInts, index] - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term @?= - Right (EvaluationSuccess expectedValue) - ] + let arrayOfInts = mkConstant @(Vector Integer) @DefaultUni () (Vector.fromList [1 .. 10]) + let index = mkConstant @Integer @DefaultUni () 5 + expectedValue = mkConstant @Integer @DefaultUni () 6 + term = mkIterAppNoAnn (tyInst () (builtin () IndexArray) integer) [arrayOfInts, index] + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + @?= Right (EvaluationSuccess expectedValue) + ] test_BuiltinPair :: TestTree test_BuiltinPair = - testCase "BuiltinPair" $ do - let arg = mkConstant @(Integer, Bool) @DefaultUni () (1, False) - inst efun = mkIterInstNoAnn (builtin () efun) [integer, bool] - swapped = apply () (inst $ Right Swap) arg - fsted = apply () (inst $ Left FstPair) arg - snded = apply () (inst $ Left SndPair) arg - -- > swap {integer} {bool} (1, False) ~> (False, 1) - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt swapped @?= - Right (EvaluationSuccess $ mkConstant @(Bool, Integer) () (False, 1)) - -- > fst {integer} {bool} (1, False) ~> 1 - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt fsted @?= - Right (EvaluationSuccess $ mkConstant @Integer () 1) - -- > snd {integer} {bool} (1, False) ~> False - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt snded @?= - Right (EvaluationSuccess $ mkConstant @Bool () False) + testCase "BuiltinPair" $ do + let arg = mkConstant @(Integer, Bool) @DefaultUni () (1, False) + inst efun = mkIterInstNoAnn (builtin () efun) [integer, bool] + swapped = apply () (inst $ Right Swap) arg + fsted = apply () (inst $ Left FstPair) arg + snded = apply () (inst $ Left SndPair) arg + -- > swap {integer} {bool} (1, False) ~> (False, 1) + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt swapped + @?= Right (EvaluationSuccess $ mkConstant @(Bool, Integer) () (False, 1)) + -- > fst {integer} {bool} (1, False) ~> 1 + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt fsted + @?= Right (EvaluationSuccess $ mkConstant @Integer () 1) + -- > snd {integer} {bool} (1, False) ~> False + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt snded + @?= Right (EvaluationSuccess $ mkConstant @Bool () False) test_SwapEls :: TestTree test_SwapEls = - testGroup "SwapEls" $ enumerate <&> \optMatch -> - testCase (show optMatch) $ do - let xs = zip [1..10] $ cycle [False, True] - res = mkConstant @Integer @DefaultUni () $ - foldr (\p r -> r + (if snd p then -1 else 1) * fst p) 0 xs - el = mkTyBuiltin @_ @(Integer, Bool) () - instProj p = mkIterInstNoAnn (builtin () p) [integer, bool] - fun = runQuote $ do - p <- freshName "p" - r <- freshName "r" - return - . lamAbs () p el - . lamAbs () r integer - $ mkIterAppNoAnn (builtin () AddInteger) - [ Var () r - , mkIterAppNoAnn (builtin () MultiplyInteger) - [ mkIterAppNoAnn (tyInst () (builtin () IfThenElse) integer) - [ apply () (instProj SndPair) $ Var () p - , mkConstant @Integer () (-1) - , mkConstant @Integer () 1 - ] - , apply () (instProj FstPair) $ Var () p - ] - ] - term - = mkIterAppNoAnn (mkIterInstNoAnn (Builtin.foldrList optMatch) [el, integer]) - [ fun - , mkConstant @Integer () 0 - , mkConstant () xs - ] - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term @?= - Right (EvaluationSuccess res) + testGroup "SwapEls" $ + enumerate <&> \optMatch -> + testCase (show optMatch) $ do + let xs = zip [1 .. 10] $ cycle [False, True] + res = + mkConstant @Integer @DefaultUni () $ + foldr (\p r -> r + (if snd p then -1 else 1) * fst p) 0 xs + el = mkTyBuiltin @_ @(Integer, Bool) () + instProj p = mkIterInstNoAnn (builtin () p) [integer, bool] + fun = runQuote $ do + p <- freshName "p" + r <- freshName "r" + return + . lamAbs () p el + . lamAbs () r integer + $ mkIterAppNoAnn + (builtin () AddInteger) + [ Var () r + , mkIterAppNoAnn + (builtin () MultiplyInteger) + [ mkIterAppNoAnn + (tyInst () (builtin () IfThenElse) integer) + [ apply () (instProj SndPair) $ Var () p + , mkConstant @Integer () (-1) + , mkConstant @Integer () 1 + ] + , apply () (instProj FstPair) $ Var () p + ] + ] + term = + mkIterAppNoAnn + (mkIterInstNoAnn (Builtin.foldrList optMatch) [el, integer]) + [ fun + , mkConstant @Integer () 0 + , mkConstant () xs + ] + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + @?= Right (EvaluationSuccess res) -- | Test that right-folding a built-in 'Data' with the constructors of 'Data' recreates the -- original value. test_IdBuiltinData :: TestTree test_IdBuiltinData = - testGroup "IdBuiltinData" $ enumerate <&> \optMatch -> - testCase (show optMatch) $ do - let dTerm :: TermLike term tyname name DefaultUni fun => term () - dTerm = mkConstant @Data () $ - Map [(I 42, Constr 4 [List [B "abc", Constr 2 []], I 0])] - emb = builtin () . Left - term = mkIterAppNoAnn (ofoldrData optMatch) - [ emb ConstrData - , emb MapData - , emb ListData - , emb IData - , emb BData - , dTerm - ] - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term @?= - Right (EvaluationSuccess dTerm) + testGroup "IdBuiltinData" $ + enumerate <&> \optMatch -> + testCase (show optMatch) $ do + let dTerm :: TermLike term tyname name DefaultUni fun => term () + dTerm = + mkConstant @Data () $ + Map [(I 42, Constr 4 [List [B "abc", Constr 2 []], I 0])] + emb = builtin () . Left + term = + mkIterAppNoAnn + (ofoldrData optMatch) + [ emb ConstrData + , emb MapData + , emb ListData + , emb IData + , emb BData + , dTerm + ] + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelExt term + @?= Right (EvaluationSuccess dTerm) -- | For testing how an evaluator instantiated at a particular 'ExBudgetMode' handles the -- 'TrackCosts' builtin. -test_TrackCostsWith - :: String -> Int -> (Term TyName Name DefaultUni ExtensionFun () -> IO ()) -> TestTree +test_TrackCostsWith :: + String -> Int -> (Term TyName Name DefaultUni ExtensionFun () -> IO ()) -> TestTree test_TrackCostsWith cat len checkTerm = - testCase ("TrackCosts: " ++ cat) $ do - let term - = apply () (builtin () TrackCosts) - $ mkConstant @Data () (List . replicate len $ I 42) - checkTerm term + testCase ("TrackCosts: " ++ cat) $ do + let term = + apply () (builtin () TrackCosts) $ + mkConstant @Data () (List . replicate len $ I 42) + checkTerm term -- | Test that individual budgets are picked up by GC while spending is still ongoing. test_TrackCostsRestricting :: TestTree test_TrackCostsRestricting = - let n = 10000 - in test_TrackCostsWith "restricting" n $ \term -> + let n = 10000 + in test_TrackCostsWith "restricting" n $ \term -> case typecheckReadKnownCek def () term of - Left err -> fail $ displayPlc err - Right (Left err) -> fail $ displayPlc err - Right (Right (res :: [Integer])) -> do - let expected = n `div` 10 - actual = length res - err = concat - [ "Too few elements picked up by GC\n" - , "Expected at least: " ++ show expected ++ "\n" - , "But got: " ++ show actual - ] - assertBool err $ expected < actual + Left err -> fail $ displayPlc err + Right (Left err) -> fail $ displayPlc err + Right (Right (res :: [Integer])) -> do + let expected = n `div` 10 + actual = length res + err = + concat + [ "Too few elements picked up by GC\n" + , "Expected at least: " ++ show expected ++ "\n" + , "But got: " ++ show actual + ] + assertBool err $ expected < actual test_TrackCostsRetaining :: TestTree test_TrackCostsRetaining = - test_TrackCostsWith "retaining" 10000 $ \term -> do - let -- An 'ExBudgetMode' that retains all the individual budgets by sticking them into a - -- 'DList'. - retaining = monoidalBudgeting $ const DList.singleton - typecheckAndRunRetainer = typecheckAnd def $ \params term' -> - let (getRes, budgets) = runCekNoEmit params retaining term' - in (getRes >>= readKnownSelf, budgets) - case typecheckAndRunRetainer () term of - Left err -> fail $ displayPlc err - Right (Left err, _) -> fail $ displayPlc err - Right (Right (res :: [Integer]), budgets) -> do - -- @length budgets@ is for retaining @budgets@ for as long as possible just in case. - -- @3@ is just for giving us room to handle erratic GC behavior. It really should be - -- @1@. - let expected = min 5 (length budgets) - actual = length res - err = concat - [ "Too many elements picked up by GC\n" - , "Expected at most: " ++ show expected ++ "\n" - , "But got: " ++ show actual ++ "\n" - , "The result was: " ++ show res - ] - assertBool err $ expected > actual + test_TrackCostsWith "retaining" 10000 $ \term -> do + let + -- An 'ExBudgetMode' that retains all the individual budgets by sticking them into a + -- 'DList'. + retaining = monoidalBudgeting $ const DList.singleton + typecheckAndRunRetainer = typecheckAnd def $ \params term' -> + let (getRes, budgets) = runCekNoEmit params retaining term' + in (getRes >>= readKnownSelf, budgets) + case typecheckAndRunRetainer () term of + Left err -> fail $ displayPlc err + Right (Left err, _) -> fail $ displayPlc err + Right (Right (res :: [Integer]), budgets) -> do + -- @length budgets@ is for retaining @budgets@ for as long as possible just in case. + -- @3@ is just for giving us room to handle erratic GC behavior. It really should be + -- @1@. + let expected = min 5 (length budgets) + actual = length res + err = + concat + [ "Too many elements picked up by GC\n" + , "Expected at most: " ++ show expected ++ "\n" + , "But got: " ++ show actual ++ "\n" + , "The result was: " ++ show res + ] + assertBool err $ expected > actual typecheckAndEvalToOutOfEx :: Term TyName Name DefaultUni DefaultFun () -> Assertion typecheckAndEvalToOutOfEx term = - let evalRestricting params = fst . runCekNoEmit params restrictingLarge - in case typecheckAnd def evalRestricting defaultBuiltinCostModelForTesting term of + let evalRestricting params = fst . runCekNoEmit params restrictingLarge + in case typecheckAnd def evalRestricting defaultBuiltinCostModelForTesting term of Right (Left (ErrorWithCause (OperationalError (CekOutOfExError _)) _)) -> - pure () + pure () err -> assertFailure $ "Expected a 'CekOutOfExError' but got: " ++ displayPlc err test_SerialiseDataImpossible :: TestTree test_SerialiseDataImpossible = - testCase "Serialising an impossible 'Data' object runs out of budget and finishes" $ do - let dataLoop :: Term TyName Name DefaultUni DefaultFun () - dataLoop = - let loop = List [loop] - in Apply () (Builtin () SerialiseData) $ mkConstant () loop - typecheckAndEvalToOutOfEx dataLoop + testCase "Serialising an impossible 'Data' object runs out of budget and finishes" $ do + let dataLoop :: Term TyName Name DefaultUni DefaultFun () + dataLoop = + let loop = List [loop] + in Apply () (Builtin () SerialiseData) $ mkConstant () loop + typecheckAndEvalToOutOfEx dataLoop test_fixId :: TestTree test_fixId = - testCase "'fix id' runs out of budget and finishes" $ do - let fixId :: Term TyName Name DefaultUni DefaultFun () - fixId = - mkIterAppNoAnn (mkIterInstNoAnn Plc.fix [integer, integer]) - [ tyInst () Plc.idFun (TyFun () integer integer) - , mkConstant @Integer () 42 - ] - typecheckAndEvalToOutOfEx fixId + testCase "'fix id' runs out of budget and finishes" $ do + let fixId :: Term TyName Name DefaultUni DefaultFun () + fixId = + mkIterAppNoAnn + (mkIterInstNoAnn Plc.fix [integer, integer]) + [ tyInst () Plc.idFun (TyFun () integer integer) + , mkConstant @Integer () 42 + ] + typecheckAndEvalToOutOfEx fixId -- | If the first char is an opening paren and the last chat is a closing paren, then remove them. -- This is useful for rendering a term-as-a-test-name in CLI, since currently we wrap readably -- pretty-printed terms in parens (which is to be fixed). stripParensIfAny :: String -> String stripParensIfAny str@('(' : str1) | last str == ')' = init str1 -stripParensIfAny str = str +stripParensIfAny str = str -- | Apply a built-in function to type then term arguments, evaluate that expression and expect -- evaluation to succeed and return the given @a@ value. -evals - :: DefaultUni `HasTermLevel` a - => a - -> DefaultFun - -> [Type TyName DefaultUni ()] - -> [Term TyName Name DefaultUni DefaultFun ()] - -> TestNested +evals :: + DefaultUni `HasTermLevel` a => + a -> + DefaultFun -> + [Type TyName DefaultUni ()] -> + [Term TyName Name DefaultUni DefaultFun ()] -> + TestNested evals expectedVal fun typeArgs termArgs = - let actualExpNoTermArgs = mkIterInstNoAnn (builtin () fun) typeArgs - actualExp = mkIterAppNoAnn actualExpNoTermArgs termArgs - prename = stripParensIfAny . render $ prettyPlcReadable actualExp - -- Shorten the name of the test in case it's too long to be displayed in CLI. - name = if length prename < 70 then prename else - stripParensIfAny (render $ prettyPlcReadable actualExpNoTermArgs) ++ - concatMap (\_ -> " <...>") termArgs - expectedRes = Right . EvaluationSuccess $ cons expectedVal - actualRes = typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting actualExp - in testNestedM name . embed . testCase "type checks and evaluates as expected" $ + let actualExpNoTermArgs = mkIterInstNoAnn (builtin () fun) typeArgs + actualExp = mkIterAppNoAnn actualExpNoTermArgs termArgs + prename = stripParensIfAny . render $ prettyPlcReadable actualExp + -- Shorten the name of the test in case it's too long to be displayed in CLI. + name = + if length prename < 70 + then prename + else + stripParensIfAny (render $ prettyPlcReadable actualExpNoTermArgs) + ++ concatMap (\_ -> " <...>") termArgs + expectedRes = Right . EvaluationSuccess $ cons expectedVal + actualRes = typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting actualExp + in testNestedM name . embed . testCase "type checks and evaluates as expected" $ expectedRes @=? actualRes -- | Apply a built-in function to type then term arguments, evaluate that expression and expect -- evaluation to fail. The logs along with the error are printed to a golden file. -fails - :: String -- ^ Name of the golden file. - -> DefaultFun - -> [Type TyName DefaultUni ()] - -> [Term TyName Name DefaultUni DefaultFun ()] - -> TestNested +fails :: + -- | Name of the golden file. + String -> + DefaultFun -> + [Type TyName DefaultUni ()] -> + [Term TyName Name DefaultUni DefaultFun ()] -> + TestNested fails fileName fun typeArgs termArgs = do - let actualExpNoTermArgs = mkIterInstNoAnn (builtin () fun) typeArgs - actualExp = mkIterAppNoAnn actualExpNoTermArgs termArgs - expectedToDisplay = "type checks and fails evaluation as expected" - case typecheckAnd def (evaluateCek logEmitter) defaultBuiltinCostModelForTesting actualExp of - Left err -> - embed . testCase "type checks as expected" $ - assertFailure $ displayPlcCondensedErrorClassic err - Right (actualRes, logs) -> case actualRes of - Right _ -> - embed . testCase expectedToDisplay $ - assertFailure "expected an evaluation failure, but got a success" - Left err -> - let prename = stripParensIfAny . render $ prettyPlcReadable actualExp - -- Shorten the name of the test in case it's too long to be displayed in CLI. - name = if length prename < 70 then prename else - stripParensIfAny (render $ prettyPlcReadable actualExpNoTermArgs) ++ - concatMap (\_ -> " <...>") termArgs - in testNestedNamedM mempty name $ - testNestedNamedM mempty expectedToDisplay $ - nestedGoldenVsDoc fileName ".err" . vsep $ concat - [ [prettyPlcReadable err] - , ["Logs were:" | not $ null logs] - , map pretty logs - ] + let actualExpNoTermArgs = mkIterInstNoAnn (builtin () fun) typeArgs + actualExp = mkIterAppNoAnn actualExpNoTermArgs termArgs + expectedToDisplay = "type checks and fails evaluation as expected" + case typecheckAnd def (evaluateCek logEmitter) defaultBuiltinCostModelForTesting actualExp of + Left err -> + embed . testCase "type checks as expected" $ + assertFailure $ + displayPlcCondensedErrorClassic err + Right (actualRes, logs) -> case actualRes of + Right _ -> + embed . testCase expectedToDisplay $ + assertFailure "expected an evaluation failure, but got a success" + Left err -> + let prename = stripParensIfAny . render $ prettyPlcReadable actualExp + -- Shorten the name of the test in case it's too long to be displayed in CLI. + name = + if length prename < 70 + then prename + else + stripParensIfAny (render $ prettyPlcReadable actualExpNoTermArgs) + ++ concatMap (\_ -> " <...>") termArgs + in testNestedNamedM mempty name $ + testNestedNamedM mempty expectedToDisplay $ + nestedGoldenVsDoc fileName ".err" . vsep $ + concat + [ [prettyPlcReadable err] + , ["Logs were:" | not $ null logs] + , map pretty logs + ] -- | Test all integer related builtins test_Integer :: TestNested test_Integer = testNestedM "Integer" $ do - evals @Integer 3 AddInteger [] [cons @Integer 2, cons @Integer 1] - evals @Integer 2 SubtractInteger [] [cons @Integer 100, cons @Integer 98] - evals @Integer (-2) SubtractInteger [] [cons @Integer 98, cons @Integer 100] - evals @Integer 9702 MultiplyInteger [] [cons @Integer 99, cons @Integer 98] - evals @Integer (-3) DivideInteger [] [cons @Integer 99, cons @Integer (-34)] - evals @Integer (-2) QuotientInteger [] [cons @Integer 99, cons @Integer (-34)] - evals @Integer 31 RemainderInteger [] [cons @Integer 99, cons @Integer (-34)] - evals @Integer (-3) ModInteger [] [cons @Integer 99, cons @Integer (-34)] - evals True LessThanInteger [] [cons @Integer 30, cons @Integer 4000] - evals False LessThanInteger [] [cons @Integer 40, cons @Integer 40] - evals True LessThanEqualsInteger [] [cons @Integer 30, cons @Integer 4000] - evals True LessThanEqualsInteger [] [cons @Integer 4000, cons @Integer 4000] - evals False LessThanEqualsInteger [] [cons @Integer 4001, cons @Integer 4000] - evals True EqualsInteger [] [cons @Integer (-101), cons @Integer (-101)] - evals False EqualsInteger [] [cons @Integer 0, cons @Integer 1] - for_ [DivideInteger, QuotientInteger, ModInteger, RemainderInteger] $ \ b -> - fails (lowerInitialChar $ show b <> "-div-by-zero") b [] [cons @Integer 1, cons @Integer 0] - test_ExpModInteger + evals @Integer 3 AddInteger [] [cons @Integer 2, cons @Integer 1] + evals @Integer 2 SubtractInteger [] [cons @Integer 100, cons @Integer 98] + evals @Integer (-2) SubtractInteger [] [cons @Integer 98, cons @Integer 100] + evals @Integer 9702 MultiplyInteger [] [cons @Integer 99, cons @Integer 98] + evals @Integer (-3) DivideInteger [] [cons @Integer 99, cons @Integer (-34)] + evals @Integer (-2) QuotientInteger [] [cons @Integer 99, cons @Integer (-34)] + evals @Integer 31 RemainderInteger [] [cons @Integer 99, cons @Integer (-34)] + evals @Integer (-3) ModInteger [] [cons @Integer 99, cons @Integer (-34)] + evals True LessThanInteger [] [cons @Integer 30, cons @Integer 4000] + evals False LessThanInteger [] [cons @Integer 40, cons @Integer 40] + evals True LessThanEqualsInteger [] [cons @Integer 30, cons @Integer 4000] + evals True LessThanEqualsInteger [] [cons @Integer 4000, cons @Integer 4000] + evals False LessThanEqualsInteger [] [cons @Integer 4001, cons @Integer 4000] + evals True EqualsInteger [] [cons @Integer (-101), cons @Integer (-101)] + evals False EqualsInteger [] [cons @Integer 0, cons @Integer 1] + for_ [DivideInteger, QuotientInteger, ModInteger, RemainderInteger] $ \b -> + fails (lowerInitialChar $ show b <> "-div-by-zero") b [] [cons @Integer 1, cons @Integer 0] + test_ExpModInteger test_ExpModInteger :: TestNested test_ExpModInteger = testNestedM "ExpMod" $ do - evals @Integer 1 b [] [int 500, zero, int 500] -- base:X, exp: zero, mod: X(strictpos) - evals @Integer 0 b [] [int 500, int 5, int 500] -- base:X, exp: strictpos, mod: X(strictpos) - evals @Integer 1 b [] [one , int (-3), int 4] -- base:1, exp: * , mod: strictpos - evals @Integer 2 b [] [int 2, int (-3), int 3] -- base:*, exp: neg, mod: prime - -- base is co-prime with mod and exponent is negative - evals @Integer 4 b [] [int 4, int (-5), int 9] - -- Always return 0 when modulus is 1. - evals @Integer 0 b [] [zero, zero, one] -- base:0, exp: zero, mod:1 - evals @Integer 0 b [] [zero, one, one] -- base:0, exp: 1, mod:1 - evals @Integer 0 b [] [zero, int (-1), one] -- base:0, exp: neg, mod:1 - evals @Integer 0 b [] [int 500, int 222, one] -- base:*, exp: strictpos, mod:1 - evals @Integer 0 b [] [int 500, int (-1777), one] -- base:*, exp: neg, mod:1 - fails "mod-zero" b [] [one, one, zero] -- base:*, exp:*, mod: 0 - fails "mod-neg" b [] [one, one, int (-3)] -- base:*, exp:*, mod: neg - -- base is zero, negative exponent - fails "exp-neg-non-inverse0" b [] [int 0, int (-1), int 7] - -- base and mod are not co-prime, negative exponent - fails "exp-neg-non-inverse1" b [] [int 2, int (-3), int 4] - -- mod is prime, but base&mod are not co-prime, negative exponent - fails "exp-neg-non-inverse2" b [] [int 500, int (-5), int 5] + evals @Integer 1 b [] [int 500, zero, int 500] -- base:X, exp: zero, mod: X(strictpos) + evals @Integer 0 b [] [int 500, int 5, int 500] -- base:X, exp: strictpos, mod: X(strictpos) + evals @Integer 1 b [] [one, int (-3), int 4] -- base:1, exp: * , mod: strictpos + evals @Integer 2 b [] [int 2, int (-3), int 3] -- base:*, exp: neg, mod: prime + -- base is co-prime with mod and exponent is negative + evals @Integer 4 b [] [int 4, int (-5), int 9] + -- Always return 0 when modulus is 1. + evals @Integer 0 b [] [zero, zero, one] -- base:0, exp: zero, mod:1 + evals @Integer 0 b [] [zero, one, one] -- base:0, exp: 1, mod:1 + evals @Integer 0 b [] [zero, int (-1), one] -- base:0, exp: neg, mod:1 + evals @Integer 0 b [] [int 500, int 222, one] -- base:*, exp: strictpos, mod:1 + evals @Integer 0 b [] [int 500, int (-1777), one] -- base:*, exp: neg, mod:1 + fails "mod-zero" b [] [one, one, zero] -- base:*, exp:*, mod: 0 + fails "mod-neg" b [] [one, one, int (-3)] -- base:*, exp:*, mod: neg + -- base is zero, negative exponent + fails "exp-neg-non-inverse0" b [] [int 0, int (-1), int 7] + -- base and mod are not co-prime, negative exponent + fails "exp-neg-non-inverse1" b [] [int 2, int (-3), int 4] + -- mod is prime, but base&mod are not co-prime, negative exponent + fails "exp-neg-non-inverse2" b [] [int 500, int (-5), int 5] where int = cons @Integer zero = int 0 @@ -675,368 +726,1024 @@ test_ExpModInteger = testNestedM "ExpMod" $ do -- | Test all string-like builtins test_String :: TestNested test_String = testNestedM "String" $ do - -- bytestrings - evals @ByteString "hello world" AppendByteString [] [cons @ByteString "hello", cons @ByteString " world"] - evals @ByteString "mpla" AppendByteString [] [cons @ByteString "", cons @ByteString "mpla"] - evals False EqualsByteString [] [cons @ByteString "" , cons @ByteString "mpla"] - evals True EqualsByteString [] [cons @ByteString "mpla" , cons @ByteString "mpla"] - evals True LessThanByteString [] [cons @ByteString "" , cons @ByteString "mpla"] - - -- strings - evals @Text "mpla" AppendString [] [cons @Text "", cons @Text "mpla"] - evals False EqualsString [] [cons @Text "" , cons @Text "mpla"] - evals True EqualsString [] [cons @Text "mpla" , cons @Text "mpla"] - evals @Text "hello world" AppendString [] [cons @Text "hello", cons @Text " world"] - - -- id for subset char8 of utf8 - evals @ByteString "hello world" EncodeUtf8 [] [cons @Text "hello world"] - evals @Text "hello world" DecodeUtf8 [] [cons @ByteString "hello world"] - - -- the 'o's replaced with greek o's, so they are kind of "invisible" - evals @ByteString "hell\206\191 w\206\191rld" EncodeUtf8 [] [cons @Text "hellο wοrld"] - -- cannot decode back, because bytestring only works on Char8 subset of utf8 - evals @Text "hellο wοrld" DecodeUtf8 [] [cons @ByteString "hell\206\191 w\206\191rld"] - - evals @ByteString "\NULhello world" ConsByteString [] [cons @Integer 0, cons @ByteString "hello world"] - -- cannot overflow back to 0 - fails "consByteString-out-of-range" ConsByteString [] - [cons @Integer 256, cons @ByteString "hello world"] - evals @ByteString "\240hello world" ConsByteString [] [cons @Integer 240, cons @ByteString "hello world"] - -- 65 is ASCII A - evals @ByteString "Ahello world" ConsByteString [] [cons @Integer 65, cons @ByteString "hello world"] - - evals @ByteString "h" SliceByteString [] [cons @Integer 0, cons @Integer 1, cons @ByteString "hello world"] - evals @ByteString "he" SliceByteString [] [cons @Integer 0, cons @Integer 2, cons @ByteString "hello world"] - evals @ByteString "el" SliceByteString [] [cons @Integer 1, cons @Integer 2, cons @ByteString "hello world"] - evals @ByteString "world" SliceByteString [] [cons @Integer 6, cons @Integer 5, cons @ByteString "hello world"] - - evals @Integer 11 LengthOfByteString [] [cons @ByteString "hello world"] - evals @Integer 0 LengthOfByteString [] [cons @ByteString ""] - evals @Integer 1 LengthOfByteString [] [cons @ByteString "\NUL"] - - -- 65 is ASCII A - evals @Integer 65 IndexByteString [] [cons @ByteString "Ahello world", cons @Integer 0] - fails "indexByteString-out-of-bounds-non-empty" IndexByteString [] - [cons @ByteString "hello world", cons @Integer 12] - fails "indexByteString-out-of-bounds-empty" IndexByteString [] - [cons @ByteString "", cons @Integer 0] + -- bytestrings + evals @ByteString "hello world" AppendByteString [] [cons @ByteString "hello", cons @ByteString " world"] + evals @ByteString "mpla" AppendByteString [] [cons @ByteString "", cons @ByteString "mpla"] + evals False EqualsByteString [] [cons @ByteString "", cons @ByteString "mpla"] + evals True EqualsByteString [] [cons @ByteString "mpla", cons @ByteString "mpla"] + evals True LessThanByteString [] [cons @ByteString "", cons @ByteString "mpla"] + + -- strings + evals @Text "mpla" AppendString [] [cons @Text "", cons @Text "mpla"] + evals False EqualsString [] [cons @Text "", cons @Text "mpla"] + evals True EqualsString [] [cons @Text "mpla", cons @Text "mpla"] + evals @Text "hello world" AppendString [] [cons @Text "hello", cons @Text " world"] + + -- id for subset char8 of utf8 + evals @ByteString "hello world" EncodeUtf8 [] [cons @Text "hello world"] + evals @Text "hello world" DecodeUtf8 [] [cons @ByteString "hello world"] + + -- the 'o's replaced with greek o's, so they are kind of "invisible" + evals @ByteString "hell\206\191 w\206\191rld" EncodeUtf8 [] [cons @Text "hellο wοrld"] + -- cannot decode back, because bytestring only works on Char8 subset of utf8 + evals @Text "hellο wοrld" DecodeUtf8 [] [cons @ByteString "hell\206\191 w\206\191rld"] + + evals @ByteString "\NULhello world" ConsByteString [] [cons @Integer 0, cons @ByteString "hello world"] + -- cannot overflow back to 0 + fails + "consByteString-out-of-range" + ConsByteString + [] + [cons @Integer 256, cons @ByteString "hello world"] + evals @ByteString "\240hello world" ConsByteString [] [cons @Integer 240, cons @ByteString "hello world"] + -- 65 is ASCII A + evals @ByteString "Ahello world" ConsByteString [] [cons @Integer 65, cons @ByteString "hello world"] + + evals @ByteString "h" SliceByteString [] [cons @Integer 0, cons @Integer 1, cons @ByteString "hello world"] + evals @ByteString "he" SliceByteString [] [cons @Integer 0, cons @Integer 2, cons @ByteString "hello world"] + evals @ByteString "el" SliceByteString [] [cons @Integer 1, cons @Integer 2, cons @ByteString "hello world"] + evals @ByteString "world" SliceByteString [] [cons @Integer 6, cons @Integer 5, cons @ByteString "hello world"] + + evals @Integer 11 LengthOfByteString [] [cons @ByteString "hello world"] + evals @Integer 0 LengthOfByteString [] [cons @ByteString ""] + evals @Integer 1 LengthOfByteString [] [cons @ByteString "\NUL"] + + -- 65 is ASCII A + evals @Integer 65 IndexByteString [] [cons @ByteString "Ahello world", cons @Integer 0] + fails + "indexByteString-out-of-bounds-non-empty" + IndexByteString + [] + [cons @ByteString "hello world", cons @Integer 12] + fails + "indexByteString-out-of-bounds-empty" + IndexByteString + [] + [cons @ByteString "", cons @Integer 0] test_MatchList :: MatchOption -> TestNested test_MatchList optMatch = testNestedM "MatchList" $ do - let -- the null function that utilizes the ChooseList builtin (through the matchList helper - -- function) - nullViaMatch :: [Integer] -> Term TyName Name DefaultUni DefaultFun () - nullViaMatch l = - mkIterAppNoAnn - (tyInst () - (apply () (tyInst () (Builtin.matchList optMatch) integer) $ cons l) - bool) - [ -- zero - true - -- cons - , runQuote $ do - a1 <- freshName "a1" - a2 <- freshName "a2" - pure - . lamAbs () a1 integer - . lamAbs () a2 (TyApp () Builtin.list integer) - $ false - ] + let + -- the null function that utilizes the ChooseList builtin (through the matchList helper + -- function) + nullViaMatch :: [Integer] -> Term TyName Name DefaultUni DefaultFun () + nullViaMatch l = + mkIterAppNoAnn + ( tyInst + () + (apply () (tyInst () (Builtin.matchList optMatch) integer) $ cons l) + bool + ) + [ -- zero + true + , -- cons + runQuote $ do + a1 <- freshName "a1" + a2 <- freshName "a2" + pure + . lamAbs () a1 integer + . lamAbs () a2 (TyApp () Builtin.list integer) + $ false + ] - embed . testCase "nullViaMatch []" $ - Right (EvaluationSuccess true) @=? - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting - (nullViaMatch []) - embed . testCase "nullViaMatch [1]" $ - Right (EvaluationSuccess false) @=? - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting - (nullViaMatch [1]) - embed . testCase "nullViaMatch [1..10]" $ - Right (EvaluationSuccess false) @=? - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting - (nullViaMatch [1..10]) + embed . testCase "nullViaMatch []" $ + Right (EvaluationSuccess true) + @=? typecheckEvaluateCekNoEmit + def + defaultBuiltinCostModelForTesting + (nullViaMatch []) + embed . testCase "nullViaMatch [1]" $ + Right (EvaluationSuccess false) + @=? typecheckEvaluateCekNoEmit + def + defaultBuiltinCostModelForTesting + (nullViaMatch [1]) + embed . testCase "nullViaMatch [1..10]" $ + Right (EvaluationSuccess false) + @=? typecheckEvaluateCekNoEmit + def + defaultBuiltinCostModelForTesting + (nullViaMatch [1 .. 10]) -- | Test all list-related builtins test_List :: TestNested test_List = testNestedM "List" $ do - evals False NullList [integer] [cons @[Integer] [1,2]] - evals False NullList [integer] [cons @[Integer] [1]] - evals True NullList [integer] [cons @[Integer] []] + evals False NullList [integer] [cons @[Integer] [1, 2]] + evals False NullList [integer] [cons @[Integer] [1]] + evals True NullList [integer] [cons @[Integer] []] - evals @Integer 1 HeadList [integer] [cons @[Integer] [1,3]] - evals @[Integer] [3,4,5] TailList [integer] [cons @[Integer] [1,3,4,5]] + evals @Integer 1 HeadList [integer] [cons @[Integer] [1, 3]] + evals @[Integer] [3, 4, 5] TailList [integer] [cons @[Integer] [1, 3, 4, 5]] - fails "headList-empty" HeadList [integer] [cons @[Integer] []] - fails "tailList-empty" TailList [integer] [cons @[Integer] []] + fails "headList-empty" HeadList [integer] [cons @[Integer] []] + fails "tailList-empty" TailList [integer] [cons @[Integer] []] - evals @[Integer] [1] MkCons [integer] [cons @Integer 1, cons @[Integer] []] - evals @[Integer] [1,2] MkCons [integer] [cons @Integer 1, cons @[Integer] [2]] + evals @[Integer] [1] MkCons [integer] [cons @Integer 1, cons @[Integer] []] + evals @[Integer] [1, 2] MkCons [integer] [cons @Integer 1, cons @[Integer] [2]] - testNested "MatchList" $ map test_MatchList enumerate + testNested "MatchList" $ map test_MatchList enumerate test_MatchData :: TestNested test_MatchData = testNestedM "MatchData" $ do - let actualExp = - mkIterAppNoAnn - (tyInst () (apply () matchData $ cons $ I 3) bool) - [ -- constr - runQuote $ do - a1 <- freshName "a1" - a2 <- freshName "a2" - pure $ lamAbs () a1 integer $ lamAbs () a2 (TyApp () Builtin.list dataTy) false - , -- map - runQuote $ do - a1 <- freshName "a1" - let listDataData = TyApp () Builtin.list $ mkIterTyAppNoAnn pair [dataTy,dataTy] - pure $ lamAbs () a1 listDataData false - , -- list - runQuote $ do - a1 <- freshName "a1" - pure $ lamAbs () a1 (TyApp () Builtin.list dataTy) false - - , -- I - runQuote $ do - a1 <- freshName "a1" - pure $ lamAbs () a1 integer true - - , -- B - runQuote $ do - a1 <- freshName "a1" - pure $ lamAbs () a1 (mkTyBuiltin @_ @ByteString ()) false - ] + let actualExp = + mkIterAppNoAnn + (tyInst () (apply () matchData $ cons $ I 3) bool) + [ -- constr + runQuote $ do + a1 <- freshName "a1" + a2 <- freshName "a2" + pure $ lamAbs () a1 integer $ lamAbs () a2 (TyApp () Builtin.list dataTy) false + , -- map + runQuote $ do + a1 <- freshName "a1" + let listDataData = TyApp () Builtin.list $ mkIterTyAppNoAnn pair [dataTy, dataTy] + pure $ lamAbs () a1 listDataData false + , -- list + runQuote $ do + a1 <- freshName "a1" + pure $ lamAbs () a1 (TyApp () Builtin.list dataTy) false + , -- I + runQuote $ do + a1 <- freshName "a1" + pure $ lamAbs () a1 integer true + , -- B + runQuote $ do + a1 <- freshName "a1" + pure $ lamAbs () a1 (mkTyBuiltin @_ @ByteString ()) false + ] - embed . testCase "chooseData" $ - Right (EvaluationSuccess true) @=? - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting - actualExp + embed . testCase "chooseData" $ + Right (EvaluationSuccess true) + @=? typecheckEvaluateCekNoEmit + def + defaultBuiltinCostModelForTesting + actualExp -- | Test all PlutusData builtins test_Data :: TestNested test_Data = testNestedM "Data" $ do - -- construction - evals (Constr 2 [I 3]) ConstrData [] [cons @Integer 2, cons @[Data] [I 3]] - evals (Constr 2 [I 3, B ""]) ConstrData [] [cons @Integer 2, cons @[Data] [I 3, B ""]] - evals (List []) ListData [] [cons @[Data] []] - evals (List [I 3, B ""]) ListData [] [cons @[Data] [I 3, B ""]] - evals (Map []) MapData [] [cons @[(Data,Data)] []] - evals (Map [(I 3, B "")]) MapData [] [cons @[(Data,Data)] [(I 3, B "")]] - evals (B "hello world") BData [] [cons @ByteString "hello world"] - evals (I 3) IData [] [cons @Integer 3] - evals (B "hello world") BData [] [cons @ByteString "hello world"] - evals @[Data] [] MkNilData [] [cons ()] - evals @[(Data,Data)] [] MkNilPairData [] [cons ()] - - -- equality - evals True EqualsData [] [cons $ B "hello world", cons $ B "hello world"] - evals True EqualsData [] [cons $ I 4, cons $ I 4] - evals False EqualsData [] [cons $ B "hello world", cons $ I 4] - evals True EqualsData [] [cons $ Constr 3 [I 4], cons $ Constr 3 [I 4]] - evals False EqualsData [] [cons $ Constr 3 [I 3, B ""], cons $ Constr 3 [I 3]] - evals False EqualsData [] [cons $ Constr 2 [I 4], cons $ Constr 3 [I 4]] - evals True EqualsData [] [cons $ Map [(I 3, B "")], cons $ Map [(I 3, B "")]] - evals False EqualsData [] [cons $ Map [(I 3, B "")], cons $ Map []] - evals False EqualsData [] [cons $ Map [(I 3, B "")], cons $ Map [(I 3, B ""), (I 4, I 4)]] - - -- destruction - evals @Integer 3 UnIData [] [cons $ I 3] - evals @ByteString "hello world" UnBData [] [cons $ B "hello world"] - evals @Integer 3 UnIData [] [cons $ I 3] - evals @(Integer, [Data]) (1, []) UnConstrData [] [cons $ Constr 1 []] - evals @(Integer, [Data]) (1, [I 3]) UnConstrData [] [cons $ Constr 1 [I 3]] - evals @[(Data, Data)] [] UnMapData [] [cons $ Map []] - evals @[(Data, Data)] [(B "", I 3)] UnMapData [] [cons $ Map [(B "", I 3)]] - evals @[Data] [] UnListData [] [cons $ List []] - evals @[Data] [I 3, I 4, B ""] UnListData [] [cons $ List [I 3, I 4, B ""]] - evals @ByteString "\162\ETX@Ehello8c" SerialiseData [] [cons $ Map [(I 3, B ""), (B "hello", I $ -100)]] - - test_MatchData + -- construction + evals (Constr 2 [I 3]) ConstrData [] [cons @Integer 2, cons @[Data] [I 3]] + evals (Constr 2 [I 3, B ""]) ConstrData [] [cons @Integer 2, cons @[Data] [I 3, B ""]] + evals (List []) ListData [] [cons @[Data] []] + evals (List [I 3, B ""]) ListData [] [cons @[Data] [I 3, B ""]] + evals (Map []) MapData [] [cons @[(Data, Data)] []] + evals (Map [(I 3, B "")]) MapData [] [cons @[(Data, Data)] [(I 3, B "")]] + evals (B "hello world") BData [] [cons @ByteString "hello world"] + evals (I 3) IData [] [cons @Integer 3] + evals (B "hello world") BData [] [cons @ByteString "hello world"] + evals @[Data] [] MkNilData [] [cons ()] + evals @[(Data, Data)] [] MkNilPairData [] [cons ()] + + -- equality + evals True EqualsData [] [cons $ B "hello world", cons $ B "hello world"] + evals True EqualsData [] [cons $ I 4, cons $ I 4] + evals False EqualsData [] [cons $ B "hello world", cons $ I 4] + evals True EqualsData [] [cons $ Constr 3 [I 4], cons $ Constr 3 [I 4]] + evals False EqualsData [] [cons $ Constr 3 [I 3, B ""], cons $ Constr 3 [I 3]] + evals False EqualsData [] [cons $ Constr 2 [I 4], cons $ Constr 3 [I 4]] + evals True EqualsData [] [cons $ Map [(I 3, B "")], cons $ Map [(I 3, B "")]] + evals False EqualsData [] [cons $ Map [(I 3, B "")], cons $ Map []] + evals False EqualsData [] [cons $ Map [(I 3, B "")], cons $ Map [(I 3, B ""), (I 4, I 4)]] + + -- destruction + evals @Integer 3 UnIData [] [cons $ I 3] + evals @ByteString "hello world" UnBData [] [cons $ B "hello world"] + evals @Integer 3 UnIData [] [cons $ I 3] + evals @(Integer, [Data]) (1, []) UnConstrData [] [cons $ Constr 1 []] + evals @(Integer, [Data]) (1, [I 3]) UnConstrData [] [cons $ Constr 1 [I 3]] + evals @[(Data, Data)] [] UnMapData [] [cons $ Map []] + evals @[(Data, Data)] [(B "", I 3)] UnMapData [] [cons $ Map [(B "", I 3)]] + evals @[Data] [] UnListData [] [cons $ List []] + evals @[Data] [I 3, I 4, B ""] UnListData [] [cons $ List [I 3, I 4, B ""]] + evals @ByteString "\162\ETX@Ehello8c" SerialiseData [] [cons $ Map [(I 3, B ""), (B "hello", I $ -100)]] + + test_MatchData -- | Test all cryptography-related builtins test_Crypto :: TestNested test_Crypto = testNestedM "Crypto" $ do - evals True VerifyEd25519Signature [] - [ -- pubkey - cons @ByteString "Y\218\215\204>\STX\233\152\251\243\158'm\130\&0\197\DEL\STXd\214`\147\243y(\234\167=kTj\164" - -- message - , cons @ByteString "hello world" - -- signature - , cons @ByteString "\a'\198\r\226\SYN;\bX\254\228\129n\131\177\193\DC3-k\249RriY\221wIL\240\144\r\145\195\191\196]\227\169U(\ETX\171\SI\199\163\138\160\128R\DC4\246n\142[g\SI\169\SUB\178\245\166\&0\243\b" + evals + True + VerifyEd25519Signature + [] + [ -- pubkey + cons @ByteString "Y\218\215\204>\STX\233\152\251\243\158'm\130\&0\197\DEL\STXd\214`\147\243y(\234\167=kTj\164" + , -- message + cons @ByteString "hello world" + , -- signature + cons @ByteString "\a'\198\r\226\SYN;\bX\254\228\129n\131\177\193\DC3-k\249RriY\221wIL\240\144\r\145\195\191\196]\227\169U(\ETX\171\SI\199\163\138\160\128R\DC4\246n\142[g\SI\169\SUB\178\245\166\&0\243\b" + ] + + evals + False + VerifyEd25519Signature + [] + [ -- pubkey + cons @ByteString "Y\218\215\204>\STX\233\152\251\243\158'm\130\&0\197\DEL\STXd\214`\147\243y(\234\167=kTj\164" + , -- message + cons @ByteString "HELLO WORLD" + , -- signature + cons @ByteString "\a'\198\r\226\SYN;\bX\254\228\129n\131\177\193\DC3-k\249RriY\221wIL\240\144\r\145\195\191\196]\227\169U(\ETX\171\SI\199\163\138\160\128R\DC4\246n\142[g\SI\169\SUB\178\245\166\&0\243\b" + ] + -- independently verified by `/usr/bin/sha256sum` with the hex output converted to ascii text + -- sha256sum hex output: b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9 + evals @ByteString + "\185M'\185\147M>\b\165.R\215\218}\171\250\196\132\239\227zS\128\238\144\136\247\172\226\239\205\233" + Sha2_256 + [] + [cons @ByteString "hello world"] + -- independently verified by `/usr/bin/sha3-256sum` with the hex output converted to ascii text + -- sha3-256sum hex output: 644bcc7e564373040999aac89e7622f3ca71fba1d972fd94a31c3bfbf24e3938 + evals @ByteString + "dK\204~VCs\EOT\t\153\170\200\158v\"\243\202q\251\161\217r\253\148\163\FS;\251\242N98" + Sha3_256 + [] + [cons @ByteString "hello world"] + -- independently verified by `/usr/bin/b2sum -l 256` with the hex output converted to ascii text + -- b2sum -l 256 hex output: 256c83b297114d201b30179f3f0ef0cace9783622da5974326b436178aeef610 + evals @ByteString + "%l\131\178\151\DC1M \ESC0\ETB\159?\SO\240\202\206\151\131b-\165\151C&\180\&6\ETB\138\238\246\DLE" + Blake2b_256 + [] + [cons @ByteString "hello world"] + -- independently verified by `/usr/bin/b2sum -l 224` with the hex output converted to ascii text + -- b2sum -l 224 hex output: 42d1854b7d69e3b57c64fcc7b4f64171b47dff43fba6ac0499ff437f + evals @ByteString + "B\209\133K}i\227\181|d\252\199\180\246Aq\180}\255C\251\166\172\EOT\153\255C\DEL" + Blake2b_224 + [] + [cons @ByteString "hello world"] + -- independently verified by the calculator at `https://emn178.github.io/online-tools/keccak_256.html` + -- with the hex output converted to ascii text + -- hex output: 47173285a8d7341e5e972fc677286384f802f8ef42a5ec5f03bbfa254cb01fad + evals @ByteString + "G\ETB2\133\168\215\&4\RS^\151/\198w(c\132\248\STX\248\239B\165\236_\ETX\187\250%L\176\US\173" + Keccak_256 + [] + [cons @ByteString "hello world"] + -- independently verified by the calculator at https://emn178.github.io/online-tools/ripemd_160.html + let + hashHex = "98c615784ccb5fe5936fbc0cbe9dfdb408d92f0f" + ripemd_160Hash = case Base16.decode $ Text.encodeUtf8 hashHex of + Right res -> res + Left _ -> error $ "Unexpected error during hex decoding: " <> Text.unpack hashHex + evals @ByteString + ripemd_160Hash + Ripemd_160 + [] + [cons @ByteString "hello world"] + -- Tests for blake2b_224: output obtained using the b2sum program from https://github.com/BLAKE2/BLAKE2 + evals + ( pack + [ 0x83 + , 0x6c + , 0xc6 + , 0x89 + , 0x31 + , 0xc2 + , 0xe4 + , 0xe3 + , 0xe8 + , 0x38 + , 0x60 + , 0x2e + , 0xca + , 0x19 + , 0x02 + , 0x59 + , 0x1d + , 0x21 + , 0x68 + , 0x37 + , 0xba + , 0xfd + , 0xdf + , 0xe6 + , 0xf0 + , 0xc8 + , 0xcb + , 0x07 + ] + ) + Blake2b_224 + [] + [cons $ pack []] + evals + ( pack + [ 0xfe + , 0x57 + , 0xe0 + , 0x22 + , 0x87 + , 0x66 + , 0x2c + , 0xe6 + , 0xe2 + , 0x9c + , 0xba + , 0x02 + , 0xca + , 0x2f + , 0x23 + , 0xc4 + , 0x1f + , 0x20 + , 0x84 + , 0xc7 + , 0x95 + , 0x9f + , 0x1c + , 0xa3 + , 0xa5 + , 0x7e + , 0xaf + , 0x9e ] + ) + Blake2b_224 + [] + [ cons $ + pack + [ 0xfc + , 0x56 + , 0xca + , 0x9a + , 0x93 + , 0x98 + , 0x2a + , 0x46 + , 0x69 + , 0xcc + , 0xab + , 0xa6 + , 0xe3 + , 0xd1 + , 0x84 + , 0xa1 + , 0x9d + , 0xe4 + , 0xce + , 0x80 + , 0x0b + , 0xb6 + , 0x43 + , 0xa3 + , 0x60 + , 0xc1 + , 0x45 + , 0x72 + , 0xae + , 0xdb + , 0x22 + , 0x97 + , 0x4f + , 0x0c + , 0x96 + , 0x6b + , 0x85 + , 0x9d + , 0x91 + , 0xad + , 0x5d + , 0x71 + , 0x3b + , 0x7a + , 0xd9 + , 0x99 + , 0x35 + , 0x79 + , 0x4d + , 0x22 -- 400 bits + -- Tests for blake2b_256: output obtained using the b2sum program from https://github.com/BLAKE2/BLAKE2 + ] + ] - evals False VerifyEd25519Signature [] - [ -- pubkey - cons @ByteString "Y\218\215\204>\STX\233\152\251\243\158'm\130\&0\197\DEL\STXd\214`\147\243y(\234\167=kTj\164" - -- message - , cons @ByteString "HELLO WORLD" - -- signature - , cons @ByteString "\a'\198\r\226\SYN;\bX\254\228\129n\131\177\193\DC3-k\249RriY\221wIL\240\144\r\145\195\191\196]\227\169U(\ETX\171\SI\199\163\138\160\128R\DC4\246n\142[g\SI\169\SUB\178\245\166\&0\243\b" + evals + ( pack + [ 0x0e + , 0x57 + , 0x51 + , 0xc0 + , 0x26 + , 0xe5 + , 0x43 + , 0xb2 + , 0xe8 + , 0xab + , 0x2e + , 0xb0 + , 0x60 + , 0x99 + , 0xda + , 0xa1 + , 0xd1 + , 0xe5 + , 0xdf + , 0x47 + , 0x77 + , 0x8f + , 0x77 + , 0x87 + , 0xfa + , 0xab + , 0x45 + , 0xcd + , 0xf1 + , 0x2f + , 0xe3 + , 0xa8 ] - -- independently verified by `/usr/bin/sha256sum` with the hex output converted to ascii text - -- sha256sum hex output: b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9 - evals @ByteString "\185M'\185\147M>\b\165.R\215\218}\171\250\196\132\239\227zS\128\238\144\136\247\172\226\239\205\233" - Sha2_256 [] [cons @ByteString "hello world"] - -- independently verified by `/usr/bin/sha3-256sum` with the hex output converted to ascii text - -- sha3-256sum hex output: 644bcc7e564373040999aac89e7622f3ca71fba1d972fd94a31c3bfbf24e3938 - evals @ByteString "dK\204~VCs\EOT\t\153\170\200\158v\"\243\202q\251\161\217r\253\148\163\FS;\251\242N98" - Sha3_256 [] [cons @ByteString "hello world"] - -- independently verified by `/usr/bin/b2sum -l 256` with the hex output converted to ascii text - -- b2sum -l 256 hex output: 256c83b297114d201b30179f3f0ef0cace9783622da5974326b436178aeef610 - evals @ByteString "%l\131\178\151\DC1M \ESC0\ETB\159?\SO\240\202\206\151\131b-\165\151C&\180\&6\ETB\138\238\246\DLE" - Blake2b_256 [] [cons @ByteString "hello world"] - -- independently verified by `/usr/bin/b2sum -l 224` with the hex output converted to ascii text - -- b2sum -l 224 hex output: 42d1854b7d69e3b57c64fcc7b4f64171b47dff43fba6ac0499ff437f - evals @ByteString "B\209\133K}i\227\181|d\252\199\180\246Aq\180}\255C\251\166\172\EOT\153\255C\DEL" - Blake2b_224 [] [cons @ByteString "hello world"] - -- independently verified by the calculator at `https://emn178.github.io/online-tools/keccak_256.html` - -- with the hex output converted to ascii text - -- hex output: 47173285a8d7341e5e972fc677286384f802f8ef42a5ec5f03bbfa254cb01fad - evals @ByteString "G\ETB2\133\168\215\&4\RS^\151/\198w(c\132\248\STX\248\239B\165\236_\ETX\187\250%L\176\US\173" - Keccak_256 [] [cons @ByteString "hello world"] - -- independently verified by the calculator at https://emn178.github.io/online-tools/ripemd_160.html - let - hashHex = "98c615784ccb5fe5936fbc0cbe9dfdb408d92f0f" - ripemd_160Hash = case Base16.decode $ Text.encodeUtf8 hashHex of - Right res -> res - Left _ -> error $ "Unexpected error during hex decoding: " <> Text.unpack hashHex - evals @ByteString ripemd_160Hash - Ripemd_160 [] [cons @ByteString "hello world"] - -- Tests for blake2b_224: output obtained using the b2sum program from https://github.com/BLAKE2/BLAKE2 - evals (pack [ 0x83, 0x6c, 0xc6, 0x89, 0x31, 0xc2, 0xe4, 0xe3, 0xe8, 0x38, 0x60, 0x2e, 0xca, 0x19 - , 0x02, 0x59, 0x1d, 0x21, 0x68, 0x37, 0xba, 0xfd, 0xdf, 0xe6, 0xf0, 0xc8, 0xcb, 0x07 ]) - Blake2b_224 [] [cons $ pack []] - evals (pack [ 0xfe, 0x57, 0xe0, 0x22, 0x87, 0x66, 0x2c, 0xe6, 0xe2, 0x9c, 0xba, 0x02, 0xca, 0x2f - , 0x23, 0xc4, 0x1f, 0x20, 0x84, 0xc7, 0x95, 0x9f, 0x1c, 0xa3, 0xa5, 0x7e, 0xaf, 0x9e ]) - Blake2b_224 [] [cons $ pack [ 0xfc, 0x56, 0xca, 0x9a, 0x93, 0x98, 0x2a, 0x46, 0x69, 0xcc - , 0xab, 0xa6, 0xe3, 0xd1, 0x84, 0xa1, 0x9d, 0xe4, 0xce, 0x80 - , 0x0b, 0xb6, 0x43, 0xa3, 0x60, 0xc1, 0x45, 0x72, 0xae, 0xdb - , 0x22, 0x97, 0x4f, 0x0c, 0x96, 0x6b, 0x85, 0x9d, 0x91, 0xad - , 0x5d, 0x71, 0x3b, 0x7a, 0xd9, 0x99, 0x35, 0x79, 0x4d, 0x22 ]] -- 400 bits - -- Tests for blake2b_256: output obtained using the b2sum program from https://github.com/BLAKE2/BLAKE2 - evals (pack [ 0x0e, 0x57, 0x51, 0xc0, 0x26, 0xe5, 0x43, 0xb2, 0xe8, 0xab, 0x2e, 0xb0, 0x60, 0x99, 0xda, 0xa1 - , 0xd1, 0xe5, 0xdf, 0x47, 0x77, 0x8f, 0x77, 0x87, 0xfa, 0xab, 0x45, 0xcd, 0xf1, 0x2f, 0xe3, 0xa8 ]) - Blake2b_256 [] [cons $ pack []] - evals (pack [ 0xfc, 0x63, 0xa3, 0xcd, 0xf1, 0xc9, 0xbe, 0xb0, 0x9e, 0x18, 0x98, 0x8a, 0x95, 0x7c, 0x58, 0x31 - , 0x98, 0xc7, 0xe3, 0x0f, 0xe4, 0x8b, 0x9e, 0x80, 0x41, 0xbb, 0x90, 0x4a, 0xf8, 0x78, 0x3b, 0x5c ]) - Blake2b_256 [] [cons $ pack [ 0xfc, 0x56, 0xca, 0x9a, 0x93, 0x98, 0x2a, 0x46, 0x69, 0xcc - , 0xab, 0xa6, 0xe3, 0xd1, 0x84, 0xa1, 0x9d, 0xe4, 0xce, 0x80 - , 0x0b, 0xb6, 0x43, 0xa3, 0x60, 0xc1, 0x45, 0x72, 0xae, 0xdb - , 0x22, 0x97, 0x4f, 0x0c, 0x96, 0x6b, 0x85, 0x9d, 0x91, 0xad - , 0x5d, 0x71, 0x3b, 0x7a, 0xd9, 0x99, 0x35, 0x79, 0x4d, 0x22 ]] -- 400 bits - -- Test vectors from ShortMsgKAT_256.txt in https://keccak.team/obsolete/KeccakKAT-3.zip. - evals (pack [ 0xC5, 0xD2, 0x46, 0x01, 0x86, 0xF7, 0x23, 0x3C, 0x92, 0x7E, 0x7D, 0xB2, 0xDC, 0xC7, 0x03, 0xC0 - , 0xE5, 0x00, 0xB6, 0x53, 0xCA, 0x82, 0x27, 0x3B, 0x7B, 0xFA, 0xD8, 0x04, 0x5D, 0x85, 0xA4, 0x70 ]) - Keccak_256 [] [cons $ pack []] - evals (pack [ 0xFA, 0x46, 0x0C, 0xD5, 0x1B, 0xC6, 0x11, 0x78, 0x6D, 0x36, 0x4F, 0xCA, 0xBE, 0x39, 0x05, 0x2B - , 0xCD, 0x5F, 0x00, 0x9E, 0xDF, 0xA8, 0x1F, 0x47, 0x01, 0xC5, 0xB2, 0x2B, 0x72, 0x9B, 0x00, 0x16 ]) - Keccak_256 [] [cons $ pack [ 0x7E, 0x15, 0xD2, 0xB9, 0xEA, 0x74, 0xCA, 0x60, 0xF6, 0x6C - , 0x8D, 0xFA, 0xB3, 0x77, 0xD9, 0x19, 0x8B, 0x7B, 0x16, 0xDE - , 0xB6, 0xA1, 0xBA, 0x0E, 0xA3, 0xC7, 0xEE, 0x20, 0x42, 0xF8 - , 0x9D, 0x37, 0x86, 0xE7, 0x79, 0xCF, 0x05, 0x3C, 0x77, 0x78 - , 0x5A, 0xA9, 0xE6, 0x92, 0xF8, 0x21, 0xF1, 0x4A, 0x7F, 0x51 ]] -- 400 bits - -- Test vectors for sha2_256 from SHA256ShortMessage.rsp in - -- https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Algorithm-Validation-Program/documents/shs/shabytetestvectors.zip - evals (pack [ 0xe3, 0xb0, 0xc4, 0x42, 0x98, 0xfc, 0x1c, 0x14, 0x9a, 0xfb, 0xf4, 0xc8, 0x99, 0x6f, 0xb9, 0x24 - , 0x27, 0xae, 0x41, 0xe4, 0x64, 0x9b, 0x93, 0x4c, 0xa4, 0x95, 0x99, 0x1b, 0x78, 0x52, 0xb8, 0x55 ]) - Sha2_256 [] [cons $ pack []] - evals (pack [ 0x99, 0xdc, 0x77, 0x2e, 0x91, 0xea, 0x02, 0xd9, 0xe4, 0x21, 0xd5, 0x52, 0xd6, 0x19, 0x01, 0x01 - , 0x6b, 0x9f, 0xd4, 0xad, 0x2d, 0xf4, 0xa8, 0x21, 0x2c, 0x1e, 0xc5, 0xba, 0x13, 0x89, 0x3a, 0xb2 ]) - Sha2_256 [] [cons $ pack [ 0x3d, 0x83, 0xdf, 0x37, 0x17, 0x2c, 0x81, 0xaf, 0xd0, 0xde - , 0x11, 0x51, 0x39, 0xfb, 0xf4, 0x39, 0x0c, 0x22, 0xe0, 0x98 - , 0xc5, 0xaf, 0x4c, 0x5a, 0xb4, 0x85, 0x24, 0x06, 0x51, 0x0b - , 0xc0, 0xe6, 0xcf, 0x74, 0x17, 0x69, 0xf4, 0x44, 0x30, 0xc5 - , 0x27, 0x0f, 0xda, 0xe0, 0xcb, 0x84, 0x9d, 0x71, 0xcb, 0xab ]] -- 400 bits - -- Test vectors for sha3_256 from SHA3_256ShortMessage.rsp in - -- https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Algorithm-Validation-Program/documents/sha3/sha-3bytetestvectors.zip - evals (pack [ 0xa7, 0xff, 0xc6, 0xf8, 0xbf, 0x1e, 0xd7, 0x66, 0x51, 0xc1, 0x47, 0x56, 0xa0, 0x61, 0xd6, 0x62 - , 0xf5, 0x80, 0xff, 0x4d, 0xe4, 0x3b, 0x49, 0xfa, 0x82, 0xd8, 0x0a, 0x4b, 0x80, 0xf8, 0x43, 0x4a ]) - Sha3_256 [] [cons $ pack []] - evals (pack [ 0xe2, 0x18, 0x06, 0xce, 0x76, 0x6b, 0xbc, 0xe8, 0xb8, 0xd1, 0xb9, 0x9b, 0xcf, 0x16, 0x2f, 0xd1 - , 0x54, 0xf5, 0x46, 0x92, 0x35, 0x1a, 0xec, 0x8e, 0x69, 0x14, 0xe1, 0xa6, 0x94, 0xbd, 0xa9, 0xee ]) - Sha3_256 [] [cons $ pack [ 0xfc, 0x56, 0xca, 0x9a, 0x93, 0x98, 0x2a, 0x46, 0x69, 0xcc - , 0xab, 0xa6, 0xe3, 0xd1, 0x84, 0xa1, 0x9d, 0xe4, 0xce, 0x80 - , 0x0b, 0xb6, 0x43, 0xa3, 0x60, 0xc1, 0x45, 0x72, 0xae, 0xdb - , 0x22, 0x97, 0x4f, 0x0c, 0x96, 0x6b, 0x85, 0x9d, 0x91, 0xad - , 0x5d, 0x71, 0x3b, 0x7a, 0xd9, 0x99, 0x35, 0x79, 0x4d, 0x22 ]] -- 400 bits + ) + Blake2b_256 + [] + [cons $ pack []] + evals + ( pack + [ 0xfc + , 0x63 + , 0xa3 + , 0xcd + , 0xf1 + , 0xc9 + , 0xbe + , 0xb0 + , 0x9e + , 0x18 + , 0x98 + , 0x8a + , 0x95 + , 0x7c + , 0x58 + , 0x31 + , 0x98 + , 0xc7 + , 0xe3 + , 0x0f + , 0xe4 + , 0x8b + , 0x9e + , 0x80 + , 0x41 + , 0xbb + , 0x90 + , 0x4a + , 0xf8 + , 0x78 + , 0x3b + , 0x5c + ] + ) + Blake2b_256 + [] + [ cons $ + pack + [ 0xfc + , 0x56 + , 0xca + , 0x9a + , 0x93 + , 0x98 + , 0x2a + , 0x46 + , 0x69 + , 0xcc + , 0xab + , 0xa6 + , 0xe3 + , 0xd1 + , 0x84 + , 0xa1 + , 0x9d + , 0xe4 + , 0xce + , 0x80 + , 0x0b + , 0xb6 + , 0x43 + , 0xa3 + , 0x60 + , 0xc1 + , 0x45 + , 0x72 + , 0xae + , 0xdb + , 0x22 + , 0x97 + , 0x4f + , 0x0c + , 0x96 + , 0x6b + , 0x85 + , 0x9d + , 0x91 + , 0xad + , 0x5d + , 0x71 + , 0x3b + , 0x7a + , 0xd9 + , 0x99 + , 0x35 + , 0x79 + , 0x4d + , 0x22 -- 400 bits + -- Test vectors from ShortMsgKAT_256.txt in https://keccak.team/obsolete/KeccakKAT-3.zip. + ] + ] + + evals + ( pack + [ 0xC5 + , 0xD2 + , 0x46 + , 0x01 + , 0x86 + , 0xF7 + , 0x23 + , 0x3C + , 0x92 + , 0x7E + , 0x7D + , 0xB2 + , 0xDC + , 0xC7 + , 0x03 + , 0xC0 + , 0xE5 + , 0x00 + , 0xB6 + , 0x53 + , 0xCA + , 0x82 + , 0x27 + , 0x3B + , 0x7B + , 0xFA + , 0xD8 + , 0x04 + , 0x5D + , 0x85 + , 0xA4 + , 0x70 + ] + ) + Keccak_256 + [] + [cons $ pack []] + evals + ( pack + [ 0xFA + , 0x46 + , 0x0C + , 0xD5 + , 0x1B + , 0xC6 + , 0x11 + , 0x78 + , 0x6D + , 0x36 + , 0x4F + , 0xCA + , 0xBE + , 0x39 + , 0x05 + , 0x2B + , 0xCD + , 0x5F + , 0x00 + , 0x9E + , 0xDF + , 0xA8 + , 0x1F + , 0x47 + , 0x01 + , 0xC5 + , 0xB2 + , 0x2B + , 0x72 + , 0x9B + , 0x00 + , 0x16 + ] + ) + Keccak_256 + [] + [ cons $ + pack + [ 0x7E + , 0x15 + , 0xD2 + , 0xB9 + , 0xEA + , 0x74 + , 0xCA + , 0x60 + , 0xF6 + , 0x6C + , 0x8D + , 0xFA + , 0xB3 + , 0x77 + , 0xD9 + , 0x19 + , 0x8B + , 0x7B + , 0x16 + , 0xDE + , 0xB6 + , 0xA1 + , 0xBA + , 0x0E + , 0xA3 + , 0xC7 + , 0xEE + , 0x20 + , 0x42 + , 0xF8 + , 0x9D + , 0x37 + , 0x86 + , 0xE7 + , 0x79 + , 0xCF + , 0x05 + , 0x3C + , 0x77 + , 0x78 + , 0x5A + , 0xA9 + , 0xE6 + , 0x92 + , 0xF8 + , 0x21 + , 0xF1 + , 0x4A + , 0x7F + , 0x51 -- 400 bits + -- Test vectors for sha2_256 from SHA256ShortMessage.rsp in + -- https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Algorithm-Validation-Program/documents/shs/shabytetestvectors.zip + ] + ] + + evals + ( pack + [ 0xe3 + , 0xb0 + , 0xc4 + , 0x42 + , 0x98 + , 0xfc + , 0x1c + , 0x14 + , 0x9a + , 0xfb + , 0xf4 + , 0xc8 + , 0x99 + , 0x6f + , 0xb9 + , 0x24 + , 0x27 + , 0xae + , 0x41 + , 0xe4 + , 0x64 + , 0x9b + , 0x93 + , 0x4c + , 0xa4 + , 0x95 + , 0x99 + , 0x1b + , 0x78 + , 0x52 + , 0xb8 + , 0x55 + ] + ) + Sha2_256 + [] + [cons $ pack []] + evals + ( pack + [ 0x99 + , 0xdc + , 0x77 + , 0x2e + , 0x91 + , 0xea + , 0x02 + , 0xd9 + , 0xe4 + , 0x21 + , 0xd5 + , 0x52 + , 0xd6 + , 0x19 + , 0x01 + , 0x01 + , 0x6b + , 0x9f + , 0xd4 + , 0xad + , 0x2d + , 0xf4 + , 0xa8 + , 0x21 + , 0x2c + , 0x1e + , 0xc5 + , 0xba + , 0x13 + , 0x89 + , 0x3a + , 0xb2 + ] + ) + Sha2_256 + [] + [ cons $ + pack + [ 0x3d + , 0x83 + , 0xdf + , 0x37 + , 0x17 + , 0x2c + , 0x81 + , 0xaf + , 0xd0 + , 0xde + , 0x11 + , 0x51 + , 0x39 + , 0xfb + , 0xf4 + , 0x39 + , 0x0c + , 0x22 + , 0xe0 + , 0x98 + , 0xc5 + , 0xaf + , 0x4c + , 0x5a + , 0xb4 + , 0x85 + , 0x24 + , 0x06 + , 0x51 + , 0x0b + , 0xc0 + , 0xe6 + , 0xcf + , 0x74 + , 0x17 + , 0x69 + , 0xf4 + , 0x44 + , 0x30 + , 0xc5 + , 0x27 + , 0x0f + , 0xda + , 0xe0 + , 0xcb + , 0x84 + , 0x9d + , 0x71 + , 0xcb + , 0xab -- 400 bits + -- Test vectors for sha3_256 from SHA3_256ShortMessage.rsp in + -- https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Algorithm-Validation-Program/documents/sha3/sha-3bytetestvectors.zip + ] + ] + + evals + ( pack + [ 0xa7 + , 0xff + , 0xc6 + , 0xf8 + , 0xbf + , 0x1e + , 0xd7 + , 0x66 + , 0x51 + , 0xc1 + , 0x47 + , 0x56 + , 0xa0 + , 0x61 + , 0xd6 + , 0x62 + , 0xf5 + , 0x80 + , 0xff + , 0x4d + , 0xe4 + , 0x3b + , 0x49 + , 0xfa + , 0x82 + , 0xd8 + , 0x0a + , 0x4b + , 0x80 + , 0xf8 + , 0x43 + , 0x4a + ] + ) + Sha3_256 + [] + [cons $ pack []] + evals + ( pack + [ 0xe2 + , 0x18 + , 0x06 + , 0xce + , 0x76 + , 0x6b + , 0xbc + , 0xe8 + , 0xb8 + , 0xd1 + , 0xb9 + , 0x9b + , 0xcf + , 0x16 + , 0x2f + , 0xd1 + , 0x54 + , 0xf5 + , 0x46 + , 0x92 + , 0x35 + , 0x1a + , 0xec + , 0x8e + , 0x69 + , 0x14 + , 0xe1 + , 0xa6 + , 0x94 + , 0xbd + , 0xa9 + , 0xee + ] + ) + Sha3_256 + [] + [ cons $ + pack + [ 0xfc + , 0x56 + , 0xca + , 0x9a + , 0x93 + , 0x98 + , 0x2a + , 0x46 + , 0x69 + , 0xcc + , 0xab + , 0xa6 + , 0xe3 + , 0xd1 + , 0x84 + , 0xa1 + , 0x9d + , 0xe4 + , 0xce + , 0x80 + , 0x0b + , 0xb6 + , 0x43 + , 0xa3 + , 0x60 + , 0xc1 + , 0x45 + , 0x72 + , 0xae + , 0xdb + , 0x22 + , 0x97 + , 0x4f + , 0x0c + , 0x96 + , 0x6b + , 0x85 + , 0x9d + , 0x91 + , 0xad + , 0x5d + , 0x71 + , 0x3b + , 0x7a + , 0xd9 + , 0x99 + , 0x35 + , 0x79 + , 0x4d + , 0x22 -- 400 bits + ] + ] -- | Test that hashes produced by a hash function contain the expected number of bits test_HashSize :: DefaultFun -> Integer -> TestTree test_HashSize hashFun expectedNumBits = - let testName = "HashSize " ++ show hashFun ++ " is " ++ show expectedNumBits ++ " bits" - propName = fromString $ "HashSize " ++ show hashFun - in testPropertyNamed - testName - propName - . mapTestLimitAtLeast 10 (`div` 50) . property $ do - bs <- forAll $ Gen.bytes (Range.linear 0 1000) - let term = mkIterAppNoAnn (builtin () MultiplyInteger) - [ cons @Integer 8 - , mkIterAppNoAnn (builtin () LengthOfByteString) - [mkIterAppNoAnn (builtin () hashFun) [cons @ByteString bs]] - ] - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term === Right (EvaluationSuccess (cons @Integer expectedNumBits)) + let testName = "HashSize " ++ show hashFun ++ " is " ++ show expectedNumBits ++ " bits" + propName = fromString $ "HashSize " ++ show hashFun + in testPropertyNamed + testName + propName + . mapTestLimitAtLeast 10 (`div` 50) + . property + $ do + bs <- forAll $ Gen.bytes (Range.linear 0 1000) + let term = + mkIterAppNoAnn + (builtin () MultiplyInteger) + [ cons @Integer 8 + , mkIterAppNoAnn + (builtin () LengthOfByteString) + [mkIterAppNoAnn (builtin () hashFun) [cons @ByteString bs]] + ] + typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term === Right (EvaluationSuccess (cons @Integer expectedNumBits)) -- | Check that all hash functions return hashes with the correct number of bits test_HashSizes :: TestTree test_HashSizes = - testGroup "Hash sizes" - [ test_HashSize Sha2_256 256 - , test_HashSize Sha3_256 256 - , test_HashSize Blake2b_256 256 - , test_HashSize Keccak_256 256 - , test_HashSize Blake2b_224 224 - , test_HashSize Ripemd_160 160 - ] + testGroup + "Hash sizes" + [ test_HashSize Sha2_256 256 + , test_HashSize Sha3_256 256 + , test_HashSize Blake2b_256 256 + , test_HashSize Keccak_256 256 + , test_HashSize Blake2b_224 224 + , test_HashSize Ripemd_160 160 + ] -- Test all remaining builtins of the default universe test_Other :: TestTree test_Other = testCase "Other" $ do - let expr1 = mkIterAppNoAnn (tyInst () (builtin () ChooseUnit) bool) [unitval, true] - Right (EvaluationSuccess true) @=? typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting expr1 + let expr1 = mkIterAppNoAnn (tyInst () (builtin () ChooseUnit) bool) [unitval, true] + Right (EvaluationSuccess true) @=? typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting expr1 - let expr2 = mkIterAppNoAnn (tyInst () (builtin () IfThenElse) integer) [true, cons @Integer 1, cons @Integer 0] - Right (EvaluationSuccess $ cons @Integer 1) @=? typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting expr2 + let expr2 = mkIterAppNoAnn (tyInst () (builtin () IfThenElse) integer) [true, cons @Integer 1, cons @Integer 0] + Right (EvaluationSuccess $ cons @Integer 1) @=? typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting expr2 - let expr3 = mkIterAppNoAnn (tyInst () (builtin () Trace) integer) [cons @Text "hello world", cons @Integer 1] - Right (EvaluationSuccess $ cons @Integer 1) @=? typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting expr3 + let expr3 = mkIterAppNoAnn (tyInst () (builtin () Trace) integer) [cons @Text "hello world", cons @Integer 1] + Right (EvaluationSuccess $ cons @Integer 1) @=? typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting expr3 -- | Check that 'ExtensionVersion' evaluates correctly. -- See Note [Builtin semantics variants] test_Version :: TestTree test_Version = - testCase "Version" $ do - let expr1 = apply () (builtin () $ Right ExtensionVersion) unitval - Right (EvaluationSuccess $ cons @Integer 0) @=? - typecheckEvaluateCekNoEmit - (PairV @DefaultFun def ExtensionFunSemanticsVariant0) - defaultBuiltinCostModelExt - expr1 - Right (EvaluationSuccess $ cons @Integer $ fromIntegral $ - fromEnum (maxBound :: BuiltinSemanticsVariant ExtensionFun)) @=? - typecheckEvaluateCekNoEmit - (PairV @DefaultFun def def) - defaultBuiltinCostModelExt - expr1 + testCase "Version" $ do + let expr1 = apply () (builtin () $ Right ExtensionVersion) unitval + Right (EvaluationSuccess $ cons @Integer 0) + @=? typecheckEvaluateCekNoEmit + (PairV @DefaultFun def ExtensionFunSemanticsVariant0) + defaultBuiltinCostModelExt + expr1 + Right + ( EvaluationSuccess $ + cons @Integer $ + fromIntegral $ + fromEnum (maxBound :: BuiltinSemanticsVariant ExtensionFun) + ) + @=? typecheckEvaluateCekNoEmit + (PairV @DefaultFun def def) + defaultBuiltinCostModelExt + expr1 -- | Check that 'ConsByteString' wraps around for plutus' builtin-version == 1, and fails in plutus's builtin-versions >=2. -- See Note [Builtin semantics variants] test_ConsByteString :: TestTree test_ConsByteString = - testCase "ConsVersion" $ do - let asciiBangWrapped = fromIntegral @Word8 @Integer maxBound - + 1 -- to make word8 wraparound - + 33 -- the index of '!' in ascii table - expr1 = mkIterAppNoAnn (builtin () ConsByteString) - [cons @Integer asciiBangWrapped, cons @ByteString "hello world"] - for_ enumerate $ \case - semVar@DefaultFunSemanticsVariantA -> - Right (EvaluationSuccess $ cons @ByteString "!hello world") @=? - typecheckEvaluateCekNoEmit semVar defaultBuiltinCostModelForTesting expr1 - semVar@DefaultFunSemanticsVariantB -> - Right (EvaluationSuccess $ cons @ByteString "!hello world") @=? - typecheckEvaluateCekNoEmit semVar defaultBuiltinCostModelForTesting expr1 - semVar@DefaultFunSemanticsVariantC -> - Right EvaluationFailure @=? - typecheckEvaluateCekNoEmit semVar defaultBuiltinCostModelForTesting expr1 + testCase "ConsVersion" $ do + let asciiBangWrapped = + fromIntegral @Word8 @Integer maxBound + + 1 -- to make word8 wraparound + + 33 -- the index of '!' in ascii table + expr1 = + mkIterAppNoAnn + (builtin () ConsByteString) + [cons @Integer asciiBangWrapped, cons @ByteString "hello world"] + for_ enumerate $ \case + semVar@DefaultFunSemanticsVariantA -> + Right (EvaluationSuccess $ cons @ByteString "!hello world") + @=? typecheckEvaluateCekNoEmit semVar defaultBuiltinCostModelForTesting expr1 + semVar@DefaultFunSemanticsVariantB -> + Right (EvaluationSuccess $ cons @ByteString "!hello world") + @=? typecheckEvaluateCekNoEmit semVar defaultBuiltinCostModelForTesting expr1 + semVar@DefaultFunSemanticsVariantC -> + Right EvaluationFailure + @=? typecheckEvaluateCekNoEmit semVar defaultBuiltinCostModelForTesting expr1 -- shorthand cons :: (DefaultUni `HasTermLevel` a, TermLike term tyname name DefaultUni fun) => a -> term () @@ -1045,90 +1752,115 @@ cons = mkConstant () -- Test that the SECP256k1 builtins are behaving correctly test_SignatureVerification :: TestTree test_SignatureVerification = - testGroup "Signature verification" - [ testGroup "Ed25519 signatures (VariantA)" - [ testPropertyNamed - "Ed25519_VariantA verification behaves correctly on all inputs" - "ed25519_VariantA_correct" - . mapTestLimitAtLeast 99 (`div` 10) $ property ed25519_VariantAProp - ] - , testGroup "Ed25519 signatures (VariantB)" - [ testPropertyNamed - "Ed25519_VariantB verification behaves correctly on all inputs" - "ed25519_VariantB_correct" - . mapTestLimitAtLeast 99 (`div` 10) $ property ed25519_VariantBProp - ] - , testGroup "Ed25519 signatures (VariantC)" - [ testPropertyNamed - "Ed25519_VariantC verification behaves correctly on all inputs" - "ed25519_VariantC_correct" - . mapTestLimitAtLeast 99 (`div` 10) $ property ed25519_VariantCProp - ] - , testGroup "Signatures on the SECP256k1 curve" - [ testPropertyNamed - "ECDSA verification behaves correctly on all inputs" - "ecdsa_correct" - . mapTestLimitAtLeast 99 (`div` 10) $ property ecdsaSecp256k1Prop - , testPropertyNamed - "Schnorr verification behaves correctly on all inputs" - "schnorr_correct" - . mapTestLimitAtLeast 99 (`div` 10) $ property schnorrSecp256k1Prop - ] - ] + testGroup + "Signature verification" + [ testGroup + "Ed25519 signatures (VariantA)" + [ testPropertyNamed + "Ed25519_VariantA verification behaves correctly on all inputs" + "ed25519_VariantA_correct" + . mapTestLimitAtLeast 99 (`div` 10) + $ property ed25519_VariantAProp + ] + , testGroup + "Ed25519 signatures (VariantB)" + [ testPropertyNamed + "Ed25519_VariantB verification behaves correctly on all inputs" + "ed25519_VariantB_correct" + . mapTestLimitAtLeast 99 (`div` 10) + $ property ed25519_VariantBProp + ] + , testGroup + "Ed25519 signatures (VariantC)" + [ testPropertyNamed + "Ed25519_VariantC verification behaves correctly on all inputs" + "ed25519_VariantC_correct" + . mapTestLimitAtLeast 99 (`div` 10) + $ property ed25519_VariantCProp + ] + , testGroup + "Signatures on the SECP256k1 curve" + [ testPropertyNamed + "ECDSA verification behaves correctly on all inputs" + "ecdsa_correct" + . mapTestLimitAtLeast 99 (`div` 10) + $ property ecdsaSecp256k1Prop + , testPropertyNamed + "Schnorr verification behaves correctly on all inputs" + "schnorr_correct" + . mapTestLimitAtLeast 99 (`div` 10) + $ property schnorrSecp256k1Prop + ] + ] -- Test that the Integer <-> ByteString conversion builtins are behaving correctly test_Conversion :: TestTree test_Conversion = - testGroup "Integer <-> ByteString conversions" - [ testGroup "Integer -> ByteString" - [ --- lengthOfByteString (integerToByteString e d 0) = d - testPropertyNamed "property 1" "i2b_prop1" - . mapTestLimitAtLeast 99 (`div` 10) $ property Conversion.i2bProperty1 - , -- indexByteString (integerToByteString e k 0) j = 0 - testPropertyNamed "property 2" "i2b_prop2" - . mapTestLimitAtLeast 99 (`div` 10) $ property Conversion.i2bProperty2 - , -- lengthOfByteString (integerToByteString e 0 p) > 0 - testPropertyNamed "property 3" "i2b_prop3" - . mapTestLimitAtLeast 99 (`div` 10) $ property Conversion.i2bProperty3 - , -- integerToByteString False 0 (multiplyInteger p 256) = consByteString - -- 0 (integerToByteString False 0 p) - testPropertyNamed "property 4" "i2b_prop4" - . mapTestLimitAtLeast 50 (`div` 20) $ property Conversion.i2bProperty4 - , -- integerToByteString True 0 (multiplyInteger p 256) = appendByteString - -- (integerToByteString True 0 p) (singleton 0) - testPropertyNamed "property 5" "i2b_prop5" - . mapTestLimitAtLeast 50 (`div` 20) $ property Conversion.i2bProperty5 - , -- integerToByteString False 0 (plusInteger (multiplyInteger q 256) r) = - -- appendByteString (integerToByteString False 0 r) (integerToByteString False 0 q) - testPropertyNamed "property 6" "i2b_prop6" - . mapTestLimitAtLeast 50 (`div` 20) $ property Conversion.i2bProperty6 - , -- integerToByteString True 0 (plusInteger (multiplyInteger q 256) r) = - -- appendByteString (integerToByteString False 0 q) - -- (integerToByteString False 0 r) - testPropertyNamed "property 7" "i2b_prop7" - . mapTestLimitAtLeast 50 (`div` 20) $ property Conversion.i2bProperty7 - , testGroup "CIP-121 examples" Conversion.i2bCipExamples - , testGroup "Tests for integerToByteString size limit" Conversion.i2bLimitTests - ] - , testGroup "ByteString -> Integer" - [ -- byteStringToInteger b (integerToByteString b d q) = q - testPropertyNamed "property 1" "b2i_prop1" - . mapTestLimitAtLeast 99 (`div` 10) $ property Conversion.b2iProperty1 - , -- byteStringToInteger b (consByteString w8 emptyByteString) = w8 - testPropertyNamed "property 2" "b2i_prop2" - . mapTestLimitAtLeast 99 (`div` 10) $ property Conversion.b2iProperty2 - , -- integerToByteString b (lengthOfByteString bs) (byteStringToInteger b bs) = bs - testPropertyNamed "property 3" "b2i_prop3" - . mapTestLimitAtLeast 99 (`div` 10) $ property Conversion.b2iProperty3 - , testGroup "CIP-121 examples" Conversion.b2iCipExamples - ] + testGroup + "Integer <-> ByteString conversions" + [ testGroup + "Integer -> ByteString" + [ --- lengthOfByteString (integerToByteString e d 0) = d + testPropertyNamed "property 1" "i2b_prop1" + . mapTestLimitAtLeast 99 (`div` 10) + $ property Conversion.i2bProperty1 + , -- indexByteString (integerToByteString e k 0) j = 0 + testPropertyNamed "property 2" "i2b_prop2" + . mapTestLimitAtLeast 99 (`div` 10) + $ property Conversion.i2bProperty2 + , -- lengthOfByteString (integerToByteString e 0 p) > 0 + testPropertyNamed "property 3" "i2b_prop3" + . mapTestLimitAtLeast 99 (`div` 10) + $ property Conversion.i2bProperty3 + , -- integerToByteString False 0 (multiplyInteger p 256) = consByteString + -- 0 (integerToByteString False 0 p) + testPropertyNamed "property 4" "i2b_prop4" + . mapTestLimitAtLeast 50 (`div` 20) + $ property Conversion.i2bProperty4 + , -- integerToByteString True 0 (multiplyInteger p 256) = appendByteString + -- (integerToByteString True 0 p) (singleton 0) + testPropertyNamed "property 5" "i2b_prop5" + . mapTestLimitAtLeast 50 (`div` 20) + $ property Conversion.i2bProperty5 + , -- integerToByteString False 0 (plusInteger (multiplyInteger q 256) r) = + -- appendByteString (integerToByteString False 0 r) (integerToByteString False 0 q) + testPropertyNamed "property 6" "i2b_prop6" + . mapTestLimitAtLeast 50 (`div` 20) + $ property Conversion.i2bProperty6 + , -- integerToByteString True 0 (plusInteger (multiplyInteger q 256) r) = + -- appendByteString (integerToByteString False 0 q) + -- (integerToByteString False 0 r) + testPropertyNamed "property 7" "i2b_prop7" + . mapTestLimitAtLeast 50 (`div` 20) + $ property Conversion.i2bProperty7 + , testGroup "CIP-121 examples" Conversion.i2bCipExamples + , testGroup "Tests for integerToByteString size limit" Conversion.i2bLimitTests ] + , testGroup + "ByteString -> Integer" + [ -- byteStringToInteger b (integerToByteString b d q) = q + testPropertyNamed "property 1" "b2i_prop1" + . mapTestLimitAtLeast 99 (`div` 10) + $ property Conversion.b2iProperty1 + , -- byteStringToInteger b (consByteString w8 emptyByteString) = w8 + testPropertyNamed "property 2" "b2i_prop2" + . mapTestLimitAtLeast 99 (`div` 10) + $ property Conversion.b2iProperty2 + , -- integerToByteString b (lengthOfByteString bs) (byteStringToInteger b bs) = bs + testPropertyNamed "property 3" "b2i_prop3" + . mapTestLimitAtLeast 99 (`div` 10) + $ property Conversion.b2iProperty3 + , testGroup "CIP-121 examples" Conversion.b2iCipExamples + ] + ] -- Tests for the bitwise logical operations, as per [CIP-122](https://cips.cardano.org/cip/CIP-0122). test_Bitwise_CIP0122 :: TestTree test_Bitwise_CIP0122 = - testGroup "Bitwise operations (CIP0122)" - [ testGroup "andByteString" + testGroup + "Bitwise operations (CIP0122)" + [ testGroup + "andByteString" [ CIP0122.abelianSemigroupLaws "truncation" PLC.AndByteString False , CIP0122.idempotenceLaw "truncation" PLC.AndByteString False , CIP0122.absorbtionLaw "truncation" PLC.AndByteString False "" @@ -1138,7 +1870,8 @@ test_Bitwise_CIP0122 = , CIP0122.abelianMonoidLaws "padding" PLC.AndByteString True "" , CIP0122.distributiveLaws "padding" PLC.AndByteString True ] - , testGroup "orByteString" + , testGroup + "orByteString" [ CIP0122.abelianSemigroupLaws "truncation" PLC.OrByteString False , CIP0122.idempotenceLaw "truncation" PLC.OrByteString False , CIP0122.absorbtionLaw "truncation" PLC.OrByteString False "" @@ -1147,23 +1880,27 @@ test_Bitwise_CIP0122 = , CIP0122.abelianMonoidLaws "padding" PLC.OrByteString True "" , CIP0122.distributiveLaws "padding" PLC.OrByteString True ] - , testGroup "xorByteString" + , testGroup + "xorByteString" [ CIP0122.abelianSemigroupLaws "truncation" PLC.XorByteString False , CIP0122.absorbtionLaw "truncation" PLC.XorByteString False "" , CIP0122.xorInvoluteLaw , CIP0122.abelianMonoidLaws "padding" PLC.XorByteString True "" ] - , testGroup "complementByteString" + , testGroup + "complementByteString" [ CIP0122.complementSelfInverse , CIP0122.deMorgan ] - , testGroup "bit reading and modification" + , testGroup + "bit reading and modification" [ CIP0122.getSet , CIP0122.setGet , CIP0122.setSet , CIP0122.writeBitsHomomorphismLaws ] - , testGroup "replicateByte" + , testGroup + "replicateByte" [ CIP0122.replicateHomomorphismLaws , CIP0122.replicateIndex ] @@ -1172,214 +1909,233 @@ test_Bitwise_CIP0122 = -- Tests of the laws for the bitwise operations from [CIP-0123](https://cips.cardano.org/cip/CIP-0123). test_Bitwise_CIP0123 :: TestTree test_Bitwise_CIP0123 = - testGroup "Bitwise operations (CIP0123)" - [ testGroup "shiftByteString" - [ testGroup "homomorphism" CIP0123.shiftHomomorphism - , testPropertyNamed "shifts over bit length clear input" "shift_too_much" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.shiftClear - , testPropertyNamed "positive shifts clear low indexes" "shift_pos_low" $ - mapTestLimitAtLeast 99 (`div` 10) CIP0123.shiftPosClearLow - , testPropertyNamed "negative shifts clear high indexes" "shift_neg_high" $ - mapTestLimitAtLeast 99 (`div` 10) CIP0123.shiftNegClearHigh - , testPropertyNamed "shifts do not break when given minBound" "shift_min_bound" $ - mapTestLimitAtLeast 99 (`div` 10) CIP0123.shiftMinBound - ] - , testGroup "rotateByteString" - [ testGroup "homomorphism" CIP0123.rotateHomomorphism - , testPropertyNamed "rotations over bit length roll over" "rotate_too_much" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.rotateRollover - , testPropertyNamed "rotations move bits but don't change them" "rotate_move" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.rotateMoveBits - , testPropertyNamed "rotations do not break when given minBound" "rotate_min_bound" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.rotateMinBound - ] - , testGroup "countSetBits" - [ testGroup "homomorphism" CIP0123.csbHomomorphism - , testPropertyNamed "rotation preserves count" "popcount_rotate" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.csbRotate - , testPropertyNamed "count of the complement" "popcount_complement" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.csbComplement - , testPropertyNamed "inclusion-exclusion" "popcount_inclusion_exclusion" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.csbInclusionExclusion - , testPropertyNamed "count of self-XOR" "popcount_self_xor" $ - mapTestLimitAtLeast 99 (`div` 10) CIP0123.csbXor - ] - , testGroup "findFirstSetBit" - [ testPropertyNamed "find first in zero bytestrings" "ffs_zero" $ - mapTestLimitAtLeast 99 (`div` 10) CIP0123.ffsZero - , testPropertyNamed "find first in replicated" "ffs_replicate" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.ffsReplicate - , testPropertyNamed "find first of self-XOR" "ffs_xor" $ - mapTestLimitAtLeast 99 (`div` 10) CIP0123.ffsXor - , testPropertyNamed "found index set, lower indices clear" "ffs_index" $ - mapTestLimitAtLeast 50 (`div` 20) CIP0123.ffsIndex - , testPropertyNamed "regression #6453 check" "regression_6453" $ - mapTestLimitAtLeast 99 (`div` 10) CIP0123.ffs6453 - ] + testGroup + "Bitwise operations (CIP0123)" + [ testGroup + "shiftByteString" + [ testGroup "homomorphism" CIP0123.shiftHomomorphism + , testPropertyNamed "shifts over bit length clear input" "shift_too_much" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.shiftClear + , testPropertyNamed "positive shifts clear low indexes" "shift_pos_low" $ + mapTestLimitAtLeast 99 (`div` 10) CIP0123.shiftPosClearLow + , testPropertyNamed "negative shifts clear high indexes" "shift_neg_high" $ + mapTestLimitAtLeast 99 (`div` 10) CIP0123.shiftNegClearHigh + , testPropertyNamed "shifts do not break when given minBound" "shift_min_bound" $ + mapTestLimitAtLeast 99 (`div` 10) CIP0123.shiftMinBound + ] + , testGroup + "rotateByteString" + [ testGroup "homomorphism" CIP0123.rotateHomomorphism + , testPropertyNamed "rotations over bit length roll over" "rotate_too_much" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.rotateRollover + , testPropertyNamed "rotations move bits but don't change them" "rotate_move" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.rotateMoveBits + , testPropertyNamed "rotations do not break when given minBound" "rotate_min_bound" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.rotateMinBound + ] + , testGroup + "countSetBits" + [ testGroup "homomorphism" CIP0123.csbHomomorphism + , testPropertyNamed "rotation preserves count" "popcount_rotate" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.csbRotate + , testPropertyNamed "count of the complement" "popcount_complement" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.csbComplement + , testPropertyNamed "inclusion-exclusion" "popcount_inclusion_exclusion" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.csbInclusionExclusion + , testPropertyNamed "count of self-XOR" "popcount_self_xor" $ + mapTestLimitAtLeast 99 (`div` 10) CIP0123.csbXor ] + , testGroup + "findFirstSetBit" + [ testPropertyNamed "find first in zero bytestrings" "ffs_zero" $ + mapTestLimitAtLeast 99 (`div` 10) CIP0123.ffsZero + , testPropertyNamed "find first in replicated" "ffs_replicate" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.ffsReplicate + , testPropertyNamed "find first of self-XOR" "ffs_xor" $ + mapTestLimitAtLeast 99 (`div` 10) CIP0123.ffsXor + , testPropertyNamed "found index set, lower indices clear" "ffs_index" $ + mapTestLimitAtLeast 50 (`div` 20) CIP0123.ffsIndex + , testPropertyNamed "regression #6453 check" "regression_6453" $ + mapTestLimitAtLeast 99 (`div` 10) CIP0123.ffs6453 + ] + ] test_integer_properties :: TestTree test_integer_properties = - testGroup "test_integer_properties" - [ test_integer_ring_properties - , test_integer_div_mod_properties - , test_integer_quot_rem_properties - , test_integer_order_properties - , test_integer_ring_properties - , test_integer_exp_mod_properties - ] + testGroup + "test_integer_properties" + [ test_integer_ring_properties + , test_integer_div_mod_properties + , test_integer_quot_rem_properties + , test_integer_order_properties + , test_integer_ring_properties + , test_integer_exp_mod_properties + ] test_Case :: TestTree test_Case = - testGroup "Case on constants" - [ QC.testProperty "Bool, 1 branch" . QC.withMaxSuccess 99 $ - \(scrut :: Bool) (i :: Integer) -> - let term :: TermLike term tyname name DefaultUni DefaultFun => term () - term = - kase () - (mkTyBuiltin @_ @Integer ()) - (mkConstant () scrut) - [mkConstant () i] - in case typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term of - Right (EvaluationSuccess res) -> res == mkConstant () i - Right EvaluationFailure -> scrut - _ -> False - , QC.testProperty "Bool, 2 branches" . QC.withMaxSuccess 99 $ - \(scrut :: Bool) (i :: Integer) (j :: Integer) -> - let term :: TermLike term tyname name DefaultUni DefaultFun => term () - term = - kase () - (mkTyBuiltin @_ @Integer ()) - (mkConstant () scrut) - [mkConstant () i, mkConstant () j] - in Right (EvaluationSuccess . mkConstant () $ if not scrut then i else j) QC.=== - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term - , QC.testProperty "Bool, 3+ branches" . QC.withMaxSuccess 99 $ - \(scrut :: Bool) (is :: [Integer]) -> - let term :: TermLike term tyname name DefaultUni DefaultFun => term () - term = - kase () - (mkTyBuiltin @_ @Integer ()) - (mkConstant () scrut) - (map (mkConstant ()) $ [1, 2, 3] <> is) - in isLeft $ typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term - , QC.testProperty "Integer success" . QC.withMaxSuccess 99 $ - \(QC.NonEmpty is :: QC.NonEmptyList Integer) -> - QC.forAll (QC.chooseInt (0, length is - 1)) $ \scrut -> - let term :: TermLike term tyname name DefaultUni DefaultFun => term () - term = - kase () - (mkTyBuiltin @_ @Integer ()) - (mkConstant () $ toInteger scrut) - (map (mkConstant ()) is) - in Right (EvaluationSuccess . mkConstant () $ is !! scrut) QC.=== - typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term - , QC.testProperty "Integer any" . QC.withMaxSuccess 99 $ - \(scrut :: Integer) (is :: [Integer]) -> - let term :: TermLike term tyname name DefaultUni DefaultFun => term () - term = - kase () - (mkTyBuiltin @_ @Integer ()) - (mkConstant () scrut) - (map (mkConstant ()) is) - in case typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term of - Left _ -> False - Right EvaluationFailure -> 0 > scrut || scrut >= fromIntegral (length is) - Right (EvaluationSuccess res) -> res == mkConstant () (is !! fromIntegral scrut) - , QC.testProperty "List, 1 branch" . QC.withMaxSuccess 99 $ - \(scrut :: [Integer]) -> - let - term :: Term TyName Name DefaultUni DefaultFun () - term = runQuote $ do - x <- freshName "x" - xs <- freshName "xs" - let - listElem = mkTyBuiltin @_ @Integer () - list = mkTyBuiltin @_ @[Integer] () - pure $ - kase () - listElem - (mkConstant () scrut) - [ lamAbs () x listElem $ lamAbs () xs list $ var () x ] - in case (typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term, scrut) of - (Right (EvaluationSuccess res), (x:_)) -> res == mkConstant () x - (Right EvaluationFailure, []) -> True - _ -> False - , QC.testProperty "List, 2 branches" . QC.withMaxSuccess 99 $ - \(scrut :: [Integer]) (i :: Integer) -> - let - term :: Term TyName Name DefaultUni DefaultFun () - term = runQuote $ do - x <- freshName "x" - xs <- freshName "xs" - let - listElem = mkTyBuiltin @_ @Integer () - list = mkTyBuiltin @_ @[Integer] () - pure $ - kase () - listElem - (mkConstant () scrut) - [ lamAbs () x listElem $ lamAbs () xs list $ var () x - , mkConstant @Integer () i - ] - in case (typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term, scrut) of - (Right (EvaluationSuccess res), []) -> res == mkConstant () i - (Right (EvaluationSuccess res), (x:_)) -> res == mkConstant () x - _ -> False - , QC.testProperty "List, 3+ branches" . QC.withMaxSuccess 99 $ - \(scrut :: [Integer]) (is :: [Integer]) -> - let - term :: Term TyName Name DefaultUni DefaultFun () - term = - kase () - (mkTyBuiltin @_ @Integer ()) - (mkConstant () scrut) - (map (mkConstant ()) $ [1, 2, 3] <> is) - in isLeft $ typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term - ] + testGroup + "Case on constants" + [ QC.testProperty "Bool, 1 branch" . QC.withMaxSuccess 99 $ + \(scrut :: Bool) (i :: Integer) -> + let term :: TermLike term tyname name DefaultUni DefaultFun => term () + term = + kase + () + (mkTyBuiltin @_ @Integer ()) + (mkConstant () scrut) + [mkConstant () i] + in case typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term of + Right (EvaluationSuccess res) -> res == mkConstant () i + Right EvaluationFailure -> scrut + _ -> False + , QC.testProperty "Bool, 2 branches" . QC.withMaxSuccess 99 $ + \(scrut :: Bool) (i :: Integer) (j :: Integer) -> + let term :: TermLike term tyname name DefaultUni DefaultFun => term () + term = + kase + () + (mkTyBuiltin @_ @Integer ()) + (mkConstant () scrut) + [mkConstant () i, mkConstant () j] + in Right (EvaluationSuccess . mkConstant () $ if not scrut then i else j) + QC.=== typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + , QC.testProperty "Bool, 3+ branches" . QC.withMaxSuccess 99 $ + \(scrut :: Bool) (is :: [Integer]) -> + let term :: TermLike term tyname name DefaultUni DefaultFun => term () + term = + kase + () + (mkTyBuiltin @_ @Integer ()) + (mkConstant () scrut) + (map (mkConstant ()) $ [1, 2, 3] <> is) + in isLeft $ typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + , QC.testProperty "Integer success" . QC.withMaxSuccess 99 $ + \(QC.NonEmpty is :: QC.NonEmptyList Integer) -> + QC.forAll (QC.chooseInt (0, length is - 1)) $ \scrut -> + let term :: TermLike term tyname name DefaultUni DefaultFun => term () + term = + kase + () + (mkTyBuiltin @_ @Integer ()) + (mkConstant () $ toInteger scrut) + (map (mkConstant ()) is) + in Right (EvaluationSuccess . mkConstant () $ is !! scrut) + QC.=== typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + , QC.testProperty "Integer any" . QC.withMaxSuccess 99 $ + \(scrut :: Integer) (is :: [Integer]) -> + let term :: TermLike term tyname name DefaultUni DefaultFun => term () + term = + kase + () + (mkTyBuiltin @_ @Integer ()) + (mkConstant () scrut) + (map (mkConstant ()) is) + in case typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term of + Left _ -> False + Right EvaluationFailure -> 0 > scrut || scrut >= fromIntegral (length is) + Right (EvaluationSuccess res) -> res == mkConstant () (is !! fromIntegral scrut) + , QC.testProperty "List, 1 branch" . QC.withMaxSuccess 99 $ + \(scrut :: [Integer]) -> + let + term :: Term TyName Name DefaultUni DefaultFun () + term = runQuote $ do + x <- freshName "x" + xs <- freshName "xs" + let + listElem = mkTyBuiltin @_ @Integer () + list = mkTyBuiltin @_ @[Integer] () + pure $ + kase + () + listElem + (mkConstant () scrut) + [lamAbs () x listElem $ lamAbs () xs list $ var () x] + in + case (typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term, scrut) of + (Right (EvaluationSuccess res), (x : _)) -> res == mkConstant () x + (Right EvaluationFailure, []) -> True + _ -> False + , QC.testProperty "List, 2 branches" . QC.withMaxSuccess 99 $ + \(scrut :: [Integer]) (i :: Integer) -> + let + term :: Term TyName Name DefaultUni DefaultFun () + term = runQuote $ do + x <- freshName "x" + xs <- freshName "xs" + let + listElem = mkTyBuiltin @_ @Integer () + list = mkTyBuiltin @_ @[Integer] () + pure $ + kase + () + listElem + (mkConstant () scrut) + [ lamAbs () x listElem $ lamAbs () xs list $ var () x + , mkConstant @Integer () i + ] + in + case (typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term, scrut) of + (Right (EvaluationSuccess res), []) -> res == mkConstant () i + (Right (EvaluationSuccess res), (x : _)) -> res == mkConstant () x + _ -> False + , QC.testProperty "List, 3+ branches" . QC.withMaxSuccess 99 $ + \(scrut :: [Integer]) (is :: [Integer]) -> + let + term :: Term TyName Name DefaultUni DefaultFun () + term = + kase + () + (mkTyBuiltin @_ @Integer ()) + (mkConstant () scrut) + (map (mkConstant ()) $ [1, 2, 3] <> is) + in + isLeft $ typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term + ] test_definition :: TestTree test_definition = - testGroup "definition" - [ test_IntegerDistribution - , test_Factorial - , test_ForallFortyTwo - , test_Const - , test_Id - , test_IdFInteger - , test_IdList - , test_IdRank2 - , test_ScottToMetaUnit - , test_FailingSucc - , test_ExpensiveSucc - , test_FailingPlus - , test_ExpensivePlus - , test_BuiltinList - , test_IdBuiltinList - , test_BuiltinArray - , test_BuiltinPair - , test_SwapEls - , test_IdBuiltinData - , test_TrackCostsRestricting - , ignoreTestWhenHpcEnabled test_TrackCostsRetaining - , test_SerialiseDataImpossible - , test_fixId - , runTestNestedHere - [ test_Integer - , test_String - , test_List - , test_Data - , test_Crypto - ] - , test_HashSizes - , test_SignatureVerification - , test_BLS12_381 - , test_integer_properties - , test_Other - , test_Version - , test_ConsByteString - , test_Conversion - , test_Bitwise_CIP0122 - , test_Bitwise_CIP0123 - , test_Case + testGroup + "definition" + [ test_IntegerDistribution + , test_Factorial + , test_ForallFortyTwo + , test_Const + , test_Id + , test_IdFInteger + , test_IdList + , test_IdRank2 + , test_ScottToMetaUnit + , test_FailingSucc + , test_ExpensiveSucc + , test_FailingPlus + , test_ExpensivePlus + , test_BuiltinList + , test_IdBuiltinList + , test_BuiltinArray + , test_BuiltinPair + , test_SwapEls + , test_IdBuiltinData + , test_TrackCostsRestricting + , ignoreTestWhenHpcEnabled test_TrackCostsRetaining + , test_SerialiseDataImpossible + , test_fixId + , runTestNestedHere + [ test_Integer + , test_String + , test_List + , test_Data + , test_Crypto ] + , test_HashSizes + , test_SignatureVerification + , test_BLS12_381 + , test_integer_properties + , test_Other + , test_Version + , test_ConsByteString + , test_Conversion + , test_Bitwise_CIP0122 + , test_Bitwise_CIP0123 + , test_Case + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/Common.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/Common.hs index ff8030922c4..f369423bde4 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/Common.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/Common.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + module Evaluation.Builtins.Integer.Common where @@ -22,16 +23,18 @@ import Test.QuickCheck (Arbitrary, Gen, arbitrary, choose, oneof) -} arbitraryBigInteger :: Gen Integer arbitraryBigInteger = - oneof [ unAsArbitraryBuiltin <$> arbitrary - , choose (-b, b) - ] - where b = (2::Integer)^(400::Integer) + oneof + [ unAsArbitraryBuiltin <$> arbitrary + , choose (-b, b) + ] + where + b = (2 :: Integer) ^ (400 :: Integer) newtype BigInteger = BigInteger Integer deriving newtype (Show, Eq, Ord, Num) instance Arbitrary BigInteger where - arbitrary = BigInteger <$> arbitraryBigInteger + arbitrary = BigInteger <$> arbitraryBigInteger biginteger :: BigInteger -> PlcTerm biginteger (BigInteger n) = integer n @@ -75,14 +78,14 @@ le0 t = lessThanEqualsInteger t zero ge0 :: PlcTerm -> PlcTerm ge0 t = lessThanEqualsInteger zero t -ite - :: forall a - . PLC.DefaultUni `PLC.HasTypeLevel` a - => PlcTerm -> PlcTerm -> PlcTerm -> PlcTerm +ite :: + forall a. + PLC.DefaultUni `PLC.HasTypeLevel` a => + PlcTerm -> PlcTerm -> PlcTerm -> PlcTerm ite b t f = let ty = mkTyBuiltin @_ @a () iteInst = tyInst () (builtin () PLC.IfThenElse) ty - in mkIterAppNoAnn iteInst [b, t, f] + in mkIterAppNoAnn iteInst [b, t, f] -- Various logical combinations of boolean terms. diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/DivModProperties.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/DivModProperties.hs index 2e3461f5d33..e7901259374 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/DivModProperties.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/DivModProperties.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -{- | Property tests for the `divideInteger` and `modInteger` builtins -} +-- | Property tests for the `divideInteger` and `modInteger` builtins module Evaluation.Builtins.Integer.DivModProperties (test_integer_div_mod_properties) where @@ -32,15 +32,15 @@ prop_mod_0_fails (biginteger -> a) = -- This is the crucial property relating `divideInteger` and `modInteger`. prop_div_mod_compatible :: BigInteger -> NonZero BigInteger -> Property prop_div_mod_compatible (biginteger -> a) (NonZero (biginteger -> b)) = - let t = addInteger (multiplyInteger b (divideInteger a b) ) (modInteger a b) - in evalOkEq t a + let t = addInteger (multiplyInteger b (divideInteger a b)) (modInteger a b) + in evalOkEq t a -- (k*b) `div` b = b and (k*b) `mod` b = 0 for all k prop_div_mod_multiple :: BigInteger -> NonZero BigInteger -> Property prop_div_mod_multiple (biginteger -> k) (NonZero (biginteger -> b)) = - let t1 = divideInteger (multiplyInteger k b) b - t2 = modInteger (multiplyInteger k b) b - in evalOkEq t1 k .&&. evalOkEq t2 zero + let t1 = divideInteger (multiplyInteger k b) b + t2 = modInteger (multiplyInteger k b) b + in evalOkEq t1 k .&&. evalOkEq t2 zero -- For fixed b, `modInteger _ b` is an additive homomorphism: -- (a+a') `mod` b = ((a `mod` b) + (a' `mod` b)) `mod` b @@ -50,7 +50,7 @@ prop_mod_additive :: BigInteger -> BigInteger -> NonZero BigInteger -> Property prop_mod_additive (biginteger -> a) (biginteger -> a') (NonZero (biginteger -> b)) = let t1 = modInteger (addInteger a a') b t2 = modInteger (addInteger (modInteger a b) (modInteger a' b)) b - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- For fixed b, `modInteger _ b` is a multiplicative homomorphism: -- (a*a') `mod` b = ((a `mod` b) * (a' `mod` b)) `mod` b @@ -58,21 +58,21 @@ prop_mod_multiplicative :: BigInteger -> BigInteger -> NonZero BigInteger -> Pro prop_mod_multiplicative (biginteger -> a) (biginteger -> a') (NonZero (biginteger -> b)) = let t1 = modInteger (multiplyInteger a a') b t2 = modInteger (multiplyInteger (modInteger a b) (modInteger a' b)) b - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- For b > 0, 0 <= a `mod` b < b; prop_mod_size_pos :: BigInteger -> Positive BigInteger -> Property prop_mod_size_pos (biginteger -> a) (Positive (biginteger -> b)) = let t1 = lessThanEqualsInteger zero (modInteger a b) t2 = lessThanInteger (modInteger a b) b - in evalOkTrue t1 .&&. evalOkTrue t2 + in evalOkTrue t1 .&&. evalOkTrue t2 -- For b < 0, b < a `mod` b <= 0 prop_mod_size_neg :: BigInteger -> Negative BigInteger -> Property prop_mod_size_neg (biginteger -> a) (Negative (biginteger -> b)) = let t1 = lessThanEqualsInteger (modInteger a b) zero t2 = lessThanInteger b (modInteger a b) - in evalOkTrue t1 .&&. evalOkTrue t2 + in evalOkTrue t1 .&&. evalOkTrue t2 -- a >= 0 && b > 0 => a `div` b >= 0 and a `mod` b >= 0 -- a <= 0 && b > 0 => a `div` b <= 0 and a `mod` b >= 0 @@ -113,7 +113,8 @@ prop_mod_neg_neg (NonPositive (biginteger -> a)) (Negative (biginteger -> b)) = test_integer_div_mod_properties :: TestTree test_integer_div_mod_properties = - testGroup "Property tests for divideInteger and modInteger" + testGroup + "Property tests for divideInteger and modInteger" [ testProp "divideInteger _ 0 always fails" prop_div_0_fails , testProp "modInteger _ 0 always fails" prop_mod_0_fails , testProp "divideInteger and modInteger are compatible" prop_div_mod_compatible @@ -131,4 +132,3 @@ test_integer_div_mod_properties = , testProp "modInteger (<= 0) (> 0) <= 0" prop_mod_pos_neg , testProp "modInteger (<= 0) (< 0) <= 0" prop_mod_neg_neg ] - diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/ExpModIntegerProperties.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/ExpModIntegerProperties.hs index ddd347bca73..9dd9c6d3f2b 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/ExpModIntegerProperties.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/ExpModIntegerProperties.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -{- | Property tests for the `expModInteger` builtin -} +-- | Property tests for the `expModInteger` builtin module Evaluation.Builtins.Integer.ExpModIntegerProperties (test_integer_exp_mod_properties) where @@ -23,20 +23,20 @@ testProp s p = testProperty s $ withMaxSuccess numberOfTests p expModInteger :: Integer -> Integer -> Integer -> PlcTerm expModInteger (integer -> a) (integer -> e) (integer -> m) = - mkIterAppNoAnn (builtin () PLC.ExpModInteger) [a, e ,m] + mkIterAppNoAnn (builtin () PLC.ExpModInteger) [a, e, m] -- Is a^e defined modulo m? This depends on the properties of gcd, which we -- just assume behaves properly. powerExists :: Integer -> Integer -> Integer -> Bool powerExists a e m = - e>=0 || (e < 0 && gcd a m == 1) + e >= 0 || (e < 0 && gcd a m == 1) -- expModInteger a e m always fails if m<=0 prop_bad_modulus :: Gen Property prop_bad_modulus = do a <- arbitraryBigInteger e <- arbitraryBigInteger - m <- arbitraryBigInteger `suchThat` (<=0) + m <- arbitraryBigInteger `suchThat` (<= 0) let t = expModInteger a e m pure $ fails t @@ -51,7 +51,7 @@ prop_modulus_one = do -- Test that expModInteger a e m always lies between 0 and m-1 (inclusive) prop_in_range :: Gen Property prop_in_range = do - m <- arbitraryBigInteger `suchThat` (>=1) + m <- arbitraryBigInteger `suchThat` (>= 1) e <- arbitraryBigInteger a <- arbitraryBigInteger `suchThat` (\a -> powerExists a e m) let t = expModInteger a e m @@ -63,7 +63,7 @@ prop_in_range = do prop_power_zero :: Gen Property prop_power_zero = do a <- arbitraryBigInteger - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) let t = expModInteger a 0 m pure $ evalOkEq t one @@ -71,7 +71,7 @@ prop_power_zero = do prop_power_one :: Gen Property prop_power_one = do a <- arbitraryBigInteger - m <- arbitraryBigInteger `suchThat` (>=1) + m <- arbitraryBigInteger `suchThat` (>= 1) let t1 = expModInteger a 1 m t2 = mkApp2 PLC.ModInteger (mkConstant () a) (mkConstant () m) pure $ evalOkEq t1 t2 @@ -79,8 +79,8 @@ prop_power_one = do -- For m >= 1 and e >= 0, expModInteger a e m exists for all a prop_positive_exponent :: Gen Property prop_positive_exponent = do - e <- arbitraryBigInteger `suchThat` (>=0) - m <- arbitraryBigInteger `suchThat` (>=1) + e <- arbitraryBigInteger `suchThat` (>= 0) + m <- arbitraryBigInteger `suchThat` (>= 1) a <- arbitraryBigInteger let t = expModInteger a e m pure $ ok t @@ -88,18 +88,18 @@ prop_positive_exponent = do -- If m > 1, e < 0, and gcd a m = 1, expModInteger a e m succeeds prop_negative_exponent_good :: Gen Property prop_negative_exponent_good = do - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) a <- arbitraryBigInteger `suchThat` (\a -> gcd a m == 1) - e <- arbitraryBigInteger `suchThat` (<0) + e <- arbitraryBigInteger `suchThat` (< 0) let t = expModInteger a e m pure $ ok t -- If m > 1, e < 0, and gcd a m /= 1, expModInteger a e m fails prop_negative_exponent_bad :: Gen Property prop_negative_exponent_bad = do - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) a <- arbitraryBigInteger `suchThat` (\a -> gcd a m /= 1) - e <- arbitraryBigInteger `suchThat` (<0) + e <- arbitraryBigInteger `suchThat` (< 0) let t = expModInteger a e m pure $ fails t @@ -107,22 +107,22 @@ prop_negative_exponent_bad = do -- multiplicative inverse of expModInteger a (-e) m modulo m. prop_negated_exponent_inverse :: Gen Property prop_negated_exponent_inverse = do - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) a <- arbitraryBigInteger `suchThat` (\a -> gcd a m == 1) e <- arbitraryBigInteger -- Positive or negative let t1 = expModInteger a e m t2 = expModInteger a (-e) m t = mkApp2 PLC.ModInteger (mkApp2 PLC.MultiplyInteger t1 t2) (mkConstant () m) - pure $ evalOkEq t one -- For m=1 this would be zero. + pure $ evalOkEq t one -- For m=1 this would be zero. -- (ab)^e mod m = a^e * b^e mod m prop_multiplicative :: Gen Property prop_multiplicative = do - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) e <- arbitraryBigInteger a <- arbitraryBigInteger `suchThat` (\a -> powerExists a e m) b <- arbitraryBigInteger `suchThat` (\b -> powerExists b e m) - let t1 = expModInteger (a*b) e m + let t1 = expModInteger (a * b) e m t2 = mkApp2 PLC.ModInteger (mkApp2 PLC.MultiplyInteger (expModInteger a e m) (expModInteger b e m)) (integer m) pure $ evalOkEq t1 t2 @@ -131,38 +131,38 @@ prop_exponent_additive :: Gen Property prop_exponent_additive = do e <- arbitraryBigInteger f <- arbitraryBigInteger - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) a <- arbitraryBigInteger `suchThat` (\a -> powerExists a e m && powerExists a f m) - let t1 = expModInteger a (e+f) m + let t1 = expModInteger a (e + f) m t2 = mkApp2 PLC.ModInteger (mkApp2 PLC.MultiplyInteger (expModInteger a e m) (expModInteger a f m)) (integer m) pure $ evalOkEq t1 t2 -- a^e mod m is the same for all members of a particular congruence class. prop_periodic :: Gen Property prop_periodic = do - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) e <- arbitraryBigInteger k <- arbitraryBigInteger a <- arbitraryBigInteger `suchThat` (\a -> powerExists a e m) let t1 = expModInteger a e m - t2 = expModInteger (a+k*m) e m + t2 = expModInteger (a + k * m) e m pure $ evalOkEq t1 t2 -- Test that a power exists when it should. This overlaps with some of the -- earlier tests. prop_power_exists :: Gen Property prop_power_exists = do - m <- arbitraryBigInteger `suchThat` (>1) - e <- arbitraryBigInteger - a <- arbitraryBigInteger `suchThat` (\a -> powerExists a e m) - let t = expModInteger a e m - pure $ ok t + m <- arbitraryBigInteger `suchThat` (> 1) + e <- arbitraryBigInteger + a <- arbitraryBigInteger `suchThat` (\a -> powerExists a e m) + let t = expModInteger a e m + pure $ ok t -- Test that a power doesn't exist when it shouldn't. This overlaps with some of -- the earlier tests. prop_power_does_not_exist :: Gen Property prop_power_does_not_exist = do - m <- arbitraryBigInteger `suchThat` (>1) + m <- arbitraryBigInteger `suchThat` (> 1) e <- arbitraryBigInteger a <- arbitraryBigInteger let t = expModInteger a e m @@ -170,7 +170,8 @@ prop_power_does_not_exist = do test_integer_exp_mod_properties :: TestTree test_integer_exp_mod_properties = - testGroup "Property tests for expModInteger" + testGroup + "Property tests for expModInteger" [ testProp "modulus <= 0 -> error" prop_bad_modulus , testProp "a^e mod 1 == 0 for all a and e" prop_modulus_one , testProp "Result lies between 0 and m-1" prop_in_range diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/OrderProperties.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/OrderProperties.hs index 9736edf4ea5..1bbe68d29c7 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/OrderProperties.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/OrderProperties.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -{- | Property tests for the `lessThanInteger` and `lessThanEqualsInteger` builtins - and their interaction with the arithmetic functions. -} +-- | Property tests for the `lessThanInteger` and `lessThanEqualsInteger` builtins +-- and their interaction with the arithmetic functions. module Evaluation.Builtins.Integer.OrderProperties (test_integer_order_properties) where @@ -40,13 +40,13 @@ lte_antisymmetric :: BigInteger -> BigInteger -> Property lte_antisymmetric (biginteger -> a) (biginteger -> b) = evalOkTrue $ (lessThanEqualsInteger a b `and` lessThanEqualsInteger b a) - `implies` equalsInteger a b + `implies` equalsInteger a b lte_transitive :: BigInteger -> BigInteger -> BigInteger -> Property lte_transitive (biginteger -> a) (biginteger -> b) (biginteger -> c) = evalOkTrue $ (lessThanEqualsInteger a b `and` lessThanEqualsInteger b c) - `implies` lessThanEqualsInteger a c + `implies` lessThanEqualsInteger a c -- This implies that lessThanEqualsInteger is a total order. trichotomy :: BigInteger -> BigInteger -> Property @@ -72,7 +72,7 @@ add_pairs :: BigInteger -> BigInteger -> BigInteger -> BigInteger -> Property add_pairs (biginteger -> a) (biginteger -> b) (biginteger -> c) (biginteger -> d) = evalOkTrue $ (lessThanEqualsInteger a b `and` lessThanEqualsInteger c d) - `implies` lessThanEqualsInteger (addInteger a c) (addInteger b d) + `implies` lessThanEqualsInteger (addInteger a c) (addInteger b d) -- Test that the signs of various types of product are correct. mul_pos_pos :: NonNegative BigInteger -> NonNegative BigInteger -> Property @@ -93,7 +93,8 @@ mul_neg_neg (NonPositive (biginteger -> a)) (NonPositive (biginteger -> b)) = test_integer_order_properties :: TestTree test_integer_order_properties = - testGroup "Property tests involving integer ordering" + testGroup + "Property tests involving integer ordering" [ testProp "lessThanEqualsInteger is reflexive" lte_reflexive , testProp "lessThanEqualsInteger is antisymmetric" lte_antisymmetric , testProp "lessThanEqualsInteger is transitive" lte_transitive diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/QuotRemProperties.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/QuotRemProperties.hs index 187cf188b53..7cb4d1ce1a3 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/QuotRemProperties.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/QuotRemProperties.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -{- | Property tests for the `quotientInteger` and `remainderInteger` builtins -} +-- | Property tests for the `quotientInteger` and `remainderInteger` builtins module Evaluation.Builtins.Integer.QuotRemProperties (test_integer_quot_rem_properties) where @@ -34,15 +34,15 @@ prop_rem_0_fails (biginteger -> a) = -- This is the crucial property relating `quotientInteger` and `remainderInteger`. prop_quot_rem_compatible :: BigInteger -> NonZero BigInteger -> Property prop_quot_rem_compatible (biginteger -> a) (NonZero (biginteger -> b)) = - let t = addInteger (multiplyInteger b (quotientInteger a b) ) (remainderInteger a b) - in evalOkEq t a + let t = addInteger (multiplyInteger b (quotientInteger a b)) (remainderInteger a b) + in evalOkEq t a -- (k*b) `quot` b = b and (k*b) `rem` b = 0 for all k prop_quot_rem_multiple :: BigInteger -> NonZero BigInteger -> Property prop_quot_rem_multiple (biginteger -> k) (NonZero (biginteger -> b)) = - let t1 = quotientInteger (multiplyInteger k b) b - t2 = remainderInteger (multiplyInteger k b) b - in evalOkEq t1 k .&&. evalOkEq t2 zero + let t1 = quotientInteger (multiplyInteger k b) b + t2 = remainderInteger (multiplyInteger k b) b + in evalOkEq t1 k .&&. evalOkEq t2 zero -- `remainderInteger _ b` is not an additive homomorphism in general (and hence -- not periodic) because the sign of `remainderInteger a b` is different for @@ -58,7 +58,7 @@ prop_rem_additive_pos :: NonNegative BigInteger -> NonNegative BigInteger -> Non prop_rem_additive_pos (NonNegative (biginteger -> a)) (NonNegative (biginteger -> a')) (NonZero (biginteger -> b)) = let t1 = remainderInteger (addInteger a a') b t2 = remainderInteger (addInteger (remainderInteger a b) (remainderInteger a' b)) b - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- For fixed b, `remainderInteger _ b` is an additive homomorphism on non-postive integers -- (a+a') `rem` b = ((a `rem` b) + (a' `rem` b)) `rem` b @@ -66,7 +66,7 @@ prop_rem_additive_neg :: NonPositive BigInteger -> NonPositive BigInteger -> Non prop_rem_additive_neg (NonPositive (biginteger -> a)) (NonPositive (biginteger -> a')) (NonZero (biginteger -> b)) = let t1 = remainderInteger (addInteger a a') b t2 = remainderInteger (addInteger (remainderInteger a b) (remainderInteger a' b)) b - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- Somewhat unexpectedly, for fixed b, `remainderInteger _ b` is a -- multiplicative homomorphism: : (a*a') `rem` b = ((a `rem` b) * (a' `rem` b)) @@ -75,7 +75,7 @@ prop_rem_multiplicative :: BigInteger -> BigInteger -> NonZero BigInteger -> Pro prop_rem_multiplicative (biginteger -> a) (biginteger -> a') (NonZero (biginteger -> b)) = let t1 = remainderInteger (multiplyInteger a a') b t2 = remainderInteger (multiplyInteger (remainderInteger a b) (remainderInteger a' b)) b - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- For a >= 0 and b > 0, 0 <= |a `rem` b| < |b| -- The sign of the remainder is a bit tricky in this case. We test that the @@ -86,7 +86,7 @@ prop_rem_size (biginteger -> a) (NonZero (biginteger -> b)) = let r = abs (remainderInteger a b) t1 = lessThanEqualsInteger zero r t2 = lessThanInteger r (abs b) - in evalOkTrue t1 .&&. evalOkTrue t2 + in evalOkTrue t1 .&&. evalOkTrue t2 -- a >= 0 && b > 0 => a `quot` b >= 0 and a `rem` b >= 0 -- a <= 0 && b > 0 => a `quot` b <= 0 and a `rem` b <= 0 @@ -127,7 +127,8 @@ prop_rem_neg_neg (NonPositive (biginteger -> a)) (Negative (biginteger -> b)) = test_integer_quot_rem_properties :: TestTree test_integer_quot_rem_properties = - testGroup "Property tests for quotientInteger and remainderInteger" + testGroup + "Property tests for quotientInteger and remainderInteger" [ testProp "quotientInteger _ 0 always fails" prop_quot_0_fails , testProp "remainderInteger _ 0 always fails" prop_rem_0_fails , testProp "quotientInteger and remainderInteger are compatible" prop_quot_rem_compatible @@ -136,10 +137,10 @@ test_integer_quot_rem_properties = , testProp "remainderInteger _ b is additive on non-positive inputs" prop_rem_additive_neg , testProp "remainderInteger is a multiplicative homomorphism" prop_rem_multiplicative , testProp "remainderInteger size correct" prop_rem_size - , testProp "quotientInteger (>= 0) (> 0) >= 0" prop_quot_pos_pos - , testProp "quotientInteger (<= 0) (> 0) <= 0" prop_quot_neg_pos - , testProp "quotientInteger (>= 0) (< 0) <= 0" prop_quot_pos_neg - , testProp "quotientInteger (<= 0) (< 0) >= 0" prop_quot_neg_neg + , testProp "quotientInteger (>= 0) (> 0) >= 0" prop_quot_pos_pos + , testProp "quotientInteger (<= 0) (> 0) <= 0" prop_quot_neg_pos + , testProp "quotientInteger (>= 0) (< 0) <= 0" prop_quot_pos_neg + , testProp "quotientInteger (<= 0) (< 0) >= 0" prop_quot_neg_neg , testProp "remainderInteger (>= 0) (> 0) >= 0" prop_rem_pos_pos , testProp "remainderInteger (<= 0) (> 0) <= 0" prop_rem_neg_pos , testProp "remainderInteger (>= 0) (< 0) >= 0" prop_rem_pos_neg diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/RingProperties.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/RingProperties.hs index 79e2255fc80..b8d4a9ab3c0 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/RingProperties.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Integer/RingProperties.hs @@ -1,9 +1,9 @@ -- editorconfig-checker-disable {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -{- | Property tests for the `addInteger`, `subtractInteger`, and `multiplyInteger` builtins -} +-- | Property tests for the `addInteger`, `subtractInteger`, and `multiplyInteger` builtins module Evaluation.Builtins.Integer.RingProperties (test_integer_ring_properties) where @@ -18,7 +18,7 @@ prop_addition_associative :: BigInteger -> BigInteger -> BigInteger -> Property prop_addition_associative (biginteger -> a) (biginteger -> b) (biginteger -> c) = let t1 = addInteger a (addInteger b c) t2 = addInteger (addInteger a b) c - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- a+b = b+a prop_addition_commutative :: BigInteger -> BigInteger -> Property @@ -40,37 +40,38 @@ prop_multiplication_associative :: BigInteger -> BigInteger -> BigInteger -> Pro prop_multiplication_associative (biginteger -> a) (biginteger -> b) (biginteger -> c) = let t1 = multiplyInteger a (multiplyInteger b c) t2 = multiplyInteger (multiplyInteger a b) c - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- a*b = b*a prop_multiplication_commutative :: BigInteger -> BigInteger -> Property prop_multiplication_commutative (biginteger -> a) (biginteger -> b) = let t1 = multiplyInteger a b t2 = multiplyInteger b a - in evalOkEq t1 t2 + in evalOkEq t1 t2 -- a*1 = a prop_one_multiplicative_identity :: BigInteger -> Property prop_one_multiplicative_identity (biginteger -> a) = let t = multiplyInteger a one - in evalOkEq t a + in evalOkEq t a -- a*(b+c) = a*b + a*c prop_distibutive :: BigInteger -> BigInteger -> BigInteger -> Property prop_distibutive (biginteger -> a) (biginteger -> b) (biginteger -> c) = let t1 = multiplyInteger a (addInteger b c) t2 = addInteger (multiplyInteger a b) (multiplyInteger a c) - in evalOkEq t1 t2 + in evalOkEq t1 t2 test_integer_ring_properties :: TestTree test_integer_ring_properties = - testGroup "Ring properties for integer arithmetic builtins" - [ testProperty "addInteger is associative" prop_addition_associative - , testProperty "addInteger is commutative" prop_addition_commutative - , testProperty "0 is an identity element for addInteger" prop_zero_additive_identity - , testProperty "subtraction is the inverse of addition" prop_add_subtract_inverse - , testProperty "multiplyInteger is associative" prop_multiplication_associative - , testProperty "multiplyInteger is commutative" prop_multiplication_commutative - , testProperty "1 is a multiplicative identity" prop_one_multiplicative_identity - , testProperty "multiplyInteger distributes over addInteger" prop_distibutive - ] + testGroup + "Ring properties for integer arithmetic builtins" + [ testProperty "addInteger is associative" prop_addition_associative + , testProperty "addInteger is commutative" prop_addition_commutative + , testProperty "0 is an identity element for addInteger" prop_zero_additive_identity + , testProperty "subtraction is the inverse of addition" prop_add_subtract_inverse + , testProperty "multiplyInteger is associative" prop_multiplication_associative + , testProperty "multiplyInteger is commutative" prop_multiplication_commutative + , testProperty "1 is a multiplicative identity" prop_one_multiplicative_identity + , testProperty "multiplyInteger distributes over addInteger" prop_distibutive + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs index 3b4dfb43c41..9e8a02195c5 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -module Evaluation.Builtins.MakeRead - ( test_makeRead - ) where +module Evaluation.Builtins.MakeRead ( + test_makeRead, +) where import PlutusCore qualified as TPLC import PlutusCore.Builtin @@ -31,35 +31,39 @@ import Data.Text (Text) -- | Lift a Haskell value into a PLC term, evaluate it and unlift the result back to the original -- Haskell value. -makeRead - :: ( MakeKnown (TPLC.Term TyName Name DefaultUni DefaultFun ()) a - , ReadKnown (UPLC.Term Name DefaultUni DefaultFun ()) a - ) - => a -> EvaluationResult a +makeRead :: + ( MakeKnown (TPLC.Term TyName Name DefaultUni DefaultFun ()) a + , ReadKnown (UPLC.Term Name DefaultUni DefaultFun ()) a + ) => + a -> EvaluationResult a makeRead x = do xTerm <- makeKnownOrFail @_ @(TPLC.Term TyName Name DefaultUni DefaultFun ()) x - case splitStructuralOperational <$> typecheckReadKnownCek def - TPLC.defaultBuiltinCostModelForTesting xTerm of - Left err -> error $ "Type error" ++ displayPlcCondensedErrorClassic err - Right (Left err) -> error $ "Evaluation error: " ++ show err - Right (Right res) -> res + case splitStructuralOperational + <$> typecheckReadKnownCek + def + TPLC.defaultBuiltinCostModelForTesting + xTerm of + Left err -> error $ "Type error" ++ displayPlcCondensedErrorClassic err + Right (Left err) -> error $ "Evaluation error: " ++ show err + Right (Right res) -> res -builtinRoundtrip - :: ( MakeKnown (TPLC.Term TyName Name DefaultUni DefaultFun ()) a - , ReadKnown (UPLC.Term Name DefaultUni DefaultFun ()) a - , Show a, Eq a - ) - => Gen a -> Property +builtinRoundtrip :: + ( MakeKnown (TPLC.Term TyName Name DefaultUni DefaultFun ()) a + , ReadKnown (UPLC.Term Name DefaultUni DefaultFun ()) a + , Show a + , Eq a + ) => + Gen a -> Property builtinRoundtrip genX = property $ do - x <- forAll genX - case makeRead x of - EvaluationFailure -> fail "EvaluationFailure" - EvaluationSuccess x' -> x === x' + x <- forAll genX + case makeRead x of + EvaluationFailure -> fail "EvaluationFailure" + EvaluationSuccess x' -> x === x' test_textRoundtrip :: TestTree test_textRoundtrip = - testPropertyNamed "textRoundtrip" "textRoundtrip" . builtinRoundtrip $ - Gen.text (Range.linear 0 20) Gen.unicode + testPropertyNamed "textRoundtrip" "textRoundtrip" . builtinRoundtrip $ + Gen.text (Range.linear 0 20) Gen.unicode -- | Generate a bunch of 'text's, put each of them into a 'Term' and apply the @Trace@ builtin over -- each of these terms and assemble all the resulting terms together in a single term where all @@ -69,21 +73,24 @@ test_textRoundtrip = -- sequence of 'text's that was originally generated. test_collectText :: BuiltinSemanticsVariant DefaultFun -> TestTree test_collectText semVar = testPropertyNamed (show semVar) (fromString $ show semVar) . property $ do - strs <- forAll . Gen.list (Range.linear 0 10) $ Gen.text (Range.linear 0 20) Gen.unicode - let step arg rest = mkIterAppNoAnn (tyInst () (builtin () Trace) unit) - [ mkConstant @Text @DefaultUni () arg - , rest - ] - term = foldr step unitval (reverse strs) - strs' <- case typecheckEvaluateCek semVar TPLC.defaultBuiltinCostModelForTesting term of - Left _ -> failure - Right (EvaluationFailure, _) -> failure - Right (EvaluationSuccess _, strs') -> return strs' - strs === strs' + strs <- forAll . Gen.list (Range.linear 0 10) $ Gen.text (Range.linear 0 20) Gen.unicode + let step arg rest = + mkIterAppNoAnn + (tyInst () (builtin () Trace) unit) + [ mkConstant @Text @DefaultUni () arg + , rest + ] + term = foldr step unitval (reverse strs) + strs' <- case typecheckEvaluateCek semVar TPLC.defaultBuiltinCostModelForTesting term of + Left _ -> failure + Right (EvaluationFailure, _) -> failure + Right (EvaluationSuccess _, strs') -> return strs' + strs === strs' test_makeRead :: TestTree test_makeRead = - testGroup "makeRead" - [ test_textRoundtrip - , testGroup "collectText" $ map test_collectText enumerate - ] + testGroup + "makeRead" + [ test_textRoundtrip + , testGroup "collectText" $ map test_collectText enumerate + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/SignatureVerification.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/SignatureVerification.hs index e100602af71..e7f8e66c2c5 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/SignatureVerification.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/SignatureVerification.hs @@ -1,12 +1,12 @@ -- editorconfig-checker-disable-file {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Evaluation.Builtins.SignatureVerification ( ecdsaSecp256k1Prop, @@ -14,15 +14,29 @@ module Evaluation.Builtins.SignatureVerification ( ed25519_VariantBProp, ed25519_VariantCProp, schnorrSecp256k1Prop, - ) where - - -import Cardano.Crypto.DSIGN.Class (ContextDSIGN, DSIGNAlgorithm, SignKeyDSIGN, Signable, - deriveVerKeyDSIGN, genKeyDSIGN, rawDeserialiseSigDSIGN, - rawDeserialiseVerKeyDSIGN, rawSerialiseSigDSIGN, - rawSerialiseVerKeyDSIGN, signDSIGN) -import Cardano.Crypto.DSIGN.EcdsaSecp256k1 (EcdsaSecp256k1DSIGN, MessageHash, SigDSIGN, VerKeyDSIGN, - fromMessageHash, toMessageHash) +) where + +import Cardano.Crypto.DSIGN.Class ( + ContextDSIGN, + DSIGNAlgorithm, + SignKeyDSIGN, + Signable, + deriveVerKeyDSIGN, + genKeyDSIGN, + rawDeserialiseSigDSIGN, + rawDeserialiseVerKeyDSIGN, + rawSerialiseSigDSIGN, + rawSerialiseVerKeyDSIGN, + signDSIGN, + ) +import Cardano.Crypto.DSIGN.EcdsaSecp256k1 ( + EcdsaSecp256k1DSIGN, + MessageHash, + SigDSIGN, + VerKeyDSIGN, + fromMessageHash, + toMessageHash, + ) import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN) import Cardano.Crypto.DSIGN.SchnorrSecp256k1 (SchnorrSecp256k1DSIGN) import Cardano.Crypto.Seed (mkSeedFromBytes) @@ -36,8 +50,10 @@ import Evaluation.Builtins.Common (typecheckEvaluateCek) import Hedgehog (Gen, PropertyT, annotateShow, cover, failure, forAllWith, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (VerifyEcdsaSecp256k1Signature, VerifyEd25519Signature, VerifySchnorrSecp256k1Signature), - EvaluationResult (EvaluationFailure, EvaluationSuccess)) +import PlutusCore ( + DefaultFun (VerifyEcdsaSecp256k1Signature, VerifyEd25519Signature, VerifySchnorrSecp256k1Signature), + EvaluationResult (EvaluationFailure, EvaluationSuccess), + ) import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -87,8 +103,9 @@ ed25519_VariantCProp = ed25519Prop DefaultFunSemanticsVariantC -- Helpers -runTestDataWith :: forall (a :: Type) (msg :: Type) . - (DSIGNAlgorithm a) => +runTestDataWith :: + forall (a :: Type) (msg :: Type). + DSIGNAlgorithm a => BuiltinSemanticsVariant DefaultFun -> Case a msg -> (msg -> ByteString) -> @@ -96,12 +113,14 @@ runTestDataWith :: forall (a :: Type) (msg :: Type) . PropertyT IO () runTestDataWith semvar testData f op = do let (vk, msg, sig) = getCaseData f testData - let actualExp = mkIterAppNoAnn (builtin () op) [ - mkConstant @ByteString () vk, - mkConstant @ByteString () msg, - mkConstant @ByteString () sig - ] - let result = typecheckEvaluateCek semvar defaultBuiltinCostModelForTesting actualExp -- FIXME: semantic variant? + let actualExp = + mkIterAppNoAnn + (builtin () op) + [ mkConstant @ByteString () vk + , mkConstant @ByteString () msg + , mkConstant @ByteString () sig + ] + let result = typecheckEvaluateCek semvar defaultBuiltinCostModelForTesting actualExp -- FIXME: semantic variant? case result of Left x -> annotateShow x >> failure Right (res, logs) -> do @@ -110,7 +129,7 @@ runTestDataWith semvar testData f op = do Nothing -> res === EvaluationFailure Just good -> case preview _AllGood good of Nothing -> res === (EvaluationSuccess . mkConstant () $ False) - Just _ -> res === (EvaluationSuccess . mkConstant () $ True) + Just _ -> res === (EvaluationSuccess . mkConstant () $ True) -- Data for an erroring case data ErrorCase (a :: Type) (msg :: Type) where @@ -122,7 +141,8 @@ deriving stock instance (Eq msg, DSIGNAlgorithm a) => Eq (ErrorCase a msg) deriving stock instance (Show msg, DSIGNAlgorithm a) => Show (ErrorCase a msg) -_BadVerKey :: forall (a :: Type) (msg :: Type) . +_BadVerKey :: + forall (a :: Type) (msg :: Type). Prism' (ErrorCase a msg) (ByteString, msg, SigDSIGN a) _BadVerKey = prism' into outOf where @@ -131,9 +151,10 @@ _BadVerKey = prism' into outOf outOf :: ErrorCase a msg -> Maybe (ByteString, msg, SigDSIGN a) outOf = \case BadVerKey bs message sig -> pure (bs, message, sig) - _ -> Nothing + _ -> Nothing -_BadMessage :: forall (a :: Type) (msg :: Type) . +_BadMessage :: + forall (a :: Type) (msg :: Type). Prism' (ErrorCase a msg) (VerKeyDSIGN a, ByteString, SigDSIGN a) _BadMessage = prism' into outOf where @@ -142,9 +163,10 @@ _BadMessage = prism' into outOf outOf :: ErrorCase a msg -> Maybe (VerKeyDSIGN a, ByteString, SigDSIGN a) outOf = \case BadMsg vk bs sig -> pure (vk, bs, sig) - _ -> Nothing + _ -> Nothing -_BadSignature :: forall (a :: Type) (msg :: Type) . +_BadSignature :: + forall (a :: Type) (msg :: Type). Prism' (ErrorCase a msg) (VerKeyDSIGN a, msg, ByteString) _BadSignature = prism' into outOf where @@ -153,7 +175,7 @@ _BadSignature = prism' into outOf outOf :: ErrorCase a msg -> Maybe (VerKeyDSIGN a, msg, ByteString) outOf = \case BadSig vk message bs -> pure (vk, message, bs) - _ -> Nothing + _ -> Nothing -- Data for non-erroring case data NoErrorCase (a :: Type) (msg :: Type) where @@ -165,7 +187,8 @@ deriving stock instance (Eq msg, DSIGNAlgorithm a) => Eq (NoErrorCase a msg) deriving stock instance (Show msg, DSIGNAlgorithm a) => Show (NoErrorCase a msg) -_WrongVerKey :: forall (a :: Type) (msg :: Type) . +_WrongVerKey :: + forall (a :: Type) (msg :: Type). Prism' (NoErrorCase a msg) (VerKeyDSIGN a, msg, SigDSIGN a) _WrongVerKey = prism' into outOf where @@ -174,9 +197,10 @@ _WrongVerKey = prism' into outOf outOf :: NoErrorCase a msg -> Maybe (VerKeyDSIGN a, msg, SigDSIGN a) outOf = \case WrongVerKey vk message sig -> pure (vk, message, sig) - _ -> Nothing + _ -> Nothing -_WrongSignature :: forall (a :: Type) (msg :: Type) . +_WrongSignature :: + forall (a :: Type) (msg :: Type). Prism' (NoErrorCase a msg) (VerKeyDSIGN a, msg, SigDSIGN a) _WrongSignature = prism' into outOf where @@ -185,9 +209,10 @@ _WrongSignature = prism' into outOf outOf :: NoErrorCase a msg -> Maybe (VerKeyDSIGN a, msg, SigDSIGN a) outOf = \case WrongSignature vk message sig -> pure (vk, message, sig) - _ -> Nothing + _ -> Nothing -_AllGood :: forall (a :: Type) (msg :: Type) . +_AllGood :: + forall (a :: Type) (msg :: Type). Prism' (NoErrorCase a msg) (VerKeyDSIGN a, msg, SigDSIGN a) _AllGood = prism' into outOf where @@ -196,7 +221,7 @@ _AllGood = prism' into outOf outOf :: NoErrorCase a msg -> Maybe (VerKeyDSIGN a, msg, SigDSIGN a) outOf = \case AllGood vk message sig -> pure (vk, message, sig) - _ -> Nothing + _ -> Nothing -- Case, irrespective of form data Case (a :: Type) (msg :: Type) where @@ -207,7 +232,8 @@ deriving stock instance (DSIGNAlgorithm a, Eq msg) => Eq (Case a msg) deriving stock instance (DSIGNAlgorithm a, Show msg) => Show (Case a msg) -_ShouldError :: forall (a :: Type) (msg :: Type) . +_ShouldError :: + forall (a :: Type) (msg :: Type). Prism' (Case a msg) (ErrorCase a msg) _ShouldError = prism' into outOf where @@ -216,9 +242,10 @@ _ShouldError = prism' into outOf outOf :: Case a msg -> Maybe (ErrorCase a msg) outOf = \case ShouldError x -> pure x - _ -> Nothing + _ -> Nothing -_Shouldn'tError :: forall (a :: Type) (msg :: Type) . +_Shouldn'tError :: + forall (a :: Type) (msg :: Type). Prism' (Case a msg) (NoErrorCase a msg) _Shouldn'tError = prism' into outOf where @@ -227,114 +254,160 @@ _Shouldn'tError = prism' into outOf outOf :: Case a msg -> Maybe (NoErrorCase a msg) outOf = \case Shouldn'tError x -> pure x - _ -> Nothing + _ -> Nothing -getCaseData :: forall (a :: Type) (msg :: Type) . - (DSIGNAlgorithm a) => +getCaseData :: + forall (a :: Type) (msg :: Type). + DSIGNAlgorithm a => (msg -> ByteString) -> Case a msg -> (ByteString, ByteString, ByteString) getCaseData f = \case ShouldError x -> case x of BadVerKey vk message sig -> (vk, f message, rawSerialiseSigDSIGN sig) - BadMsg vk message sig -> (rawSerialiseVerKeyDSIGN vk, - message, - rawSerialiseSigDSIGN sig) + BadMsg vk message sig -> + ( rawSerialiseVerKeyDSIGN vk + , message + , rawSerialiseSigDSIGN sig + ) BadSig vk message sig -> (rawSerialiseVerKeyDSIGN vk, f message, sig) Shouldn'tError x -> case x of - WrongVerKey vk message sig -> (rawSerialiseVerKeyDSIGN vk, - f message, - rawSerialiseSigDSIGN sig) - WrongSignature vk message sig -> (rawSerialiseVerKeyDSIGN vk, - f message, - rawSerialiseSigDSIGN sig) - AllGood vk message sig -> (rawSerialiseVerKeyDSIGN vk, - f message, - rawSerialiseSigDSIGN sig) + WrongVerKey vk message sig -> + ( rawSerialiseVerKeyDSIGN vk + , f message + , rawSerialiseSigDSIGN sig + ) + WrongSignature vk message sig -> + ( rawSerialiseVerKeyDSIGN vk + , f message + , rawSerialiseSigDSIGN sig + ) + AllGood vk message sig -> + ( rawSerialiseVerKeyDSIGN vk + , f message + , rawSerialiseSigDSIGN sig + ) -- Generators genEcdsaErrorCase :: Gen (ErrorCase EcdsaSecp256k1DSIGN MessageHash) genEcdsaErrorCase = - Gen.prune . Gen.choice $ [ - review _BadVerKey <$> mkBadVerKeyBits, - review _BadMessage <$> mkBadMessageBits, - review _BadSignature <$> mkBadSignatureBits + Gen.prune . Gen.choice $ + [ review _BadVerKey <$> mkBadVerKeyBits + , review _BadMessage <$> mkBadMessageBits + , review _BadSignature <$> mkBadSignatureBits ] where - mkBadVerKeyBits :: Gen (ByteString, - MessageHash, - SigDSIGN EcdsaSecp256k1DSIGN) - mkBadVerKeyBits = (,,) <$> genBadVerKey @EcdsaSecp256k1DSIGN <*> - genEcdsaMsg <*> - genEcdsaSig - mkBadMessageBits :: Gen (VerKeyDSIGN EcdsaSecp256k1DSIGN, - ByteString, - SigDSIGN EcdsaSecp256k1DSIGN) + mkBadVerKeyBits :: + Gen + ( ByteString + , MessageHash + , SigDSIGN EcdsaSecp256k1DSIGN + ) + mkBadVerKeyBits = + (,,) + <$> genBadVerKey @EcdsaSecp256k1DSIGN + <*> genEcdsaMsg + <*> genEcdsaSig + mkBadMessageBits :: + Gen + ( VerKeyDSIGN EcdsaSecp256k1DSIGN + , ByteString + , SigDSIGN EcdsaSecp256k1DSIGN + ) mkBadMessageBits = (,,) <$> genVerKey <*> genBadEcdsaMsg <*> genEcdsaSig - mkBadSignatureBits :: Gen (VerKeyDSIGN EcdsaSecp256k1DSIGN, - MessageHash, - ByteString) - mkBadSignatureBits = (,,) <$> genVerKey <*> - genEcdsaMsg <*> - genBadSig @EcdsaSecp256k1DSIGN + mkBadSignatureBits :: + Gen + ( VerKeyDSIGN EcdsaSecp256k1DSIGN + , MessageHash + , ByteString + ) + mkBadSignatureBits = + (,,) + <$> genVerKey + <*> genEcdsaMsg + <*> genBadSig @EcdsaSecp256k1DSIGN genSchnorrErrorCase :: Gen (ErrorCase SchnorrSecp256k1DSIGN ByteString) -genSchnorrErrorCase = Gen.choice [ - review _BadVerKey <$> mkBadVerKeyBits, - review _BadSignature <$> mkBadSignatureBits - ] +genSchnorrErrorCase = + Gen.choice + [ review _BadVerKey <$> mkBadVerKeyBits + , review _BadSignature <$> mkBadSignatureBits + ] where - mkBadVerKeyBits :: Gen (ByteString, - ByteString, - SigDSIGN SchnorrSecp256k1DSIGN) - mkBadVerKeyBits = (,,) <$> genBadVerKey @SchnorrSecp256k1DSIGN <*> - (Gen.bytes . Range.linear 0 $ 64) <*> - genSchnorrSig - mkBadSignatureBits :: Gen (VerKeyDSIGN SchnorrSecp256k1DSIGN, - ByteString, - ByteString) - mkBadSignatureBits = (,,) <$> genVerKey <*> - (Gen.bytes . Range.linear 0 $ 64) <*> - genBadSig @SchnorrSecp256k1DSIGN + mkBadVerKeyBits :: + Gen + ( ByteString + , ByteString + , SigDSIGN SchnorrSecp256k1DSIGN + ) + mkBadVerKeyBits = + (,,) + <$> genBadVerKey @SchnorrSecp256k1DSIGN + <*> (Gen.bytes . Range.linear 0 $ 64) + <*> genSchnorrSig + mkBadSignatureBits :: + Gen + ( VerKeyDSIGN SchnorrSecp256k1DSIGN + , ByteString + , ByteString + ) + mkBadSignatureBits = + (,,) + <$> genVerKey + <*> (Gen.bytes . Range.linear 0 $ 64) + <*> genBadSig @SchnorrSecp256k1DSIGN genEd25519ErrorCase :: Gen (ErrorCase Ed25519DSIGN ByteString) -genEd25519ErrorCase = Gen.choice [ - review _BadVerKey <$> mkBadVerKeyBits, - review _BadSignature <$> mkBadSignatureBits - ] +genEd25519ErrorCase = + Gen.choice + [ review _BadVerKey <$> mkBadVerKeyBits + , review _BadSignature <$> mkBadSignatureBits + ] where - mkBadVerKeyBits :: Gen (ByteString, - ByteString, - SigDSIGN Ed25519DSIGN) - mkBadVerKeyBits = (,,) <$> genBadVerKey @Ed25519DSIGN <*> - (Gen.bytes . Range.linear 0 $ 64) <*> - genEd25519Sig - mkBadSignatureBits :: Gen (VerKeyDSIGN Ed25519DSIGN, - ByteString, - ByteString) - mkBadSignatureBits = (,,) <$> genVerKey <*> - (Gen.bytes . Range.linear 0 $ 64) <*> - genBadSig @Ed25519DSIGN + mkBadVerKeyBits :: + Gen + ( ByteString + , ByteString + , SigDSIGN Ed25519DSIGN + ) + mkBadVerKeyBits = + (,,) + <$> genBadVerKey @Ed25519DSIGN + <*> (Gen.bytes . Range.linear 0 $ 64) + <*> genEd25519Sig + mkBadSignatureBits :: + Gen + ( VerKeyDSIGN Ed25519DSIGN + , ByteString + , ByteString + ) + mkBadSignatureBits = + (,,) + <$> genVerKey + <*> (Gen.bytes . Range.linear 0 $ 64) + <*> genBadSig @Ed25519DSIGN genEcdsaNoErrorCase :: Gen (NoErrorCase EcdsaSecp256k1DSIGN MessageHash) genEcdsaNoErrorCase = do sk <- genSignKey let vk = deriveVerKeyDSIGN sk msg <- genEcdsaMsg - Gen.prune . Gen.choice $ [ - review _WrongVerKey <$> mkWrongKeyBits sk vk msg, - review _WrongSignature <$> mkWrongSignatureBits sk vk msg, - pure . review _AllGood $ (vk, msg, signDSIGN () msg sk) + Gen.prune . Gen.choice $ + [ review _WrongVerKey <$> mkWrongKeyBits sk vk msg + , review _WrongSignature <$> mkWrongSignatureBits sk vk msg + , pure . review _AllGood $ (vk, msg, signDSIGN () msg sk) ] where mkWrongSignatureBits :: SignKeyDSIGN EcdsaSecp256k1DSIGN -> VerKeyDSIGN EcdsaSecp256k1DSIGN -> MessageHash -> - Gen (VerKeyDSIGN EcdsaSecp256k1DSIGN, - MessageHash, - SigDSIGN EcdsaSecp256k1DSIGN) + Gen + ( VerKeyDSIGN EcdsaSecp256k1DSIGN + , MessageHash + , SigDSIGN EcdsaSecp256k1DSIGN + ) mkWrongSignatureBits sk vk msg = do msgBad <- Gen.filter (/= msg) genEcdsaMsg pure (vk, msg, signDSIGN () msgBad sk) @@ -344,19 +417,21 @@ genSchnorrNoErrorCase = do sk <- genSignKey let vk = deriveVerKeyDSIGN sk msg <- Gen.bytes . Range.linear 0 $ 64 - Gen.choice [ - review _WrongVerKey <$> mkWrongKeyBits sk vk msg, - review _WrongSignature <$> mkWrongSignatureBits sk vk msg, - pure . review _AllGood $ (vk, msg, signDSIGN () msg sk) + Gen.choice + [ review _WrongVerKey <$> mkWrongKeyBits sk vk msg + , review _WrongSignature <$> mkWrongSignatureBits sk vk msg + , pure . review _AllGood $ (vk, msg, signDSIGN () msg sk) ] where mkWrongSignatureBits :: SignKeyDSIGN SchnorrSecp256k1DSIGN -> VerKeyDSIGN SchnorrSecp256k1DSIGN -> ByteString -> - Gen (VerKeyDSIGN SchnorrSecp256k1DSIGN, - ByteString, - SigDSIGN SchnorrSecp256k1DSIGN) + Gen + ( VerKeyDSIGN SchnorrSecp256k1DSIGN + , ByteString + , SigDSIGN SchnorrSecp256k1DSIGN + ) mkWrongSignatureBits sk vk msg = do msgBad <- Gen.filter (/= msg) (Gen.bytes . Range.linear 0 $ 64) pure (vk, msg, signDSIGN () msgBad sk) @@ -366,42 +441,48 @@ genEd25519NoErrorCase = do sk <- genSignKey let vk = deriveVerKeyDSIGN sk msg <- Gen.bytes . Range.linear 0 $ 64 - Gen.choice [ - review _WrongVerKey <$> mkWrongKeyBits sk vk msg, - review _WrongSignature <$> mkWrongSignatureBits sk vk msg, - pure . review _AllGood $ (vk, msg, signDSIGN () msg sk) + Gen.choice + [ review _WrongVerKey <$> mkWrongKeyBits sk vk msg + , review _WrongSignature <$> mkWrongSignatureBits sk vk msg + , pure . review _AllGood $ (vk, msg, signDSIGN () msg sk) ] where mkWrongSignatureBits :: SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN -> ByteString -> - Gen (VerKeyDSIGN Ed25519DSIGN, - ByteString, - SigDSIGN Ed25519DSIGN) + Gen + ( VerKeyDSIGN Ed25519DSIGN + , ByteString + , SigDSIGN Ed25519DSIGN + ) mkWrongSignatureBits sk vk msg = do msgBad <- Gen.filter (/= msg) (Gen.bytes . Range.linear 0 $ 64) pure (vk, msg, signDSIGN () msgBad sk) genEcdsaCase :: Gen (Case EcdsaSecp256k1DSIGN MessageHash) -genEcdsaCase = Gen.prune . Gen.choice $ [ - review _Shouldn'tError <$> genEcdsaNoErrorCase, - review _ShouldError <$> genEcdsaErrorCase - ] +genEcdsaCase = + Gen.prune . Gen.choice $ + [ review _Shouldn'tError <$> genEcdsaNoErrorCase + , review _ShouldError <$> genEcdsaErrorCase + ] genSchnorrCase :: Gen (Case SchnorrSecp256k1DSIGN ByteString) -genSchnorrCase = Gen.prune . Gen.frequency $ [ - (6, review _Shouldn'tError <$> genSchnorrNoErrorCase), - (4, review _ShouldError <$> genSchnorrErrorCase) - ] +genSchnorrCase = + Gen.prune . Gen.frequency $ + [ (6, review _Shouldn'tError <$> genSchnorrNoErrorCase) + , (4, review _ShouldError <$> genSchnorrErrorCase) + ] genEd25519Case :: Gen (Case Ed25519DSIGN ByteString) -genEd25519Case = Gen.prune . Gen.frequency $ [ - (6, review _Shouldn'tError <$> genEd25519NoErrorCase), - (4, review _ShouldError <$> genEd25519ErrorCase) - ] +genEd25519Case = + Gen.prune . Gen.frequency $ + [ (6, review _Shouldn'tError <$> genEd25519NoErrorCase) + , (4, review _ShouldError <$> genEd25519ErrorCase) + ] -mkWrongKeyBits :: forall (a :: Type) (msg :: Type) . +mkWrongKeyBits :: + forall (a :: Type) (msg :: Type). (DSIGNAlgorithm a, ContextDSIGN a ~ (), Signable a msg) => SignKeyDSIGN a -> VerKeyDSIGN a -> @@ -411,10 +492,13 @@ mkWrongKeyBits sk vk msg = do vkBad <- Gen.filter (/= vk) genVerKey pure (vkBad, msg, signDSIGN () msg sk) -genBadVerKey :: forall (a :: Type) . - (DSIGNAlgorithm a) => Gen ByteString -genBadVerKey = Gen.filter (isNothing . rawDeserialiseVerKeyDSIGN @a) - (Gen.bytes . Range.linear 0 $ 64) +genBadVerKey :: + forall (a :: Type). + DSIGNAlgorithm a => Gen ByteString +genBadVerKey = + Gen.filter + (isNothing . rawDeserialiseVerKeyDSIGN @a) + (Gen.bytes . Range.linear 0 $ 64) genEcdsaMsg :: Gen MessageHash genEcdsaMsg = Gen.mapMaybe toMessageHash (Gen.bytes . Range.singleton $ 32) @@ -437,17 +521,19 @@ genEd25519Sig = do msg <- Gen.bytes . Range.linear 0 $ 64 pure . signDSIGN () msg $ sk -genVerKey :: forall (a :: Type) . (DSIGNAlgorithm a) => Gen (VerKeyDSIGN a) +genVerKey :: forall (a :: Type). DSIGNAlgorithm a => Gen (VerKeyDSIGN a) genVerKey = deriveVerKeyDSIGN <$> genSignKey genBadEcdsaMsg :: Gen ByteString genBadEcdsaMsg = Gen.filter (isNothing . toMessageHash) (Gen.bytes . Range.linear 0 $ 64) -genBadSig :: forall (a :: Type) . (DSIGNAlgorithm a) => Gen ByteString -genBadSig = Gen.filter (isNothing . rawDeserialiseSigDSIGN @a) - (Gen.bytes . Range.linear 0 $ 64) +genBadSig :: forall (a :: Type). DSIGNAlgorithm a => Gen ByteString +genBadSig = + Gen.filter + (isNothing . rawDeserialiseSigDSIGN @a) + (Gen.bytes . Range.linear 0 $ 64) -genSignKey :: forall (a :: Type) . (DSIGNAlgorithm a) => Gen (SignKeyDSIGN a) +genSignKey :: forall (a :: Type). DSIGNAlgorithm a => Gen (SignKeyDSIGN a) genSignKey = do seed <- mkSeedFromBytes <$> (Gen.bytes . Range.linear 64 $ 128) pure . genKeyDSIGN $ seed diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs index 294f5dcb948..f8f48809568 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} -module Evaluation.Debug - ( test_debug - ) where +module Evaluation.Debug ( + test_debug, +) where import PlutusCore.Evaluation.Machine.ExBudgetingDefaults import PlutusCore.Pretty @@ -30,27 +30,29 @@ import Test.Tasty.Golden import UntypedPlutusCore.Evaluation.Machine.Cek test_debug :: TestTree -test_debug = testGroup "debug" $ +test_debug = + testGroup "debug" $ fmap goldenVsDebug examples -- i am not testing breakpoint functionality at the moment type Breakpoints = Void newtype EmptyAnn = EmptyAnn () - deriving newtype (Semigroup, Monoid) + deriving newtype (Semigroup, Monoid) instance Breakpointable EmptyAnn Breakpoints where - hasBreakpoints _ = absurd + hasBreakpoints _ = absurd examples :: [(String, [Cmd Breakpoints], NTerm DefaultUni DefaultFun EmptyAnn)] -examples = [ - ("ex1", repeat Step, Delay mempty $ Error mempty) - , ("ex2", replicate 4 Step, Force mempty $ Delay mempty $ Error mempty) - , ("ex3", replicate 5 Step, Force mempty $ Delay mempty $ Error mempty) - , ("ex4", repeat Step, Error mempty) - ] +examples = + [ ("ex1", repeat Step, Delay mempty $ Error mempty) + , ("ex2", replicate 4 Step, Force mempty $ Delay mempty $ Error mempty) + , ("ex3", replicate 5 Step, Force mempty $ Delay mempty $ Error mempty) + , ("ex4", repeat Step, Error mempty) + ] goldenVsDebug :: (TestName, [Cmd Breakpoints], NTerm DefaultUni DefaultFun EmptyAnn) -> TestTree goldenVsDebug (name, cmds, term) = - goldenVsString name + goldenVsString + name ("untyped-plutus-core/test/Evaluation/Debug/" ++ base ++ ".golden" ++ ext) (pure $ BS.pack $ unlines $ mock cmds term) where @@ -58,51 +60,76 @@ goldenVsDebug (name, cmds, term) = -- A Mocking interpreter -mock :: [Cmd Breakpoints] -- ^ commands to feed - -> NTerm DefaultUni DefaultFun EmptyAnn -- ^ term to debug - -> [String] -- ^ mocking output +mock :: + -- | commands to feed + [Cmd Breakpoints] -> + -- | term to debug + NTerm DefaultUni DefaultFun EmptyAnn -> + -- | mocking output + [String] mock cmds t = runST $ unCekM $ do - (cekTrans,_) <- mkCekTrans defaultCekParametersForTesting - restrictingEnormous noEmitter defaultSlippage - execWriterT $ flip runReaderT cmds $ - -- MAYBE: use cutoff or partialIterT to prevent runaway - iterM (handle cekTrans) $ runDriverT t + (cekTrans, _) <- + mkCekTrans + defaultCekParametersForTesting + restrictingEnormous + noEmitter + defaultSlippage + execWriterT $ + flip runReaderT cmds $ + -- MAYBE: use cutoff or partialIterT to prevent runaway + iterM (handle cekTrans) $ + runDriverT t -- Interpretation of the mocker ------------------------------- -handle :: forall uni fun s m. - ( ThrowableBuiltins uni fun - , MonadWriter [String] m, MonadReader [Cmd Breakpoints] m - , PrimMonad m, PrimState m ~ s - ) - => CekTrans uni fun EmptyAnn s - -> DebugF uni fun EmptyAnn Breakpoints (m ()) -> m () +handle :: + forall uni fun s m. + ( ThrowableBuiltins uni fun + , MonadWriter [String] m + , MonadReader [Cmd Breakpoints] m + , PrimMonad m + , PrimState m ~ s + ) => + CekTrans uni fun EmptyAnn s -> + DebugF uni fun EmptyAnn Breakpoints (m ()) -> + m () handle cekTrans = \case - StepF prevState k -> do - eNewState <- liftCek $ tryError $ cekTrans prevState - case eNewState of - Right newState -> do - tell [show $ "OldState:" <+> pretty prevState - <+> "NewState:" <+> pretty newState] - k newState - Left e -> tell [show $ "OldState:" <+> pretty prevState - <+> "NewState is Error:" <+> viaShow e] - -- no kontinuation, exit - InputF k -> handleInput k - DriverLogF text k -> handleLog (T.unpack text) >> k - UpdateClientF _ k -> k -- ignore + StepF prevState k -> do + eNewState <- liftCek $ tryError $ cekTrans prevState + case eNewState of + Right newState -> do + tell + [ show $ + "OldState:" + <+> pretty prevState + <+> "NewState:" + <+> pretty newState + ] + k newState + Left e -> + tell + [ show $ + "OldState:" + <+> pretty prevState + <+> "NewState is Error:" + <+> viaShow e + ] + -- no kontinuation, exit + InputF k -> handleInput k + DriverLogF text k -> handleLog (T.unpack text) >> k + UpdateClientF _ k -> k -- ignore where handleInput :: (Cmd Breakpoints -> m ()) -> m () handleInput k = do - cmds <- ask - case cmds of - [] -> - tell ["Early run out of commands"] - (cmd:cmds') -> - local (const cmds') $ - -- continue by feeding the next command to continuation - k cmd + cmds <- ask + case cmds of + [] -> + tell ["Early run out of commands"] + (cmd : cmds') -> + local (const cmds') $ + -- continue by feeding the next command to continuation + k cmd handleLog :: String -> m () handleLog = tell . pure diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs index a180f0b89f0..fe55268c3b2 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} + module Evaluation.FreeVars (test_freevars) where import PlutusCore.Default @@ -21,76 +22,91 @@ import Test.Tasty.HUnit -- by using the Internal module, thus bypassing any prior term conformance checks, e.g. -- that the term is closed (no free variables). testCekInternalFree :: TestTree -testCekInternalFree = testGroup "cekInternal" $ fmap (uncurry testCase) - [("delay0", eval (Delay () var0) @?= True) - ,("fun0var0", eval fun0var0 @?= True) - -- Interesting example because it is a `const x y` where x is a value and y is out-of-scope. - -- The evaluation result (success or failure) depends on how the machine - -- ignores the irrelevant to the computation) part of the environment. - ,("const0var0", eval (const0 @@ [unitval, fun0var0]) @?= True) - -- same as above, plus match on discharged value to show that freevar is completely ignored - ,("const0var0Discharge", evalV (const0 @@ [unitval, fun0var0]) @?= Right unitval) - ,("iteLazy0", eval iteLazy0 @?= True) - ,("iteStrict0", eval iteStrict0 @?= False) - ,("illITELazy", eval illITELazy @?= True) - ,("illITEStrict", eval illITEStrict @?= True) - ,("illAdd", eval illAdd @?= False) - ,("illOverAppBuiltin", eval illOverAppBuiltin @?= False) - ,("illOverAppFun", eval illOverAppFun @?= False) - ] +testCekInternalFree = + testGroup "cekInternal" $ + fmap + (uncurry testCase) + [ ("delay0", eval (Delay () var0) @?= True) + , ("fun0var0", eval fun0var0 @?= True) + , -- Interesting example because it is a `const x y` where x is a value and y is out-of-scope. + -- The evaluation result (success or failure) depends on how the machine + -- ignores the irrelevant to the computation) part of the environment. + ("const0var0", eval (const0 @@ [unitval, fun0var0]) @?= True) + , -- same as above, plus match on discharged value to show that freevar is completely ignored + ("const0var0Discharge", evalV (const0 @@ [unitval, fun0var0]) @?= Right unitval) + , ("iteLazy0", eval iteLazy0 @?= True) + , ("iteStrict0", eval iteStrict0 @?= False) + , ("illITELazy", eval illITELazy @?= True) + , ("illITEStrict", eval illITEStrict @?= True) + , ("illAdd", eval illAdd @?= False) + , ("illOverAppBuiltin", eval illOverAppBuiltin @?= False) + , ("illOverAppFun", eval illOverAppFun @?= False) + ] where - evalV = toFakeTerm - >>> runCekDeBruijn PLC.defaultCekParametersForTesting counting noEmitter - >>> _cekReportResult - >>> cekResultToEither - - eval = evalV - >>> isRight + evalV = + toFakeTerm + >>> runCekDeBruijn PLC.defaultCekParametersForTesting counting noEmitter + >>> _cekReportResult + >>> cekResultToEither + eval = + evalV + >>> isRight -- | Test the behaviour of discharge function against open terms (containing free variables) -- by manually constructing CekValue's and Cek Environment's. The free variables should -- be left untouched. testDischargeFree :: TestTree -testDischargeFree = testGroup "discharge" $ fmap (uncurry testCase) - [("freeRemains1", freeRemains1) - ,("freeRemains2", freeRemains2) - ] +testDischargeFree = + testGroup "discharge" $ + fmap + (uncurry testCase) + [ ("freeRemains1", freeRemains1) + , ("freeRemains2", freeRemains2) + ] where freeRemains1 = - -- dis( empty |- (delay (\x ->var0)) ) === (delay (\x -> var0)) - dis (VDelay (toFakeTerm fun0var0) - []) -- empty env - @?= - DischargeNonConstant (toFakeTerm $ Delay () fun0var0) + -- dis( empty |- (delay (\x ->var0)) ) === (delay (\x -> var0)) + dis + ( VDelay + (toFakeTerm fun0var0) + [] -- empty env + ) + @?= DischargeNonConstant (toFakeTerm $ Delay () fun0var0) freeRemains2 = - -- dis( y:unit |- \x-> x y var0) ) === (\x -> x unit var0) - -- x is bound so it is left alone - -- y is discharged from the env - -- var0 is free so it is left alone - dis (VLamAbs (fakeNameDeBruijn $ DeBruijn deBruijnInitIndex) - (toFakeTerm $ - v 1 @@ -- x - [v 2 -- y - ,var0 -- free - ] - ) - [VCon $ someValue ()] -- env has y + -- dis( y:unit |- \x-> x y var0) ) === (\x -> x unit var0) + -- x is bound so it is left alone + -- y is discharged from the env + -- var0 is free so it is left alone + dis + ( VLamAbs + (fakeNameDeBruijn $ DeBruijn deBruijnInitIndex) + ( toFakeTerm $ + v 1 + @@ [ v 2 -- x + -- y + , var0 -- free + ] ) - @?= - DischargeNonConstant (toFakeTerm . lamAbs0 $ - v 1 @@ -- x - [ Constant () (someValue ()) -- substituted y - , var0 -- free - ] - ) + [VCon $ someValue ()] -- env has y + ) + @?= DischargeNonConstant + ( toFakeTerm . lamAbs0 $ + v 1 + @@ [ Constant () (someValue ()) -- x + -- substituted y + , var0 -- free + ] + ) dis = dischargeCekValue @DefaultUni @DefaultFun v = Var () . DeBruijn test_freevars :: TestTree -test_freevars = testGroup "FreeVars" +test_freevars = + testGroup + "FreeVars" [ testCekInternalFree , testDischargeFree ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs index 98fa6b2cda2..8a71efb8868 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs @@ -1,12 +1,12 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module Evaluation.Golden - ( test_golden - , namesAndTests - ) where +module Evaluation.Golden ( + test_golden, + namesAndTests, +) where import Prelude hiding (even) @@ -46,84 +46,92 @@ string = mkTyBuiltin @_ @Text () evenAndOdd :: uni `HasTypeAndTermLevel` Bool => Tuple (Term TyName Name uni fun) uni () evenAndOdd = runQuote $ do - let nat = _recursiveType natData + let nat = _recursiveType natData - evenn <- freshName "even" - oddd <- freshName "odd" + evenn <- freshName "even" + oddd <- freshName "odd" - let eoFunc b recc = do - n <- freshName "n" - pure $ - LamAbs () n nat $ - Apply () (Apply () (TyInst () (Unwrap () (Var () n)) bool) b) $ Var () recc + let eoFunc b recc = do + n <- freshName "n" + pure $ + LamAbs () n nat $ + Apply () (Apply () (TyInst () (Unwrap () (Var () n)) bool) b) $ + Var () recc - evenF <- FunctionDef () evenn (FunctionType () nat bool) <$> eoFunc true oddd - oddF <- FunctionDef () oddd (FunctionType () nat bool) <$> eoFunc false evenn + evenF <- FunctionDef () evenn (FunctionType () nat bool) <$> eoFunc true oddd + oddF <- FunctionDef () oddd (FunctionType () nat bool) <$> eoFunc false evenn - getMutualFixOf () (fixN 2 fixBy) [evenF, oddF] + getMutualFixOf () (fixN 2 fixBy) [evenF, oddF] even :: uni `HasTypeAndTermLevel` Bool => Term TyName Name uni fun () even = runQuote $ tupleTermAt () 0 evenAndOdd evenAndOddList :: Tuple (Term TyName Name uni fun) uni () evenAndOddList = runQuote $ do - let list = _recursiveType listData - nat = _recursiveType natData - listNat = TyApp () list nat - - evenn <- freshName "even" - oddd <- freshName "odd" - - let eoFunc recc = do - l <- freshName "l" - pure $ - LamAbs () l listNat $ - Apply () ( - Apply () (TyInst () (Unwrap () (Var () l)) listNat) - (TyInst() nil nat)) + let list = _recursiveType listData + nat = _recursiveType natData + listNat = TyApp () list nat + + evenn <- freshName "even" + oddd <- freshName "odd" + + let eoFunc recc = do + l <- freshName "l" + pure $ + LamAbs () l listNat $ + Apply + () + ( Apply + () + (TyInst () (Unwrap () (Var () l)) listNat) + (TyInst () nil nat) + ) recc - evenF <- FunctionDef () evenn (FunctionType () listNat listNat) <$> do - h <- freshName "head" - t <- freshName "tail" - eoFunc $ - LamAbs () h nat $ - LamAbs () t listNat $ + evenF <- + FunctionDef () evenn (FunctionType () listNat listNat) <$> do + h <- freshName "head" + t <- freshName "tail" + eoFunc $ + LamAbs () h nat $ + LamAbs () t listNat $ Apply () (Apply () (TyInst () cons nat) (Var () h)) $ - Apply () (Var () oddd) (Var () t) - - oddF <- FunctionDef () oddd (FunctionType () listNat listNat) <$> do - h <- freshName "head" - t <- freshName "tail" - eoFunc $ - LamAbs () h nat $ - LamAbs () t listNat $ + Apply () (Var () oddd) (Var () t) + + oddF <- + FunctionDef () oddd (FunctionType () listNat listNat) <$> do + h <- freshName "head" + t <- freshName "tail" + eoFunc $ + LamAbs () h nat $ + LamAbs () t listNat $ Apply () (Var () evenn) (Var () t) - getMutualFixOf () (fixN 2 fixBy) [evenF, oddF] + getMutualFixOf () (fixN 2 fixBy) [evenF, oddF] evenList :: Term TyName Name uni fun () evenList = runQuote $ tupleTermAt () 0 evenAndOddList smallNatList :: Term TyName Name uni fun () -smallNatList = metaListToScottList nat nats where - nats = Prelude.map metaIntegerToNat [1,2,3] +smallNatList = metaListToScottList nat nats + where + nats = Prelude.map metaIntegerToNat [1, 2, 3] nat = _recursiveType natData polyError :: Term TyName Name uni fun () polyError = runQuote $ do - a <- freshTyName "a" - pure $ TyAbs () a (Type ()) $ Error () (TyVar () a) + a <- freshTyName "a" + pure $ TyAbs () a (Type ()) $ Error () (TyVar () a) -- | For checking that evaluating a term to a non-constant results in all remaining variables -- being instantiated. closure :: uni `HasTypeAndTermLevel` Integer => Term TyName Name uni fun () closure = runQuote $ do - i <- freshName "i" - j <- freshName "j" - pure - . Apply () (LamAbs () i integer . LamAbs () j integer $ Var () i) - $ mkConstant @Integer () 1 + i <- freshName "i" + j <- freshName "j" + pure + . Apply () (LamAbs () i integer . LamAbs () j integer $ Var () i) + $ mkConstant @Integer () 1 {- Tests for evaluation of builtins. The main point of these is to check that interleaving of term and type arguments is correct, but a number of other @@ -164,7 +172,6 @@ stringResultFalse = mkConstant @Text () "¬(11 <= 22)" lteExpr :: Term TyName Name DefaultUni DefaultFun () lteExpr = mkIterAppNoAnn lte [eleven, twentytwo] - -- Various combinations of (partial) instantiation/application for ifThenElse -- (builtin ifThenElse) : WellTypedRuns @@ -178,7 +185,7 @@ iteAt = TyInst () ite -- [ (builtin ifThenElse) (11<=22) ] : IllTypedFails (ifThenElse isn't -- instantiated: type expected, term supplied.) iteUninstantiatedWithCond :: Term TyName Name DefaultUni DefaultFun () -iteUninstantiatedWithCond = Apply () ite lteExpr +iteUninstantiatedWithCond = Apply () ite lteExpr -- (builtin ifThenElse) (11<=22) "11 <= 22" "¬(11<=22)" : IllTypedFails (no -- instantiation) @@ -222,7 +229,9 @@ iteAtIntegerFullyApplied = mkIterAppNoAnn iteAtIntegerWithCond [stringResultTrue -- [ (builtin divideInteger) 1 0 ] : WellTypedFails. Division by zero. diFullyApplied :: Term TyName Name DefaultUni DefaultFun () -diFullyApplied = mkIterAppNoAnn (Builtin () DivideInteger) +diFullyApplied = + mkIterAppNoAnn + (Builtin () DivideInteger) [ mkConstant @Integer () 1 , mkConstant @Integer () 0 ] @@ -240,7 +249,9 @@ iteAtStringWithCond = Apply () iteAtString lteExpr -- @string@. It still runs succefully, because even in typed world (the CK machine) we don't look -- at types at runtime. iteAtStringWithCondWithIntegerWithString :: Term TyName Name DefaultUni DefaultFun () -iteAtStringWithCondWithIntegerWithString = mkIterAppNoAnn iteAtStringWithCond +iteAtStringWithCondWithIntegerWithString = + mkIterAppNoAnn + iteAtStringWithCond [ mkConstant @Integer () 33 , mkConstant @Text () "abc" ] @@ -259,28 +270,30 @@ iteAtIntegerArrowIntegerWithCond = Apply () iteAtIntegerArrowInteger lteExpr -- [ { (builtin ifThenElse) (fun (con integer) (con integer)) } (11<=22) (11 *) (22 -)] : -- WellTypedRuns (returns a function of type int -> int) -iteAtIntegerArrowIntegerApplied1 :: Term TyName Name DefaultUni DefaultFun () -iteAtIntegerArrowIntegerApplied1 = mkIterAppNoAnn - iteAtIntegerArrowInteger - [ lteExpr - , Apply () (Builtin () MultiplyInteger) eleven - , Apply () (Builtin () SubtractInteger) twentytwo - ] +iteAtIntegerArrowIntegerApplied1 :: Term TyName Name DefaultUni DefaultFun () +iteAtIntegerArrowIntegerApplied1 = + mkIterAppNoAnn + iteAtIntegerArrowInteger + [ lteExpr + , Apply () (Builtin () MultiplyInteger) eleven + , Apply () (Builtin () SubtractInteger) twentytwo + ] -- [ { (builtin ifThenElse) (fun (con integer) (con integer)) } (11<=22) (*) (-)] : -- IllTypedRuns (int -> int -> int instead of int -> int). -iteAtIntegerArrowIntegerApplied2 :: Term TyName Name DefaultUni DefaultFun () -iteAtIntegerArrowIntegerApplied2 = mkIterAppNoAnn - iteAtIntegerArrowInteger - [ lteExpr - , Builtin () MultiplyInteger - , Builtin () SubtractInteger - ] +iteAtIntegerArrowIntegerApplied2 :: Term TyName Name DefaultUni DefaultFun () +iteAtIntegerArrowIntegerApplied2 = + mkIterAppNoAnn + iteAtIntegerArrowInteger + [ lteExpr + , Builtin () MultiplyInteger + , Builtin () SubtractInteger + ] -- [ { (builtin ifThenElse) (fun (con integer) (con integer)) } (11<=22) (11 *) (22 -) 22] : -- WellTypedRuns (ifThenElse returns a function which is then applied to a constant). iteAtIntegerArrowIntegerAppliedApplied :: Term TyName Name DefaultUni DefaultFun () -iteAtIntegerArrowIntegerAppliedApplied = Apply () iteAtIntegerArrowIntegerApplied1 twentytwo +iteAtIntegerArrowIntegerAppliedApplied = Apply () iteAtIntegerArrowIntegerApplied1 twentytwo -- { (builtin ifThenElse) (lam a . a -> a) } : IllTypedRuns. -- Evaluation should succeed, but typechecking should fail with a kind error. @@ -289,8 +302,9 @@ iteAtIntegerArrowIntegerAppliedApplied = Apply () iteAtIntegerArrowIntegerAppli -- types of kind *. iteAtHigherKind :: Term TyName Name DefaultUni DefaultFun () iteAtHigherKind = iteAt (TyLam () a (Type ()) aArrowA) - where a = TyName (Name "a" (Unique 0)) - aArrowA = TyFun () (TyVar () a) (TyVar () a) + where + a = TyName (Name "a" (Unique 0)) + aArrowA = TyFun () (TyVar () a) (TyVar () a) -- [ { (builtin ifThenElse) (lam a . a -> a) } (11<=22) ] : IllTypedRuns -- (illegal kind) @@ -311,12 +325,11 @@ iteAtIntegerAtInteger = TyInst () iteAtInteger integer iteTypeTermType :: Term TyName Name DefaultUni DefaultFun () iteTypeTermType = TyInst () iteAtIntegerWithCond string - -- Various attempts to instantiate the MultiplyInteger builtin. This is not -- polymorphic, so most should fail (and we're checking that they _do_ fail). -- (builtin multiplyInteger) (not tested) -mul :: Term TyName Name DefaultUni DefaultFun () +mul :: Term TyName Name DefaultUni DefaultFun () mul = Builtin () MultiplyInteger -- [ [ (builtin multiplyInteger) 11 ] 22 ] : WellTypedRuns @@ -342,49 +355,57 @@ tag2 :: Term TyName Name DefaultUni DefaultFun () tag2 = Constr () (TySOP () [[integer], [string]]) 1 [mkConstant @Text () "hello"] tagProd1 :: Term TyName Name DefaultUni DefaultFun () -tagProd1 = Constr () (TySOP () [[integer, integer, integer], [string]]) 0 +tagProd1 = + Constr + () + (TySOP () [[integer, integer, integer], [string]]) + 0 [mkConstant @Integer () 1, mkConstant @Integer () 2, mkConstant @Integer () 4] case1 :: Term TyName Name DefaultUni DefaultFun () case1 = runQuote $ do - a <- freshName "a" - let branch1 = LamAbs () a integer (Var () a) - branch2 = LamAbs () a string (mkConstant @Integer () 2) - pure $ Case () integer tag1 [branch1, branch2] + a <- freshName "a" + let branch1 = LamAbs () a integer (Var () a) + branch2 = LamAbs () a string (mkConstant @Integer () 2) + pure $ Case () integer tag1 [branch1, branch2] case2 :: Term TyName Name DefaultUni DefaultFun () case2 = runQuote $ do - a <- freshName "a" - let branch1 = LamAbs () a integer (Var () a) - branch2 = LamAbs () a string (mkConstant @Integer () 2) - pure $ Case () integer tag2 [branch1, branch2] + a <- freshName "a" + let branch1 = LamAbs () a integer (Var () a) + branch2 = LamAbs () a string (mkConstant @Integer () 2) + pure $ Case () integer tag2 [branch1, branch2] case3 :: Term TyName Name DefaultUni DefaultFun () case3 = runQuote $ do - a <- freshName "a" - let branch1 = LamAbs () a integer (mkConstant @Text () "no") - branch2 = LamAbs () a string (Var () a) - pure $ Case () string tag1 [branch1, branch2] + a <- freshName "a" + let branch1 = LamAbs () a integer (mkConstant @Text () "no") + branch2 = LamAbs () a string (Var () a) + pure $ Case () string tag1 [branch1, branch2] case4 :: Term TyName Name DefaultUni DefaultFun () case4 = runQuote $ do - a <- freshName "a" - let branch1 = LamAbs () a integer (mkConstant @Text () "no") - branch2 = LamAbs () a string (Var () a) - pure $ Case () string tag2 [branch1, branch2] + a <- freshName "a" + let branch1 = LamAbs () a integer (mkConstant @Text () "no") + branch2 = LamAbs () a string (Var () a) + pure $ Case () string tag2 [branch1, branch2] caseProd1 :: Term TyName Name DefaultUni DefaultFun () caseProd1 = runQuote $ do - a <- freshName "a" - b <- freshName "b" - c <- freshName "c" - let branch1 = LamAbs () a integer $ LamAbs () b integer $ LamAbs () c integer $ - mkIterAppNoAnn (Builtin () SubtractInteger) [ - mkIterAppNoAnn (Builtin () AddInteger) [Var () a, Var () b] - , Var () c - ] - branch2 = LamAbs () a string (mkConstant @Integer () 2) - pure $ Case () integer tagProd1 [branch1, branch2] + a <- freshName "a" + b <- freshName "b" + c <- freshName "c" + let branch1 = + LamAbs () a integer $ + LamAbs () b integer $ + LamAbs () c integer $ + mkIterAppNoAnn + (Builtin () SubtractInteger) + [ mkIterAppNoAnn (Builtin () AddInteger) [Var () a, Var () b] + , Var () c + ] + branch2 = LamAbs () a string (mkConstant @Integer () 2) + pure $ Case () integer tagProd1 [branch1, branch2] caseNoBranch :: Term TyName Name DefaultUni DefaultFun () caseNoBranch = Case () integer tag1 [] @@ -397,7 +418,10 @@ caseList = runQuote $ do a <- freshName "a" b <- freshName "b" pure $ - Case () integer (mkConstant @[Integer] () [1]) + Case + () + integer + (mkConstant @[Integer] () [1]) [ LamAbs () a integer $ LamAbs () b (mkTyBuiltin @_ @[Integer] ()) $ Var () a ] @@ -406,32 +430,33 @@ caseNonTag = Case () integer (builtin () AddInteger) [] -- | For testing that an accidental exception will get caught. headSingletonException :: Term TyName Name DefaultUni DefaultFun () -headSingletonException - = Apply () (TyInst () (Builtin () HeadList) $ mkTyBuiltin @_ @Bool ()) - $ mkConstant () [errorWithoutStackTrace "catch me if you can" :: Bool] +headSingletonException = + Apply () (TyInst () (Builtin () HeadList) $ mkTyBuiltin @_ @Bool ()) $ + mkConstant () [errorWithoutStackTrace "catch me if you can" :: Bool] -- Running the tests goldenVsPretty :: PrettyPlc a => String -> String -> a -> TestTree goldenVsPretty extn name value = - goldenVsString name ("untyped-plutus-core/test/Evaluation/Golden/" ++ name ++ extn) $ - pure . BSL.fromStrict . encodeUtf8 . render $ prettyPlcClassicSimple value + goldenVsString name ("untyped-plutus-core/test/Evaluation/Golden/" ++ name ++ extn) $ + pure . BSL.fromStrict . encodeUtf8 . render $ + prettyPlcClassicSimple value goldenVsEvaluatedCK :: String -> Term TyName Name DefaultUni DefaultFun () -> TestTree -goldenVsEvaluatedCK name - = goldenVsPretty ".golden.plc" name +goldenVsEvaluatedCK name = + goldenVsPretty ".golden.plc" name . bimap (fmap eraseTerm) eraseTerm . evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def goldenVsEvaluatedCEK :: String -> Term TyName Name DefaultUni DefaultFun () -> TestTree -goldenVsEvaluatedCEK name - = goldenVsPretty ".golden.uplc" name +goldenVsEvaluatedCEK name = + goldenVsPretty ".golden.uplc" name . evaluateCekNoEmit defaultCekParametersForTesting . eraseTerm -runTypecheck - :: Term TyName Name DefaultUni DefaultFun () - -> Either (Error DefaultUni DefaultFun ()) (Normalized (Type TyName DefaultUni ())) +runTypecheck :: + Term TyName Name DefaultUni DefaultFun () -> + Either (Error DefaultUni DefaultFun ()) (Normalized (Type TyName DefaultUni ())) runTypecheck term = runQuoteT $ modifyError TypeErrorE $ do tcConfig <- getDefTypeCheckConfig () @@ -442,78 +467,80 @@ goldenVsTypechecked name = goldenVsPretty ".golden.type" name . runTypecheck goldenVsTypecheckedEvaluatedCK :: String -> Term TyName Name DefaultUni DefaultFun () -> TestTree goldenVsTypecheckedEvaluatedCK name term = - -- The CK machine can evaluate an ill-typed term to a well-typed one, so we check - -- that the term is well-typed before checking that the type of the result is the - -- one stored in the golden file (we could simply check the two types for equality, - -- but since we're doing golden testing in this file, why not do it here as well). - case (runTypecheck term, evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def term) of - (Right _, Right res) -> goldenVsTypechecked name res - _ -> testGroup name [] + -- The CK machine can evaluate an ill-typed term to a well-typed one, so we check + -- that the term is well-typed before checking that the type of the result is the + -- one stored in the golden file (we could simply check the two types for equality, + -- but since we're doing golden testing in this file, why not do it here as well). + case (runTypecheck term, evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def term) of + (Right _, Right res) -> goldenVsTypechecked name res + _ -> testGroup name [] namesAndTests :: [(String, Term TyName Name DefaultUni DefaultFun ())] namesAndTests = - [ ("even2", Apply () even $ metaIntegerToNat 2) - , ("even3", Apply () even $ metaIntegerToNat 3) - , ("evenList", Apply () natSum $ Apply () evenList smallNatList) - , ("polyError", polyError) - , ("polyErrorInst", TyInst () polyError (mkTyBuiltin @_ @Integer ())) - , ("closure", closure) - , ("ite", ite) - , ("iteUninstantiatedWithCond", iteUninstantiatedWithCond) - , ("iteUninstantiatedFullyApplied", iteUninstantiatedFullyApplied) - , ("iteAtInteger", iteAtInteger) - , ("iteAtIntegerWithCond", iteAtIntegerWithCond) - , ("iteAtIntegerWrongCondTypeUnSat", iteAtIntegerWrongCondTypeUnSat) - , ("iteAtIntegerWrongCondTypeSat", iteAtIntegerWrongCondTypeSat) - , ("iteAtIntegerFullyApplied", iteAtIntegerFullyApplied) - , ("diFullyApplied", diFullyApplied) - , ("iteAtString", iteAtString) - , ("iteAtStringWithCond", iteAtStringWithCond) - , ("iteAtStringWithCondWithIntegerWithString", iteAtStringWithCondWithIntegerWithString) - , ("iteAtStringFullyApplied", iteAtStringFullyApplied) - , ("iteAtIntegerArrowInteger", iteAtIntegerArrowInteger) - , ("iteAtIntegerArrowIntegerWithCond", iteAtIntegerArrowIntegerWithCond) - , ("iteAtIntegerArrowIntegerApplied1", iteAtIntegerArrowIntegerApplied1) - , ("iteAtIntegerArrowIntegerApplied2", iteAtIntegerArrowIntegerApplied2) - , ("iteAtIntegerArrowIntegerAppliedApplied", iteAtIntegerArrowIntegerAppliedApplied) - , ("iteAtHigherKind", iteAtHigherKind) - , ("iteAtHigherKindWithCond", iteAtHigherKindWithCond) - , ("iteAtHigherKindFullyApplied", iteAtHigherKindFullyApplied) - , ("iteAtIntegerAtInteger", iteAtIntegerAtInteger) - , ("iteTypeTermType", iteTypeTermType) - , ("mulOK", mulOK) - , ("mulInstError1", mulInstError1) - , ("mulInstError2", mulInstError2) - , ("mulInstError3", mulInstError3) - , ("tag1", tag1) - , ("tag2", tag2) - , ("tagProd1", tagProd1) - , ("case1", case1) - , ("case2", case2) - , ("case3", case3) - , ("case4", case4) - , ("caseProd1", caseProd1) - , ("caseNoBranch", caseNoBranch) - , ("caseInteger", caseInteger) - , ("caseList", caseList) - , ("caseNonTag", caseNonTag) - ] + [ ("even2", Apply () even $ metaIntegerToNat 2) + , ("even3", Apply () even $ metaIntegerToNat 3) + , ("evenList", Apply () natSum $ Apply () evenList smallNatList) + , ("polyError", polyError) + , ("polyErrorInst", TyInst () polyError (mkTyBuiltin @_ @Integer ())) + , ("closure", closure) + , ("ite", ite) + , ("iteUninstantiatedWithCond", iteUninstantiatedWithCond) + , ("iteUninstantiatedFullyApplied", iteUninstantiatedFullyApplied) + , ("iteAtInteger", iteAtInteger) + , ("iteAtIntegerWithCond", iteAtIntegerWithCond) + , ("iteAtIntegerWrongCondTypeUnSat", iteAtIntegerWrongCondTypeUnSat) + , ("iteAtIntegerWrongCondTypeSat", iteAtIntegerWrongCondTypeSat) + , ("iteAtIntegerFullyApplied", iteAtIntegerFullyApplied) + , ("diFullyApplied", diFullyApplied) + , ("iteAtString", iteAtString) + , ("iteAtStringWithCond", iteAtStringWithCond) + , ("iteAtStringWithCondWithIntegerWithString", iteAtStringWithCondWithIntegerWithString) + , ("iteAtStringFullyApplied", iteAtStringFullyApplied) + , ("iteAtIntegerArrowInteger", iteAtIntegerArrowInteger) + , ("iteAtIntegerArrowIntegerWithCond", iteAtIntegerArrowIntegerWithCond) + , ("iteAtIntegerArrowIntegerApplied1", iteAtIntegerArrowIntegerApplied1) + , ("iteAtIntegerArrowIntegerApplied2", iteAtIntegerArrowIntegerApplied2) + , ("iteAtIntegerArrowIntegerAppliedApplied", iteAtIntegerArrowIntegerAppliedApplied) + , ("iteAtHigherKind", iteAtHigherKind) + , ("iteAtHigherKindWithCond", iteAtHigherKindWithCond) + , ("iteAtHigherKindFullyApplied", iteAtHigherKindFullyApplied) + , ("iteAtIntegerAtInteger", iteAtIntegerAtInteger) + , ("iteTypeTermType", iteTypeTermType) + , ("mulOK", mulOK) + , ("mulInstError1", mulInstError1) + , ("mulInstError2", mulInstError2) + , ("mulInstError3", mulInstError3) + , ("tag1", tag1) + , ("tag2", tag2) + , ("tagProd1", tagProd1) + , ("case1", case1) + , ("case2", case2) + , ("case3", case3) + , ("case4", case4) + , ("caseProd1", caseProd1) + , ("caseNoBranch", caseNoBranch) + , ("caseInteger", caseInteger) + , ("caseList", caseList) + , ("caseNonTag", caseNonTag) + ] -- | An extension of 'namesAndTests' that only works with the CEK machine and not the CK one. namesAndTestsCek :: [(String, Term TyName Name DefaultUni DefaultFun ())] -namesAndTestsCek - = ("headSingletonException", headSingletonException) +namesAndTestsCek = + ("headSingletonException", headSingletonException) : namesAndTests test_golden :: TestTree -test_golden = testGroup "golden" - [ testGroup "CK" $ fmap (uncurry goldenVsEvaluatedCK) namesAndTests - -- The CEK tests have been added to the plutus-conformance tests - -- (mostly renamed since there's no instantation, and with some - -- duplicates removed). We should also add the typed tests to the - -- conformance suite and remove them from here once we've done - -- that. - , testGroup "CEK" $ fmap (uncurry goldenVsEvaluatedCEK) namesAndTestsCek - , testGroup "Typechecking" $ fmap (uncurry goldenVsTypechecked) namesAndTestsCek - , testGroup "Typechecking CK output" $ fmap (uncurry goldenVsTypecheckedEvaluatedCK) namesAndTests - ] +test_golden = + testGroup + "golden" + [ testGroup "CK" $ fmap (uncurry goldenVsEvaluatedCK) namesAndTests + , -- The CEK tests have been added to the plutus-conformance tests + -- (mostly renamed since there's no instantation, and with some + -- duplicates removed). We should also add the typed tests to the + -- conformance suite and remove them from here once we've done + -- that. + testGroup "CEK" $ fmap (uncurry goldenVsEvaluatedCEK) namesAndTestsCek + , testGroup "Typechecking" $ fmap (uncurry goldenVsTypechecked) namesAndTestsCek + , testGroup "Typechecking CK output" $ fmap (uncurry goldenVsTypecheckedEvaluatedCK) namesAndTests + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs index 46a18553fed..315ddba37e6 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs @@ -1,18 +1,19 @@ -- editorconfig-checker-disable-file {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} -- | Various helpers for defining evaluation tests. module Evaluation.Helpers ( -- * Generators forAllByteString, forAllByteStringThat, + -- * Evaluation helpers evaluateTheSame, evaluatesToConstant, assertEvaluatesToConstant, evaluateToHaskell, - ) where +) where import Data.ByteString (ByteString) import Data.ByteString qualified as BS @@ -40,7 +41,8 @@ import UntypedPlutusCore qualified as UPLC -- It is the caller's responsibility to ensure that the bounds are sensible: that is, that neither -- the upper or lower bound are negative, and that the lower bound is not greater than the upper -- bound. -forAllByteString :: forall (m :: Type -> Type) . +forAllByteString :: + forall (m :: Type -> Type). (Monad m, HasCallStack) => Int -> Int -> PropertyT m ByteString forAllByteString lo = forAllWith hexShow . Gen.bytes . Range.linear lo @@ -51,7 +53,8 @@ forAllByteString lo = forAllWith hexShow . Gen.bytes . Range.linear lo -- -- If the postcondition is unlikely, the generator may eventually fail after too many retries. -- Ensure that the postcondition is likely to avoid problems. -forAllByteStringThat :: forall (m :: Type -> Type) . +forAllByteStringThat :: + forall (m :: Type -> Type). (Monad m, HasCallStack) => (ByteString -> Bool) -> Int -> Int -> PropertyT m ByteString forAllByteStringThat p lo = forAllWith hexShow . Gen.filterT p . Gen.bytes . Range.linear lo @@ -81,7 +84,8 @@ evaluateTheSame lhs rhs = -- | As 'evaluateTheSame', but for cases where we want to compare a more complex computation to a -- constant (as if by @mkConstant@). This is slightly more efficient. -evaluatesToConstant :: forall (a :: Type) . +evaluatesToConstant :: + forall (a :: Type). PLC.Contains UPLC.DefaultUni a => a -> PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> @@ -90,24 +94,26 @@ evaluatesToConstant k expr = case typecheckEvaluateCek def defaultBuiltinCostModelForTesting expr of Left err -> annotateShow err >> failure Right (res, logs) -> case res of - PLC.EvaluationFailure -> annotateShow logs >> failure + PLC.EvaluationFailure -> annotateShow logs >> failure PLC.EvaluationSuccess r -> r === mkConstant () k -- | Given a PLC expression and an intended type (via a type argument), typecheck the expression, -- evaluate it, then produce the required Haskell value from the results. If we fail at any stage, -- instead fail the test and report the failure. -evaluateToHaskell :: forall (a :: Type) . +evaluateToHaskell :: + forall (a :: Type). ReadKnownIn UPLC.DefaultUni (UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun ()) a => PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> PropertyT IO a evaluateToHaskell expr = case typecheckReadKnownCek def defaultBuiltinCostModelForTesting expr of - Left err -> annotateShow err >> failure + Left err -> annotateShow err >> failure Right (Left err) -> annotateShow err >> failure - Right (Right x) -> pure x + Right (Right x) -> pure x -- | As 'evaluatesToConstant', but for a unit instead of a property. -assertEvaluatesToConstant :: forall (a :: Type) . +assertEvaluatesToConstant :: + forall (a :: Type). PLC.Contains UPLC.DefaultUni a => a -> PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> @@ -116,7 +122,7 @@ assertEvaluatesToConstant k expr = case typecheckEvaluateCek def defaultBuiltinCostModelForTesting expr of Left err -> assertFailure . show $ err Right (res, logs) -> case res of - PLC.EvaluationFailure -> assertFailure . show $ logs + PLC.EvaluationFailure -> assertFailure . show $ logs PLC.EvaluationSuccess r -> assertEqual "" r (mkConstant () k) -- Helpers diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs index cd9e0dd38e2..b452f398b6d 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs @@ -1,14 +1,14 @@ -- editorconfig-checker-disable-file {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -module Evaluation.Machines - ( test_machines - , test_budget - , test_tallying - , test_NumberOfStepCounters - ) where +module Evaluation.Machines ( + test_machines, + test_budget, + test_tallying, + test_NumberOfStepCounters, +) where import PlutusPrelude @@ -44,118 +44,128 @@ import Test.Tasty.Extras import Test.Tasty.Golden import Test.Tasty.Hedgehog -testMachine - :: (uni ~ DefaultUni, fun ~ DefaultFun, PrettyPlc structural) - => String - -> (Term Name uni fun () -> - Either - (EvaluationException structural operational (Term Name uni fun ())) - (Term Name uni fun ())) - -> TestTree +testMachine :: + (uni ~ DefaultUni, fun ~ DefaultFun, PrettyPlc structural) => + String -> + ( Term Name uni fun () -> + Either + (EvaluationException structural operational (Term Name uni fun ())) + (Term Name uni fun ()) + ) -> + TestTree testMachine machine eval = - testGroup machine $ fromInterestingTermGens $ \name genTermOfTbv -> - testPropertyNamed name (fromString name) . withTests 99 . property $ do - TermOf term val <- forAllWith mempty genTermOfTbv - let resExp = makeKnownOrFail @_ @(Plc.Term TyName Name DefaultUni DefaultFun ()) val - case splitStructuralOperational . eval $ eraseTerm term of - Left err -> fail $ show err - Right resAct -> resAct === fmap eraseTerm resExp + testGroup machine $ fromInterestingTermGens $ \name genTermOfTbv -> + testPropertyNamed name (fromString name) . withTests 99 . property $ do + TermOf term val <- forAllWith mempty genTermOfTbv + let resExp = makeKnownOrFail @_ @(Plc.Term TyName Name DefaultUni DefaultFun ()) val + case splitStructuralOperational . eval $ eraseTerm term of + Left err -> fail $ show err + Right resAct -> resAct === fmap eraseTerm resExp test_machines :: TestTree test_machines = - testGroup "machines" - [ testMachine "CEK" $ Cek.evaluateCekNoEmit Plc.defaultCekParametersForTesting - , testMachine "SteppableCEK" $ SCek.evaluateCekNoEmit Plc.defaultCekParametersForTesting - ] - -testBudget - :: (Ix fun, Show fun, Hashable fun, Pretty fun, Typeable fun) - => BuiltinsRuntime fun (CekValue DefaultUni fun ()) - -> TestName - -> Term Name DefaultUni fun () - -> TestNested + testGroup + "machines" + [ testMachine "CEK" $ Cek.evaluateCekNoEmit Plc.defaultCekParametersForTesting + , testMachine "SteppableCEK" $ SCek.evaluateCekNoEmit Plc.defaultCekParametersForTesting + ] + +testBudget :: + (Ix fun, Show fun, Hashable fun, Pretty fun, Typeable fun) => + BuiltinsRuntime fun (CekValue DefaultUni fun ()) -> + TestName -> + Term Name DefaultUni fun () -> + TestNested testBudget runtime name term = - nestedGoldenVsText + nestedGoldenVsText name ".uplc" - (render - $ prettyPlcReadable - $ runCekNoEmit - (MachineParameters def $ - MachineVariantParameters Plc.defaultCekMachineCostsForTesting runtime) - Cek.tallying term) + ( render $ + prettyPlcReadable $ + runCekNoEmit + ( MachineParameters def $ + MachineVariantParameters Plc.defaultCekMachineCostsForTesting runtime + ) + Cek.tallying + term + ) bunchOfFibs :: PlcFolderContents DefaultUni DefaultFun -bunchOfFibs = FolderContents [treeFolderContents "Fib" $ map fibFile [1..3]] where +bunchOfFibs = FolderContents [treeFolderContents "Fib" $ map fibFile [1 .. 3]] + where fibFile i = plcTermFile (show i) (naiveFib i) -- | To check how a sequence of calls to a built-in @id@ affects budgeting when a (relatively) -- big AST is threaded through them. bunchOfIdNats :: PlcFolderContents DefaultUni ExtensionFun bunchOfIdNats = - FolderContents [treeFolderContents "IdNat" $ map idNatFile [0 :: Int, 3.. 9]] where - idNatFile i = plcTermFile (show i) (idNat id0 i) - -- > id0 = foldNat {nat} succ zero - id0 = mkIterAppNoAnn (tyInst () Plc.foldNat $ Plc.natTy) [Plc.succ, Plc.zero] - - idNat idN 0 = apply () idN $ metaIntegerToNat 10 - idNat idN n = idNat idN' (n - 1) where - -- Intentionally not eta-expanding the call to @idN'@, so that it gets forced during - -- evaluation, which causes @idN@ to get forced, which on the first iteration causes - -- @id0@ to get forced, which gives us a sufficiently big AST. - -- > idN' = id {nat -> nat} idN - idN' = apply () (tyInst () (builtin () Id) $ Plc.TyFun () Plc.natTy Plc.natTy) idN + FolderContents [treeFolderContents "IdNat" $ map idNatFile [0 :: Int, 3 .. 9]] + where + idNatFile i = plcTermFile (show i) (idNat id0 i) + -- > id0 = foldNat {nat} succ zero + id0 = mkIterAppNoAnn (tyInst () Plc.foldNat $ Plc.natTy) [Plc.succ, Plc.zero] + + idNat idN 0 = apply () idN $ metaIntegerToNat 10 + idNat idN n = idNat idN' (n - 1) + where + -- Intentionally not eta-expanding the call to @idN'@, so that it gets forced during + -- evaluation, which causes @idN@ to get forced, which on the first iteration causes + -- @id0@ to get forced, which gives us a sufficiently big AST. + -- > idN' = id {nat -> nat} idN + idN' = apply () (tyInst () (builtin () Id) $ Plc.TyFun () Plc.natTy Plc.natTy) idN -- | Same as 'bunchOfIdNats' except uses the built-in @ifThenElse@. bunchOfIfThenElseNats :: PlcFolderContents DefaultUni DefaultFun bunchOfIfThenElseNats = - FolderContents [treeFolderContents "IfThenElse" $ map ifThenElseNatFile [0 :: Int, 1.. 5]] where - ifThenElseNatFile i = plcTermFile (show i) (ifThenElseNat id0 i) - -- > id0 = foldNat {nat} succ zero - id0 = mkIterAppNoAnn (tyInst () Plc.foldNat Plc.natTy) [Plc.succ, Plc.zero] - - ifThenElseNat idN 0 = apply () idN $ metaIntegerToNat 10 - ifThenElseNat idN n = ifThenElseNat idN' (n - 1) where - -- Eta-expanding @idN'@ so that all of the if-then-else-s don't get evaluated -- - -- only those that are on the actual execution path. - -- > idN' = \(n : nat) -> ifThenElse {nat -> nat} ($(even n)) idN idN n - idN' - - = etaExpand Plc.natTy - $ mkIterAppNoAnn (tyInst () (builtin () IfThenElse) $ Plc.TyFun () Plc.natTy Plc.natTy) - [mkConstant () $ even n, idN, idN] + FolderContents [treeFolderContents "IfThenElse" $ map ifThenElseNatFile [0 :: Int, 1 .. 5]] + where + ifThenElseNatFile i = plcTermFile (show i) (ifThenElseNat id0 i) + -- > id0 = foldNat {nat} succ zero + id0 = mkIterAppNoAnn (tyInst () Plc.foldNat Plc.natTy) [Plc.succ, Plc.zero] + + ifThenElseNat idN 0 = apply () idN $ metaIntegerToNat 10 + ifThenElseNat idN n = ifThenElseNat idN' (n - 1) + where + -- Eta-expanding @idN'@ so that all of the if-then-else-s don't get evaluated -- + -- only those that are on the actual execution path. + -- > idN' = \(n : nat) -> ifThenElse {nat -> nat} ($(even n)) idN idN n + idN' = + etaExpand Plc.natTy $ + mkIterAppNoAnn + (tyInst () (builtin () IfThenElse) $ Plc.TyFun () Plc.natTy Plc.natTy) + [mkConstant () $ even n, idN, idN] test_budget :: TestTree -test_budget - -- Error diffs are very big - = localOption (SizeCutoff 1000000) +test_budget = + -- Error diffs are very big + localOption (SizeCutoff 1000000) . runTestNested ["untyped-plutus-core", "test", "Evaluation", "Machines", "Budget"] $ concat - [ folder Plc.defaultBuiltinsRuntimeForTesting bunchOfFibs - , folder (toBuiltinsRuntime def ()) bunchOfIdNats - , folder Plc.defaultBuiltinsRuntimeForTesting bunchOfIfThenElseNats - ] + [ folder Plc.defaultBuiltinsRuntimeForTesting bunchOfFibs + , folder (toBuiltinsRuntime def ()) bunchOfIdNats + , folder Plc.defaultBuiltinsRuntimeForTesting bunchOfIfThenElseNats + ] where folder runtime = - foldPlcFolderContents testNested mempty (\name -> testBudget runtime name . eraseTerm) + foldPlcFolderContents testNested mempty (\name -> testBudget runtime name . eraseTerm) testTallying :: TestName -> Term Name DefaultUni DefaultFun () -> TestNested testTallying name term = - nestedGoldenVsText + nestedGoldenVsText name ".uplc" (render $ prettyPlcReadable $ runCekNoEmit Plc.defaultCekParametersForTesting Cek.tallying term) test_tallying :: TestTree test_tallying = - -- Error diffs are very big - localOption (SizeCutoff 1000000) - . runTestNested ["untyped-plutus-core", "test", "Evaluation", "Machines", "Tallying"] - . foldPlcFolderContents testNested mempty (\name -> testTallying name . eraseTerm) - $ bunchOfFibs + -- Error diffs are very big + localOption (SizeCutoff 1000000) + . runTestNested ["untyped-plutus-core", "test", "Evaluation", "Machines", "Tallying"] + . foldPlcFolderContents testNested mempty (\name -> testTallying name . eraseTerm) + $ bunchOfFibs test_NumberOfStepCounters :: TestTree test_NumberOfStepCounters = - runTestNestedM ["untyped-plutus-core", "test", "Evaluation", "Machines"] $ do - nestedGoldenVsDoc "NumberOfStepCounters" "" . pretty . natVal $ Proxy @NumberOfStepCounters - nestedGoldenVsDoc "NumberOfStepCounters" "" . pretty . length $ enumerate @StepKind + runTestNestedM ["untyped-plutus-core", "test", "Evaluation", "Machines"] $ do + nestedGoldenVsDoc "NumberOfStepCounters" "" . pretty . natVal $ Proxy @NumberOfStepCounters + nestedGoldenVsDoc "NumberOfStepCounters" "" . pretty . length $ enumerate @StepKind diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Regressions.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Regressions.hs index 8cc85cf32ca..f6ce1cb8722 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Regressions.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Regressions.hs @@ -1,18 +1,20 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Evaluation.Regressions ( - schnorrVerifyRegressions - ) where + schnorrVerifyRegressions, +) where import Data.Bits (zeroBits) import Data.ByteString (ByteString) import Data.List.Split (chunksOf) import Evaluation.Builtins.Common (typecheckEvaluateCek) import GHC.Exts (fromListN) -import PlutusCore (DefaultFun (VerifySchnorrSecp256k1Signature), - EvaluationResult (EvaluationFailure)) +import PlutusCore ( + DefaultFun (VerifySchnorrSecp256k1Signature), + EvaluationResult (EvaluationFailure), + ) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModelForTesting) import PlutusCore.MkPlc (builtin, mkConstant, mkIterAppNoAnn) import PlutusPrelude @@ -22,19 +24,22 @@ import Text.Read (readMaybe) schnorrVerifyRegressions :: TestTree schnorrVerifyRegressions = - testGroup "Schnorr signature verification regressions" [ - testCase "malformed verkey should fail" $ do - let badVerKey = "m" - let message = "\213" - let comp = mkIterAppNoAnn (builtin () VerifySchnorrSecp256k1Signature) [ - mkConstant @ByteString () badVerKey, - mkConstant @ByteString () message, - mkConstant @ByteString () signature - ] - let result = typecheckEvaluateCek def defaultBuiltinCostModelForTesting comp - case result of - Left _ -> assertFailure "Failed to type check unexpectedly" - Right (res, _) -> assertEqual "" EvaluationFailure res + testGroup + "Schnorr signature verification regressions" + [ testCase "malformed verkey should fail" $ do + let badVerKey = "m" + let message = "\213" + let comp = + mkIterAppNoAnn + (builtin () VerifySchnorrSecp256k1Signature) + [ mkConstant @ByteString () badVerKey + , mkConstant @ByteString () message + , mkConstant @ByteString () signature + ] + let result = typecheckEvaluateCek def defaultBuiltinCostModelForTesting comp + case result of + Left _ -> assertFailure "Failed to type check unexpectedly" + Right (res, _) -> assertEqual "" EvaluationFailure res ] -- The original reproducing case is a hex string diff --git a/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs index 7e7117c97ec..3d4ff89a197 100644 --- a/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs @@ -1,9 +1,9 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Flat.Spec (test_flat) where @@ -24,29 +24,29 @@ import UntypedPlutusCore.Core.Type test_deBruijnIso :: TestTree test_deBruijnIso = testProperty "deBruijnIso" $ \d -> - d === fromFake (toFake d) + d === fromFake (toFake d) test_fakeIso :: TestTree test_fakeIso = testProperty "fakeIso" $ \fnd -> - fnd === toFake (fromFake fnd) + fnd === toFake (fromFake fnd) test_deBruijnTripping :: TestTree test_deBruijnTripping = testProperty "debruijnTripping" $ \d -> - Right d === unflat (flat @DeBruijn d) + Right d === unflat (flat @DeBruijn d) test_fakeTripping :: TestTree test_fakeTripping = testProperty "fakeTripping" $ \fnd -> - Right fnd === unflat (flat @FakeNamedDeBruijn fnd) + Right fnd === unflat (flat @FakeNamedDeBruijn fnd) test_binderDeBruijn :: TestTree test_binderDeBruijn = testProperty "binderDeBruijn" $ \b -> - -- binders should always decode as init binder - Right initB === unflat (flat @(Binder DeBruijn) b) + -- binders should always decode as init binder + Right initB === unflat (flat @(Binder DeBruijn) b) test_binderFake :: TestTree test_binderFake = testProperty "binderFake" $ \bf -> - -- binders should always decode as init binder - Right (toFake <$> initB) === unflat (flat @(Binder FakeNamedDeBruijn) bf) + -- binders should always decode as init binder + Right (toFake <$> initB) === unflat (flat @(Binder FakeNamedDeBruijn) bf) {- Check that a bytestring is the canonical flat encoding of another bytestring. A bytestring is encoded as sequence of chunks where each chunk is preceded by a @@ -59,24 +59,26 @@ the `flat` encoding, in particular Section C.2.5. -} isCanonicalFlatEncodedByteString :: BS.ByteString -> Bool isCanonicalFlatEncodedByteString bs = case BS.unpack bs of - [] -> False -- Should never happen. - 0x01:r -> go r -- 0x01 is the tag for an encoded bytestring - -- (Plutus Core specification, Table C.2) - _ -> False -- Not the encoding of a bytestring. + [] -> False -- Should never happen. + 0x01 : r -> go r -- 0x01 is the tag for an encoded bytestring + -- (Plutus Core specification, Table C.2) + _ -> False -- Not the encoding of a bytestring. where - go [] = False -- We've fallen off the end, possibly due to having dropped too many bytes. - go l@(w:ws) = -- w is the purported size of the next chunk. + go [] = False -- We've fallen off the end, possibly due to having dropped too many bytes. + go l@(w : ws) = + -- w is the purported size of the next chunk. if w == 0xFF - then go (drop 255 ws) -- Throw away any initial 255-byte chunks. - else l == end || drop (fromIntegral w) ws == end - -- Either we've arrived exactly at the end or we have a single short chunk before the end. - where end = [0x00, 0x01] -- An empty chunk followed by a padding byte. + then go (drop 255 ws) -- Throw away any initial 255-byte chunks. + else l == end || drop (fromIntegral w) ws == end + where + -- Either we've arrived exactly at the end or we have a single short chunk before the end. + end = [0x00, 0x01] -- An empty chunk followed by a padding byte. -test_canonicalEncoding :: forall a . (Arbitrary a, Flat a, Show a) => String -> Int -> TestTree +test_canonicalEncoding :: forall a. (Arbitrary a, Flat a, Show a) => String -> Int -> TestTree test_canonicalEncoding s n = testProperty s $ - withMaxSuccess n $ - forAll (arbitrary @a) (isCanonicalFlatEncodedByteString . flat @a) + withMaxSuccess n $ + forAll (arbitrary @a) (isCanonicalFlatEncodedByteString . flat @a) -- Data objects are encoded by first being converted to a bytestring using CBOR. -- This is the case that we're really interested in, since we get a lazy @@ -108,106 +110,250 @@ test_nonCanonicalByteStringDecoding = ch :: Char -> Word8 ch = fromIntegral . ord - input1 = BS.pack [ 0x01 -- 0x01 is the tag for an encoded bytestring. - , 0x01, ch 'T' - , 0x01, ch 'h' - , 0x01, ch 'i' - , 0x01, ch 's' - , 0x01, ch ' ' - , 0x01, ch 'i' - , 0x01, ch 's' - , 0x01, ch ' ' - , 0x01, ch 'a' - , 0x01, ch ' ' - , 0x01, ch 't' - , 0x01, ch 'e' - , 0x01, ch 's' - , 0x01, ch 't' - , 0x01, ch '.' - , 0x00 - , 0x01 ] - - input2 = BS.pack [ 0x01 - , 0x03, ch 'T', ch 'h', ch 'i' - , 0x03, ch 's', ch ' ', ch 'i' - , 0x03, ch 's', ch ' ', ch 'a' - , 0x03, ch ' ', ch 't', ch 'e' - , 0x03, ch 's', ch 't', ch '.' - , 0x00 - , 0x01 ] - - input3 = BS.pack [ 0x01 - , 0x01, ch 'T' - , 0x02, ch 'h', ch 'i' - , 0x03, ch 's', ch ' ', ch 'i' - , 0x04, ch 's', ch ' ', ch 'a', ch ' ' - , 0x05, ch 't', ch 'e', ch 's', ch 't', ch '.' - , 0x00 - , 0x01 ] - - input4 = BS.pack [ 0x01 - , 0x05, ch 'T', ch 'h', ch 'i', ch 's', ch ' ' - , 0x05, ch 'i', ch 's', ch ' ', ch 'a', ch ' ' - , 0x05, ch 't', ch 'e', ch 's', ch 't', ch '.' - , 0x00 - , 0x01 ] - - input5 = BS.pack [ 0x01 - , 0x05, ch 'T', ch 'h', ch 'i', ch 's', ch ' ' - , 0x04, ch 'i', ch 's', ch ' ', ch 'a' - , 0x03, ch ' ', ch 't', ch 'e' - , 0x02, ch 's', ch 't' - , 0x01, ch '.' - , 0x00 - , 0x01 ] - - input6 = BS.pack [ 0x01 - , 0x01, ch 'T' - , 0x0e, ch 'h', ch 'i', ch 's', ch ' ', ch 'i', ch 's', ch ' ' - , ch 'a', ch ' ', ch 't', ch 'e', ch 's', ch 't', ch '.' - , 0x00 - , 0x01 ] - - input7 = BS.pack [ 0x01 - , 0x01, ch 'T' - , 0x0d, ch 'h', ch 'i', ch 's', ch ' ', ch 'i', ch 's', ch ' ' - , ch 'a', ch ' ', ch 't', ch 'e', ch 's', ch 't' - , 0x01, ch '.' - , 0x00 - , 0x01 ] - - input8 = BS.pack [ 0x01 - , 0x03, ch 'T', ch 'h', ch 'i' - , 0x01, ch 's' - , 0x05, ch ' ', ch 'i', ch 's', ch ' ', ch 'a' - , 0x02, ch ' ', ch 't' - , 0x04, ch 'e', ch 's', ch 't', ch '.' - , 0x00 - , 0x01 ] + input1 = + BS.pack + [ 0x01 -- 0x01 is the tag for an encoded bytestring. + , 0x01 + , ch 'T' + , 0x01 + , ch 'h' + , 0x01 + , ch 'i' + , 0x01 + , ch 's' + , 0x01 + , ch ' ' + , 0x01 + , ch 'i' + , 0x01 + , ch 's' + , 0x01 + , ch ' ' + , 0x01 + , ch 'a' + , 0x01 + , ch ' ' + , 0x01 + , ch 't' + , 0x01 + , ch 'e' + , 0x01 + , ch 's' + , 0x01 + , ch 't' + , 0x01 + , ch '.' + , 0x00 + , 0x01 + ] + + input2 = + BS.pack + [ 0x01 + , 0x03 + , ch 'T' + , ch 'h' + , ch 'i' + , 0x03 + , ch 's' + , ch ' ' + , ch 'i' + , 0x03 + , ch 's' + , ch ' ' + , ch 'a' + , 0x03 + , ch ' ' + , ch 't' + , ch 'e' + , 0x03 + , ch 's' + , ch 't' + , ch '.' + , 0x00 + , 0x01 + ] + + input3 = + BS.pack + [ 0x01 + , 0x01 + , ch 'T' + , 0x02 + , ch 'h' + , ch 'i' + , 0x03 + , ch 's' + , ch ' ' + , ch 'i' + , 0x04 + , ch 's' + , ch ' ' + , ch 'a' + , ch ' ' + , 0x05 + , ch 't' + , ch 'e' + , ch 's' + , ch 't' + , ch '.' + , 0x00 + , 0x01 + ] + + input4 = + BS.pack + [ 0x01 + , 0x05 + , ch 'T' + , ch 'h' + , ch 'i' + , ch 's' + , ch ' ' + , 0x05 + , ch 'i' + , ch 's' + , ch ' ' + , ch 'a' + , ch ' ' + , 0x05 + , ch 't' + , ch 'e' + , ch 's' + , ch 't' + , ch '.' + , 0x00 + , 0x01 + ] + + input5 = + BS.pack + [ 0x01 + , 0x05 + , ch 'T' + , ch 'h' + , ch 'i' + , ch 's' + , ch ' ' + , 0x04 + , ch 'i' + , ch 's' + , ch ' ' + , ch 'a' + , 0x03 + , ch ' ' + , ch 't' + , ch 'e' + , 0x02 + , ch 's' + , ch 't' + , 0x01 + , ch '.' + , 0x00 + , 0x01 + ] + + input6 = + BS.pack + [ 0x01 + , 0x01 + , ch 'T' + , 0x0e + , ch 'h' + , ch 'i' + , ch 's' + , ch ' ' + , ch 'i' + , ch 's' + , ch ' ' + , ch 'a' + , ch ' ' + , ch 't' + , ch 'e' + , ch 's' + , ch 't' + , ch '.' + , 0x00 + , 0x01 + ] + + input7 = + BS.pack + [ 0x01 + , 0x01 + , ch 'T' + , 0x0d + , ch 'h' + , ch 'i' + , ch 's' + , ch ' ' + , ch 'i' + , ch 's' + , ch ' ' + , ch 'a' + , ch ' ' + , ch 't' + , ch 'e' + , ch 's' + , ch 't' + , 0x01 + , ch '.' + , 0x00 + , 0x01 + ] + + input8 = + BS.pack + [ 0x01 + , 0x03 + , ch 'T' + , ch 'h' + , ch 'i' + , 0x01 + , ch 's' + , 0x05 + , ch ' ' + , ch 'i' + , ch 's' + , ch ' ' + , ch 'a' + , 0x02 + , ch ' ' + , ch 't' + , 0x04 + , ch 'e' + , ch 's' + , ch 't' + , ch '.' + , 0x00 + , 0x01 + ] mkTest input = assertBool "Input failed to decode successfully" $ - (Right target == unflat input) - - in testGroup "Non-canonical bytestring encodings decode succesfully" - [ testProperty "Data via lazy bytestrings" $ - withMaxSuccess 5000 $ - forAll (arbitrary @Data) (\d -> Right d === unflat (flat $ (serialise d :: BSL.ByteString))) - , testProperty "Arbitrary lazy bytestrings" $ - withMaxSuccess 10000 $ - forAll (arbitrary @BSL.ByteString) (\bs -> Right (BSL.toStrict bs) === unflat (flat bs) ) - , testCase "Explicit input 1" $ mkTest input1 - , testCase "Explicit input 2" $ mkTest input2 - , testCase "Explicit input 3" $ mkTest input3 - , testCase "Explicit input 4" $ mkTest input4 - , testCase "Explicit input 5" $ mkTest input5 - , testCase "Explicit input 6" $ mkTest input6 - , testCase "Explicit input 7" $ mkTest input7 - , testCase "Explicit input 8" $ mkTest input8 - ] + (Right target == unflat input) + in testGroup + "Non-canonical bytestring encodings decode succesfully" + [ testProperty "Data via lazy bytestrings" $ + withMaxSuccess 5000 $ + forAll (arbitrary @Data) (\d -> Right d === unflat (flat $ (serialise d :: BSL.ByteString))) + , testProperty "Arbitrary lazy bytestrings" $ + withMaxSuccess 10000 $ + forAll (arbitrary @BSL.ByteString) (\bs -> Right (BSL.toStrict bs) === unflat (flat bs)) + , testCase "Explicit input 1" $ mkTest input1 + , testCase "Explicit input 2" $ mkTest input2 + , testCase "Explicit input 3" $ mkTest input3 + , testCase "Explicit input 4" $ mkTest input4 + , testCase "Explicit input 5" $ mkTest input5 + , testCase "Explicit input 6" $ mkTest input6 + , testCase "Explicit input 7" $ mkTest input7 + , testCase "Explicit input 8" $ mkTest input8 + ] test_flat :: TestTree -test_flat = testGroup "FlatProp" +test_flat = + testGroup + "FlatProp" [ test_deBruijnIso , test_fakeIso , test_deBruijnTripping @@ -227,6 +373,6 @@ initB = Binder $ DeBruijn deBruijnInitIndex -- orphans for QuickCheck generation deriving via Word64 instance Arbitrary DeBruijn instance Arbitrary FakeNamedDeBruijn where - arbitrary= toFake <$> arbitrary -- via debruijn + arbitrary = toFake <$> arbitrary -- via debruijn deriving newtype instance Arbitrary (Binder DeBruijn) deriving newtype instance Arbitrary (Binder FakeNamedDeBruijn) diff --git a/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs index 78460e2681f..3a9627e8ae3 100644 --- a/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs @@ -1,6 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -- | UPLC property tests (pretty-printing\/parsing and binary encoding\/decoding). module Generators.Spec where @@ -25,8 +25,8 @@ import PlutusCore.Pretty (displayPlc) import PlutusCore.Quote (runQuoteT) import PlutusCore.Test (isSerialisable) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testPropertyNamed) import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.Hedgehog (testPropertyNamed) import UntypedPlutusCore (Program) import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Core.Type (progTerm, termAnn) @@ -35,82 +35,92 @@ import UntypedPlutusCore.Parser (parseProgram, parseTerm) propFlat :: TestTree propFlat = testPropertyNamed "Flat" "Flat" $ property $ do - prog <- forAllPretty . runAstGen $ - regenConstantsUntil isSerialisable =<< genProgram @DefaultFun - tripping prog (flat . UPLC.UnrestrictedProgram) (fmap UPLC.unUnrestrictedProgram . unflat) + prog <- + forAllPretty . runAstGen $ + regenConstantsUntil isSerialisable =<< genProgram @DefaultFun + tripping prog (flat . UPLC.UnrestrictedProgram) (fmap UPLC.unUnrestrictedProgram . unflat) propParser :: TestTree propParser = testPropertyNamed "Parser" "parser" $ property $ do - prog <- forAllPretty (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) - tripping prog displayPlc (fmap void . parseProg) - where - parseProg - :: T.Text -> Either ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan) - parseProg = runQuoteT . parseProgram + prog <- forAllPretty (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram) + tripping prog displayPlc (fmap void . parseProg) + where + parseProg :: + T.Text -> Either ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan) + parseProg = runQuoteT . parseProgram -- | The `SrcSpan` of a parsed `Term` should not including trailing whitespaces. propTermSrcSpan :: TestTree propTermSrcSpan = testPropertyNamed - "parser captures ending positions correctly" - "propTermSrcSpan" - . property - $ do - code <- display <$> - forAllPretty (view progTerm <$> - runAstGen (regenConstantsUntil isSerialisable =<< genProgram @DefaultFun)) - annotateShow code - let (endingLine, endingCol) = length &&& T.length . last $ T.lines code - trailingSpaces <- forAllPretty $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n']) - case runQuoteT . parseTerm $ code <> trailingSpaces of - Right parsed -> - let sp = termAnn parsed - in (srcSpanELine sp, srcSpanECol sp) === (endingLine, endingCol + 1) - Left err -> annotate (display err) >> failure + "parser captures ending positions correctly" + "propTermSrcSpan" + . property + $ do + code <- + display + <$> forAllPretty + ( view progTerm + <$> runAstGen (regenConstantsUntil isSerialisable =<< genProgram @DefaultFun) + ) + annotateShow code + let (endingLine, endingCol) = length &&& T.length . last $ T.lines code + trailingSpaces <- forAllPretty $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n']) + case runQuoteT . parseTerm $ code <> trailingSpaces of + Right parsed -> + let sp = termAnn parsed + in (srcSpanELine sp, srcSpanECol sp) === (endingLine, endingCol + 1) + Left err -> annotate (display err) >> failure propUnit :: TestTree -propUnit = testCase "Unit" $ fold - [ pTerm "(con bool True)" - @?= "(con bool True)" - , pTerm "(con (list bool) [True, False])" - @?= "(con (list bool) [True,False])" - , pTerm "(con (pair unit (list integer)) ((),[1,2,3]))" - @?= "(con (pair unit (list integer)) ((), [1,2,3]))" - , pTerm "(con (list (pair string bool)) [(\"abc\", True), (\"def\", False)])" - @?= "(con (list (pair string bool)) [(\"abc\", True), (\"def\", False)])" - , pTerm "(con string \"abc\")" - @?= "(con string \"abc\")" - ] - where - pTerm :: String -> Text - pTerm - = either (error . display) display - . runQuoteT - . parseTerm - . T.pack +propUnit = + testCase "Unit" $ + fold + [ pTerm "(con bool True)" + @?= "(con bool True)" + , pTerm "(con (list bool) [True, False])" + @?= "(con (list bool) [True,False])" + , pTerm "(con (pair unit (list integer)) ((),[1,2,3]))" + @?= "(con (pair unit (list integer)) ((), [1,2,3]))" + , pTerm "(con (list (pair string bool)) [(\"abc\", True), (\"def\", False)])" + @?= "(con (list (pair string bool)) [(\"abc\", True), (\"def\", False)])" + , pTerm "(con string \"abc\")" + @?= "(con string \"abc\")" + ] + where + pTerm :: String -> Text + pTerm = + either (error . display) display + . runQuoteT + . parseTerm + . T.pack propDefaultUni :: TestTree -propDefaultUni = testCase "DefaultUni" $ fold - [ pDefaultUni "bool" @?= "bool" - , pDefaultUni "list" @?= "list" - , pDefaultUni "(list integer)" @?= "(list integer)" - , pDefaultUni "(pair (list bool))" @?= "(pair (list bool))" - , pDefaultUni "(pair (list unit) integer)" @?= "(pair (list unit) integer)" - , pDefaultUni "(list (pair unit integer))" @?= "(list (pair unit integer))" - , pDefaultUni "(pair unit (pair bool integer))" @?= "(pair unit (pair bool integer))" - ] - where - pDefaultUni :: String -> Text - pDefaultUni - = either (error . display) display - . runQuoteT - . parseGen defaultUni - . T.pack +propDefaultUni = + testCase "DefaultUni" $ + fold + [ pDefaultUni "bool" @?= "bool" + , pDefaultUni "list" @?= "list" + , pDefaultUni "(list integer)" @?= "(list integer)" + , pDefaultUni "(pair (list bool))" @?= "(pair (list bool))" + , pDefaultUni "(pair (list unit) integer)" @?= "(pair (list unit) integer)" + , pDefaultUni "(list (pair unit integer))" @?= "(list (pair unit integer))" + , pDefaultUni "(pair unit (pair bool integer))" @?= "(pair unit (pair bool integer))" + ] + where + pDefaultUni :: String -> Text + pDefaultUni = + either (error . display) display + . runQuoteT + . parseGen defaultUni + . T.pack test_parsing :: TestTree -test_parsing = testGroup "Parsing" - [ propFlat - , propParser - , propTermSrcSpan - , propUnit - , propDefaultUni - ] +test_parsing = + testGroup + "Parsing" + [ propFlat + , propParser + , propTermSrcSpan + , propUnit + , propDefaultUni + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs index a5955bd81da..e6ebc860741 100644 --- a/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Scoping.Spec where @@ -22,25 +22,25 @@ import PlutusCore.Test qualified as T import Hedgehog import Hedgehog.Gen qualified as Gen import Test.Tasty -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog test_mangle :: TestTree test_mangle = testPropertyNamed "equality does not survive mangling" "equality_mangling" $ - withDiscards 1000000 . T.mapTestLimitAtLeast 300 (`div` 3) . property $ do - (term, termMangled) <- forAll . runAstGen . Gen.justT $ do - term <- genTerm - mayTermMang <- mangleNames term - pure $ (,) term <$> mayTermMang - term /== termMangled - termMangled /== term + withDiscards 1000000 . T.mapTestLimitAtLeast 300 (`div` 3) . property $ do + (term, termMangled) <- forAll . runAstGen . Gen.justT $ do + term <- genTerm + mayTermMang <- mangleNames term + pure $ (,) term <$> mayTermMang + term /== termMangled + termMangled /== term -- | Test equality of a program and its renamed version, given a renamer. -prop_equalityFor - :: program ~ Program Name DefaultUni DefaultFun () - => (program -> Quote program) - -> Property +prop_equalityFor :: + program ~ Program Name DefaultUni DefaultFun () => + (program -> Quote program) -> + Property prop_equalityFor ren = property $ do prog <- forAllPretty $ runAstGen genProgram let progRen = runQuote $ ren prog @@ -66,44 +66,59 @@ test_equalityNoMarkRename = -- See Note [Scoping tests API]. test_names :: TestTree -test_names = testGroup "names" - [ T.test_scopingGood "renaming" (genProgram @DefaultFun) T.BindingRemovalNotOk T.PrerenameNo +test_names = + testGroup + "names" + [ T.test_scopingGood + "renaming" + (genProgram @DefaultFun) + T.BindingRemovalNotOk + T.PrerenameNo rename - , T.test_scopingSpoilRenamer (genProgram @DefaultFun) markNonFreshProgram + , T.test_scopingSpoilRenamer + (genProgram @DefaultFun) + markNonFreshProgram renameProgramM - -- We don't test case-of-case, because it duplicates binders and we don't support that in the - -- scoping tests machinery. - , T.test_scopingGood "case-of-known-constructor" + , -- We don't test case-of-case, because it duplicates binders and we don't support that in the + -- scoping tests machinery. + T.test_scopingGood + "case-of-known-constructor" (genTerm @DefaultFun) - T.BindingRemovalOk -- COKC removes branches, which may (and likely do) contain bindings. + T.BindingRemovalOk -- COKC removes branches, which may (and likely do) contain bindings. T.PrerenameYes (evalSimplifierT . caseReduce) , -- CSE creates entirely new names, which isn't supported by the scoping check machinery. - T.test_scopingBad "cse" + T.test_scopingBad + "cse" (genTerm @DefaultFun) T.BindingRemovalOk T.PrerenameYes (evalSimplifierT . cse maxBound) - , T.test_scopingGood "float-delay" + , T.test_scopingGood + "float-delay" (genTerm @DefaultFun) T.BindingRemovalNotOk T.PrerenameNo (evalSimplifierT . floatDelay) - , T.test_scopingGood "force-delay" + , T.test_scopingGood + "force-delay" (genTerm @DefaultFun) T.BindingRemovalNotOk T.PrerenameYes (evalSimplifierT . forceDelay maxBound) - , T.test_scopingGood "inline" + , T.test_scopingGood + "inline" (genTerm @DefaultFun) T.BindingRemovalOk T.PrerenameYes - (evalSimplifierT . - inline 0 - True - (_soPreserveLogging defaultSimplifyOpts) - (_soInlineHints defaultSimplifyOpts) - maxBound ) + ( evalSimplifierT + . inline + 0 + True + (_soPreserveLogging defaultSimplifyOpts) + (_soInlineHints defaultSimplifyOpts) + maxBound + ) , test_mangle , test_equalityRename , test_equalityBrokenRename diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs index 17d1f4001e3..983ca521b4a 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Transform.CaseOfCase.Spec where @@ -9,10 +9,15 @@ import Data.Text.Encoding (encodeUtf8) import Data.Vector qualified as V import PlutusCore qualified as PLC import PlutusCore.Evaluation.Machine.BuiltinCostModel (BuiltinCostModel) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModelForTesting, - defaultCekMachineCostsForTesting) -import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..), MachineParameters (..), - mkMachineVariantParameters) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults ( + defaultBuiltinCostModelForTesting, + defaultCekMachineCostsForTesting, + ) +import PlutusCore.Evaluation.Machine.MachineParameters ( + CostModel (..), + MachineParameters (..), + mkMachineVariantParameters, + ) import PlutusCore.Evaluation.Machine.MachineParameters.Default (DefaultMachineParameters) import PlutusCore.MkPlc (mkConstant, mkIterApp) import PlutusCore.Pretty @@ -23,9 +28,13 @@ import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit (testCase, (@?=)) import UntypedPlutusCore (DefaultFun, DefaultUni, Name, Term (..)) import UntypedPlutusCore.Core qualified as UPLC -import UntypedPlutusCore.Evaluation.Machine.Cek (CekMachineCosts, EvaluationResult (..), - evaluateCek, noEmitter, - unsafeSplitStructuralOperational) +import UntypedPlutusCore.Evaluation.Machine.Cek ( + CekMachineCosts, + EvaluationResult (..), + evaluateCek, + noEmitter, + unsafeSplitStructuralOperational, + ) import UntypedPlutusCore.Transform.CaseOfCase (caseOfCase) import UntypedPlutusCore.Transform.Simplifier (evalSimplifier) @@ -49,10 +58,9 @@ caseOfCase1 = runQuote do alts = V.fromList [mkConstant @Integer () 1, mkConstant @Integer () 2] pure $ Case () (mkIterApp ite [((), Var () b), ((), true), ((), false)]) alts -{- | This should not simplify, because one of the branches of `ifThenElse` is not a `Constr`. -Unless both branches are known constructors, the case-of-case transformation -may increase the program size. --} +-- | This should not simplify, because one of the branches of `ifThenElse` is not a `Constr`. +-- Unless both branches are known constructors, the case-of-case transformation +-- may increase the program size. caseOfCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun () caseOfCase2 = runQuote do b <- freshName "b" @@ -63,9 +71,8 @@ caseOfCase2 = runQuote do alts = V.fromList [mkConstant @Integer () 1, mkConstant @Integer () 2] pure $ Case () (mkIterApp ite [((), Var () b), ((), true), ((), false)]) alts -{- | Similar to `caseOfCase1`, but the type of the @true@ and @false@ branches is -@[Integer]@ rather than Bool (note that @Constr 0@ has two parameters, @x@ and @xs@). --} +-- | Similar to `caseOfCase1`, but the type of the @true@ and @false@ branches is +-- @[Integer]@ rather than Bool (note that @Constr 0@ has two parameters, @x@ and @xs@). caseOfCase3 :: Term Name PLC.DefaultUni PLC.DefaultFun () caseOfCase3 = runQuote do b <- freshName "b" @@ -80,23 +87,22 @@ caseOfCase3 = runQuote do alts = V.fromList [altTrue, altFalse] pure $ Case () (mkIterApp ite [((), Var () b), ((), true), ((), false)]) alts -{- | - -@ - case (force ifThenElse) True True False of - True -> () - False -> _|_ -@ - -Evaluates to `()` because the first case alternative is selected. -(The _|_ is not evaluated because case alternatives are evaluated lazily). - -After the `CaseOfCase` transformation the program should evaluate to `()` as well. - -@ - force ((force ifThenElse) True (delay ()) (delay _|_)) -@ --} +-- | +-- +-- @ +-- case (force ifThenElse) True True False of +-- True -> () +-- False -> _|_ +-- @ +-- +-- Evaluates to `()` because the first case alternative is selected. +-- (The _|_ is not evaluated because case alternatives are evaluated lazily). +-- +-- After the `CaseOfCase` transformation the program should evaluate to `()` as well. +-- +-- @ +-- force ((force ifThenElse) True (delay ()) (delay _|_)) +-- @ caseOfCaseWithError :: Term Name DefaultUni DefaultFun () caseOfCaseWithError = Case @@ -119,22 +125,22 @@ testCaseOfCaseWithError = ---------------------------------------------------------------------------------------------------- -- Helper functions -------------------------------------------------------------------------------- -evalCaseOfCase - :: Term Name DefaultUni DefaultFun () - -> Term Name DefaultUni DefaultFun () +evalCaseOfCase :: + Term Name DefaultUni DefaultFun () -> + Term Name DefaultUni DefaultFun () evalCaseOfCase term = evalSimplifier $ caseOfCase term -evaluateUplc - :: UPLC.Term Name DefaultUni DefaultFun () - -> EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()) +evaluateUplc :: + UPLC.Term Name DefaultUni DefaultFun () -> + EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()) evaluateUplc = unsafeSplitStructuralOperational . fst <$> evaluateCek noEmitter machineParameters - where - costModel :: CostModel CekMachineCosts BuiltinCostModel - costModel = + where + costModel :: CostModel CekMachineCosts BuiltinCostModel + costModel = CostModel defaultCekMachineCostsForTesting defaultBuiltinCostModelForTesting - machineParameters :: DefaultMachineParameters - machineParameters = + machineParameters :: DefaultMachineParameters + machineParameters = -- TODO: proper semantic variant. What should def be? MachineParameters def $ mkMachineVariantParameters def costModel diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs index 7cc8631cc5f..464349bfb81 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Transform.Inline.Spec where @@ -16,11 +16,19 @@ import PlutusCore.Quote (runQuote) import PlutusPrelude (def) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, testCase) -import UntypedPlutusCore.Core (Term (..)) import UntypedPlutusCore.AstSize (AstSize (..)) -import UntypedPlutusCore.Transform.Inline (InlineHints (..), InlineInfo (..), InlineM, S (..), - Subst (..), TermEnv (..), effectSafe, - isFirstVarBeforeEffects, isStrictIn) +import UntypedPlutusCore.Core (Term (..)) +import UntypedPlutusCore.Transform.Inline ( + InlineHints (..), + InlineInfo (..), + InlineM, + S (..), + Subst (..), + TermEnv (..), + effectSafe, + isFirstVarBeforeEffects, + isStrictIn, + ) test_inline :: TestTree test_inline = @@ -56,19 +64,19 @@ testVarBeforeAfterEffects = do isFirstVarBeforeEffects def b term assertBool "c is not evaluated before effects" $ not do isFirstVarBeforeEffects def c term - where - term :: Term Name DefaultUni DefaultFun () - term = - {- Evaluation order: - - 1. pure work-free: a - 2. pure work-free: b - 3. impure? maybe work?: addInteger a b - 4. pure work-free: c - 5. impure? maybe work?: addInteger (addInteger a b) c - -} - addInteger (addInteger (var a) (var b)) (var c) - (a, b, c, _) = makeUniqueNames + where + term :: Term Name DefaultUni DefaultFun () + term = + {- Evaluation order: + + 1. pure work-free: a + 2. pure work-free: b + 3. impure? maybe work?: addInteger a b + 4. pure work-free: c + 5. impure? maybe work?: addInteger (addInteger a b) c + -} + addInteger (addInteger (var a) (var b)) (var c) + (a, b, c, _) = makeUniqueNames testVarIsEventuallyEvaluatedDelay :: Assertion testVarIsEventuallyEvaluatedDelay = do @@ -78,11 +86,11 @@ testVarIsEventuallyEvaluatedDelay = do isStrictIn b term assertBool "it's not known if var 'c' is eventually evaluated" $ not (isStrictIn c term) - where - term :: Term Name DefaultUni DefaultFun () - term = delay (var a `addInteger` var b) `addInteger` var b + where + term :: Term Name DefaultUni DefaultFun () + term = delay (var a `addInteger` var b) `addInteger` var b - (a, b, c, _) = makeUniqueNames + (a, b, c, _) = makeUniqueNames testVarIsEventuallyEvaluatedLambda :: Assertion testVarIsEventuallyEvaluatedLambda = do @@ -92,11 +100,11 @@ testVarIsEventuallyEvaluatedLambda = do isStrictIn c term assertBool "it's not known if var 'd' is eventually evaluated" $ not (isStrictIn d term) - where - term :: Term Name DefaultUni DefaultFun () - term = lam b (var a `addInteger` var c) `app` var c + where + term :: Term Name DefaultUni DefaultFun () + term = lam b (var a `addInteger` var c) `app` var c - (a, b, c, d) = makeUniqueNames + (a, b, c, d) = makeUniqueNames testVarIsEventuallyEvaluatedCaseBranch :: Assertion testVarIsEventuallyEvaluatedCaseBranch = do @@ -106,11 +114,11 @@ testVarIsEventuallyEvaluatedCaseBranch = do isStrictIn b term assertBool "it is not known if var 'd' is eventually evaluated" $ not (isStrictIn d term) - where - term :: Term Name DefaultUni DefaultFun () - term = case_ (var b) [var a, var b, var c] + where + term :: Term Name DefaultUni DefaultFun () + term = case_ (var b) [var a, var b, var c] - (a, b, c, d) = makeUniqueNames + (a, b, c, d) = makeUniqueNames testEffectSafePreservedLogs :: Assertion testEffectSafePreservedLogs = do @@ -118,11 +126,11 @@ testEffectSafePreservedLogs = do runInlineWithLogging (not <$> effectSafe term c False) assertBool "a var before effects is \"effect safe\"" $ runInlineWithLogging (effectSafe term a False) - where - term :: Term Name DefaultUni DefaultFun () - term = (var a `addInteger` var b) `addInteger` var c + where + term :: Term Name DefaultUni DefaultFun () + term = (var a `addInteger` var b) `addInteger` var c - (a, b, c, _) = makeUniqueNames + (a, b, c, _) = makeUniqueNames testEffectSafeWithoutPreservedLogs :: Assertion testEffectSafeWithoutPreservedLogs = do @@ -130,11 +138,11 @@ testEffectSafeWithoutPreservedLogs = do runInlineWithoutLogging (effectSafe term c False) assertBool "a var before effects is \"effect safe\"" $ runInlineWithoutLogging (effectSafe term a False) - where - term :: Term Name DefaultUni DefaultFun () - term = (var a `addInteger` var b) `addInteger` var c + where + term :: Term Name DefaultUni DefaultFun () + term = (var a `addInteger` var b) `addInteger` var c - (a, b, c, _) = makeUniqueNames + (a, b, c, _) = makeUniqueNames -------------------------------------------------------------------------------- -- InlineM runner -------------------------------------------------------------- @@ -147,21 +155,21 @@ runInlineWithLogging = runInlineM True runInlineM :: Bool -> InlineM Name DefaultUni DefaultFun () r -> r runInlineM preserveLogging m = result - where - (result, _finalState) = - runQuote (runStateT (runReaderT m inlineInfo) initialState) - inlineInfo :: InlineInfo Name DefaultFun () - inlineInfo = - InlineInfo - { _iiUsages = mempty - , _iiHints = InlineHints \_ann _name -> MayInline - , _iiBuiltinSemanticsVariant = def - , _iiInlineConstants = True - , _iiInlineCallsiteGrowth = AstSize 1_000_000 - , _iiPreserveLogging = preserveLogging - } - initialState :: S Name DefaultUni DefaultFun () - initialState = S{_subst = Subst (TermEnv mempty), _vars = mempty} + where + (result, _finalState) = + runQuote (runStateT (runReaderT m inlineInfo) initialState) + inlineInfo :: InlineInfo Name DefaultFun () + inlineInfo = + InlineInfo + { _iiUsages = mempty + , _iiHints = InlineHints \_ann _name -> MayInline + , _iiBuiltinSemanticsVariant = def + , _iiInlineConstants = True + , _iiInlineCallsiteGrowth = AstSize 1_000_000 + , _iiPreserveLogging = preserveLogging + } + initialState :: S Name DefaultUni DefaultFun () + initialState = S {_subst = Subst (TermEnv mempty), _vars = mempty} -------------------------------------------------------------------------------- -- UPLC Term constructors ------------------------------------------------------ diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs index 374899b409b..5dd662992ef 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs @@ -11,12 +11,21 @@ import PlutusCore.Pretty (PrettyPlc, Render (render), prettyPlcReadableSimple) import PlutusPrelude (Default (def)) import Test.Tasty (TestTree) import Test.Tasty.Golden (goldenVsString) -import UntypedPlutusCore (Name, SimplifierTrace, Term, defaultSimplifyOpts, runSimplifierT, - soInlineCallsiteGrowth, soMaxCseIterations, soMaxSimplifierIterations, - soPreserveLogging, termSimplifier) +import UntypedPlutusCore ( + Name, + SimplifierTrace, + Term, + defaultSimplifyOpts, + runSimplifierT, + soInlineCallsiteGrowth, + soMaxCseIterations, + soMaxSimplifierIterations, + soPreserveLogging, + termSimplifier, + ) -- TODO Fix duplication with other golden tests, quite annoying -goldenVsPretty :: (PrettyPlc a) => String -> String -> a -> TestTree +goldenVsPretty :: PrettyPlc a => String -> String -> a -> TestTree goldenVsPretty extn name value = goldenVsString name ("untyped-plutus-core/test/Transform/" ++ name ++ extn) $ pure . BSL.fromStrict . encodeUtf8 . render $ @@ -29,14 +38,14 @@ goldenVsSimplified name = . fmap fst . testSimplify -testSimplify - :: Term Name PLC.DefaultUni PLC.DefaultFun () - -> PLC.Quote - ( Term Name PLC.DefaultUni PLC.DefaultFun () - , SimplifierTrace Name PLC.DefaultUni PLC.DefaultFun () - ) +testSimplify :: + Term Name PLC.DefaultUni PLC.DefaultFun () -> + PLC.Quote + ( Term Name PLC.DefaultUni PLC.DefaultFun () + , SimplifierTrace Name PLC.DefaultUni PLC.DefaultFun () + ) testSimplify = - runSimplifierT + runSimplifierT . termSimplifier ( defaultSimplifyOpts -- Just run one iteration, to see what that does @@ -54,14 +63,14 @@ goldenVsCse name = . fmap fst . testCse -testCse - :: Term Name PLC.DefaultUni PLC.DefaultFun () - -> PLC.Quote - ( Term Name PLC.DefaultUni PLC.DefaultFun () - , SimplifierTrace Name PLC.DefaultUni PLC.DefaultFun () - ) +testCse :: + Term Name PLC.DefaultUni PLC.DefaultFun () -> + PLC.Quote + ( Term Name PLC.DefaultUni PLC.DefaultFun () + , SimplifierTrace Name PLC.DefaultUni PLC.DefaultFun () + ) testCse = - runSimplifierT + runSimplifierT . termSimplifier ( defaultSimplifyOpts -- Just run one iteration, to see what that does diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs index 449ff9ddd17..e52a455ae90 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Transform.Simplify.Spec where @@ -38,10 +38,9 @@ caseOfCase1 = runQuote $ do alts = V.fromList [mkConstant @Integer () 1, mkConstant @Integer () 2] pure $ Case () (mkIterApp ite [((), Var () b), ((), true), ((), false)]) alts -{- | This should not simplify, because one of the branches of `ifThenElse` is not a `Constr`. -Unless both branches are known constructors, the case-of-case transformation -may increase the program size. --} +-- | This should not simplify, because one of the branches of `ifThenElse` is not a `Constr`. +-- Unless both branches are known constructors, the case-of-case transformation +-- may increase the program size. caseOfCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun () caseOfCase2 = runQuote $ do b <- freshName "b" @@ -52,9 +51,8 @@ caseOfCase2 = runQuote $ do alts = V.fromList [mkConstant @Integer () 1, mkConstant @Integer () 2] pure $ Case () (mkIterApp ite [((), Var () b), ((), true), ((), false)]) alts -{- | Similar to `caseOfCase1`, but the type of the @true@ and @false@ branches is -@[Integer]@ rather than Bool (note that @Constr 0@ has two parameters, @x@ and @xs@). --} +-- | Similar to `caseOfCase1`, but the type of the @true@ and @false@ branches is +-- @[Integer]@ rather than Bool (note that @Constr 0@ has two parameters, @x@ and @xs@). caseOfCase3 :: Term Name PLC.DefaultUni PLC.DefaultFun () caseOfCase3 = runQuote $ do b <- freshName "b" @@ -81,9 +79,8 @@ floatDelay1 = runQuote $ do lam = LamAbs () a body pure $ Apply () lam (Delay () (mkConstant @Integer () 1)) -{- | The `Delay` should not be floated into the lambda, because the argument (1 + 2) -is not work-free. --} +-- | The `Delay` should not be floated into the lambda, because the argument (1 + 2) +-- is not work-free. floatDelay2 :: Term Name PLC.DefaultUni PLC.DefaultFun () floatDelay2 = runQuote $ do a <- freshName "a" @@ -100,10 +97,9 @@ floatDelay2 = runQuote $ do (mkConstant @Integer () 2) pure $ Apply () lam (Delay () arg) -{- | The `Delay` should not be floated into the lambda in the first simplifier iteration, -because one of the occurrences of `a` is not under `Force`. It should be floated into -the lambda in the second simplifier iteration, after `b` is inlined. --} +-- | The `Delay` should not be floated into the lambda in the first simplifier iteration, +-- because one of the occurrences of `a` is not under `Force`. It should be floated into +-- the lambda in the second simplifier iteration, after `b` is inlined. floatDelay3 :: Term Name PLC.DefaultUni PLC.DefaultFun () floatDelay3 = runQuote $ do a <- freshName "a" @@ -123,9 +119,9 @@ basicInline = runQuote $ do -- a 'Quote' that produces a term together with a list of free variables. -- The free variables are bound at the top level of the final term in order -- to ensure that the produced final term is well-scoped. -mkInlinePurityTest - :: Quote ([Name], Term Name PLC.DefaultUni PLC.DefaultFun ()) - -> Term Name PLC.DefaultUni PLC.DefaultFun () +mkInlinePurityTest :: + Quote ([Name], Term Name PLC.DefaultUni PLC.DefaultFun ()) -> + Term Name PLC.DefaultUni PLC.DefaultFun () mkInlinePurityTest termToInline = runQuote $ do a <- freshName "a" b <- freshName "b" @@ -135,9 +131,9 @@ mkInlinePurityTest termToInline = runQuote $ do let withTopLevelBindings = mkIterLamAbs (UVarDecl () <$> freeVars) - pure - $ withTopLevelBindings - $ Apply () (LamAbs () a $ LamAbs () b $ Var () a) term + pure $ + withTopLevelBindings $ + Apply () (LamAbs () a $ LamAbs () b $ Var () a) term -- | A single @Var@ is pure. inlinePure1 :: Term Name PLC.DefaultUni PLC.DefaultFun () @@ -145,22 +141,20 @@ inlinePure1 = mkInlinePurityTest $ do a <- freshName "a" pure ([a], Var () a) -{- | @force (delay a)@ is pure. - -Note that this relies on @forceDelayCancel@ to cancel the @force@ and the @delay@, -otherwise the inliner would treat the term as impure. --} +-- | @force (delay a)@ is pure. +-- +-- Note that this relies on @forceDelayCancel@ to cancel the @force@ and the @delay@, +-- otherwise the inliner would treat the term as impure. inlinePure2 :: Term Name PLC.DefaultUni PLC.DefaultFun () inlinePure2 = mkInlinePurityTest $ do a <- freshName "a" pure ([a], Force () $ Delay () $ Var () a) -{- | @[(\x -> \y -> [x x]) (con integer 1)]@ is pure. - -Note that the @(con integer 1)@ won't get inlined: it isn't pre-inlined because -@x@ occurs twice, and it isn't post-inlined because @costIsAcceptable Constant{} = False@. -However, the entire term will be inlined since it is pure. --} +-- | @[(\x -> \y -> [x x]) (con integer 1)]@ is pure. +-- +-- Note that the @(con integer 1)@ won't get inlined: it isn't pre-inlined because +-- @x@ occurs twice, and it isn't post-inlined because @costIsAcceptable Constant{} = False@. +-- However, the entire term will be inlined since it is pure. inlinePure3 :: Term Name PLC.DefaultUni PLC.DefaultFun () inlinePure3 = mkInlinePurityTest $ do x <- freshName "x" @@ -173,20 +167,19 @@ inlinePure3 = mkInlinePurityTest $ do vars = [] pure (vars, t) -{- | @force ([(\x -> delay (\y -> [x x])) (delay ([error (con integer 1)]))])@ is pure, -but it is very tricky to see so. It requires us to match up a force and a -delay through several steps of intervening computation. --} +-- | @force ([(\x -> delay (\y -> [x x])) (delay ([error (con integer 1)]))])@ is pure, +-- but it is very tricky to see so. It requires us to match up a force and a +-- delay through several steps of intervening computation. inlinePure4 :: Term Name PLC.DefaultUni PLC.DefaultFun () inlinePure4 = mkInlinePurityTest $ do x <- freshName "x" y <- freshName "y" let term = - Force () - $ Apply - () - (LamAbs () x $ Delay () $ LamAbs () y $ Apply () (Var () x) (Var () x)) - (Delay () $ Apply () (Error ()) $ mkConstant @Integer () 1) + Force () $ + Apply + () + (LamAbs () x $ Delay () $ LamAbs () y $ Apply () (Var () x) (Var () x)) + (Delay () $ Apply () (Error ()) $ mkConstant @Integer () 1) pure ([], term) -- | @error@ is impure. @@ -197,47 +190,44 @@ inlineImpure1 = mkInlinePurityTest $ pure ([], Error ()) inlineImpure2 :: Term Name PLC.DefaultUni PLC.DefaultFun () inlineImpure2 = mkInlinePurityTest $ pure ([], Force () . Delay () $ Error ()) -{- | @force (force (force (delay (delay (delay (error))))))@ is impure, since it -is the same as @error@. --} +-- | @force (force (force (delay (delay (delay (error))))))@ is impure, since it +-- is the same as @error@. inlineImpure3 :: Term Name PLC.DefaultUni PLC.DefaultFun () inlineImpure3 = - mkInlinePurityTest - $ pure + mkInlinePurityTest $ + pure ( [] , Force () - . Force () - . Force () - . Delay () - . Delay () - . Delay () - $ Error () + . Force () + . Force () + . Delay () + . Delay () + . Delay () + $ Error () ) -{- | @force (force (force (delay (delay a))))@ is impure, since @a@ may expand -to an impure term such as @error@. --} +-- | @force (force (force (delay (delay a))))@ is impure, since @a@ may expand +-- to an impure term such as @error@. inlineImpure4 :: Term Name PLC.DefaultUni PLC.DefaultFun () inlineImpure4 = mkInlinePurityTest $ do a <- freshName "a" let term = Force () - . Force () - . Force () - . Delay () - . Delay () - . Var () - $ a + . Force () + . Force () + . Delay () + . Delay () + . Var () + $ a pure ([a], term) -{- | @(\a -> f (a 0 1) (a 2)) (\x y -> g x y)@ - -The first occurrence of `a` should be inlined because doing so does not increase -the size or the cost. - -The second occurrence of `a` should be unconditionally inlined in the second simplifier -iteration, but in this test we are only running one iteration. --} +-- | @(\a -> f (a 0 1) (a 2)) (\x y -> g x y)@ +-- +-- The first occurrence of `a` should be inlined because doing so does not increase +-- the size or the cost. +-- +-- The second occurrence of `a` should be unconditionally inlined in the second simplifier +-- iteration, but in this test we are only running one iteration. callsiteInline :: Term Name PLC.DefaultUni PLC.DefaultFun () callsiteInline = runQuote $ do a <- freshName "a" @@ -283,14 +273,13 @@ forceDelayNoAppsLayered = runQuote $ do term = Force () $ Force () $ Force () $ Delay () $ Delay () $ Delay () one pure term -{- | The UPLC term in this test should come from the following TPLC term after erasing its types: - -> (/\(p :: *) -> \(x : p) -> /\(q :: *) -> \(y : q) -> /\(r :: *) -> \(z : r) -> z) -> Int 1 Int 2 Int 3 - -This case is simple in the sense that each type abstraction -is followed by a single term abstraction. --} +-- | The UPLC term in this test should come from the following TPLC term after erasing its types: +-- +-- > (/\(p :: *) -> \(x : p) -> /\(q :: *) -> \(y : q) -> /\(r :: *) -> \(z : r) -> z) +-- > Int 1 Int 2 Int 3 +-- +-- This case is simple in the sense that each type abstraction +-- is followed by a single term abstraction. forceDelaySimple :: Term Name PLC.DefaultUni PLC.DefaultFun () forceDelaySimple = runQuote $ do x <- freshName "x" @@ -303,9 +292,8 @@ forceDelaySimple = runQuote $ do app = Apply () (Force () (Apply () (Force () (Apply () (Force () t) one)) two)) three pure app -{- | A test for the case when there are multiple applications between the 'Force' at the top -and the 'Delay' at the top of the term inside the abstractions/applications. --} +-- | A test for the case when there are multiple applications between the 'Force' at the top +-- and the 'Delay' at the top of the term inside the abstractions/applications. forceDelayMultiApply :: Term Name PLC.DefaultUni PLC.DefaultFun () forceDelayMultiApply = runQuote $ do x1 <- freshName "x1" @@ -317,22 +305,21 @@ forceDelayMultiApply = runQuote $ do two = mkConstant @Integer () 2 three = mkConstant @Integer () 3 term = - LamAbs () funcVar - $ Force () - $ mkIterAppNoAnn - ( LamAbs () x1 $ - LamAbs () x2 $ - LamAbs () x3 $ - LamAbs () f $ - Delay () $ - mkIterAppNoAnn (Var () f) [Var () x1, Var () x2, Var () x3] - ) - [one, two, three, Var () funcVar] + LamAbs () funcVar $ + Force () $ + mkIterAppNoAnn + ( LamAbs () x1 $ + LamAbs () x2 $ + LamAbs () x3 $ + LamAbs () f $ + Delay () $ + mkIterAppNoAnn (Var () f) [Var () x1, Var () x2, Var () x3] + ) + [one, two, three, Var () funcVar] pure term -{- | A test for the case when there are multiple type abstractions over a single term -abstraction/application. --} +-- | A test for the case when there are multiple type abstractions over a single term +-- abstraction/application. forceDelayMultiForce :: Term Name PLC.DefaultUni PLC.DefaultFun () forceDelayMultiForce = runQuote $ do x <- freshName "x" @@ -352,18 +339,17 @@ forceDelayMultiForce = runQuote $ do one pure term -{- | The UPLC term in this test should come from the following TPLC term after erasing its types: - -> (/\(p1 :: *) (p2 :: *) -> \(x : p2) -> -> /\(q1 :: *) (q2 :: *) (q3 :: *) -> \(y1 : q1) (y2 : q2) (y3 : String) -> -> /\(r :: *) -> \(z1 : r) -> \(z2 : r) -> -> /\(t :: *) -> \(f : p1 -> q1 -> q2 -> String -> r -> r -> String) -> -> f x y1 y2 y3 z1 z2 -> ) Int Int 1 Int String Int 2 "foo" "bar" Int 3 3 ByteString -> (funcVar : Int -> Int -> String -> String -> Int -> String) - -Note this term has multiple interleaved type and term instantiations/applications. --} +-- | The UPLC term in this test should come from the following TPLC term after erasing its types: +-- +-- > (/\(p1 :: *) (p2 :: *) -> \(x : p2) -> +-- > /\(q1 :: *) (q2 :: *) (q3 :: *) -> \(y1 : q1) (y2 : q2) (y3 : String) -> +-- > /\(r :: *) -> \(z1 : r) -> \(z2 : r) -> +-- > /\(t :: *) -> \(f : p1 -> q1 -> q2 -> String -> r -> r -> String) -> +-- > f x y1 y2 y3 z1 z2 +-- > ) Int Int 1 Int String Int 2 "foo" "bar" Int 3 3 ByteString +-- > (funcVar : Int -> Int -> String -> String -> Int -> String) +-- +-- Note this term has multiple interleaved type and term instantiations/applications. forceDelayComplex :: Term Name PLC.DefaultUni PLC.DefaultFun () forceDelayComplex = runQuote $ do x <- freshName "x" @@ -404,26 +390,26 @@ forceDelayComplex = runQuote $ do , Var () z2 ] app = - LamAbs () funcVar - $ Apply - () - ( Force () $ - mkIterAppNoAnn - ( Force () $ - mkIterAppNoAnn - ( Force () $ - Force () $ + LamAbs () funcVar $ + Apply + () + ( Force () $ + mkIterAppNoAnn + ( Force () $ + mkIterAppNoAnn + ( Force () $ Force () $ - Apply - () - (Force () $ Force () term) - one - ) - [two, foo, bar] - ) - [three, three] - ) - (Var () funcVar) + Force () $ + Apply + () + (Force () $ Force () term) + one + ) + [two, foo, bar] + ) + [three, three] + ) + (Var () funcVar) pure app forceCaseDelayNoApps1 :: Term Name PLC.DefaultUni PLC.DefaultFun () @@ -431,9 +417,9 @@ forceCaseDelayNoApps1 = runQuote $ do scrut <- freshName "scrut" let one = mkConstant @Integer () 1 term = - LamAbs () scrut - $ Force () - $ Case () (Var () scrut) (V.fromList [Delay () one]) + LamAbs () scrut $ + Force () $ + Case () (Var () scrut) (V.fromList [Delay () one]) pure term forceCaseDelayWithApps1 :: Term Name PLC.DefaultUni PLC.DefaultFun () @@ -442,11 +428,12 @@ forceCaseDelayWithApps1 = runQuote $ do x <- freshName "x" let one = mkConstant @Integer () 1 term = - LamAbs () scrut - $ Force () - $ Case () - (Var () scrut) - (V.fromList [LamAbs () x $ Delay () one]) + LamAbs () scrut $ + Force () $ + Case + () + (Var () scrut) + (V.fromList [LamAbs () x $ Delay () one]) pure term forceCaseDelayNoApps2 :: Term Name PLC.DefaultUni PLC.DefaultFun () @@ -455,11 +442,12 @@ forceCaseDelayNoApps2 = runQuote $ do let one = mkConstant @Integer () 1 two = mkConstant @Integer () 2 term = - LamAbs () scrut - $ Force () - $ Case () - (Var () scrut) - (V.fromList [Delay () one, Delay () two]) + LamAbs () scrut $ + Force () $ + Case + () + (Var () scrut) + (V.fromList [Delay () one, Delay () two]) pure term forceCaseDelayWithApps2 :: Term Name PLC.DefaultUni PLC.DefaultFun () @@ -469,11 +457,12 @@ forceCaseDelayWithApps2 = runQuote $ do let one = mkConstant @Integer () 1 two = mkConstant @Integer () 2 term = - LamAbs () scrut - $ Force () - $ Case () - (Var () scrut) - (V.fromList [LamAbs () x $ Delay () one, Delay () two]) + LamAbs () scrut $ + Force () $ + Case + () + (Var () scrut) + (V.fromList [LamAbs () x $ Delay () one, Delay () two]) pure term forceCaseDelayNoApps2Fail :: Term Name PLC.DefaultUni PLC.DefaultFun () @@ -482,11 +471,12 @@ forceCaseDelayNoApps2Fail = runQuote $ do let one = mkConstant @Integer () 1 two = mkConstant @Integer () 2 term = - LamAbs () scrut - $ Force () - $ Case () - (Var () scrut) - (V.fromList [Delay () one, two]) + LamAbs () scrut $ + Force () $ + Case + () + (Var () scrut) + (V.fromList [Delay () one, two]) pure term forceCaseDelayWithApps2Fail :: Term Name PLC.DefaultUni PLC.DefaultFun () @@ -497,15 +487,16 @@ forceCaseDelayWithApps2Fail = runQuote $ do let one = mkConstant @Integer () 1 two = mkConstant @Integer () 2 term = - LamAbs () scrut - $ Force () - $ Case () - (Var () scrut) - (V.fromList - [ LamAbs () x $ LamAbs () y $ Delay () one - , LamAbs () x two - ] - ) + LamAbs () scrut $ + Force () $ + Case + () + (Var () scrut) + ( V.fromList + [ LamAbs () x $ LamAbs () y $ Delay () one + , LamAbs () x two + ] + ) pure term -- | This is the first example in Note [CSE]. @@ -615,4 +606,4 @@ test_simplify = testGroup "simplify" $ fmap (uncurry goldenVsSimplified) testSimplifyInputs - <> fmap (uncurry goldenVsCse) testCseInputs + <> fmap (uncurry goldenVsCse) testCseInputs diff --git a/plutus-executables/executables/pir/Main.hs b/plutus-executables/executables/pir/Main.hs index b60f1ae64e4..9de57e637aa 100644 --- a/plutus-executables/executables/pir/Main.hs +++ b/plutus-executables/executables/pir/Main.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Main where @@ -39,7 +39,6 @@ import Options.Applicative type PirError a = PIR.Error PLC.DefaultUni PLC.DefaultFun a type UnitProvenance = PIR.Provenance () - {- Note [De Bruijn indices and PIR] The `plc` and `uplc` commands both support ASTs whose "names" are de Bruijn indices. These aren't supported for PIR because PIR has `Let` blocks of @@ -63,27 +62,28 @@ data PirConvertOptions = PirConvertOptions Input PirFormat Output PirFormat Prin -- disallow unsupported name types. toConvertOptions :: PirConvertOptions -> ConvertOptions toConvertOptions (PirConvertOptions inp ifmt outp ofmt mode) = - ConvertOptions inp (pirFormatToFormat ifmt) outp (pirFormatToFormat ofmt) mode + ConvertOptions inp (pirFormatToFormat ifmt) outp (pirFormatToFormat ofmt) mode data AnalyseOptions = AnalyseOptions Input PirFormat Output -- Input is a program, output is text -- | Compilation options: target language, whether to optimise or not, input and output streams and types -data CompileOptions = - CompileOptions Language - Bool -- Optimise or not? - Bool -- True -> just report if compilation was successful; False -> write output - Input - PirFormat - Output - Format - PrintMode - -data Command = Analyse AnalyseOptions - | Compile CompileOptions - | Convert PirConvertOptions - | Optimise PirOptimiseOptions - | Print PrintOptions - +data CompileOptions + = CompileOptions + Language + Bool -- Optimise or not? + Bool -- True -> just report if compilation was successful; False -> write output + Input + PirFormat + Output + Format + PrintMode + +data Command + = Analyse AnalyseOptions + | Compile CompileOptions + | Convert PirConvertOptions + | Optimise PirOptimiseOptions + | Print PrintOptions ---------------- Option parsers ---------------- @@ -99,98 +99,124 @@ pAnalyseOptions = AnalyseOptions <$> input <*> pPirInputFormat <*> output -- | Whether to perform optimisations or not. The default here is True, -- ie *do* optimise; specifying --dont-optimise returns False. pOptimise :: Parser Bool -pOptimise = flag True False - ( long "dont-optimise" - <> long "dont-optimize" - <> help "Turn off optimisations" - ) +pOptimise = + flag + True + False + ( long "dont-optimise" + <> long "dont-optimize" + <> help "Turn off optimisations" + ) pJustTest :: Parser Bool -pJustTest = switch ( long "test" - <> help "Just report success or failure, don't produce an output file" - ) +pJustTest = + switch + ( long "test" + <> help "Just report success or failure, don't produce an output file" + ) pCompileOptions :: Parser CompileOptions -pCompileOptions = CompileOptions - <$> pLanguage - <*> pOptimise - <*> pJustTest - <*> input - <*> pPirInputFormat - <*> output - <*> outputformat - <*> printmode +pCompileOptions = + CompileOptions + <$> pLanguage + <*> pOptimise + <*> pJustTest + <*> input + <*> pPirInputFormat + <*> output + <*> outputformat + <*> printmode pPirOptions :: Parser Command -pPirOptions = hsubparser $ - command "analyse" ( - analyse ("Given a PIR program in flat format, deserialise and analyse the program, " <> - "looking for variables with the largest retained size.")) - <> command "analyze" (analyse "Same as 'analyse'.") - <> command "compile" - (info (Compile <$> pCompileOptions) $ - progDesc $ - "Given a PIR program in flat format, deserialise it, " <> - "and test if it can be successfully compiled to PLC.") - <> command "convert" - (info (Convert <$> pPirConvertOptions) - (progDesc "Convert a program between textual and flat-named format.")) - <> command "optimise" (optimise "Run the PIR optimisation pipeline on the input.") - <> command "optimize" (optimise "Same as 'optimise'.") - <> command "print" - (info (Print <$> printOpts) $ - progDesc $ - "Given a PIR program in textual format, " <> - "read it in and print it in the selected format.") - where - analyse desc = info (Analyse <$> pAnalyseOptions) $ progDesc desc - optimise desc = info (Optimise <$> pPirOptimiseOptions) $ progDesc desc - +pPirOptions = + hsubparser $ + command + "analyse" + ( analyse + ( "Given a PIR program in flat format, deserialise and analyse the program, " + <> "looking for variables with the largest retained size." + ) + ) + <> command "analyze" (analyse "Same as 'analyse'.") + <> command + "compile" + ( info (Compile <$> pCompileOptions) $ + progDesc $ + "Given a PIR program in flat format, deserialise it, " + <> "and test if it can be successfully compiled to PLC." + ) + <> command + "convert" + ( info + (Convert <$> pPirConvertOptions) + (progDesc "Convert a program between textual and flat-named format.") + ) + <> command "optimise" (optimise "Run the PIR optimisation pipeline on the input.") + <> command "optimize" (optimise "Same as 'optimise'.") + <> command + "print" + ( info (Print <$> printOpts) $ + progDesc $ + "Given a PIR program in textual format, " + <> "read it in and print it in the selected format." + ) + where + analyse desc = info (Analyse <$> pAnalyseOptions) $ progDesc desc + optimise desc = info (Optimise <$> pPirOptimiseOptions) $ progDesc desc ---------------- Compilation ---------------- compileToPlc :: Bool -> PirProg () -> Either (PirError UnitProvenance) (PlcProg ()) compileToPlc optimise p = do - plcTcConfig <- modifyError (PIR.PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig PIR.noProvenance - let ctx = getCtx plcTcConfig - plcProg <- runExcept $ flip runReaderT ctx $ runQuoteT $ PIR.compileProgram p - pure $ void plcProg + plcTcConfig <- modifyError (PIR.PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig PIR.noProvenance + let ctx = getCtx plcTcConfig + plcProg <- runExcept $ flip runReaderT ctx $ runQuoteT $ PIR.compileProgram p + pure $ void plcProg where - getCtx :: PLC.TypeCheckConfig PLC.DefaultUni PLC.DefaultFun - -> PIR.CompilationCtx PLC.DefaultUni PLC.DefaultFun a + getCtx :: + PLC.TypeCheckConfig PLC.DefaultUni PLC.DefaultFun -> + PIR.CompilationCtx PLC.DefaultUni PLC.DefaultFun a getCtx plcTcConfig = PIR.toDefaultCompilationCtx plcTcConfig - & PIR.ccOpts . PIR.coOptimize .~ optimise - -- See PlutusIR.Compiler.Types.CompilerOpts for other compilation flags, - -- including coPedantic, which causes the result of every stage in the - -- pipeline to be typechecked. + & PIR.ccOpts + . PIR.coOptimize + .~ optimise + +-- See PlutusIR.Compiler.Types.CompilerOpts for other compilation flags, +-- including coPedantic, which causes the result of every stage in the +-- pipeline to be typechecked. compileToUplc :: Bool -> PlcProg () -> UplcProg () compileToUplc optimise plcProg = - let plcCompilerOpts = - if optimise - then PLC.defaultCompilationOpts - else PLC.defaultCompilationOpts - & PLC.coSimplifyOpts . UPLC.soMaxSimplifierIterations .~ 0 - in runQuote $ flip runReaderT plcCompilerOpts $ PLC.compileProgram plcProg + let plcCompilerOpts = + if optimise + then PLC.defaultCompilationOpts + else + PLC.defaultCompilationOpts + & PLC.coSimplifyOpts + . UPLC.soMaxSimplifierIterations + .~ 0 + in runQuote $ flip runReaderT plcCompilerOpts $ PLC.compileProgram plcProg loadPirAndCompile :: CompileOptions -> IO () -loadPirAndCompile (CompileOptions language optimise test inp ifmt outp ofmt mode) = do - pirProg <- readProgram (pirFormatToFormat ifmt) inp - when test $ putStrLn "!!! Compiling" - -- Now compile to plc, maybe optimising - case compileToPlc optimise (void pirProg) of - Left pirError -> error $ show pirError - Right plcProg -> - case language of - PLC -> if test - then putStrLn "!!! Compilation successful" - else writeProgram outp ofmt mode plcProg - UPLC -> do -- compile the PLC to UPLC - let uplcProg = compileToUplc optimise plcProg - if test then putStrLn "!!! Compilation successful" - else writeProgram outp ofmt mode uplcProg - +loadPirAndCompile (CompileOptions language optimise test inp ifmt outp ofmt mode) = do + pirProg <- readProgram (pirFormatToFormat ifmt) inp + when test $ putStrLn "!!! Compiling" + -- Now compile to plc, maybe optimising + case compileToPlc optimise (void pirProg) of + Left pirError -> error $ show pirError + Right plcProg -> + case language of + PLC -> + if test + then putStrLn "!!! Compilation successful" + else writeProgram outp ofmt mode plcProg + UPLC -> do + -- compile the PLC to UPLC + let uplcProg = compileToUplc optimise plcProg + if test + then putStrLn "!!! Compilation successful" + else writeProgram outp ofmt mode uplcProg ---------------- Optimisation ---------------- @@ -200,66 +226,74 @@ doOptimisations term = do let ctx = getCtx plcTcConfig runExcept $ flip runReaderT ctx $ runQuoteT $ PIR.runCompilerPass PIR.simplifier (PIR.Original () <$ term) where - getCtx - :: PLC.TypeCheckConfig PLC.DefaultUni PLC.DefaultFun - -> PIR.CompilationCtx PLC.DefaultUni PLC.DefaultFun a + getCtx :: + PLC.TypeCheckConfig PLC.DefaultUni PLC.DefaultFun -> + PIR.CompilationCtx PLC.DefaultUni PLC.DefaultFun a getCtx plcTcConfig = PIR.toDefaultCompilationCtx plcTcConfig - & PIR.ccOpts . PIR.coOptimize .~ True - -- This is on by default anyway, but let's make certain. + & PIR.ccOpts + . PIR.coOptimize + .~ True + +-- This is on by default anyway, but let's make certain. -- | Run the PIR optimisations -runOptimisations:: PirOptimiseOptions -> IO () +runOptimisations :: PirOptimiseOptions -> IO () runOptimisations (PirOptimiseOptions inp ifmt outp ofmt mode) = do Program _ _ term <- readProgram (pirFormatToFormat ifmt) inp case doOptimisations term of - Left e -> error $ show e - Right t -> writeProgram outp (pirFormatToFormat ofmt) mode - (Program () PLC.latestVersion(void t)) - + Left e -> error $ show e + Right t -> + writeProgram + outp + (pirFormatToFormat ofmt) + mode + (Program () PLC.latestVersion (void t)) ---------------- Analysis ---------------- -- | a csv-outputtable record row of {name,unique,size} -data RetentionRecord = RetentionRecord { name :: T.Text, unique :: Int, size :: PIR.AstSize} - deriving stock (Generic, Show) - deriving anyclass Csv.ToNamedRecord - deriving anyclass Csv.DefaultOrdered +data RetentionRecord = RetentionRecord {name :: T.Text, unique :: Int, size :: PIR.AstSize} + deriving stock (Generic, Show) + deriving anyclass (Csv.ToNamedRecord) + deriving anyclass (Csv.DefaultOrdered) + deriving newtype instance Csv.ToField PIR.AstSize loadPirAndAnalyse :: AnalyseOptions -> IO () loadPirAndAnalyse (AnalyseOptions inp ifmt outp) = do - -- load pir and make sure that it is globally unique (required for retained size) - p :: PirProg PLC.SrcSpan <- readProgram (pirFormatToFormat ifmt) inp - let PIR.Program _ _ term = runQuote . PLC.rename $ void p - putStrLn "!!! Analysing for retention" - let - -- all the variable names (tynames coerced to names) - names = term ^.. termSubtermsDeep.termBindings.bindingNames ++ - term ^.. termSubtermsDeep.termBindings.bindingTyNames.coerced - -- a helper lookup table of uniques to their textual representation - nameTable :: IM.IntMap T.Text - nameTable = IM.fromList [(coerce $ _nameUnique n , _nameText n) | n <- names] - - -- build the retentionMap - retentionMap = PIR.termRetentionMap def (termVarInfo term) term - -- sort the map by decreasing retained size - sortedRetained = sortOn (negate . snd) $ IM.assocs retentionMap - - -- change uniques to texts and use csv-outputtable records - sortedRecords :: [RetentionRecord] - sortedRecords = - sortedRetained <&> \(i, s) -> - RetentionRecord (IM.findWithDefault "given key is not in map" i nameTable) i s - - -- encode to csv and output it - Csv.encodeDefaultOrderedByName sortedRecords & - case outp of - FileOutput path -> BSL.writeFile path - StdOutput -> BSL.putStr - -- NoOutput supresses the output of programs/terms, but that's not - -- what we've got here. - NoOutput -> BSL.putStr + -- load pir and make sure that it is globally unique (required for retained size) + p :: PirProg PLC.SrcSpan <- readProgram (pirFormatToFormat ifmt) inp + let PIR.Program _ _ term = runQuote . PLC.rename $ void p + putStrLn "!!! Analysing for retention" + let + -- all the variable names (tynames coerced to names) + names = + term ^.. termSubtermsDeep . termBindings . bindingNames + ++ term ^.. termSubtermsDeep . termBindings . bindingTyNames . coerced + -- a helper lookup table of uniques to their textual representation + nameTable :: IM.IntMap T.Text + nameTable = IM.fromList [(coerce $ _nameUnique n, _nameText n) | n <- names] + + -- build the retentionMap + retentionMap = PIR.termRetentionMap def (termVarInfo term) term + -- sort the map by decreasing retained size + sortedRetained = sortOn (negate . snd) $ IM.assocs retentionMap + + -- change uniques to texts and use csv-outputtable records + sortedRecords :: [RetentionRecord] + sortedRecords = + sortedRetained <&> \(i, s) -> + RetentionRecord (IM.findWithDefault "given key is not in map" i nameTable) i s + + -- encode to csv and output it + Csv.encodeDefaultOrderedByName sortedRecords + & case outp of + FileOutput path -> BSL.writeFile path + StdOutput -> BSL.putStr + -- NoOutput supresses the output of programs/terms, but that's not + -- what we've got here. + NoOutput -> BSL.putStr ---------------- Parse and print a PIR source file ---------------- -- This option for PIR source file does NOT check for @UniqueError@'s. @@ -267,22 +301,21 @@ loadPirAndAnalyse (AnalyseOptions inp ifmt outp) = do runPrint :: PrintOptions -> IO () runPrint (PrintOptions inp outp mode) = do - contents <- getInput inp - -- parse the program - case parseNamedProgram (show inp) contents of - -- when fail, pretty print the parse errors. - Left (ParseErrorB err) -> - errorWithoutStackTrace $ errorBundlePretty err - -- otherwise, - Right (p::PirProg PLC.SrcSpan) -> do - let - printed :: String - printed = show $ prettyPrintByMode mode p - case outp of - FileOutput path -> writeFile path printed - StdOutput -> putStrLn printed - NoOutput -> pure () - + contents <- getInput inp + -- parse the program + case parseNamedProgram (show inp) contents of + -- when fail, pretty print the parse errors. + Left (ParseErrorB err) -> + errorWithoutStackTrace $ errorBundlePretty err + -- otherwise, + Right (p :: PirProg PLC.SrcSpan) -> do + let + printed :: String + printed = show $ prettyPrintByMode mode p + case outp of + FileOutput path -> writeFile path printed + StdOutput -> putStrLn printed + NoOutput -> pure () versioner :: Parser (a -> a) versioner = simpleVersioner (gitAwareVersionInfo Paths.version) @@ -291,18 +324,21 @@ versioner = simpleVersioner (gitAwareVersionInfo Paths.version) main :: IO () main = do - comm <- customExecParser (prefs showHelpOnEmpty) infoOpts - case comm of - Analyse opts -> loadPirAndAnalyse opts - Compile opts -> loadPirAndCompile opts - Convert opts -> runConvert @PirProg (toConvertOptions opts) - Optimise opts -> runOptimisations opts - Print opts -> runPrint opts + comm <- customExecParser (prefs showHelpOnEmpty) infoOpts + case comm of + Analyse opts -> loadPirAndAnalyse opts + Compile opts -> loadPirAndCompile opts + Convert opts -> runConvert @PirProg (toConvertOptions opts) + Optimise opts -> runOptimisations opts + Print opts -> runPrint opts where infoOpts = - info (pPirOptions <**> versioner <**> helper) - ( fullDesc - <> header "PIR tool" - <> progDesc ("This program provides a number of utilities for dealing with " - <> "PIR programs, including printing, analysis, optimisation, and compilation to UPLC and PLC.")) - + info + (pPirOptions <**> versioner <**> helper) + ( fullDesc + <> header "PIR tool" + <> progDesc + ( "This program provides a number of utilities for dealing with " + <> "PIR programs, including printing, analysis, optimisation, and compilation to UPLC and PLC." + ) + ) diff --git a/plutus-executables/executables/plc/Main.hs b/plutus-executables/executables/plc/Main.hs index de9475583d3..10df2c48270 100644 --- a/plutus-executables/executables/plc/Main.hs +++ b/plutus-executables/executables/plc/Main.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module Main (main) where @@ -34,8 +34,8 @@ plcInfoCommand = plutus plcHelpText data TypecheckOptions = TypecheckOptions Input Format Output PrintMode NameFormat -data EvalOptions = - EvalOptions +data EvalOptions + = EvalOptions Input Format Output @@ -45,19 +45,19 @@ data EvalOptions = data EraseOptions = EraseOptions Input Format Output Format PrintMode - -- Main commands -data Command = Apply ApplyOptions - | ApplyToData ApplyOptions - | Typecheck TypecheckOptions - | Optimise OptimiseOptions - | Convert ConvertOptions - | Print PrintOptions - | Example ExampleOptions - | Erase EraseOptions - | Eval EvalOptions - | DumpModel (BuiltinSemanticsVariant PLC.DefaultFun) - | PrintBuiltinSignatures +data Command + = Apply ApplyOptions + | ApplyToData ApplyOptions + | Typecheck TypecheckOptions + | Optimise OptimiseOptions + | Convert ConvertOptions + | Print PrintOptions + | Example ExampleOptions + | Erase EraseOptions + | Eval EvalOptions + | DumpModel (BuiltinSemanticsVariant PLC.DefaultFun) + | PrintBuiltinSignatures ---------------- Option parsers ---------------- @@ -70,72 +70,113 @@ eraseOpts = EraseOptions <$> input <*> inputformat <*> output <*> outputformat < evalOpts :: Parser EvalOptions evalOpts = EvalOptions - <$> input - <*> inputformat - <*> output - <*> printmode - <*> nameformat - <*> builtinSemanticsVariant + <$> input + <*> inputformat + <*> output + <*> printmode + <*> nameformat + <*> builtinSemanticsVariant plutus :: -- | The @helpText@ String -> ParserInfo Command plutus langHelpText = - info - (plutusOpts <**> versioner <**> helper) - (fullDesc <> header "Typed Plutus Core Tool" <> progDesc langHelpText) + info + (plutusOpts <**> versioner <**> helper) + (fullDesc <> header "Typed Plutus Core Tool" <> progDesc langHelpText) plutusOpts :: Parser Command -plutusOpts = hsubparser $ - command "apply" - (info (Apply <$> applyOpts) - (progDesc $ "Given a list of input files f g1 g2 ... gn " <> - "containing Typed Plutus Core scripts, " <> - "output a script consisting of (... ((f g1) g2) ... gn); " <> - "for example, 'plc apply --if flat Validator.flat " <> - "Datum.flat Redeemer.flat Context.flat --of flat -o Script.flat'.")) - <> command "apply-to-data" - (info (ApplyToData <$> applyOpts) - (progDesc $ "Given a list f d1 d2 ... dn where f is a " <> - "Typed Plutus Core script and d1,...,dn are files " <> - "containing flat-encoded data ojbects, output a script " <> - "consisting of f applied to the data objects; " <> - "for example, 'plc apply-to-data --if " <> - "flat Validator.flat Datum.flat Redeemer.flat Context.flat " <> - "--of flat -o Script.flat'.")) - <> command "print" - (info (Print <$> printOpts) - (progDesc "Parse a program then prettyprint it.")) - <> command "convert" - (info (Convert <$> convertOpts) - (progDesc "Convert a program between various formats")) - <> command "example" - (info (Example <$> exampleOpts) - (progDesc $ "Show a program example. " - ++ "Usage: first request the list of available examples (optional step), " - ++ "then request a particular example by the name of a term. " - ++ "Note that evaluating a generated example may result in 'Failure'.")) - <> command "typecheck" - (info (Typecheck <$> typecheckOpts) - (progDesc "Typecheck a typed Plutus Core program.")) - <> command "optimise" (optimise $ "Run the PLC optimisation pipeline on the input. " - ++ "At present there are no PLC optimisations.") - <> command "optimize" (optimise "Same as 'optimise'.") - <> command "erase" - (info (Erase <$> eraseOpts) - (progDesc "Convert a typed Plutus Core program to an untyped one.")) - <> command "evaluate" - (info (Eval <$> evalOpts) - (progDesc "Evaluate a typed Plutus Core program using the CK machine.")) - <> command "dump-cost-model" - (info (DumpModel <$> builtinSemanticsVariant) - (progDesc "Dump the cost model parameters.")) - <> command "print-builtin-signatures" - (info (pure PrintBuiltinSignatures) - (progDesc "Print the signatures of the built-in functions.")) - where optimise desc = info (Optimise <$> optimiseOpts) $ progDesc desc - +plutusOpts = + hsubparser $ + command + "apply" + ( info + (Apply <$> applyOpts) + ( progDesc $ + "Given a list of input files f g1 g2 ... gn " + <> "containing Typed Plutus Core scripts, " + <> "output a script consisting of (... ((f g1) g2) ... gn); " + <> "for example, 'plc apply --if flat Validator.flat " + <> "Datum.flat Redeemer.flat Context.flat --of flat -o Script.flat'." + ) + ) + <> command + "apply-to-data" + ( info + (ApplyToData <$> applyOpts) + ( progDesc $ + "Given a list f d1 d2 ... dn where f is a " + <> "Typed Plutus Core script and d1,...,dn are files " + <> "containing flat-encoded data ojbects, output a script " + <> "consisting of f applied to the data objects; " + <> "for example, 'plc apply-to-data --if " + <> "flat Validator.flat Datum.flat Redeemer.flat Context.flat " + <> "--of flat -o Script.flat'." + ) + ) + <> command + "print" + ( info + (Print <$> printOpts) + (progDesc "Parse a program then prettyprint it.") + ) + <> command + "convert" + ( info + (Convert <$> convertOpts) + (progDesc "Convert a program between various formats") + ) + <> command + "example" + ( info + (Example <$> exampleOpts) + ( progDesc $ + "Show a program example. " + ++ "Usage: first request the list of available examples (optional step), " + ++ "then request a particular example by the name of a term. " + ++ "Note that evaluating a generated example may result in 'Failure'." + ) + ) + <> command + "typecheck" + ( info + (Typecheck <$> typecheckOpts) + (progDesc "Typecheck a typed Plutus Core program.") + ) + <> command + "optimise" + ( optimise $ + "Run the PLC optimisation pipeline on the input. " + ++ "At present there are no PLC optimisations." + ) + <> command "optimize" (optimise "Same as 'optimise'.") + <> command + "erase" + ( info + (Erase <$> eraseOpts) + (progDesc "Convert a typed Plutus Core program to an untyped one.") + ) + <> command + "evaluate" + ( info + (Eval <$> evalOpts) + (progDesc "Evaluate a typed Plutus Core program using the CK machine.") + ) + <> command + "dump-cost-model" + ( info + (DumpModel <$> builtinSemanticsVariant) + (progDesc "Dump the cost model parameters.") + ) + <> command + "print-builtin-signatures" + ( info + (pure PrintBuiltinSignatures) + (progDesc "Print the signatures of the built-in functions.") + ) + where + optimise desc = info (Optimise <$> optimiseOpts) $ progDesc desc ---------------- Script application ---------------- @@ -143,10 +184,10 @@ plutusOpts = hsubparser $ -- scripts must be PLC.Program objects. runApply :: ApplyOptions -> IO () runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do - scripts <- mapM ((readProgram ifmt :: Input -> IO (PlcProg PLC.SrcSpan)) . FileInput) inputfiles + scripts <- mapM ((readProgram ifmt :: Input -> IO (PlcProg PLC.SrcSpan)) . FileInput) inputfiles let appliedScript = case map (\case p -> () <$ p) scripts of - [] -> errorWithoutStackTrace "No input files" + [] -> errorWithoutStackTrace "No input files" progAndargs -> foldl1 (unsafeFromRight .* PLC.applyProgram) progAndargs writeProgram outp ofmt mode appliedScript @@ -155,22 +196,22 @@ runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do -- output the result. runApplyToData :: ApplyOptions -> IO () runApplyToData (ApplyOptions inputfiles ifmt outp ofmt mode) = do - case inputfiles of + case inputfiles of [] -> errorWithoutStackTrace "No input files" - p:ds -> do - prog@(PLC.Program _ version _) :: PlcProg PLC.SrcSpan <- readProgram ifmt (FileInput p) - args <- mapM (getDataObject version) ds - let prog' = () <$ prog - appliedScript = foldl1 (unsafeFromRight .* PLC.applyProgram) (prog':args) - writeProgram outp ofmt mode appliedScript - where getDataObject :: PLC.Version -> FilePath -> IO (PlcProg ()) - getDataObject ver path = do - bs <- BSL.readFile path - case unflat bs of - Left err -> fail ("Error reading " ++ show path ++ ": " ++ show err) - Right (d :: Data) -> - pure $ PLC.Program () ver $ mkConstant () d - + p : ds -> do + prog@(PLC.Program _ version _) :: PlcProg PLC.SrcSpan <- readProgram ifmt (FileInput p) + args <- mapM (getDataObject version) ds + let prog' = () <$ prog + appliedScript = foldl1 (unsafeFromRight .* PLC.applyProgram) (prog' : args) + writeProgram outp ofmt mode appliedScript + where + getDataObject :: PLC.Version -> FilePath -> IO (PlcProg ()) + getDataObject ver path = do + bs <- BSL.readFile path + case unflat bs of + Left err -> fail ("Error reading " ++ show path ++ ": " ++ show err) + Right (d :: Data) -> + pure $ PLC.Program () ver $ mkConstant () d ---------------- Typechecking ---------------- @@ -179,22 +220,21 @@ runTypecheck (TypecheckOptions inp fmt outp printMode nameFormat) = do prog <- readProgram fmt inp case PLC.runQuoteT $ modifyError PLC.TypeErrorE $ do tcConfig <- PLC.getDefTypeCheckConfig () - PLC.inferTypeOfProgram tcConfig (void prog) - of - Left (e :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) -> - errorWithoutStackTrace $ PP.displayPlc e - Right (PLC.Normalized ty) -> - case nameFormat of - IdNames -> writeToOutput outp $ prettyPrintByMode printMode ty - DeBruijnNames -> - writeToOutput outp $ prettyPrintByMode printMode $ toDeBruijnTypePLC ty + PLC.inferTypeOfProgram tcConfig (void prog) of + Left (e :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) -> + errorWithoutStackTrace $ PP.displayPlc e + Right (PLC.Normalized ty) -> + case nameFormat of + IdNames -> writeToOutput outp $ prettyPrintByMode printMode ty + DeBruijnNames -> + writeToOutput outp $ prettyPrintByMode printMode $ toDeBruijnTypePLC ty ---------------- Optimisation ---------------- -runOptimisations:: OptimiseOptions -> IO () +runOptimisations :: OptimiseOptions -> IO () runOptimisations (OptimiseOptions inp ifmt outp ofmt mode _) = do - prog <- readProgram ifmt inp :: IO (PlcProg PLC.SrcSpan) - let optimised = prog -- No PLC optimisations at present! + prog <- readProgram ifmt inp :: IO (PlcProg PLC.SrcSpan) + let optimised = prog -- No PLC optimisations at present! writeProgram outp ofmt mode optimised ---------------- Evaluation ---------------- @@ -205,7 +245,7 @@ runEval (EvalOptions inp ifmt outp printMode nameFormat semvar) = do let evaluate = Ck.evaluateCkNoEmit (PLC.defaultBuiltinsRuntimeForSemanticsVariant semvar) def term = void $ prog ^. PLC.progTerm case evaluate term of - Right v -> + Right v -> case nameFormat of IdNames -> writeToOutput outp (prettyPrintByMode printMode v) DeBruijnNames -> @@ -225,7 +265,7 @@ runErase (EraseOptions inp ifmt outp ofmt mode) = do typedProg <- (readProgram ifmt inp :: IO (PlcProg PLC.SrcSpan)) let untypedProg = () <$ PLC.eraseProgram typedProg case ofmt of - Textual -> writePrettyToOutput outp mode untypedProg + Textual -> writePrettyToOutput outp mode untypedProg Flat flatMode -> writeFlat outp flatMode untypedProg ---------------- Version ---------------- @@ -237,16 +277,16 @@ versioner = simpleVersioner (gitAwareVersionInfo Paths.version) main :: IO () main = do - options <- customExecParser (prefs showHelpOnEmpty) plcInfoCommand - case options of - Apply opts -> runApply opts - ApplyToData opts -> runApplyToData opts - Typecheck opts -> runTypecheck opts - Optimise opts -> runOptimisations opts - Eval opts -> runEval opts - Example opts -> runPlcPrintExample opts - Erase opts -> runErase opts - Print opts -> runPrint @PlcProg opts - Convert opts -> runConvert @PlcProg opts - DumpModel opts -> runDumpModel opts - PrintBuiltinSignatures -> runPrintBuiltinSignatures + options <- customExecParser (prefs showHelpOnEmpty) plcInfoCommand + case options of + Apply opts -> runApply opts + ApplyToData opts -> runApplyToData opts + Typecheck opts -> runTypecheck opts + Optimise opts -> runOptimisations opts + Eval opts -> runEval opts + Example opts -> runPlcPrintExample opts + Erase opts -> runErase opts + Print opts -> runPrint @PlcProg opts + Convert opts -> runConvert @PlcProg opts + DumpModel opts -> runDumpModel opts + PrintBuiltinSignatures -> runPrintBuiltinSignatures diff --git a/plutus-executables/executables/uplc/Main.hs b/plutus-executables/executables/uplc/Main.hs index 9f72bf757a2..b05bb6128ab 100644 --- a/plutus-executables/executables/uplc/Main.hs +++ b/plutus-executables/executables/uplc/Main.hs @@ -1,5 +1,4 @@ - -- editorconfig-checker-disable - +-- editorconfig-checker-disable {-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where @@ -56,15 +55,17 @@ uplcHelpText = helpText "Untyped Plutus Core" uplcInfoCommand :: ParserInfo Command uplcInfoCommand = plutus uplcHelpText -data BudgetMode = Silent - | Verbose SomeBudgetMode +data BudgetMode + = Silent + | Verbose SomeBudgetMode -data SomeBudgetMode = - forall cost. (Eq cost, NFData cost, PrintBudgetState cost) => - SomeBudgetMode (Cek.ExBudgetMode cost PLC.DefaultUni PLC.DefaultFun) +data SomeBudgetMode + = forall cost. + (Eq cost, NFData cost, PrintBudgetState cost) => + SomeBudgetMode (Cek.ExBudgetMode cost PLC.DefaultUni PLC.DefaultFun) -data EvalOptions = - EvalOptions +data EvalOptions + = EvalOptions Input Format PrintMode @@ -75,76 +76,84 @@ data EvalOptions = CekModel (BuiltinSemanticsVariant PLC.DefaultFun) -data BenchmarkOptions = - BenchmarkOptions +data BenchmarkOptions + = BenchmarkOptions Input Format (BuiltinSemanticsVariant PLC.DefaultFun) Double -data DbgOptions = - DbgOptions - Input Format +data DbgOptions + = DbgOptions + Input + Format CekModel (BuiltinSemanticsVariant PLC.DefaultFun) - ---------------- Main commands ----------------- -data Command = Apply ApplyOptions - | ApplyToFlatData ApplyOptions - | ApplyToCborData ApplyOptions - | Benchmark BenchmarkOptions - | Convert ConvertOptions - | Optimise OptimiseOptions - | Print PrintOptions - | Example ExampleOptions - | Eval EvalOptions - | Dbg DbgOptions - | DumpModel (BuiltinSemanticsVariant PLC.DefaultFun) - | PrintBuiltinSignatures +data Command + = Apply ApplyOptions + | ApplyToFlatData ApplyOptions + | ApplyToCborData ApplyOptions + | Benchmark BenchmarkOptions + | Convert ConvertOptions + | Optimise OptimiseOptions + | Print PrintOptions + | Example ExampleOptions + | Eval EvalOptions + | Dbg DbgOptions + | DumpModel (BuiltinSemanticsVariant PLC.DefaultFun) + | PrintBuiltinSignatures ---------------- Option parsers ---------------- cekmodel :: Parser CekModel cekmodel = - flag Default Unit - ( short '1' + flag + Default + Unit + ( short '1' <> long "unit-cek-model" <> help "Use unit AST node costs and builtin costs for CEK cost model (tallying mode only)" - ) + ) benchmarkOpts :: Parser BenchmarkOptions benchmarkOpts = BenchmarkOptions - <$> input - <*> inputformat - <*> builtinSemanticsVariant - <*> option auto - ( long "time-limit" + <$> input + <*> inputformat + <*> builtinSemanticsVariant + <*> option + auto + ( long "time-limit" <> short 'T' <> metavar "TIME LIMIT" <> value 5.0 <> showDefault - <> help "Time limit (in seconds) for benchmarking.") + <> help "Time limit (in seconds) for benchmarking." + ) evalOpts :: Parser EvalOptions evalOpts = EvalOptions - <$> input - <*> inputformat - <*> printmode - <*> nameformat - <*> budgetmode - <*> tracemode - <*> output - <*> cekmodel - <*> builtinSemanticsVariant + <$> input + <*> inputformat + <*> printmode + <*> nameformat + <*> budgetmode + <*> tracemode + <*> output + <*> cekmodel + <*> builtinSemanticsVariant dbgOpts :: Parser DbgOptions dbgOpts = - DbgOptions <$> - input <*> inputformat <*> cekmodel <*> builtinSemanticsVariant + DbgOptions + <$> input + <*> inputformat + <*> cekmodel + <*> builtinSemanticsVariant -- Reader for budget. The --restricting option requires two integer arguments -- and the easiest way to do this is to supply a colon-separated pair of @@ -153,42 +162,54 @@ exbudgetReader :: ReadM ExBudget exbudgetReader = do s <- str case splitOn ":" s of - [a,b] -> case (readMaybe a, readMaybe b) of - (Just cpu, Just mem) -> pure $ ExBudget (ExCPU cpu) (ExMemory mem) - _ -> readerError badfmt - _ -> readerError badfmt - where badfmt = "Invalid budget (expected eg 10000:50000)" + [a, b] -> case (readMaybe a, readMaybe b) of + (Just cpu, Just mem) -> pure $ ExBudget (ExCPU cpu) (ExMemory mem) + _ -> readerError badfmt + _ -> readerError badfmt + where + badfmt = "Invalid budget (expected eg 10000:50000)" restrictingbudgetEnormous :: Parser BudgetMode restrictingbudgetEnormous = - flag' (Verbose $ SomeBudgetMode Cek.restrictingEnormous) - ( long "restricting-enormous" + flag' + (Verbose $ SomeBudgetMode Cek.restrictingEnormous) + ( long "restricting-enormous" <> short 'r' - <> help "Run the machine in restricting mode with an enormous budget" ) + <> help "Run the machine in restricting mode with an enormous budget" + ) restrictingbudget :: Parser BudgetMode restrictingbudget = - Verbose . SomeBudgetMode . Cek.restricting . ExRestrictingBudget - <$> option exbudgetReader - ( long "restricting" - <> short 'R' - <> metavar "ExCPU:ExMemory" - <> help "Run the machine in restricting mode with the given limits" ) + Verbose . SomeBudgetMode . Cek.restricting . ExRestrictingBudget + <$> option + exbudgetReader + ( long "restricting" + <> short 'R' + <> metavar "ExCPU:ExMemory" + <> help "Run the machine in restricting mode with the given limits" + ) countingbudget :: Parser BudgetMode -countingbudget = flag' (Verbose $ SomeBudgetMode Cek.counting) - ( long "counting" - <> short 'c' - <> help "Run machine in counting mode and report results" ) +countingbudget = + flag' + (Verbose $ SomeBudgetMode Cek.counting) + ( long "counting" + <> short 'c' + <> help "Run machine in counting mode and report results" + ) tallyingbudget :: Parser BudgetMode -tallyingbudget = flag' (Verbose $ SomeBudgetMode Cek.tallying) - ( long "tallying" - <> short 't' - <> help "Run machine in tallying mode and report results" ) +tallyingbudget = + flag' + (Verbose $ SomeBudgetMode Cek.tallying) + ( long "tallying" + <> short 't' + <> help "Run machine in tallying mode and report results" + ) budgetmode :: Parser BudgetMode -budgetmode = asum +budgetmode = + asum [ restrictingbudgetEnormous , restrictingbudget , countingbudget @@ -201,68 +222,110 @@ plutus :: String -> ParserInfo Command plutus langHelpText = - info - (plutusOpts <**> versioner <**> helper) - (fullDesc <> header "Untyped Plutus Core Tool" <> progDesc langHelpText) + info + (plutusOpts <**> versioner <**> helper) + (fullDesc <> header "Untyped Plutus Core Tool" <> progDesc langHelpText) plutusOpts :: Parser Command -plutusOpts = hsubparser $ - command "apply" - (info (Apply <$> applyOpts) - (progDesc $ "Given a list of input files f g1 g2 ... gn " <> - "containing Untyped Plutus Core scripts, " <> - "output a script consisting of (... ((f g1) g2) ... gn); " <> - "for example, 'uplc apply --if flat Validator.flat " <> - "Datum.flat Redeemer.flat Context.flat --of flat -o Script.flat'.")) - <> command "apply-to-flat-data" - (info (ApplyToFlatData <$> applyOpts) - (progDesc $ "Given a list f d1 d2 ... dn where f is an " <> - "Untyped Plutus Core script and d1,...,dn are files " <> - "containing flat-encoded data ojbects, output a script " <> - "consisting of f applied to the data objects; " <> - "for example, 'uplc apply-to-flat-data --if " <> - "flat Validator.flat Datum.flat Redeemer.flat Context.flat " <> - "--of flat -o Script.flat'.")) - <> command "apply-to-cbor-data" - (info (ApplyToCborData <$> applyOpts) - (progDesc $ "Given a list f d1 d2 ... dn where f is an " <> - "Untyped Plutus Core script and d1,...,dn are files " <> - "containing CBOR-encoded data ojbects, output a script " <> - "consisting of f applied to the data objects; " <> - "for example, 'uplc apply-to-cbor-data --if " <> - "flat Validator.flat Datum.cbor Redeemer.cbor Context.cbor " <> - "--of flat -o Script.flat'.")) - <> command "print" - (info (Print <$> printOpts) - (progDesc "Parse a program then prettyprint it.")) - <> command "convert" - (info (Convert <$> convertOpts) - (progDesc "Convert a program between various formats.")) - <> command "optimise" (optimise "Run the UPLC optimisation pipeline on the input.") - <> command "optimize" (optimise "Same as 'optimise'.") - <> command "example" - (info (Example <$> exampleOpts) - (progDesc $ "Show a program example. " - ++ "Usage: first request the list of available examples (optional step), " - ++ "then request a particular example by the name of a term. " - ++ "Note that evaluating a generated example may result in 'Failure'.")) - <> command "benchmark" - (info (Benchmark <$> benchmarkOpts) - (progDesc "Benchmark an untyped Plutus Core program on the CEK machine using Criterion.")) - <> command "evaluate" - (info (Eval <$> evalOpts) - (progDesc "Evaluate an untyped Plutus Core program using the CEK machine.")) - <> command "debug" - (info (Dbg <$> dbgOpts) - (progDesc "Debug an untyped Plutus Core program using the CEK machine.")) - <> command "dump-cost-model" - (info (DumpModel <$> builtinSemanticsVariant) - (progDesc "Dump the cost model parameters.")) - <> command "print-builtin-signatures" - (info (pure PrintBuiltinSignatures) - (progDesc "Print the signatures of the built-in functions.")) - where optimise desc = info (Optimise <$> optimiseOpts) $ progDesc desc - +plutusOpts = + hsubparser $ + command + "apply" + ( info + (Apply <$> applyOpts) + ( progDesc $ + "Given a list of input files f g1 g2 ... gn " + <> "containing Untyped Plutus Core scripts, " + <> "output a script consisting of (... ((f g1) g2) ... gn); " + <> "for example, 'uplc apply --if flat Validator.flat " + <> "Datum.flat Redeemer.flat Context.flat --of flat -o Script.flat'." + ) + ) + <> command + "apply-to-flat-data" + ( info + (ApplyToFlatData <$> applyOpts) + ( progDesc $ + "Given a list f d1 d2 ... dn where f is an " + <> "Untyped Plutus Core script and d1,...,dn are files " + <> "containing flat-encoded data ojbects, output a script " + <> "consisting of f applied to the data objects; " + <> "for example, 'uplc apply-to-flat-data --if " + <> "flat Validator.flat Datum.flat Redeemer.flat Context.flat " + <> "--of flat -o Script.flat'." + ) + ) + <> command + "apply-to-cbor-data" + ( info + (ApplyToCborData <$> applyOpts) + ( progDesc $ + "Given a list f d1 d2 ... dn where f is an " + <> "Untyped Plutus Core script and d1,...,dn are files " + <> "containing CBOR-encoded data ojbects, output a script " + <> "consisting of f applied to the data objects; " + <> "for example, 'uplc apply-to-cbor-data --if " + <> "flat Validator.flat Datum.cbor Redeemer.cbor Context.cbor " + <> "--of flat -o Script.flat'." + ) + ) + <> command + "print" + ( info + (Print <$> printOpts) + (progDesc "Parse a program then prettyprint it.") + ) + <> command + "convert" + ( info + (Convert <$> convertOpts) + (progDesc "Convert a program between various formats.") + ) + <> command "optimise" (optimise "Run the UPLC optimisation pipeline on the input.") + <> command "optimize" (optimise "Same as 'optimise'.") + <> command + "example" + ( info + (Example <$> exampleOpts) + ( progDesc $ + "Show a program example. " + ++ "Usage: first request the list of available examples (optional step), " + ++ "then request a particular example by the name of a term. " + ++ "Note that evaluating a generated example may result in 'Failure'." + ) + ) + <> command + "benchmark" + ( info + (Benchmark <$> benchmarkOpts) + (progDesc "Benchmark an untyped Plutus Core program on the CEK machine using Criterion.") + ) + <> command + "evaluate" + ( info + (Eval <$> evalOpts) + (progDesc "Evaluate an untyped Plutus Core program using the CEK machine.") + ) + <> command + "debug" + ( info + (Dbg <$> dbgOpts) + (progDesc "Debug an untyped Plutus Core program using the CEK machine.") + ) + <> command + "dump-cost-model" + ( info + (DumpModel <$> builtinSemanticsVariant) + (progDesc "Dump the cost model parameters.") + ) + <> command + "print-builtin-signatures" + ( info + (pure PrintBuiltinSignatures) + (progDesc "Print the signatures of the built-in functions.") + ) + where + optimise desc = info (Optimise <$> optimiseOpts) $ progDesc desc ---------------- Optimisation ---------------- @@ -277,7 +340,7 @@ runOptimisations (OptimiseOptions inp ifmt outp ofmt mode mcert) = do UPLC.simplifyProgramWithTrace UPLC.defaultSimplifyOpts defaultBuiltinSemanticsVariant renamed writeProgram outp ofmt mode simplified case mcert of - Nothing -> pure () + Nothing -> pure () Just cert -> execCertifier simplificationTrace cert where execCertifier simplificationTrace cert = do @@ -286,14 +349,13 @@ runOptimisations (OptimiseOptions inp ifmt outp ofmt mode mcert) = do Left err -> do putStrLn $ prettyCertifierError err case err of - InvalidCertificate _ -> exitWith $ ExitFailure 1 + InvalidCertificate _ -> exitWith $ ExitFailure 1 InvalidCompilerOutput -> exitWith $ ExitFailure 2 - ValidationError _ -> exitWith $ ExitFailure 3 + ValidationError _ -> exitWith $ ExitFailure 3 Right certSucc -> do putStrLn $ prettyCertifierSuccess certSucc exitSuccess - ---------------- Script application ---------------- -- | Apply one script to a list of others and output the result. All of the @@ -303,7 +365,7 @@ runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do scripts <- mapM ((readProgram ifmt :: Input -> IO (UplcProg SrcSpan)) . FileInput) inputfiles let appliedScript = case void <$> scripts of - [] -> errorWithoutStackTrace "No input files" + [] -> errorWithoutStackTrace "No input files" progAndargs -> foldl1 (unsafeFromRight .* UPLC.applyProgram) progAndargs writeProgram outp ofmt mode appliedScript @@ -312,39 +374,41 @@ runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do -- output the result. runApplyToFlatData :: ApplyOptions -> IO () runApplyToFlatData (ApplyOptions inputfiles ifmt outp ofmt mode) = - case inputfiles of + case inputfiles of [] -> errorWithoutStackTrace "No input files" - p:ds -> do - prog@(UPLC.Program _ version _) :: UplcProg SrcSpan <- readProgram ifmt (FileInput p) - args <- mapM (getDataObject version) ds - let prog' = void prog - appliedScript = foldl1 (unsafeFromRight .* UPLC.applyProgram) (prog':args) - writeProgram outp ofmt mode appliedScript - where getDataObject :: UPLC.Version -> FilePath -> IO (UplcProg ()) - getDataObject ver path = do - bs <- BSL.readFile path - case unflat bs of - Left err -> fail ("Error reading " ++ show path ++ ": " ++ show err) - Right (d :: Data) -> pure $ UPLC.Program () ver $ mkConstant () d + p : ds -> do + prog@(UPLC.Program _ version _) :: UplcProg SrcSpan <- readProgram ifmt (FileInput p) + args <- mapM (getDataObject version) ds + let prog' = void prog + appliedScript = foldl1 (unsafeFromRight .* UPLC.applyProgram) (prog' : args) + writeProgram outp ofmt mode appliedScript + where + getDataObject :: UPLC.Version -> FilePath -> IO (UplcProg ()) + getDataObject ver path = do + bs <- BSL.readFile path + case unflat bs of + Left err -> fail ("Error reading " ++ show path ++ ": " ++ show err) + Right (d :: Data) -> pure $ UPLC.Program () ver $ mkConstant () d -- | Apply a UPLC program to script to a list of CBOR-encoded flat-encoded Data -- objects and output the result. runApplyToCborData :: ApplyOptions -> IO () runApplyToCborData (ApplyOptions inputfiles ifmt outp ofmt mode) = - case inputfiles of + case inputfiles of [] -> errorWithoutStackTrace "No input files" - p:ds -> do - prog@(UPLC.Program _ version _) :: UplcProg SrcSpan <- readProgram ifmt (FileInput p) - args <- mapM (getCborDataObject version) ds - let prog' = void prog - appliedScript = foldl1 (unsafeFromRight .* UPLC.applyProgram) (prog':args) - writeProgram outp ofmt mode appliedScript - where getCborDataObject :: UPLC.Version -> FilePath -> IO (UplcProg ()) - getCborDataObject ver path = do - bs <- BSL.readFile path - case deserialiseOrFail bs :: Either DeserialiseFailure Data - of Left err -> fail ("Cannot decode CBOR object " ++ show path ++ ":" ++ show err) - Right d -> pure $ UPLC.Program () ver $ mkConstant () d + p : ds -> do + prog@(UPLC.Program _ version _) :: UplcProg SrcSpan <- readProgram ifmt (FileInput p) + args <- mapM (getCborDataObject version) ds + let prog' = void prog + appliedScript = foldl1 (unsafeFromRight .* UPLC.applyProgram) (prog' : args) + writeProgram outp ofmt mode appliedScript + where + getCborDataObject :: UPLC.Version -> FilePath -> IO (UplcProg ()) + getCborDataObject ver path = do + bs <- BSL.readFile path + case deserialiseOrFail bs :: Either DeserialiseFailure Data of + Left err -> fail ("Cannot decode CBOR object " ++ show path ++ ":" ++ show err) + Right d -> pure $ UPLC.Program () ver $ mkConstant () d ---------------- Benchmarking ---------------- @@ -358,8 +422,10 @@ runBenchmark (BenchmarkOptions inp ifmt semvar timeLim) = do evaluate = getResult . Cek.runCekDeBruijn cekparams Cek.restrictingEnormous Cek.noEmitter -- readProgam throws away De Bruijn indices and returns an AST with Names; -- we have to put them back to get an AST with NamedDeBruijn names. - !term = fromRight (error "Unexpected open term in runBenchmark.") . - runExcept @FreeVariableError $ UPLC.deBruijnTerm (UPLC._progTerm prog) + !term = + fromRight (error "Unexpected open term in runBenchmark.") + . runExcept @FreeVariableError + $ UPLC.deBruijnTerm (UPLC._progTerm prog) -- Big names slow things down !anonTerm = UPLC.termMapNames (\(PLC.NamedDeBruijn _ i) -> PLC.NamedDeBruijn "" i) term -- Big annotations slow things down @@ -369,114 +435,130 @@ runBenchmark (BenchmarkOptions inp ifmt semvar timeLim) = do ---------------- Evaluation ---------------- runEval :: EvalOptions -> IO () -runEval (EvalOptions inp ifmt printMode nameFormat budgetMode traceMode - outp cekModel semvar) = do +runEval + ( EvalOptions + inp + ifmt + printMode + nameFormat + budgetMode + traceMode + outp + cekModel + semvar + ) = do prog <- readProgram ifmt inp let term = void $ prog ^. UPLC.progTerm cekparams = case cekModel of - -- AST nodes are charged according to the default cost model - Default -> PLC.defaultCekParametersForVariant semvar - -- AST nodes are charged one unit each, so we can see how many times each node - -- type is encountered. This is useful for calibrating the budgeting code - Unit -> PLC.unitCekParameters + -- AST nodes are charged according to the default cost model + Default -> PLC.defaultCekParametersForVariant semvar + -- AST nodes are charged one unit each, so we can see how many times each node + -- type is encountered. This is useful for calibrating the budgeting code + Unit -> PLC.unitCekParameters let emitM = case traceMode of - None -> Cek.noEmitter - Logs -> Cek.logEmitter - LogsWithTimestamps -> Cek.logWithTimeEmitter - LogsWithBudgets -> Cek.logWithBudgetEmitter - LogsWithCallTrace -> Cek.logWithCallTraceEmitter + None -> Cek.noEmitter + Logs -> Cek.logEmitter + LogsWithTimestamps -> Cek.logWithTimeEmitter + LogsWithBudgets -> Cek.logWithBudgetEmitter + LogsWithCallTrace -> Cek.logWithCallTraceEmitter -- Need the existential cost type in scope let budgetM = case budgetMode of - Silent -> SomeBudgetMode Cek.restrictingEnormous - Verbose bm -> bm + Silent -> SomeBudgetMode Cek.restrictingEnormous + Verbose bm -> bm case budgetM of - SomeBudgetMode bm -> - do - let Cek.CekReport res budget logs = Cek.runCek cekparams bm emitM term - case Cek.cekResultToEither res of - Left err -> hPrint stderr err - Right v -> - case nameFormat of - IdNames -> writeToOutput outp $ prettyPrintByMode printMode v - DeBruijnNames -> writeToOutput outp $ prettyPrintByMode printMode $ toDeBruijnTermUPLC v - case budgetMode of - Silent -> pure () - Verbose _ -> printBudgetState term cekModel budget - case traceMode of - None -> pure () - _ -> writeToOutput outp (T.intercalate "\n" logs) - case Cek.cekResultToEither res of - Left _ -> exitFailure - Right _ -> pure () + SomeBudgetMode bm -> + do + let Cek.CekReport res budget logs = Cek.runCek cekparams bm emitM term + case Cek.cekResultToEither res of + Left err -> hPrint stderr err + Right v -> + case nameFormat of + IdNames -> writeToOutput outp $ prettyPrintByMode printMode v + DeBruijnNames -> writeToOutput outp $ prettyPrintByMode printMode $ toDeBruijnTermUPLC v + case budgetMode of + Silent -> pure () + Verbose _ -> printBudgetState term cekModel budget + case traceMode of + None -> pure () + _ -> writeToOutput outp (T.intercalate "\n" logs) + case Cek.cekResultToEither res of + Left _ -> exitFailure + Right _ -> pure () ---------------- Debugging ---------------- runDbg :: DbgOptions -> IO () runDbg (DbgOptions inp ifmt cekModel semvar) = do - prog <- readProgram ifmt inp - let term = prog ^. UPLC.progTerm - nterm = fromRight (error "Term to debug must be closed.") $ - runExcept @FreeVariableError $ UPLC.deBruijnTerm term - let cekparams = case cekModel of - -- AST nodes are charged according to the appropriate cost model - Default -> PLC.defaultCekParametersForVariant semvar - -- AST nodes are charged one unit each, so we can see how many times each node - -- type is encountered. This is useful for calibrating the budgeting code - Unit -> PLC.unitCekParameters - replSettings = Repl.Settings { Repl.complete = Repl.noCompletion - , Repl.historyFile = Nothing - , Repl.autoAddHistory = False - } - -- nilSlippage is important so as to get correct live up-to-date budget - cekTrans <- fst <$> D.mkCekTrans cekparams Cek.restrictingEnormous Cek.noEmitter D.nilSlippage - Repl.runInputT replSettings $ - D.iterTM (handleDbg cekTrans) $ D.runDriverT nterm + prog <- readProgram ifmt inp + let term = prog ^. UPLC.progTerm + nterm = + fromRight (error "Term to debug must be closed.") $ + runExcept @FreeVariableError $ + UPLC.deBruijnTerm term + let cekparams = case cekModel of + -- AST nodes are charged according to the appropriate cost model + Default -> PLC.defaultCekParametersForVariant semvar + -- AST nodes are charged one unit each, so we can see how many times each node + -- type is encountered. This is useful for calibrating the budgeting code + Unit -> PLC.unitCekParameters + replSettings = + Repl.Settings + { Repl.complete = Repl.noCompletion + , Repl.historyFile = Nothing + , Repl.autoAddHistory = False + } + -- nilSlippage is important so as to get correct live up-to-date budget + cekTrans <- fst <$> D.mkCekTrans cekparams Cek.restrictingEnormous Cek.noEmitter D.nilSlippage + Repl.runInputT replSettings $ + D.iterTM (handleDbg cekTrans) $ + D.runDriverT nterm -- TODO: this is just an example of an optional single breakpoint, decide -- if we actually want breakpoints for the cli -newtype MaybeBreakpoint = MaybeBreakpoint { _fromMaybeBreakpoint :: Maybe SrcSpan } +newtype MaybeBreakpoint = MaybeBreakpoint {_fromMaybeBreakpoint :: Maybe SrcSpan} type DAnn = SrcSpan instance D.Breakpointable DAnn MaybeBreakpoint where - hasBreakpoints = error "Not implemented: Breakpointable DAnn Breakpoints" + hasBreakpoints = error "Not implemented: Breakpointable DAnn Breakpoints" -- Peel off one layer -handleDbg :: (Cek.ThrowableBuiltins uni fun) - => D.CekTrans uni fun DAnn RealWorld - -> D.DebugF uni fun DAnn MaybeBreakpoint (Repl.InputT IO ()) - -> Repl.InputT IO () +handleDbg :: + Cek.ThrowableBuiltins uni fun => + D.CekTrans uni fun DAnn RealWorld -> + D.DebugF uni fun DAnn MaybeBreakpoint (Repl.InputT IO ()) -> + Repl.InputT IO () handleDbg cekTrans = \case - D.StepF prevState k -> do - -- Note that we first turn Cek to IO and then `liftIO` it to InputT; the alternative of - -- directly using MonadTrans.lift needs MonadCatch+MonadMask instances for CekM, i.e. messy - -- also liftIO would be unnecessary if haskeline.InputT worked with `primitive` - eNewState <- liftIO $ D.liftCek $ tryError $ cekTrans prevState - case eNewState of - Right newState -> k newState - Left e -> Repl.outputStrLn $ show e - -- no continuation, so it acts like exitSuccess - -- FIXME: decide what should happen after the error occurs - D.InputF k -> handleInput >>= k - D.DriverLogF text k -> handleLog text >> k - D.UpdateClientF ds k -> handleUpdate ds >> k + D.StepF prevState k -> do + -- Note that we first turn Cek to IO and then `liftIO` it to InputT; the alternative of + -- directly using MonadTrans.lift needs MonadCatch+MonadMask instances for CekM, i.e. messy + -- also liftIO would be unnecessary if haskeline.InputT worked with `primitive` + eNewState <- liftIO $ D.liftCek $ tryError $ cekTrans prevState + case eNewState of + Right newState -> k newState + Left e -> Repl.outputStrLn $ show e + -- no continuation, so it acts like exitSuccess + -- FIXME: decide what should happen after the error occurs + D.InputF k -> handleInput >>= k + D.DriverLogF text k -> handleLog text >> k + D.UpdateClientF ds k -> handleUpdate ds >> k where handleInput = do - c <- Repl.getInputChar "(s)tep (c)ontinue (n)ext (f)inish (Ctrl+d exit):" - -- TODO: implement print "program counter", breakpoints - -- MAYBE: switch to repline - case c of - Just 's' -> pure D.Step - Just 'c' -> pure $ D.Continue $ MaybeBreakpoint empty - Just 'n' -> pure $ D.Next $ MaybeBreakpoint empty - Just 'f' -> pure $ D.Finish $ MaybeBreakpoint empty - -- otherwise retry - _ -> handleInput + c <- Repl.getInputChar "(s)tep (c)ontinue (n)ext (f)inish (Ctrl+d exit):" + -- TODO: implement print "program counter", breakpoints + -- MAYBE: switch to repline + case c of + Just 's' -> pure D.Step + Just 'c' -> pure $ D.Continue $ MaybeBreakpoint empty + Just 'n' -> pure $ D.Next $ MaybeBreakpoint empty + Just 'f' -> pure $ D.Finish $ MaybeBreakpoint empty + -- otherwise retry + _ -> handleInput handleUpdate s = Repl.outputStrLn $ show $ "Updated state:" <+> pretty s handleLog = Repl.outputStrLn . T.unpack ----------------- Print examples ----------------------- runUplcPrintExample :: - ExampleOptions -> IO () + ExampleOptions -> IO () runUplcPrintExample = runPrintExample getUplcExamples ----------------- Version ----------------------- @@ -488,17 +570,17 @@ versioner = simpleVersioner (gitAwareVersionInfo Paths.version) main :: IO () main = do - options <- customExecParser (prefs showHelpOnEmpty) uplcInfoCommand - case options of - Apply opts -> runApply opts - ApplyToFlatData opts -> runApplyToFlatData opts - ApplyToCborData opts -> runApplyToCborData opts - Benchmark opts -> runBenchmark opts - Eval opts -> runEval opts - Dbg opts -> runDbg opts - Example opts -> runUplcPrintExample opts - Optimise opts -> runOptimisations opts - Print opts -> runPrint @UplcProg opts - Convert opts -> runConvert @UplcProg opts - DumpModel opts -> runDumpModel opts - PrintBuiltinSignatures -> runPrintBuiltinSignatures + options <- customExecParser (prefs showHelpOnEmpty) uplcInfoCommand + case options of + Apply opts -> runApply opts + ApplyToFlatData opts -> runApplyToFlatData opts + ApplyToCborData opts -> runApplyToCborData opts + Benchmark opts -> runBenchmark opts + Eval opts -> runEval opts + Dbg opts -> runDbg opts + Example opts -> runUplcPrintExample opts + Optimise opts -> runOptimisations opts + Print opts -> runPrint @UplcProg opts + Convert opts -> runConvert @UplcProg opts + DumpModel opts -> runDumpModel opts + PrintBuiltinSignatures -> runPrintBuiltinSignatures diff --git a/plutus-executables/test/certifier/Spec.hs b/plutus-executables/test/certifier/Spec.hs index 36da623b869..cfca874e780 100644 --- a/plutus-executables/test/certifier/Spec.hs +++ b/plutus-executables/test/certifier/Spec.hs @@ -1,8 +1,7 @@ -{- | The tests in this file run tests of the uplc certifier. Various - unoptimised UPLC is fed to the optimiser with the certifier turned - on, which will then call the Agda decision procedures for each of - the phases. -} - +-- | The tests in this file run tests of the uplc certifier. Various +-- unoptimised UPLC is fed to the optimiser with the certifier turned +-- on, which will then call the Agda decision procedures for each of +-- the phases. module Main (main) where import GHC.IO.Encoding (setLocaleEncoding, utf8) @@ -14,6 +13,7 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain $ - testGroup "Certification" - [ executableTests - ] + testGroup + "Certification" + [ executableTests + ] diff --git a/plutus-executables/test/certifier/Test/Certifier/Executable.hs b/plutus-executables/test/certifier/Test/Certifier/Executable.hs index 6f68984fdd8..31ba94bbb34 100644 --- a/plutus-executables/test/certifier/Test/Certifier/Executable.hs +++ b/plutus-executables/test/certifier/Test/Certifier/Executable.hs @@ -10,48 +10,55 @@ import System.Process import Test.Tasty import Test.Tasty.HUnit -{- | The tests in this file run tests of the uplc certifier. Various - unoptimised UPLC is fed to the optimiser with the certifier turned - on, which will then call the Agda decision procedures for each of - the phases. -} +-- | The tests in this file run tests of the uplc certifier. Various +-- unoptimised UPLC is fed to the optimiser with the certifier turned +-- on, which will then call the Agda decision procedures for each of +-- the phases. -{- | Run an external executable with some arguments. This is for use inside - HUnit Assertions -} +-- | Run an external executable with some arguments. This is for use inside +-- HUnit Assertions -- TODO(https://github.com/IntersectMBO/plutus-private/issues/1582): -- this is a mess, makeExampleM uses another function to run the certifier, need to -- refactor things to introduce less duplication makeUplcCert :: String -> IO FilePath makeUplcCert name = do - let inputFile = fixedPath "UPLC" name ++ ".uplc" - let args = ["optimise", "--certify", name, - "--input", inputFile, - "--print-mode", "Classic"] - (exitCode, output, err) <- readProcessWithExitCode "uplc" args "" - let certDir = find (fstToUpper name `isPrefixOf`) . concatMap words . lines $ output - case exitCode of - ExitFailure code -> - assertFailure - $ "uplc failed with code: " - <> show code - <> " and output: " - <> output - <> " and error: " - <> err - ExitSuccess -> - case certDir of - Just certDir' -> pure certDir' - Nothing -> assertFailure - $ "uplc failed to produce a certificate for " - <> name - <> " with output: " - <> output - <> " and error: " - <> err + let inputFile = fixedPath "UPLC" name ++ ".uplc" + let args = + [ "optimise" + , "--certify" + , name + , "--input" + , inputFile + , "--print-mode" + , "Classic" + ] + (exitCode, output, err) <- readProcessWithExitCode "uplc" args "" + let certDir = find (fstToUpper name `isPrefixOf`) . concatMap words . lines $ output + case exitCode of + ExitFailure code -> + assertFailure $ + "uplc failed with code: " + <> show code + <> " and output: " + <> output + <> " and error: " + <> err + ExitSuccess -> + case certDir of + Just certDir' -> pure certDir' + Nothing -> + assertFailure $ + "uplc failed to produce a certificate for " + <> name + <> " with output: " + <> output + <> " and error: " + <> err fstToUpper :: String -> String -fstToUpper [] = [] -fstToUpper (x:xs) = toUpper x : xs +fstToUpper [] = [] +fstToUpper (x : xs) = toUpper x : xs makeSimpleCertTest :: String -> TestTree makeSimpleCertTest name = @@ -84,31 +91,37 @@ makeExampleM :: String -> IO ExitCode makeExampleM testname = do (_, example, _) <- readProcessWithExitCode "uplc" ["example", "-s", testname] [] let testNameCert = testname <> "Cert" - args = ["optimise", "--certify", testNameCert, - "--print-mode", "Classic"] + args = + [ "optimise" + , "--certify" + , testNameCert + , "--print-mode" + , "Classic" + ] (exitCode, output, err) <- readProcessWithExitCode "uplc" args example case exitCode of ExitFailure code -> - assertFailure - $ "uplc failed with code: " - <> show code - <> " and output: " - <> output - <> " and error: " - <> err + assertFailure $ + "uplc failed with code: " + <> show code + <> " and output: " + <> output + <> " and error: " + <> err ExitSuccess -> do let certDir = find (fstToUpper testNameCert `isPrefixOf`) . concatMap words . lines $ output case certDir of Just certDir' -> do removeDirectoryRecursive certDir' pure exitCode - Nothing -> assertFailure - $ "uplc failed to produce a certificate for " - <> testNameCert - <> " with output: " - <> output - <> " and error: " - <> err + Nothing -> + assertFailure $ + "uplc failed to produce a certificate for " + <> testNameCert + <> " with output: " + <> output + <> " and error: " + <> err makeExample :: String -> Assertion makeExample testname = do @@ -124,17 +137,16 @@ runAgda file = do (exitCode, result, _) <- readProcessWithExitCode "agda-with-stdlib-and-metatheory" [file] [] return (exitCode, result) - agdaTestCert :: String -> Assertion agdaTestCert name = do - certDir <- makeUplcCert name - oldDir <- getCurrentDirectory - setCurrentDirectory certDir - (resCode, resText) <- runAgda ("src" fstToUpper name <> ".agda") - setCurrentDirectory oldDir - if resCode == ExitSuccess - then removeDirectoryRecursive certDir - else assertFailure $ name ++ " creates an invalid certificate: " ++ resText + certDir <- makeUplcCert name + oldDir <- getCurrentDirectory + setCurrentDirectory certDir + (resCode, resText) <- runAgda ("src" fstToUpper name <> ".agda") + setCurrentDirectory oldDir + if resCode == ExitSuccess + then removeDirectoryRecursive certDir + else assertFailure $ name ++ " creates an invalid certificate: " ++ resText {- agdaExampleCert :: String -> Assertion @@ -151,7 +163,7 @@ agdaExampleCert name = do fixedPath :: FilePath fixedPath = "test/certifier/" -srcTests :: [ String ] +srcTests :: [String] srcTests = [ "inc" , "len" @@ -161,13 +173,13 @@ srcTests = , "builtinUnparse" ] -makeExampleTests :: [ String ] -> [ TestTree ] +makeExampleTests :: [String] -> [TestTree] makeExampleTests = map (\testname -> testCase testname (makeExample testname)) -makeSimpleTests :: [ String ] -> [ TestTree ] +makeSimpleTests :: [String] -> [TestTree] makeSimpleTests = map $ makeSimpleCertTest -makeSerialisationTests :: [ String ] -> [ TestTree] +makeSerialisationTests :: [String] -> [TestTree] makeSerialisationTests = map (\testname -> testCase testname (agdaTestCert testname)) {- @@ -177,12 +189,12 @@ makeSerialisationExampleTests = map (\testname -> testCase testname (agdaExample executableTests :: TestTree executableTests = - testGroup "certifier executable tests" - [ - -- TODO: tracked by https://github.com/IntersectMBO/plutus-private/issues/1556 - -- testGroup "example serialisation certification" - -- $ makeSerialisationExampleTests exampleNames - testGroup "simple certification" $ makeSimpleTests srcTests - , testGroup "example certification" $ makeExampleTests exampleNames - , testGroup "serialisation certification" $ makeSerialisationTests srcTests + testGroup + "certifier executable tests" + [ -- TODO: tracked by https://github.com/IntersectMBO/plutus-private/issues/1556 + -- testGroup "example serialisation certification" + -- $ makeSerialisationExampleTests exampleNames + testGroup "simple certification" $ makeSimpleTests srcTests + , testGroup "example certification" $ makeExampleTests exampleNames + , testGroup "serialisation certification" $ makeSerialisationTests srcTests ] diff --git a/plutus-executables/test/detailed/Spec.hs b/plutus-executables/test/detailed/Spec.hs index 33d71d85321..b75839ff49f 100644 --- a/plutus-executables/test/detailed/Spec.hs +++ b/plutus-executables/test/detailed/Spec.hs @@ -1,11 +1,10 @@ -- editorconfig-checker-disable-file {-# LANGUAGE LambdaCase #-} -{- | The tests in this file run the various Adga PLC evaluators on the examples - provided by `plc example` and `uplc example` and checks that the output is - the same as that produced by the Haskell `plc` and `uplc` evaluators and the - other Agda evaluators.. -} - +-- | The tests in this file run the various Adga PLC evaluators on the examples +-- provided by `plc example` and `uplc example` and checks that the output is +-- the same as that produced by the Haskell `plc` and `uplc` evaluators and the +-- other Agda evaluators.. module Main (main) where import PlutusCore.Name.Unique (isIdentifierChar) @@ -43,23 +42,25 @@ catchOutput act = do removeFile tmpFP return str -{- | Run plc-agda with some arguments. This is for use inside HUnit Assertions -} +-- | Run plc-agda with some arguments. This is for use inside HUnit Assertions runPlcAgda :: [String] -> IO String runPlcAgda args = - catchOutput $ catch - (withArgs args M.main) - (\case - ExitFailure _ -> assertFailure "plc-agda failed" - ExitSuccess -> return ()) - -{- | Run an external executable with some arguments. This is for use inside HUnit - Assertions -} + catchOutput $ + catch + (withArgs args M.main) + ( \case + ExitFailure _ -> assertFailure "plc-agda failed" + ExitSuccess -> return () + ) + +-- | Run an external executable with some arguments. This is for use inside HUnit +-- Assertions runProg :: String -> [String] -> String -> IO String runProg prog args stdin' = do (exitCode, output, err) <- readProcessWithExitCode prog args stdin' case exitCode of ExitFailure _ -> assertFailure $ prog ++ " failed: " ++ err - ExitSuccess -> pure () + ExitSuccess -> pure () pure output {- These tests were previously broken because they produced textual output from @@ -78,52 +79,52 @@ directly. This depends crucially on names with de Bruijn indices being of the form `[A-Za-z0-9_]*![0-9]+`. -} -{- | This takes a string and reverses it while squashing all sequences of - whitespace (including '\n' and '\t') down to single spaces -} +-- | This takes a string and reverses it while squashing all sequences of +-- whitespace (including '\n' and '\t') down to single spaces squashRev :: String -> String squashRev s = go s [] - where go [] acc = acc - go (c:cs) acc = - if isSpace c - then go (dropWhile isSpace cs) (' ':acc) - else go cs (c:acc) - -{- | This takes a string with de Bruijn indices of the form abc!456 and converts - them to things like !456. We actually take a reversed string and when we - find a digit we seek along the string for a '!'; if we find one then we skip - all characters after it which are allowed in textual IDs until we get to one - that isn't. Conveniently `squashRev` provides us with a reversed string for - input to this function. -} + where + go [] acc = acc + go (c : cs) acc = + if isSpace c + then go (dropWhile isSpace cs) (' ' : acc) + else go cs (c : acc) + +-- | This takes a string with de Bruijn indices of the form abc!456 and converts +-- them to things like !456. We actually take a reversed string and when we +-- find a digit we seek along the string for a '!'; if we find one then we skip +-- all characters after it which are allowed in textual IDs until we get to one +-- that isn't. Conveniently `squashRev` provides us with a reversed string for +-- input to this function. anonDeBruijn :: String -> String anonDeBruijn s = go s [] where go [] acc = acc - go (c:cs) acc = + go (c : cs) acc = if isDigit c - then go2 cs (c:acc) - else go cs (c:acc) + then go2 cs (c : acc) + else go cs (c : acc) {- go2: copy all digits to the output until we find a '!'; after that drop all characters that might appear in a textual name. Strictly we should also check that the final character is an identifierStartingChar and maybe also account for quoted ideintfiers. -} - go2 [] acc = acc - go2 ('!':cs) acc = go (dropWhile isIdentifierChar cs) ('!':acc) - go2 s' acc = go s' acc - -{- | Convert a textual PLC term containing de Bruijn-named variables of the form id!index -to a canonical form. - -eg, "(lam var!0 [( builtin addInteger) var!1 x!4 ])" - -> "(lam !0 [( builtin addInteger) var!1 x!4 ])" - -The main point of this is to (a) ignore everything in names apart from the de -Bruijn index, and (b) to remove newlines and indentation. This could be -misleading if a program happens tocontain a literal string that has a substring -that looks like one of our de Bruijn-named variables. However that seems very -improbable, and for it to cause problems in our tests we'd need to have two -terms that contain literal strings in the same place which have different -de-Bruijn-like substrings, which seems even more unlikely. --} + go2 [] acc = acc + go2 ('!' : cs) acc = go (dropWhile isIdentifierChar cs) ('!' : acc) + go2 s' acc = go s' acc + +-- | Convert a textual PLC term containing de Bruijn-named variables of the form id!index +-- to a canonical form. +-- +-- eg, "(lam var!0 [( builtin addInteger) var!1 x!4 ])" +-- -> "(lam !0 [( builtin addInteger) var!1 x!4 ])" +-- +-- The main point of this is to (a) ignore everything in names apart from the de +-- Bruijn index, and (b) to remove newlines and indentation. This could be +-- misleading if a program happens tocontain a literal string that has a substring +-- that looks like one of our de Bruijn-named variables. However that seems very +-- improbable, and for it to cause problems in our tests we'd need to have two +-- terms that contain literal strings in the same place which have different +-- de-Bruijn-like substrings, which seems even more unlikely. canonicalise :: String -> String canonicalise = anonDeBruijn . squashRev @@ -138,11 +139,17 @@ compareResultPlc eq mode testname = withTempFile $ \tmp -> do plcAgdaOutput <- runPlcAgda [mode, "--input", tmp] let plcOutput' = canonicalise plcOutput plcAgdaOutput' = canonicalise plcAgdaOutput - assertBool ("plc: " ++ plcOutput ++ "plc-agda: " ++ plcAgdaOutput - ++ "** If these look the same they may be failing to parse.") $ - T.pack plcOutput' `eq` T.pack plcAgdaOutput' - -- If `eq` was M.alphaTm here it would return False if either of the inputs - -- didn't parse, which is confusing. + assertBool + ( "plc: " + ++ plcOutput + ++ "plc-agda: " + ++ plcAgdaOutput + ++ "** If these look the same they may be failing to parse." + ) + $ T.pack plcOutput' `eq` T.pack plcAgdaOutput' + +-- If `eq` was M.alphaTm here it would return False if either of the inputs +-- didn't parse, which is confusing. -- Compare the output of uplc vs plc-agda in untyped mode compareResultUplc :: (T.Text -> T.Text -> Bool) -> String -> String -> Assertion @@ -153,9 +160,14 @@ compareResultUplc eq mode testname = withTempFile $ \tmp -> do plcAgdaOutput <- runPlcAgda [mode, "-mU", "--input", tmp] let plcOutput' = canonicalise plcOutput plcAgdaOutput' = canonicalise plcAgdaOutput - assertBool ("uplc: " ++ plcAgdaOutput ++ "plc-agda: " ++ plcOutput - ++ "** If these look the same they may be failing to parse.") $ - T.pack plcOutput' `eq` T.pack plcAgdaOutput' + assertBool + ( "uplc: " + ++ plcAgdaOutput + ++ "plc-agda: " + ++ plcOutput + ++ "** If these look the same they may be failing to parse." + ) + $ T.pack plcOutput' `eq` T.pack plcAgdaOutput' -- Compare the results of two different (typed) plc-agda modes compareResultAgda :: (T.Text -> T.Text -> Bool) -> String -> String -> String -> Assertion @@ -165,9 +177,16 @@ compareResultAgda eq mode1 mode2 testname = withTempFile $ \tmp -> do plcAgdaOutput1 <- runPlcAgda ["evaluate", "--input", tmp, "--mode", mode1] plcAgdaOutput2 <- runPlcAgda ["evaluate", "--input", tmp, "--mode", mode2] -- The outputs are both produced by plc-agda so we don't have to canonicalise them. - assertBool (mode1 ++ ": " ++ plcAgdaOutput1 ++ mode2 ++ ": " ++ plcAgdaOutput2 - ++ "** If these look the same they may be failing to parse.") $ - T.pack plcAgdaOutput1 `eq` T.pack plcAgdaOutput2 + assertBool + ( mode1 + ++ ": " + ++ plcAgdaOutput1 + ++ mode2 + ++ ": " + ++ plcAgdaOutput2 + ++ "** If these look the same they may be failing to parse." + ) + $ T.pack plcAgdaOutput1 `eq` T.pack plcAgdaOutput2 -- These come from `plc example -a` but there are a couple of failing tests which are omitted. -- `uplc` provides the same examples, but erased. @@ -205,16 +224,18 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain $ - testGroup "Detailed" - -- These should really use M.alphaTm or M.alphaTy instead of (==). - [ testGroup "plc-agda vs. uplc: evaluation" . mkTests $ mkTestUplc (==) "evaluate" - , testGroup "plc-agda vs. plc: evaluation" . mkTests $ mkTestPlc (==) "evaluate" - , testGroup "plc-agda vs. plc: typechecking" . mkTests $ mkTestPlc (==) "typecheck" - , testGroup "TL vs. TCK" . mkTests $ mkTestAgda (==) "TL" "TCK" - , testGroup "TCK vs. TCEK" . mkTests $ mkTestAgda (==) "TCK" "TCEK" + testGroup + "Detailed" + -- These should really use M.alphaTm or M.alphaTy instead of (==). + [ testGroup "plc-agda vs. uplc: evaluation" . mkTests $ mkTestUplc (==) "evaluate" + , testGroup "plc-agda vs. plc: evaluation" . mkTests $ mkTestPlc (==) "evaluate" + , testGroup "plc-agda vs. plc: typechecking" . mkTests $ mkTestPlc (==) "typecheck" + , testGroup "TL vs. TCK" . mkTests $ mkTestAgda (==) "TL" "TCK" + , testGroup "TCK vs. TCEK" . mkTests $ mkTestAgda (==) "TCK" "TCEK" -- tests against extrinisically typed interpreter disabled -- , mkTestMode "L" "TL" M.alphaTm -- , mkTestMode "L" "CK" M.alphaTm -- , mkTestMode "CK" "TCK" M.alphaTm - ] - where mkTests mktest = map mktest testNames + ] + where + mkTests mktest = map mktest testNames diff --git a/plutus-executables/test/simple/Spec.hs b/plutus-executables/test/simple/Spec.hs index 231b41b0a6c..4b10732ff99 100644 --- a/plutus-executables/test/simple/Spec.hs +++ b/plutus-executables/test/simple/Spec.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PackageImports #-} -{- | The tests in this file run the various Adga PLC and UPLC evaluators on the - examples provided by `plc example` and `uplc example` and checks that the - tests succeed or fail as expected. -} - +-- | The tests in this file run the various Adga PLC and UPLC evaluators on the +-- examples provided by `plc example` and `uplc example` and checks that the +-- tests succeed or fail as expected. module Main where import Control.Exception @@ -15,66 +14,71 @@ import System.Process import MAlonzo.Code.Main qualified as M --- |List of tests that are expected to succeed +-- | List of tests that are expected to succeed succeedingEvalTests :: [String] -succeedingEvalTests = ["succInteger" - ,"unitval" - ,"true" - ,"false" - ,"churchZero" - ,"churchSucc" - ,"overapplication" - ,"factorial" - ,"fibonacci" - ,"NatRoundTrip" - ,"ScottListSum" - ,"IfIntegers" - ,"ApplyAdd1" - ,"ApplyAdd2" - ] - --- |List of tests that are expected to fail +succeedingEvalTests = + [ "succInteger" + , "unitval" + , "true" + , "false" + , "churchZero" + , "churchSucc" + , "overapplication" + , "factorial" + , "fibonacci" + , "NatRoundTrip" + , "ScottListSum" + , "IfIntegers" + , "ApplyAdd1" + , "ApplyAdd2" + ] + +-- | List of tests that are expected to fail failingEvalTests :: [String] failingEvalTests = ["DivideByZero"] type Mode = String -data Command = Evaluate Mode | Typecheck deriving stock Show +data Command = Evaluate Mode | Typecheck deriving stock (Show) --- |For each Command construct arguments to pass to plc-agda +-- | For each Command construct arguments to pass to plc-agda mkArgs :: String -> Command -> [String] -mkArgs file (Evaluate mode) = ["evaluate","--input",file,"--mode",mode] -mkArgs file Typecheck = ["typecheck","--input",file] +mkArgs file (Evaluate mode) = ["evaluate", "--input", file, "--mode", mode] +mkArgs file Typecheck = ["typecheck", "--input", file] --- |For each Command determine which executable should generate examples +-- | For each Command determine which executable should generate examples exampleGenerator :: Command -> String exampleGenerator (Evaluate "U") = "uplc" -exampleGenerator _ = "plc" +exampleGenerator _ = "plc" --- |@runTest cmd tst@ generates a @tst@ example and runs it with the given @cmd@. +-- | @runTest cmd tst@ generates a @tst@ example and runs it with the given @cmd@. runTest :: Command -> String -> IO () runTest command test = withTempFile $ \tmp -> do - example <- readProcess (exampleGenerator command) ["example", "-s",test] [] + example <- readProcess (exampleGenerator command) ["example", "-s", test] [] writeFile tmp example putStrLn $ "test: " ++ test ++ " [" ++ show command ++ "]" withArgs (mkArgs tmp command) M.main --- |Run a list of tests with a given command expecting them to succeed. +-- | Run a list of tests with a given command expecting them to succeed. runSucceedingTests :: Command -> [String] -> IO () runSucceedingTests _ [] = return () -runSucceedingTests command (test:tests) = catch - (runTest command test) - (\case - ExitFailure _ -> exitFailure - ExitSuccess -> runSucceedingTests command tests) - --- |Run a list of tests with a given command expecting them to fail. +runSucceedingTests command (test : tests) = + catch + (runTest command test) + ( \case + ExitFailure _ -> exitFailure + ExitSuccess -> runSucceedingTests command tests + ) + +-- | Run a list of tests with a given command expecting them to fail. runFailingTests :: Command -> [String] -> IO () runFailingTests _ [] = return () -runFailingTests command (test:tests) = catch - (runTest command test) - (\case - ExitFailure _ -> runFailingTests command tests - ExitSuccess -> exitFailure) +runFailingTests command (test : tests) = + catch + (runTest command test) + ( \case + ExitFailure _ -> runFailingTests command tests + ExitSuccess -> exitFailure + ) main :: IO () main = do diff --git a/plutus-ledger-api/exe/analyse-script-events/Main.hs b/plutus-ledger-api/exe/analyse-script-events/Main.hs index 2e873cd64b6..33c2abe1788 100644 --- a/plutus-ledger-api/exe/analyse-script-events/Main.hs +++ b/plutus-ledger-api/exe/analyse-script-events/Main.hs @@ -1,13 +1,13 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- | Various analyses of events in mainnet script dumps. module Main (main) where @@ -41,11 +41,11 @@ import System.IO (stderr) import Text.Printf (hPrintf, printf) -- | The type of a generic analysis function -type EventAnalyser - = EvaluationContext - -> [Int64] -- cost parameters - -> ScriptEvaluationEvent - -> IO () +type EventAnalyser = + EvaluationContext -> + [Int64] -> -- cost parameters + ScriptEvaluationEvent -> + IO () -- Analyse values in ScriptContext @@ -66,28 +66,28 @@ stringOfPurposeV2 = \case stringOfPurposeV3 :: V3.ScriptInfo -> String stringOfPurposeV3 = \case - V3.MintingScript{} -> "V3 Minting" - V3.SpendingScript{} -> "V3 Spending" - V3.RewardingScript{} -> "V3 Rewarding" - V3.CertifyingScript{} -> "V3 Certifying" - V3.VotingScript{} -> "V3 Voting" - V3.ProposingScript{} -> "V3 Proposing" - -shapeOfValue :: V1.Value -> String + V3.MintingScript {} -> "V3 Minting" + V3.SpendingScript {} -> "V3 Spending" + V3.RewardingScript {} -> "V3 Rewarding" + V3.CertifyingScript {} -> "V3 Certifying" + V3.VotingScript {} -> "V3 Voting" + V3.ProposingScript {} -> "V3 Proposing" + +shapeOfValue :: V1.Value -> String shapeOfValue (V1.Value m) = - let l = M.toList m - in printf "[%d: %s]" (length l) (intercalate "," (fmap (printf "%d" . length . M.toList . snd) l)) + let l = M.toList m + in printf "[%d: %s]" (length l) (intercalate "," (fmap (printf "%d" . length . M.toList . snd) l)) analyseValue :: V1.Value -> IO () analyseValue v = do putStr $ shapeOfValue v printf "\n" -analyseOutputs :: [a] -> (a -> V1.Value) -> IO () -- Luckily V1.Value is the same as V2.Value +analyseOutputs :: [a] -> (a -> V1.Value) -> IO () -- Luckily V1.Value is the same as V2.Value analyseOutputs outputs getValue = case outputs of - [] -> putStrLn "No outputs" -- This happens in 0000000046344292-*.event - l -> do + [] -> putStrLn "No outputs" -- This happens in 0000000046344292-*.event + l -> do putStr $ printf "Outputs %d " (length l) putStrLn $ intercalate ", " (fmap (shapeOfValue . getValue) l) @@ -119,44 +119,46 @@ analyseTxInfoV3 i = do analyseScriptContext :: EventAnalyser analyseScriptContext _ctx _params ev = case ev of - PlutusEvent PlutusV1 ScriptEvaluationData{..} _expected -> - case dataInputs of - [_,_,c] -> analyseCtxV1 c - [_,c] -> analyseCtxV1 c - l -> error $ printf "Unexpected number of V1 script arguments: %d" (length l) - PlutusEvent PlutusV2 ScriptEvaluationData{..} _expected -> - case dataInputs of - [_,_,c] -> analyseCtxV2 c - [_,c] -> analyseCtxV2 c - l -> error $ printf "Unexpected number of V2 script arguments: %d" (length l) - PlutusEvent PlutusV3 ScriptEvaluationData{..} _expected -> - case dataInputs of - [_,_,c] -> analyseCtxV3 c - [_,c] -> analyseCtxV3 c - l -> error $ printf "Unexpected number of V3 script arguments: %d" (length l) - where + PlutusEvent PlutusV1 ScriptEvaluationData {..} _expected -> + case dataInputs of + [_, _, c] -> analyseCtxV1 c + [_, c] -> analyseCtxV1 c + l -> error $ printf "Unexpected number of V1 script arguments: %d" (length l) + PlutusEvent PlutusV2 ScriptEvaluationData {..} _expected -> + case dataInputs of + [_, _, c] -> analyseCtxV2 c + [_, c] -> analyseCtxV2 c + l -> error $ printf "Unexpected number of V2 script arguments: %d" (length l) + PlutusEvent PlutusV3 ScriptEvaluationData {..} _expected -> + case dataInputs of + [_, _, c] -> analyseCtxV3 c + [_, c] -> analyseCtxV3 c + l -> error $ printf "Unexpected number of V3 script arguments: %d" (length l) + where analyseCtxV1 c = - case V1.fromData @V1.ScriptContext c of - Just p -> printV1info p - Nothing -> do - -- This really happens: there are V1 events in 0000000103367139-*.event with a V2 context - putStrLn "\n* Failed to decode V1 ScriptContext for V1 event: trying V2" - case V2.fromData @V2.ScriptContext c of - Nothing -> putStrLn "* Failed to decode V2 ScriptContext for V1 event: giving up\n" - Just p -> - do putStrLn "* Successfully decoded V2 ScriptContext for V1 event" - printV2info p + case V1.fromData @V1.ScriptContext c of + Just p -> printV1info p + Nothing -> do + -- This really happens: there are V1 events in 0000000103367139-*.event with a V2 context + putStrLn "\n* Failed to decode V1 ScriptContext for V1 event: trying V2" + case V2.fromData @V2.ScriptContext c of + Nothing -> putStrLn "* Failed to decode V2 ScriptContext for V1 event: giving up\n" + Just p -> + do + putStrLn "* Successfully decoded V2 ScriptContext for V1 event" + printV2info p analyseCtxV2 c = - case V2.fromData @V2.ScriptContext c of - Just p -> printV2info p - Nothing -> do - putStrLn "\n* Failed to decode V2 ScriptContext for V2 event: trying V1" - case V1.fromData @V1.ScriptContext c of - Nothing -> putStrLn "* Failed to decode V1 ScriptContext for V2 event: giving up\n" - Just p -> - do putStrLn "* Successfully decoded V1 ScriptContext for V2 event" - printV1info p + case V2.fromData @V2.ScriptContext c of + Just p -> printV2info p + Nothing -> do + putStrLn "\n* Failed to decode V2 ScriptContext for V2 event: trying V1" + case V1.fromData @V1.ScriptContext c of + Nothing -> putStrLn "* Failed to decode V1 ScriptContext for V2 event: giving up\n" + Just p -> + do + putStrLn "* Successfully decoded V1 ScriptContext for V2 event" + printV1info p analyseCtxV3 c = case V3.fromData @V3.ScriptContext c of @@ -193,22 +195,23 @@ analyseScriptContext _ctx _params ev = case ev of -- Statistics about a Data object data DataInfo = DataInfo - { _memUsage :: Integer - , _numNodes :: Integer - , _depth :: Integer - , _numInodes :: Integer - , _maxIsize :: Integer -- Maximum memoryUsage of integers in I nodes - , _totalIsize :: Integer -- Total memoryUsage of integers in I nodes - , _numBnodes :: Integer - , _maxBsize :: Integer -- Maximum memoryUsage of bytestrings in B nodes - , _totalBsize :: Integer -- Total memoryUsage of bytestrings in B nodes - , _numLnodes :: Integer - , _maxLlen :: Integer -- Maximum list length - , _numCnodes :: Integer - , _maxClen :: Integer -- Maximum number of constructor arguments - , _numMnodes :: Integer - , _maxMlen :: Integer -- Maximum map length - } deriving stock (Show) + { _memUsage :: Integer + , _numNodes :: Integer + , _depth :: Integer + , _numInodes :: Integer + , _maxIsize :: Integer -- Maximum memoryUsage of integers in I nodes + , _totalIsize :: Integer -- Total memoryUsage of integers in I nodes + , _numBnodes :: Integer + , _maxBsize :: Integer -- Maximum memoryUsage of bytestrings in B nodes + , _totalBsize :: Integer -- Total memoryUsage of bytestrings in B nodes + , _numLnodes :: Integer + , _maxLlen :: Integer -- Maximum list length + , _numCnodes :: Integer + , _maxClen :: Integer -- Maximum number of constructor arguments + , _numMnodes :: Integer + , _maxMlen :: Integer -- Maximum map length + } + deriving stock (Show) makeLenses ''DataInfo emptyInfo :: DataInfo @@ -221,51 +224,64 @@ memU = fromSatInt . sumCostStream . flattenCostRose . memoryUsage -- Header (useful for R) printDataHeader :: IO () printDataHeader = - printf "memUsage numNodes depth numI maxIsize totalIsize numB maxBsize totalBsize numL maxL numC maxC numM maxM\n" + printf "memUsage numNodes depth numI maxIsize totalIsize numB maxBsize totalBsize numL maxL numC maxC numM maxM\n" printDataInfo :: DataInfo -> IO () -printDataInfo DataInfo{..} = - printf "%4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d\n" - _memUsage _numNodes _depth - _numInodes _maxIsize _totalIsize - _numBnodes _maxBsize _totalBsize - _numLnodes _maxLlen - _numCnodes _maxClen - _numMnodes _maxMlen +printDataInfo DataInfo {..} = + printf + "%4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d %4d\n" + _memUsage + _numNodes + _depth + _numInodes + _maxIsize + _totalIsize + _numBnodes + _maxBsize + _totalBsize + _numLnodes + _maxLlen + _numCnodes + _maxClen + _numMnodes + _maxMlen -- Traverse a Data object collecting information getDataInfo :: Data -> DataInfo getDataInfo d = - let ilen = fromIntegral . length - info = go d emptyInfo - go x i = - case x of - I n -> i & numInodes +~ 1 & maxIsize %~ max s & totalIsize +~ s where s = memU n - B b -> i & numBnodes +~ 1 & maxBsize %~ max s & totalBsize +~ s where s = memU b - List l -> foldr go i' l where i' = i & numLnodes +~ 1 & maxLlen %~ max (ilen l) - Data.Constr _ l -> foldr go i' l where i' = i & numCnodes %~ (+1) & maxClen %~ max (ilen l) - Map l -> let (a,b) = unzip l - in foldr go (foldr go i' a) b where i' = i & numMnodes +~ 1 & maxMlen %~ max (ilen l) - getDepth = \case - I _ -> 1 - B _ -> 1 - List l -> 1 + depthList l - Data.Constr _ l -> 1 + depthList l - Map l -> let (a,b) = unzip l - in 1 + max (depthList a) (depthList b) - depthList = foldl (\n a -> max n (getDepth a)) 0 - totalNodes = sum $ info ^.. (numInodes <> numBnodes <> numLnodes <> numCnodes <> numMnodes) - in info & memUsage .~ memU d & numNodes .~ totalNodes & depth .~ getDepth d + let ilen = fromIntegral . length + info = go d emptyInfo + go x i = + case x of + I n -> i & numInodes +~ 1 & maxIsize %~ max s & totalIsize +~ s where s = memU n + B b -> i & numBnodes +~ 1 & maxBsize %~ max s & totalBsize +~ s where s = memU b + List l -> foldr go i' l where i' = i & numLnodes +~ 1 & maxLlen %~ max (ilen l) + Data.Constr _ l -> foldr go i' l where i' = i & numCnodes %~ (+ 1) & maxClen %~ max (ilen l) + Map l -> + let (a, b) = unzip l + in foldr go (foldr go i' a) b + where + i' = i & numMnodes +~ 1 & maxMlen %~ max (ilen l) + getDepth = \case + I _ -> 1 + B _ -> 1 + List l -> 1 + depthList l + Data.Constr _ l -> 1 + depthList l + Map l -> + let (a, b) = unzip l + in 1 + max (depthList a) (depthList b) + depthList = foldl (\n a -> max n (getDepth a)) 0 + totalNodes = sum $ info ^.. (numInodes <> numBnodes <> numLnodes <> numCnodes <> numMnodes) + in info & memUsage .~ memU d & numNodes .~ totalNodes & depth .~ getDepth d printDataInfoFor :: Data -> IO () printDataInfoFor = printDataInfo <$> getDataInfo - -- Analyse a redeemer (as a Data object) from a script evaluation event analyseRedeemer :: EventAnalyser analyseRedeemer _ctx _params ev = do case ev of - PlutusEvent ledgerLanguage ScriptEvaluationData{..} _expected -> + PlutusEvent ledgerLanguage ScriptEvaluationData {..} _expected -> case dataInputs of [_d, r, _c] -> printDataInfoFor r [r, _c] -> printDataInfoFor r @@ -275,7 +291,7 @@ analyseRedeemer _ctx _params ev = do analyseDatum :: EventAnalyser analyseDatum _ctx _params ev = do case ev of - PlutusEvent ledgerLanguage ScriptEvaluationData{..} _expected -> + PlutusEvent ledgerLanguage ScriptEvaluationData {..} _expected -> case dataInputs of [d, _r, _c] -> printDataInfoFor d [_r, _c] -> pure () @@ -284,22 +300,22 @@ analyseDatum _ctx _params ev = do -- Print statistics about Data objects in a Term analyseTermDataObjects :: Term NamedDeBruijn DefaultUni DefaultFun () -> IO () analyseTermDataObjects = go - where go = - \case - Var _ _ -> pure () - LamAbs _ _ t -> go t - Apply _ t1 t2 -> go t1 >> go t2 - Force _ t -> go t - Delay _ t -> go t - Constant _ c -> - case c of - Some (ValueOf DefaultUniData d) -> printDataInfoFor d - _ -> pure () - Builtin _ _ -> pure () - Error _ -> pure () - UPLC.Constr _ _ ts -> mapM_ go ts - Case _ t1 t2 -> go t1 >> mapM_ go t2 - + where + go = + \case + Var _ _ -> pure () + LamAbs _ _ t -> go t + Apply _ t1 t2 -> go t1 >> go t2 + Force _ t -> go t + Delay _ t -> go t + Constant _ c -> + case c of + Some (ValueOf DefaultUniData d) -> printDataInfoFor d + _ -> pure () + Builtin _ _ -> pure () + Error _ -> pure () + UPLC.Constr _ _ ts -> mapM_ go ts + Case _ t1 t2 -> go t1 >> mapM_ go t2 -- Counting builtins @@ -307,20 +323,21 @@ type BuiltinCounts = P.MutablePrimArray (PrimState IO) Int countBuiltinsInTerm :: BuiltinCounts -> Term NamedDeBruijn DefaultUni DefaultFun () -> IO () countBuiltinsInTerm counts = go - where go = \case - Var _ _ -> pure () - LamAbs _ _ t -> go t - Apply _ t1 t2 -> go t1 >> go t2 - Force _ t -> go t - Delay _ t -> go t - Constant _ _ -> pure () - Builtin _ b -> incrCount $ fromEnum b - Error _ -> pure () - UPLC.Constr _ _ ts -> mapM_ go ts - Case _ t1 t2 -> go t1 >> mapM_ go t2 - incrCount i = do - c <- P.readPrimArray counts i - P.writePrimArray counts i (c+1) + where + go = \case + Var _ _ -> pure () + LamAbs _ _ t -> go t + Apply _ t1 t2 -> go t1 >> go t2 + Force _ t -> go t + Delay _ t -> go t + Constant _ _ -> pure () + Builtin _ b -> incrCount $ fromEnum b + Error _ -> pure () + UPLC.Constr _ _ ts -> mapM_ go ts + Case _ t1 t2 -> go t1 >> mapM_ go t2 + incrCount i = do + c <- P.readPrimArray counts i + P.writePrimArray counts i (c + 1) -- The other analyses just print out results as they proceed. It's a little -- more complicated here because we have to accumulate the results and print @@ -333,107 +350,103 @@ countBuiltins eventFiles = do mapM_ (analyseOneFile (analyseUnappliedScript (countBuiltinsInTerm counts))) eventFiles finalCounts <- P.freezePrimArray counts 0 numBuiltins P.itraversePrimArray_ printEntry finalCounts - where printEntry i = printf "%-35s %12d\n" (show (toEnum i :: DefaultFun)) - + where + printEntry i = printf "%-35s %12d\n" (show (toEnum i :: DefaultFun)) -data EvaluationResult = OK ExBudget | Failed | DeserialisationError +data EvaluationResult = OK ExBudget | Failed | DeserialisationError -- Convert to a string for use in an R frame toRString :: EvaluationResult -> String toRString = \case - OK _ -> "T" - Failed -> "F" + OK _ -> "T" + Failed -> "F" DeserialisationError -> "NA" -- Print out the actual and claimed CPU and memory cost of every script. analyseCosts :: EventAnalyser analyseCosts ctx _ ev = case ev of - PlutusEvent PlutusV1 ScriptEvaluationData{..} _ -> + PlutusEvent PlutusV1 ScriptEvaluationData {..} _ -> let result = case deserialiseScript PlutusV1 dataProtocolVersion dataScript of Left _ -> DeserialisationError Right script -> - case - V1.evaluateScriptRestricting + case V1.evaluateScriptRestricting dataProtocolVersion V1.Quiet ctx dataBudget script - dataInputs - of - (_, Left _) -> Failed + dataInputs of + (_, Left _) -> Failed (_, Right cost) -> OK cost - in printCost result dataBudget - - PlutusEvent PlutusV2 ScriptEvaluationData{..} _ -> + in printCost result dataBudget + PlutusEvent PlutusV2 ScriptEvaluationData {..} _ -> let result = case deserialiseScript PlutusV2 dataProtocolVersion dataScript of Left _ -> DeserialisationError Right script -> - case - V2.evaluateScriptRestricting + case V2.evaluateScriptRestricting dataProtocolVersion V2.Quiet ctx dataBudget script - dataInputs - of - (_, Left _) -> Failed + dataInputs of + (_, Left _) -> Failed (_, Right cost) -> OK cost - in printCost result dataBudget - - PlutusEvent PlutusV3 ScriptEvaluationData{..} _ -> do + in printCost result dataBudget + PlutusEvent PlutusV3 ScriptEvaluationData {..} _ -> do dataInput <- case dataInputs of [input] -> pure input - _ -> throwIO $ userError "PlutusV3 script expects exactly one input" + _ -> throwIO $ userError "PlutusV3 script expects exactly one input" let result = case deserialiseScript PlutusV3 dataProtocolVersion dataScript of Left _ -> DeserialisationError Right script -> do - case - V3.evaluateScriptRestricting - dataProtocolVersion - V3.Quiet - ctx - dataBudget - script - dataInput of - (_, Left _) -> Failed + case V3.evaluateScriptRestricting + dataProtocolVersion + V3.Quiet + ctx + dataBudget + script + dataInput of + (_, Left _) -> Failed (_, Right cost) -> OK cost printCost result dataBudget - - where printCost :: EvaluationResult -> ExBudget -> IO () - printCost result claimedCost = - let (claimedCPU, claimedMem) = costAsInts claimedCost - in case result of - OK cost -> - let (actualCPU, actualMem) = costAsInts cost - in printf "%15d %15d %15d %15d %2s\n" actualCPU claimedCPU actualMem claimedMem (toRString result) - -- Something went wrong; print the cost as "NA" ("Not Available" in R) so that R can - -- still process it. - _ -> - printf "%15s %15d %15s %15d %2s\n" "NA" claimedCPU "NA" claimedMem (toRString result) - costAsInts :: ExBudget -> (Int, Int) - costAsInts (ExBudget (V2.ExCPU cpu) (V2.ExMemory mem)) = - (fromSatInt cpu, fromSatInt mem) + where + printCost :: EvaluationResult -> ExBudget -> IO () + printCost result claimedCost = + let (claimedCPU, claimedMem) = costAsInts claimedCost + in case result of + OK cost -> + let (actualCPU, actualMem) = costAsInts cost + in printf "%15d %15d %15d %15d %2s\n" actualCPU claimedCPU actualMem claimedMem (toRString result) + -- Something went wrong; print the cost as "NA" ("Not Available" in R) so that R can + -- still process it. + _ -> + printf "%15s %15d %15s %15d %2s\n" "NA" claimedCPU "NA" claimedMem (toRString result) + costAsInts :: ExBudget -> (Int, Int) + costAsInts (ExBudget (V2.ExCPU cpu) (V2.ExMemory mem)) = + (fromSatInt cpu, fromSatInt mem) -- Extract the script from an evaluation event and apply some analysis function analyseUnappliedScript :: (Term NamedDeBruijn DefaultUni DefaultFun () -> IO ()) -> EventAnalyser analyseUnappliedScript - analyse _ctx _params (PlutusEvent plutusLedgerLanguage ScriptEvaluationData{..} _expected) = + analyse + _ctx + _params + (PlutusEvent plutusLedgerLanguage ScriptEvaluationData {..} _expected) = case deserialiseScript plutusLedgerLanguage dataProtocolVersion dataScript of - Left err -> print err + Left err -> print err Right (deserialisedScript -> ScriptNamedDeBruijn (Program _ _ t)) -> analyse t -- | Run some analysis function over the events from a single event dump file -analyseOneFile - :: EventAnalyser - -> FilePath - -> IO () +analyseOneFile :: + EventAnalyser -> + FilePath -> + IO () analyseOneFile analyse eventFile = do events <- loadEvents eventFile printf "# %s\n" $ takeFileName eventFile @@ -445,87 +458,92 @@ analyseOneFile analyse eventFile = do , mkContext V3.mkEvaluationContext (eventsCostParamsV2 events) ) of (Right ctxV1, Right ctxV2, Right ctxV3) -> - mapM_ (runSingleEvent ctxV1 ctxV2 ctxV3) (eventsOf events) + mapM_ (runSingleEvent ctxV1 ctxV2 ctxV3) (eventsOf events) (Left err, _, _) -> error $ display err (_, Left err, _) -> error $ display err (_, _, Left err) -> error $ display err where mkContext f = \case - Nothing -> Right Nothing - Just costParams -> Just . (,costParams) . fst <$> runWriterT (f costParams) - - runSingleEvent - :: Maybe (EvaluationContext, [Int64]) - -> Maybe (EvaluationContext, [Int64]) - -> Maybe (EvaluationContext, [Int64]) - -> ScriptEvaluationEvent - -> IO () + Nothing -> Right Nothing + Just costParams -> Just . (,costParams) . fst <$> runWriterT (f costParams) + + runSingleEvent :: + Maybe (EvaluationContext, [Int64]) -> + Maybe (EvaluationContext, [Int64]) -> + Maybe (EvaluationContext, [Int64]) -> + ScriptEvaluationEvent -> + IO () runSingleEvent ctxV1 ctxV2 ctxV3 event = - case event of - PlutusEvent PlutusV1 _ _ -> - case ctxV1 of - Just (ctx, params) -> analyse ctx params event - Nothing -> putStrLn "*** ctxV1 missing ***" - PlutusEvent PlutusV2 _ _ -> - case ctxV2 of - Just (ctx, params) -> analyse ctx params event - Nothing -> putStrLn "*** ctxV2 missing ***" - PlutusEvent PlutusV3 _ _ -> - case ctxV3 of - Just (ctx, params) -> analyse ctx params event - Nothing -> putStrLn "*** ctxV3 missing ***" - + case event of + PlutusEvent PlutusV1 _ _ -> + case ctxV1 of + Just (ctx, params) -> analyse ctx params event + Nothing -> putStrLn "*** ctxV1 missing ***" + PlutusEvent PlutusV2 _ _ -> + case ctxV2 of + Just (ctx, params) -> analyse ctx params event + Nothing -> putStrLn "*** ctxV2 missing ***" + PlutusEvent PlutusV3 _ _ -> + case ctxV3 of + Just (ctx, params) -> analyse ctx params event + Nothing -> putStrLn "*** ctxV3 missing ***" main :: IO () main = - let analyses = - [ ( "values" - , "analyse shapes of Values" - , doAnalysis analyseScriptContext - ) - , ( "redeemers" - , "print statistics about redeemer Data objects" - , printDataHeader `thenDoAnalysis` analyseRedeemer - ) - , ( "datums" - , "print statistics about datum Data objects" - , printDataHeader `thenDoAnalysis` analyseDatum - ) - , ( "script-data" - , "print statistics about Data objects in validator scripts" - , printDataHeader `thenDoAnalysis` analyseUnappliedScript analyseTermDataObjects - ) - , ( "count-builtins" - , "count the total number of occurrences of each builtin in validator scripts" - , countBuiltins - ) - , ( "costs" - , "print actual and claimed costs of scripts" - , putStrLn " cpuActual cpuClaimed memActual memClaimed status" - `thenDoAnalysis` analyseCosts - ) - ] - - doAnalysis analyser = mapM_ (analyseOneFile analyser) - (prelude `thenDoAnalysis` analyser) files = prelude >> doAnalysis analyser files - - usage = do - getProgName >>= hPrintf stderr "Usage: %s []\n" - hPrintf stderr "Analyse the .event files in (default = current directory)\n" - hPrintf stderr "Avaliable analyses:\n" - mapM_ printDescription analyses - where printDescription (n,h,_) = hPrintf stderr " %-16s: %s\n" n h - - go name dir = - case find (\(n, _, _) -> n == name) analyses of - Nothing -> printf "Unknown analysis: %s\n" name >> usage - Just (_, _, analysis) -> do - files <- listFiles dir - case filter ("event" `isExtensionOf`) files of - [] -> printf "No .event files in %s\n" dir - eventFiles -> analysis eventFiles - - in getArgs >>= \case - [name] -> go name "." - [name, dir] -> go name dir - _ -> usage + let analyses = + [ + ( "values" + , "analyse shapes of Values" + , doAnalysis analyseScriptContext + ) + , + ( "redeemers" + , "print statistics about redeemer Data objects" + , printDataHeader `thenDoAnalysis` analyseRedeemer + ) + , + ( "datums" + , "print statistics about datum Data objects" + , printDataHeader `thenDoAnalysis` analyseDatum + ) + , + ( "script-data" + , "print statistics about Data objects in validator scripts" + , printDataHeader `thenDoAnalysis` analyseUnappliedScript analyseTermDataObjects + ) + , + ( "count-builtins" + , "count the total number of occurrences of each builtin in validator scripts" + , countBuiltins + ) + , + ( "costs" + , "print actual and claimed costs of scripts" + , putStrLn " cpuActual cpuClaimed memActual memClaimed status" + `thenDoAnalysis` analyseCosts + ) + ] + + doAnalysis analyser = mapM_ (analyseOneFile analyser) + (prelude `thenDoAnalysis` analyser) files = prelude >> doAnalysis analyser files + + usage = do + getProgName >>= hPrintf stderr "Usage: %s []\n" + hPrintf stderr "Analyse the .event files in (default = current directory)\n" + hPrintf stderr "Avaliable analyses:\n" + mapM_ printDescription analyses + where + printDescription (n, h, _) = hPrintf stderr " %-16s: %s\n" n h + + go name dir = + case find (\(n, _, _) -> n == name) analyses of + Nothing -> printf "Unknown analysis: %s\n" name >> usage + Just (_, _, analysis) -> do + files <- listFiles dir + case filter ("event" `isExtensionOf`) files of + [] -> printf "No .event files in %s\n" dir + eventFiles -> analysis eventFiles + in getArgs >>= \case + [name] -> go name "." + [name, dir] -> go name dir + _ -> usage diff --git a/plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs b/plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs index 20ed264c615..0b20136059f 100644 --- a/plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs +++ b/plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} module Main (main) where @@ -30,47 +30,46 @@ import Data.Vector qualified as V (fromList) import Options.Applicative (execParser) import Text.Printf (printf) -{- | This executable prints out the cost model parameters according to the various - `PlutusLedgerApi.V.ParamName types`. These determine both the cost model - parameters included in the protocol parameters (and hence which Plutus - builtins are available to each Plutus ledger language version) and the order - in which they occur. The protocol parameters and the ledger both treat the - cost model parameters as ordered lists of integers and know nothing about - the names of the parameters (see - `cardano-ledger/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs` - for how the ledger (and also cardano-api and cardano-cli) deals with cost - models), and the `ParamName` types provide the link between the lists of - parameters and the complex structure used to represent a cost model in - Plutus Core. New cost models (possibly enabling new builtins) are - propagated to the chain by protocol updates which update the cost model - parameters, and this executable produces lists of cost model parameters in a - form suitable for inclusion in the protocol parameters, and so can be helpful - when we need to propose new parameters for use on the chain, and to check - that the on-chain parameters are as expected. Note that this code deals - only with the cost model parameters in the current state of the `plutus` - repository, which may differ from those on the chain: specifically, the cost - model parameters dealt with by this code will often be those which are - expected to come into effect at the next hard fork and hence will be ahead - of those currently in use for new script executions on the chain. The exact - structure of the cost model used by a particular ledger language is - determined by a _semantic variant_ which depends on both the ledger language - and the protocol version (see the `mkEvaluationContext` functions in the - various `EvaluationContext` files), and this code will need to be updated - if, for example, a new Plutus Ledger language is added or the structure of - the cost model used by an existing ledger language changes. --} +-- | This executable prints out the cost model parameters according to the various +-- `PlutusLedgerApi.V.ParamName types`. These determine both the cost model +-- parameters included in the protocol parameters (and hence which Plutus +-- builtins are available to each Plutus ledger language version) and the order +-- in which they occur. The protocol parameters and the ledger both treat the +-- cost model parameters as ordered lists of integers and know nothing about +-- the names of the parameters (see +-- `cardano-ledger/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs` +-- for how the ledger (and also cardano-api and cardano-cli) deals with cost +-- models), and the `ParamName` types provide the link between the lists of +-- parameters and the complex structure used to represent a cost model in +-- Plutus Core. New cost models (possibly enabling new builtins) are +-- propagated to the chain by protocol updates which update the cost model +-- parameters, and this executable produces lists of cost model parameters in a +-- form suitable for inclusion in the protocol parameters, and so can be helpful +-- when we need to propose new parameters for use on the chain, and to check +-- that the on-chain parameters are as expected. Note that this code deals +-- only with the cost model parameters in the current state of the `plutus` +-- repository, which may differ from those on the chain: specifically, the cost +-- model parameters dealt with by this code will often be those which are +-- expected to come into effect at the next hard fork and hence will be ahead +-- of those currently in use for new script executions on the chain. The exact +-- structure of the cost model used by a particular ledger language is +-- determined by a _semantic variant_ which depends on both the ledger language +-- and the protocol version (see the `mkEvaluationContext` functions in the +-- various `EvaluationContext` files), and this code will need to be updated +-- if, for example, a new Plutus Ledger language is added or the structure of +-- the cost model used by an existing ledger language changes. -- Mapping of LL versions to semantic versions and parameter names for *the -- current state of the repository*. This MUST be updated if the mappings in -- the PlutusLedgerApi.V.EvaluationContext modules are changed. infoFor :: PlutusLedgerLanguage -> (PLC.BuiltinSemanticsVariant PLC.DefaultFun, [Text]) infoFor = - let paramNames :: forall a . IsParamName a => [Text] + let paramNames :: forall a. IsParamName a => [Text] paramNames = fmap showParamName $ enumerate @a - in \case - PlutusV1 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V1.ParamName) - PlutusV2 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V2.ParamName) - PlutusV3 -> (PLC.DefaultFunSemanticsVariantC, paramNames @V3.ParamName) + in \case + PlutusV1 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V1.ParamName) + PlutusV2 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V2.ParamName) + PlutusV3 -> (PLC.DefaultFunSemanticsVariantC, paramNames @V3.ParamName) -- Return the current cost model parameters for a given LL version in the form -- of a list of (name, value) pairs ordered by name according to the relevant @@ -80,16 +79,21 @@ getParamsFor ll = let (semvar, paramNames) = infoFor ll params = case PLC.defaultCostModelParamsForVariant semvar of - Nothing -> error $ "Can't find default cost model parameters for " - ++ show semvar - Just p -> p + Nothing -> + error $ + "Can't find default cost model parameters for " + ++ show semvar + Just p -> p lookupParam name = case Map.lookup name params of - Nothing -> error $ "No entry for " ++ show name - ++ " in cost model for semantic variant " - ++ show semvar - Just n -> (name, n) - in fmap lookupParam paramNames + Nothing -> + error $ + "No entry for " + ++ show name + ++ " in cost model for semantic variant " + ++ show semvar + Just n -> (name, n) + in fmap lookupParam paramNames -- A couple of convenience functions for dealing with JSON. mkObject :: String -> v -> KM.KeyMap v @@ -106,19 +110,19 @@ putJSON = Data.ByteString.Lazy.putStr . encodePretty getParamsAsJSON :: PlutusLedgerLanguage -> A.Object getParamsAsJSON ll = let params = getParamsFor ll - entries = A.Array $ V.fromList $ fmap (\(_,v) -> A.Number $ fromIntegral v) params - in mkObject (show ll) entries + entries = A.Array $ V.fromList $ fmap (\(_, v) -> A.Number $ fromIntegral v) params + in mkObject (show ll) entries printParameters :: Format -> PlutusLedgerLanguage -> IO () printParameters fmt ll = case fmt of Untagged -> do printf "%s:\n" $ show ll - mapM_ (\(_,val) -> printf " %-d\n" val) $ getParamsFor ll + mapM_ (\(_, val) -> printf " %-d\n" val) $ getParamsFor ll printf "\n" Tagged -> do printf "%s:\n" $ show ll - mapM_ (\(name,val) -> printf " %-12d -- %s\n" val name) $ getParamsFor ll + mapM_ (\(name, val) -> printf " %-12d -- %s\n" val name) $ getParamsFor ll printf "\n" JSON -> putJSON $ getParamsAsJSON ll @@ -130,11 +134,11 @@ printAll :: Format -> IO () printAll fmt = case fmt of JSON -> putJSON $ mkObject "costModels" $ mconcat (fmap getParamsAsJSON enumerate) - _ -> mapM_ (printParameters fmt) enumerate + _ -> mapM_ (printParameters fmt) enumerate main :: IO () main = do (lls, fmt) <- execParser parseDumpOptions case lls of One ll -> printParameters fmt ll - All -> printAll fmt + All -> printAll fmt diff --git a/plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs b/plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs index 97e5b76c0d3..941c4fc6803 100644 --- a/plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs +++ b/plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs @@ -1,14 +1,14 @@ {-# LANGUAGE LambdaCase #-} -module Parsers (Format(..), WhichLL(..), parseDumpOptions) +module Parsers (Format (..), WhichLL (..), parseDumpOptions) where import Options.Applicative import PlutusLedgerApi.Common.Versions (PlutusLedgerLanguage (..)) -data WhichLL = - One PlutusLedgerLanguage -- Print parameters for a single LL. - | All -- Print parameters for all LLs. +data WhichLL + = One PlutusLedgerLanguage -- Print parameters for a single LL. + | All -- Print parameters for all LLs. deriving stock (Show) parseVersion :: ReadM WhichLL @@ -20,38 +20,45 @@ parseVersion = eitherReader $ \case whichll :: Parser WhichLL whichll = - option parseVersion - (short 'V' <> - metavar "N" <> - help "Print parameters for PlutusV only" - ) - <|> flag All All - -- This makes `All` the default: if the previous parser fails then we - -- arrive here and it returns `All` whether or not the option is - -- present on the command line. - (short 'a' <> - long "all" <> - help "Print parameters for all Plutus ledger language versions (default)" - ) + option + parseVersion + ( short 'V' + <> metavar "N" + <> help "Print parameters for PlutusV only" + ) + <|> flag + All + All + -- This makes `All` the default: if the previous parser fails then we + -- arrive here and it returns `All` whether or not the option is + -- present on the command line. + ( short 'a' + <> long "all" + <> help "Print parameters for all Plutus ledger language versions (default)" + ) data Format = Untagged | Tagged | JSON deriving stock (Show) format :: Parser Format format = - flag' Untagged (short 'u' <> long "untagged" <> help "Print parameter values only") - <|> flag' Tagged (short 't' <> long "tagged" <> help "Print parameter values and names") - <|> flag JSON JSON (short 'j' <> long "json" <> help "Print parameters in JSON format (default)") + flag' Untagged (short 'u' <> long "untagged" <> help "Print parameter values only") + <|> flag' Tagged (short 't' <> long "tagged" <> help "Print parameter values and names") + <|> flag JSON JSON (short 'j' <> long "json" <> help "Print parameters in JSON format (default)") dumpOptions :: Parser (WhichLL, Format) dumpOptions = (,) <$> whichll <*> format parseDumpOptions :: ParserInfo (WhichLL, Format) parseDumpOptions = - info (dumpOptions <**> helper) - (fullDesc <> - progDesc ("Print the current (and possibly undeployed) cost model parameters " - ++ " in the plutus repository in the order used in the protocol parameters.\n" - ++ "The purpose of this tool is to help with the deployment and verification " - ++ "of updated cost model parameters: it MUST be kept up to date with the " - ++ "`mkEvaluationContext` functions in plututus-ledger-api.")) + info + (dumpOptions <**> helper) + ( fullDesc + <> progDesc + ( "Print the current (and possibly undeployed) cost model parameters " + ++ " in the plutus repository in the order used in the protocol parameters.\n" + ++ "The purpose of this tool is to help with the deployment and verification " + ++ "of updated cost model parameters: it MUST be kept up to date with the " + ++ "`mkEvaluationContext` functions in plututus-ledger-api." + ) + ) diff --git a/plutus-ledger-api/exe/test-onchain-evaluation/Main.hs b/plutus-ledger-api/exe/test-onchain-evaluation/Main.hs index e74ed36ec98..316588f7a26 100644 --- a/plutus-ledger-api/exe/test-onchain-evaluation/Main.hs +++ b/plutus-ledger-api/exe/test-onchain-evaluation/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} module Main (main) where @@ -42,22 +42,22 @@ testOneFile eventFile = testCase (takeBaseName eventFile) $ do (Left err, _, _) -> assertFailure $ display err (_, Left err, _) -> assertFailure $ display err (_, _, Left err) -> assertFailure $ display err - where - mkContext f = \case - Nothing -> Right Nothing - Just costParams -> Just . (,costParams) . fst <$> runWriterT (f costParams) + where + mkContext f = \case + Nothing -> Right Nothing + Just costParams -> Just . (,costParams) . fst <$> runWriterT (f costParams) - runSingleEvent ctxV1 ctxV2 ctxV3 event = - case event of - PlutusEvent PlutusV1 _ _ -> case ctxV1 of - Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event - Nothing -> Just $ MissingCostParametersFor PlutusV1 - PlutusEvent PlutusV2 _ _ -> case ctxV2 of - Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event - Nothing -> Just $ MissingCostParametersFor PlutusV2 - PlutusEvent PlutusV3 _ _ -> case ctxV3 of - Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event - Nothing -> Just $ MissingCostParametersFor PlutusV3 + runSingleEvent ctxV1 ctxV2 ctxV3 event = + case event of + PlutusEvent PlutusV1 _ _ -> case ctxV1 of + Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event + Nothing -> Just $ MissingCostParametersFor PlutusV1 + PlutusEvent PlutusV2 _ _ -> case ctxV2 of + Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event + Nothing -> Just $ MissingCostParametersFor PlutusV2 + PlutusEvent PlutusV3 _ _ -> case ctxV3 of + Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event + Nothing -> Just $ MissingCostParametersFor PlutusV3 main :: IO () main = do diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common.hs index 513621a2cc3..24766b6ff6c 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common.hs @@ -23,9 +23,9 @@ module PlutusLedgerApi.Common ( Eval.EvaluationError (..), -- * Network's versioning - {-| The network's behaviour (and plutus's by extension) can change via /hard forks/, - which directly correspond to major-number protocol version bumps. - -} + + -- | The network's behaviour (and plutus's by extension) can change via /hard forks/, + -- which directly correspond to major-number protocol version bumps. Versions.MajorProtocolVersion (..), Versions.PlutusLedgerLanguage (..), Versions.Version (..), @@ -54,16 +54,16 @@ module PlutusLedgerApi.Common ( SatInt.fromSatInt, -- * Network's costing parameters - {-| A less drastic approach (that does not rely on a HF) - to affect the network's (and plutus's by extension) behaviour - is by tweaking the values of the cost model parameters. - - The network does not associate names to cost model parameters; - Plutus attaches names to the network's cost model parameters (values) - either in a raw textual form or typed by a specific plutus version. - See Note [Cost model parameters] - -} + -- | A less drastic approach (that does not rely on a HF) + -- to affect the network's (and plutus's by extension) behaviour + -- is by tweaking the values of the cost model parameters. + -- + -- The network does not associate names to cost model parameters; + -- Plutus attaches names to the network's cost model parameters (values) + -- either in a raw textual form or typed by a specific plutus version. + -- + -- See Note [Cost model parameters] PLC.CostModelParams, ParamName.toCostModelParams, Eval.assertWellFormedCostModelParams, diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index d489e166def..5bac64b5f18 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -1,26 +1,26 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module PlutusLedgerApi.Common.Eval - ( EvaluationError (..) - , EvaluationContext (..) - , AsScriptDecodeError (..) - , LogOutput - , VerboseMode (..) - , evaluateScriptRestricting - , evaluateScriptCounting - , evaluateTerm - , mkDynEvaluationContext - , toMachineParameters - , mkTermToEvaluate - , assertWellFormedCostModelParams - ) where +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module PlutusLedgerApi.Common.Eval ( + EvaluationError (..), + EvaluationContext (..), + AsScriptDecodeError (..), + LogOutput, + VerboseMode (..), + evaluateScriptRestricting, + evaluateScriptCounting, + evaluateTerm, + mkDynEvaluationContext, + toMachineParameters, + mkTermToEvaluate, + assertWellFormedCostModelParams, +) where import PlutusCore import PlutusCore.Builtin (CaserBuiltin) @@ -50,150 +50,161 @@ import Data.Tuple import NoThunks.Class -- | Errors that can be thrown when evaluating a Plutus script. -data EvaluationError = - CekError !(UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) -- ^ An error from the evaluator itself - | DeBruijnError !FreeVariableError -- ^ An error in the pre-evaluation step of converting from de-Bruijn indices - | CodecError !ScriptDecodeError -- ^ A deserialisation error +data EvaluationError + = -- | An error from the evaluator itself + CekError !(UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) + | -- | An error in the pre-evaluation step of converting from de-Bruijn indices + DeBruijnError !FreeVariableError + | -- | A deserialisation error -- TODO: make this error more informative when we have more information about what went wrong - | CostModelParameterMismatch -- ^ An error indicating that the cost model parameters didn't match what we expected - | InvalidReturnValue -- ^ The script evaluated to a value that is not a valid return value. - deriving stock (Show, Eq) + CodecError !ScriptDecodeError + | -- | An error indicating that the cost model parameters didn't match what we expected + CostModelParameterMismatch + | -- | The script evaluated to a value that is not a valid return value. + InvalidReturnValue + deriving stock (Show, Eq) + makeClassyPrisms ''EvaluationError instance AsScriptDecodeError EvaluationError where - _ScriptDecodeError = _CodecError + _ScriptDecodeError = _CodecError instance Pretty EvaluationError where - pretty (CekError e) = prettyClassic e - pretty (DeBruijnError e) = pretty e - pretty (CodecError e) = pretty e - pretty CostModelParameterMismatch = "Cost model parameters were not as we expected" - pretty InvalidReturnValue = - "The evaluation finished but the result value is not valid. " - <> "Plutus V3 scripts must return BuiltinUnit. " - <> "Returning any other value is considered a failure." + pretty (CekError e) = prettyClassic e + pretty (DeBruijnError e) = pretty e + pretty (CodecError e) = pretty e + pretty CostModelParameterMismatch = "Cost model parameters were not as we expected" + pretty InvalidReturnValue = + "The evaluation finished but the result value is not valid. " + <> "Plutus V3 scripts must return BuiltinUnit. " + <> "Returning any other value is considered a failure." -- | A simple toggle indicating whether or not we should accumulate logs during script execution. -data VerboseMode = - Verbose -- ^ accumulate all traces - | Quiet -- ^ don't accumulate anything - deriving stock (Eq) - -{-| The type of the executed script's accumulated log output: a list of 'Text'. - -It will be an empty list if the `VerboseMode` is set to `Quiet`. --} +data VerboseMode + = -- | accumulate all traces + Verbose + | -- | don't accumulate anything + Quiet + deriving stock (Eq) + +-- | The type of the executed script's accumulated log output: a list of 'Text'. +-- +-- It will be an empty list if the `VerboseMode` is set to `Quiet`. type LogOutput = [Text] -{-| Shared helper for the evaluation functions: 'evaluateScriptCounting' and 'evaluateScriptRestricting', - -Given a 'ScriptForEvaluation': - -1) applies the term to a list of 'Data' arguments (e.g. Datum, Redeemer, `ScriptContext`) -2) checks that the applied-term is well-scoped -3) returns the applied-term --} -mkTermToEvaluate - :: (MonadError EvaluationError m) - => PlutusLedgerLanguage -- ^ the Plutus ledger language of the script under execution. - -> MajorProtocolVersion -- ^ which major protocol version to run the operation in - -> ScriptForEvaluation -- ^ the script to evaluate - -> [Plutus.Data] -- ^ the arguments that the script's underlying term will be applied to - -> m (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) +-- | Shared helper for the evaluation functions: 'evaluateScriptCounting' and 'evaluateScriptRestricting', +-- +-- Given a 'ScriptForEvaluation': +-- +-- 1) applies the term to a list of 'Data' arguments (e.g. Datum, Redeemer, `ScriptContext`) +-- 2) checks that the applied-term is well-scoped +-- 3) returns the applied-term +mkTermToEvaluate :: + MonadError EvaluationError m => + -- | the Plutus ledger language of the script under execution. + PlutusLedgerLanguage -> + -- | which major protocol version to run the operation in + MajorProtocolVersion -> + -- | the script to evaluate + ScriptForEvaluation -> + -- | the arguments that the script's underlying term will be applied to + [Plutus.Data] -> + m (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) mkTermToEvaluate ll pv script args = do - let ScriptNamedDeBruijn (UPLC.Program _ v t) = deserialisedScript script - termArgs = fmap (UPLC.mkConstant ()) args - appliedT = UPLC.mkIterAppNoAnn t termArgs + let ScriptNamedDeBruijn (UPLC.Program _ v t) = deserialisedScript script + termArgs = fmap (UPLC.mkConstant ()) args + appliedT = UPLC.mkIterAppNoAnn t termArgs - -- check that the Plutus Core language version is available - -- See Note [Checking the Plutus Core language version] - unless (v `Set.member` plcVersionsAvailableIn ll pv) $ - throwing _ScriptDecodeError $ PlutusCoreLanguageNotAvailableError v ll pv + -- check that the Plutus Core language version is available + -- See Note [Checking the Plutus Core language version] + unless (v `Set.member` plcVersionsAvailableIn ll pv) $ + throwing _ScriptDecodeError $ + PlutusCoreLanguageNotAvailableError v ll pv - -- make sure that term is closed, i.e. well-scoped - through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT + -- make sure that term is closed, i.e. well-scoped + through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters toMachineParameters pv (EvaluationContext ll toCaser toSemVar machParsList) = - case lookup (toSemVar pv) machParsList of - Nothing -> error $ Prelude.concat - ["Internal error: ", show ll, " does not support protocol version ", show pv] - Just machVarPars -> MachineParameters (toCaser pv) machVarPars - -{-| An opaque type that contains all the static parameters that the evaluator needs to evaluate a -script. This is so that they can be computed once and cached, rather than being recomputed on every -evaluation. - -Different protocol versions may require different bundles of machine parameters, which allows us for -example to tweak the shape of the costing function of a builtin, so that the builtin costs less. -Currently this means that we have to create multiple 'DefaultMachineParameters' per language -version, which we put into a cache (represented by an association list) in order to avoid costly -recomputation of machine parameters. - -In order to get the appropriate 'DefaultMachineParameters' at validation time we look it up in the -cache using a semantics variant as a key. We compute the semantics variant from the protocol -version using the stored function. Note that the semantics variant depends on the language version -too, but the latter is known statically (because each language version has its own evaluation -context), hence there's no reason to require it to be provided at runtime. - -To say it differently, there's a matrix of semantics variants indexed by (LL, PV) pairs and we -cache its particular row corresponding to the statically given LL in an 'EvaluationContext'. - -The reason why we associate a 'DefaultMachineParameters' with a semantics variant rather than a -protocol version are - -1. generally there are far more protocol versions than semantics variants supported by a specific - language version, so we save on pointless duplication of bundles of machine parameters -2. builtins don't know anything about protocol versions, only semantics variants. It is therefore - more semantically precise to associate bundles of machine parameters with semantics variants than - with protocol versions --} + case lookup (toSemVar pv) machParsList of + Nothing -> + error $ + Prelude.concat + ["Internal error: ", show ll, " does not support protocol version ", show pv] + Just machVarPars -> MachineParameters (toCaser pv) machVarPars + +-- | An opaque type that contains all the static parameters that the evaluator needs to evaluate a +-- script. This is so that they can be computed once and cached, rather than being recomputed on every +-- evaluation. +-- +-- Different protocol versions may require different bundles of machine parameters, which allows us for +-- example to tweak the shape of the costing function of a builtin, so that the builtin costs less. +-- Currently this means that we have to create multiple 'DefaultMachineParameters' per language +-- version, which we put into a cache (represented by an association list) in order to avoid costly +-- recomputation of machine parameters. +-- +-- In order to get the appropriate 'DefaultMachineParameters' at validation time we look it up in the +-- cache using a semantics variant as a key. We compute the semantics variant from the protocol +-- version using the stored function. Note that the semantics variant depends on the language version +-- too, but the latter is known statically (because each language version has its own evaluation +-- context), hence there's no reason to require it to be provided at runtime. +-- +-- To say it differently, there's a matrix of semantics variants indexed by (LL, PV) pairs and we +-- cache its particular row corresponding to the statically given LL in an 'EvaluationContext'. +-- +-- The reason why we associate a 'DefaultMachineParameters' with a semantics variant rather than a +-- protocol version are +-- +-- 1. generally there are far more protocol versions than semantics variants supported by a specific +-- language version, so we save on pointless duplication of bundles of machine parameters +-- 2. builtins don't know anything about protocol versions, only semantics variants. It is therefore +-- more semantically precise to associate bundles of machine parameters with semantics variants than +-- with protocol versions data EvaluationContext = EvaluationContext - { _evalCtxLedgerLang :: PlutusLedgerLanguage - -- ^ Specifies what language versions the 'EvaluationContext' is for. - , _evalCtxCaserBuiltin :: MajorProtocolVersion -> CaserBuiltin DefaultUni - -- ^ Specifies how 'case' on values of built-in types works: fails evaluation for older - -- protocol versions and defers to 'caseBuiltin' for newer ones. Note that this function - -- doesn't depend on the 'PlutusLedgerLanguage' or the AST version: deserialisation of a 1.0.0 - -- AST fails upon encountering a 'Case' node anyway, so we can safely assume here that 'case' - -- is available. - -- FIXME: do we need to test that it fails for older PVs? We can't submit - -- transactions in old PVs, so maybe it doesn't matter. - , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun - -- ^ Specifies how to get a semantics variant for this ledger language given a - -- 'MajorProtocolVersion'. - , _evalCtxMachParsCache :: - [(BuiltinSemanticsVariant DefaultFun, DefaultMachineVariantParameters)] - -- ^ The cache of 'DefaultMachineParameters' for each semantics variant supported by the - -- current language version. - } - deriving stock Generic - deriving anyclass (NFData, NoThunks) - -{-| Create an 'EvaluationContext' given all builtin semantics variants supported by the provided -language version. - -The input is a `Map` of `Text`s to cost integer values (aka `Plutus.CostModelParams`, `Alonzo.CostModel`) -See Note [Inlining meanings of builtins]. - -IMPORTANT: the 'toSemVar' argument computes the semantics variant for each 'MajorProtocolVersion' -and it must only return semantics variants from the 'semVars' list, as well as cover ANY -'MajorProtocolVersion', including those that do not exist yet (i.e. 'toSemVar' must never fail). - -IMPORTANT: The evaluation context of every Plutus version must be recreated upon a protocol update -with the updated cost model parameters. --} -mkDynEvaluationContext - :: MonadError CostModelApplyError m - => PlutusLedgerLanguage - -> (MajorProtocolVersion -> CaserBuiltin DefaultUni) - -> [BuiltinSemanticsVariant DefaultFun] - -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) - -> Plutus.CostModelParams - -> m EvaluationContext + { _evalCtxLedgerLang :: PlutusLedgerLanguage + -- ^ Specifies what language versions the 'EvaluationContext' is for. + , _evalCtxCaserBuiltin :: MajorProtocolVersion -> CaserBuiltin DefaultUni + -- ^ Specifies how 'case' on values of built-in types works: fails evaluation for older + -- protocol versions and defers to 'caseBuiltin' for newer ones. Note that this function + -- doesn't depend on the 'PlutusLedgerLanguage' or the AST version: deserialisation of a 1.0.0 + -- AST fails upon encountering a 'Case' node anyway, so we can safely assume here that 'case' + -- is available. + -- FIXME: do we need to test that it fails for older PVs? We can't submit + -- transactions in old PVs, so maybe it doesn't matter. + , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun + -- ^ Specifies how to get a semantics variant for this ledger language given a + -- 'MajorProtocolVersion'. + , _evalCtxMachParsCache :: + [(BuiltinSemanticsVariant DefaultFun, DefaultMachineVariantParameters)] + -- ^ The cache of 'DefaultMachineParameters' for each semantics variant supported by the + -- current language version. + } + deriving stock (Generic) + deriving anyclass (NFData, NoThunks) + +-- | Create an 'EvaluationContext' given all builtin semantics variants supported by the provided +-- language version. +-- +-- The input is a `Map` of `Text`s to cost integer values (aka `Plutus.CostModelParams`, `Alonzo.CostModel`) +-- See Note [Inlining meanings of builtins]. +-- +-- IMPORTANT: the 'toSemVar' argument computes the semantics variant for each 'MajorProtocolVersion' +-- and it must only return semantics variants from the 'semVars' list, as well as cover ANY +-- 'MajorProtocolVersion', including those that do not exist yet (i.e. 'toSemVar' must never fail). +-- +-- IMPORTANT: The evaluation context of every Plutus version must be recreated upon a protocol update +-- with the updated cost model parameters. +mkDynEvaluationContext :: + MonadError CostModelApplyError m => + PlutusLedgerLanguage -> + (MajorProtocolVersion -> CaserBuiltin DefaultUni) -> + [BuiltinSemanticsVariant DefaultFun] -> + (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> + Plutus.CostModelParams -> + m EvaluationContext mkDynEvaluationContext ll toCaser semVars toSemVar newCMP = do - machPars <- mkMachineVariantParametersFor semVars newCMP - pure $ EvaluationContext ll toCaser toSemVar machPars + machPars <- mkMachineVariantParametersFor semVars newCMP + pure $ EvaluationContext ll toCaser toSemVar machPars -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1726): remove this function assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m () @@ -201,86 +212,97 @@ assertWellFormedCostModelParams = void . Plutus.applyCostModelParams Plutus.defa -- | Evaluate a fully-applied term using the CEK machine. Useful for mimicking the behaviour of the -- on-chain evaluator. -evaluateTerm - :: UPLC.ExBudgetMode cost DefaultUni DefaultFun - -> MajorProtocolVersion - -> VerboseMode - -> EvaluationContext - -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.CekReport cost NamedDeBruijn DefaultUni DefaultFun +evaluateTerm :: + UPLC.ExBudgetMode cost DefaultUni DefaultFun -> + MajorProtocolVersion -> + VerboseMode -> + EvaluationContext -> + UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () -> + UPLC.CekReport cost NamedDeBruijn DefaultUni DefaultFun evaluateTerm budgetMode pv verbose ectx = - UPLC.runCekDeBruijn - (toMachineParameters pv ectx) - budgetMode - (if verbose == Verbose then UPLC.logEmitter else UPLC.noEmitter) + UPLC.runCekDeBruijn + (toMachineParameters pv ectx) + budgetMode + (if verbose == Verbose then UPLC.logEmitter else UPLC.noEmitter) -- Just replicating the old behavior, probably doesn't matter. {-# INLINE evaluateTerm #-} -{-| Evaluates a script, with a cost model and a budget that restricts how many -resources it can use according to the cost model. Also returns the budget that -was actually used. - -Can be used to calculate budgets for scripts, but even in this case you must give -a limit to guard against scripts that run for a long time or loop. - -Note: Parameterized over the 'LedgerPlutusVersion' since -1. The builtins allowed (during decoding) differ, and -2. The Plutus language versions allowed differ. --} -evaluateScriptRestricting - :: PlutusLedgerLanguage -- ^ The Plutus ledger language of the script under execution. - -> MajorProtocolVersion -- ^ Which major protocol version to run the operation in - -> VerboseMode -- ^ Whether to produce log output - -> EvaluationContext -- ^ Includes the cost model to use for tallying up the execution costs - -> ExBudget -- ^ The resource budget which must not be exceeded during evaluation - -> ScriptForEvaluation -- ^ The script to evaluate - -> [Plutus.Data] -- ^ The arguments to the script - -> (LogOutput, Either EvaluationError ExBudget) +-- | Evaluates a script, with a cost model and a budget that restricts how many +-- resources it can use according to the cost model. Also returns the budget that +-- was actually used. +-- +-- Can be used to calculate budgets for scripts, but even in this case you must give +-- a limit to guard against scripts that run for a long time or loop. +-- +-- Note: Parameterized over the 'LedgerPlutusVersion' since +-- 1. The builtins allowed (during decoding) differ, and +-- 2. The Plutus language versions allowed differ. +evaluateScriptRestricting :: + -- | The Plutus ledger language of the script under execution. + PlutusLedgerLanguage -> + -- | Which major protocol version to run the operation in + MajorProtocolVersion -> + -- | Whether to produce log output + VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + EvaluationContext -> + -- | The resource budget which must not be exceeded during evaluation + ExBudget -> + -- | The script to evaluate + ScriptForEvaluation -> + -- | The arguments to the script + [Plutus.Data] -> + (LogOutput, Either EvaluationError ExBudget) evaluateScriptRestricting ll pv verbose ectx budget p args = swap $ runWriter @LogOutput $ runExceptT $ do - appliedTerm <- mkTermToEvaluate ll pv p args - let UPLC.CekReport res (UPLC.RestrictingSt (ExRestrictingBudget final)) logs = - evaluateTerm (UPLC.restricting $ ExRestrictingBudget budget) pv verbose ectx appliedTerm - processLogsAndErrors ll logs res - pure (budget `minusExBudget` final) - -{-| Evaluates a script, returning the minimum budget that the script would need -to evaluate successfully. This will take as long as the script takes, if you need to -limit the execution time of the script also, you can use 'evaluateScriptRestricting', which -also returns the used budget. - -Note: Parameterized over the ledger-plutus-version since the builtins allowed (during decoding) differs. --} -evaluateScriptCounting - :: PlutusLedgerLanguage -- ^ The Plutus ledger language of the script under execution. - -> MajorProtocolVersion -- ^ Which major protocol version to run the operation in - -> VerboseMode -- ^ Whether to produce log output - -> EvaluationContext -- ^ Includes the cost model to use for tallying up the execution costs - -> ScriptForEvaluation -- ^ The script to evaluate - -> [Plutus.Data] -- ^ The arguments to the script - -> (LogOutput, Either EvaluationError ExBudget) + appliedTerm <- mkTermToEvaluate ll pv p args + let UPLC.CekReport res (UPLC.RestrictingSt (ExRestrictingBudget final)) logs = + evaluateTerm (UPLC.restricting $ ExRestrictingBudget budget) pv verbose ectx appliedTerm + processLogsAndErrors ll logs res + pure (budget `minusExBudget` final) + +-- | Evaluates a script, returning the minimum budget that the script would need +-- to evaluate successfully. This will take as long as the script takes, if you need to +-- limit the execution time of the script also, you can use 'evaluateScriptRestricting', which +-- also returns the used budget. +-- +-- Note: Parameterized over the ledger-plutus-version since the builtins allowed (during decoding) differs. +evaluateScriptCounting :: + -- | The Plutus ledger language of the script under execution. + PlutusLedgerLanguage -> + -- | Which major protocol version to run the operation in + MajorProtocolVersion -> + -- | Whether to produce log output + VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + EvaluationContext -> + -- | The script to evaluate + ScriptForEvaluation -> + -- | The arguments to the script + [Plutus.Data] -> + (LogOutput, Either EvaluationError ExBudget) evaluateScriptCounting ll pv verbose ectx p args = swap $ runWriter @LogOutput $ runExceptT $ do - appliedTerm <- mkTermToEvaluate ll pv p args - let UPLC.CekReport res (UPLC.CountingSt final) logs = - evaluateTerm UPLC.counting pv verbose ectx appliedTerm - processLogsAndErrors ll logs res - pure final + appliedTerm <- mkTermToEvaluate ll pv p args + let UPLC.CekReport res (UPLC.CountingSt final) logs = + evaluateTerm UPLC.counting pv verbose ectx appliedTerm + processLogsAndErrors ll logs res + pure final processLogsAndErrors :: - forall m. - (MonadError EvaluationError m, MonadWriter LogOutput m) => - PlutusLedgerLanguage -> - LogOutput -> - UPLC.CekResult NamedDeBruijn DefaultUni DefaultFun -> - m () + forall m. + (MonadError EvaluationError m, MonadWriter LogOutput m) => + PlutusLedgerLanguage -> + LogOutput -> + UPLC.CekResult NamedDeBruijn DefaultUni DefaultFun -> + m () processLogsAndErrors ll logs res = do - tell logs - case res of - UPLC.CekFailure err -> throwError $ CekError err - -- If evaluation result is '()', then that's correct for all Plutus versions. - UPLC.CekSuccessConstant (Some (ValueOf DefaultUniUnit ())) -> pure () - -- If evaluation result is any other constant or term, then it's only correct for V1 and V2. - UPLC.CekSuccessConstant{} -> handleOldVersions - UPLC.CekSuccessNonConstant{} -> handleOldVersions + tell logs + case res of + UPLC.CekFailure err -> throwError $ CekError err + -- If evaluation result is '()', then that's correct for all Plutus versions. + UPLC.CekSuccessConstant (Some (ValueOf DefaultUniUnit ())) -> pure () + -- If evaluation result is any other constant or term, then it's only correct for V1 and V2. + UPLC.CekSuccessConstant {} -> handleOldVersions + UPLC.CekSuccessNonConstant {} -> handleOldVersions where handleOldVersions = unless (ll == PlutusV1 || ll == PlutusV2) $ throwError InvalidReturnValue {-# INLINE processLogsAndErrors #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/ParamName.hs index 415f7599c04..609b07299d4 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/ParamName.hs @@ -1,16 +1,16 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -module PlutusLedgerApi.Common.ParamName - ( IsParamName (..) - , GenericParamName (..) - , toCostModelParams - , tagWithParamNames - , CostModelApplyError (..) - , CostModelApplyWarn (..) - ) where +module PlutusLedgerApi.Common.ParamName ( + IsParamName (..), + GenericParamName (..), + toCostModelParams, + tagWithParamNames, + CostModelApplyError (..), + CostModelApplyWarn (..), +) where import PlutusCore.Evaluation.Machine.CostModelInterface @@ -24,37 +24,36 @@ import Data.Text qualified as Text import GHC.Generics import PlutusPrelude -{-| A parameter name for different plutus versions. - -Each Plutus version should expose such an enumeration as an ADT and create -an instance of 'ParamName' out of it. - -A valid parameter name has to be enumeration, bounded, ordered, and -prettyprintable to a \"lower-Kebab\" string. --} +-- | A parameter name for different plutus versions. +-- +-- Each Plutus version should expose such an enumeration as an ADT and create +-- an instance of 'ParamName' out of it. +-- +-- A valid parameter name has to be enumeration, bounded, ordered, and +-- prettyprintable to a \"lower-Kebab\" string. class (Enum a, Bounded a) => IsParamName a where - -- | Produce the raw textual form for a given typed-by-plutus-version cost model parameter - -- Any implementation *must be* an injective function. - -- The 'GIsParamName' generic implementation guarantees injectivity. - showParamName :: a -> Text.Text + -- | Produce the raw textual form for a given typed-by-plutus-version cost model parameter + -- Any implementation *must be* an injective function. + -- The 'GIsParamName' generic implementation guarantees injectivity. + showParamName :: a -> Text.Text - -- | default implementation that inverts the showParamName operation (not very efficient) - readParamName :: Text.Text -> Maybe a - readParamName str = List.lookup str $ fmap (\p -> (showParamName p, p)) $ enumerate @a + -- | default implementation that inverts the showParamName operation (not very efficient) + readParamName :: Text.Text -> Maybe a + readParamName str = List.lookup str $ fmap (\p -> (showParamName p, p)) $ enumerate @a -- | A Generic wrapper for use with deriving via newtype GenericParamName a = GenericParamName a - deriving newtype (Enum, Bounded) + deriving newtype (Enum, Bounded) instance (Enum (GenericParamName a), Bounded (GenericParamName a), Generic a, GIsParamName (Rep a)) => IsParamName (GenericParamName a) where - showParamName (GenericParamName a) = gshowParamName $ from a + showParamName (GenericParamName a) = gshowParamName $ from a -- | A datatype-generic class to prettyprint 'sums of nullary constructors' in lower-kebab syntax. class GIsParamName f where - gshowParamName :: f p -> Text.Text + gshowParamName :: f p -> Text.Text -instance (GIsParamName a) => GIsParamName (M1 D i a) where - gshowParamName (M1 x) = gshowParamName x +instance GIsParamName a => GIsParamName (M1 D i a) where + gshowParamName (M1 x) = gshowParamName x {- Note [Quotation marks in cost model parameter constructors] We use the quotation mark <'> inside each nullary constructor of @@ -63,48 +62,51 @@ The character <_> cannot be used as a delimiter because it may be part of the bu -} instance Constructor i => GIsParamName (M1 C i U1) where - gshowParamName = Text.pack . lowerKebab . conName - where - lowerKebab :: String -> String - lowerKebab (h:t) = toLower h : fmap maybeKebab t - lowerKebab _ = error "this should not happen because constructors cannot have empty names" - - maybeKebab '\'' = '-' - maybeKebab c = c + gshowParamName = Text.pack . lowerKebab . conName + where + lowerKebab :: String -> String + lowerKebab (h : t) = toLower h : fmap maybeKebab t + lowerKebab _ = error "this should not happen because constructors cannot have empty names" + maybeKebab '\'' = '-' + maybeKebab c = c instance (GIsParamName a, GIsParamName b) => GIsParamName ((:+:) a b) where - gshowParamName (L1 x) = gshowParamName x - gshowParamName (R1 x) = gshowParamName x + gshowParamName (L1 x) = gshowParamName x + gshowParamName (R1 x) = gshowParamName x -- | Given an ordered list of parameter values, tag them with their parameter -- names. If the passed parameter values are more than expected: the function -- will ignore the extraneous values at the tail of the list, if the passed -- values are less than expected: the function will throw an error; for more -- information, see Note [Cost model parameters from the ledger's point of view] -tagWithParamNames :: forall k m. (Enum k, Bounded k, - MonadError CostModelApplyError m, - -- OPTIMIZE: MonadWriter.CPS is probably better than MonadWriter.Strict but needs mtl>=2.3 - -- OPTIMIZE: using List [] as the log datatype is worse than others (DList/Endo) but does not matter much here - MonadWriter [CostModelApplyWarn] m) - => [Int64] -> m [(k, Int64)] +tagWithParamNames :: + forall k m. + ( Enum k + , Bounded k + , MonadError CostModelApplyError m + , -- OPTIMIZE: MonadWriter.CPS is probably better than MonadWriter.Strict but needs mtl>=2.3 + -- OPTIMIZE: using List [] as the log datatype is worse than others (DList/Endo) but does not matter much here + MonadWriter [CostModelApplyWarn] m + ) => + [Int64] -> m [(k, Int64)] tagWithParamNames ledgerParams = - let paramNames = enumerate @k - lenExpected = length paramNames - lenActual = length ledgerParams - in case lenExpected `compare` lenActual of + let paramNames = enumerate @k + lenExpected = length paramNames + lenActual = length ledgerParams + in case lenExpected `compare` lenActual of EQ -> - pure $ zip paramNames ledgerParams + pure $ zip paramNames ledgerParams LT -> do - -- See Note [Cost model parameters from the ledger's point of view] - tell [CMTooManyParamsWarn {cmExpected = lenExpected, cmActual = lenActual}] - -- zip will truncate/ignore any extraneous parameter values - pure $ zip paramNames ledgerParams + -- See Note [Cost model parameters from the ledger's point of view] + tell [CMTooManyParamsWarn {cmExpected = lenExpected, cmActual = lenActual}] + -- zip will truncate/ignore any extraneous parameter values + pure $ zip paramNames ledgerParams GT -> do - -- Too few parameters - substitute a large number for the missing parameters - -- See Note [Cost model parameters from the ledger's point of view] - tell [CMTooFewParamsWarn {cmExpected = lenExpected, cmActual = lenActual}] - pure $ zip paramNames (ledgerParams ++ repeat maxBound) + -- Too few parameters - substitute a large number for the missing parameters + -- See Note [Cost model parameters from the ledger's point of view] + tell [CMTooFewParamsWarn {cmExpected = lenExpected, cmActual = lenActual}] + pure $ zip paramNames (ledgerParams ++ repeat maxBound) -- | Untags the plutus version from the typed cost model parameters and returns their raw textual form -- (internally used by CostModelInterface). diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs index b6827875bf4..7a46746c24a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs @@ -1,20 +1,22 @@ -module PlutusLedgerApi.Common.ProtocolVersions - ( MajorProtocolVersion (..) - -- ** Protocol Version aliases - -- | Based on https://github.com/IntersectMBO/cardano-ledger/wiki/First-Block-of-Each-Era - , shelleyPV - , allegraPV - , maryPV - , alonzoPV - , vasilPV - , valentinePV - , changPV - , plominPV - , pv11PV - , newestPV - , knownPVs - , futurePV - ) where +module PlutusLedgerApi.Common.ProtocolVersions ( + MajorProtocolVersion (..), + + -- ** Protocol Version aliases + + -- | Based on https://github.com/IntersectMBO/cardano-ledger/wiki/First-Block-of-Each-Era + shelleyPV, + allegraPV, + maryPV, + alonzoPV, + vasilPV, + valentinePV, + changPV, + plominPV, + pv11PV, + newestPV, + knownPVs, + futurePV, +) where import Codec.Serialise (Serialise) import GHC.Generics (Generic) @@ -37,12 +39,12 @@ import Prettyprinter -- The ledger can only supply the major component of the protocol version, not the minor -- component, and Plutus should only need to care about the major component anyway. -- This relies on careful understanding between us and the ledger as to what this means. -newtype MajorProtocolVersion = MajorProtocolVersion { getMajorProtocolVersion :: Int } +newtype MajorProtocolVersion = MajorProtocolVersion {getMajorProtocolVersion :: Int} deriving newtype (Eq, Ord, Show, Serialise, Enum) deriving stock (Generic) instance Pretty MajorProtocolVersion where - pretty (MajorProtocolVersion v) = pretty v + pretty (MajorProtocolVersion v) = pretty v -- | Shelley era was introduced in protocol version 2.0 shelleyPV :: MajorProtocolVersion @@ -89,16 +91,16 @@ pv11PV = MajorProtocolVersion 11 -- used for testing, so efficiency is not parmount and a list is fine. knownPVs :: [MajorProtocolVersion] knownPVs = - [ shelleyPV - , allegraPV - , maryPV - , alonzoPV - , vasilPV - , valentinePV - , changPV - , plominPV - , pv11PV - ] + [ shelleyPV + , allegraPV + , maryPV + , alonzoPV + , vasilPV + , valentinePV + , changPV + , plominPV + , pv11PV + ] -- We're sometimes in an intermediate state where we've added new builtins but -- not yet released them (but intend to). This is used by some of the tests to @@ -107,14 +109,13 @@ knownPVs = newestPV :: MajorProtocolVersion newestPV = pv11PV -{-| This is a placeholder for when we don't yet know what protocol version will - be used for something. It's a very high protocol version that should never - appear in reality. - - We should not assign names to future protocol versions until it's - confirmed that they are correct, otherwise we could accidentally - associate something with the wrong protocol version. --} +-- | This is a placeholder for when we don't yet know what protocol version will +-- be used for something. It's a very high protocol version that should never +-- appear in reality. +-- +-- We should not assign names to future protocol versions until it's +-- confirmed that they are correct, otherwise we could accidentally +-- associate something with the wrong protocol version. futurePV :: MajorProtocolVersion futurePV = MajorProtocolVersion maxBound diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs index a17def31f14..08e2cc25995 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module PlutusLedgerApi.Common.SerialisedScript ( SerialisedScript, @@ -61,17 +61,17 @@ data ScriptDecodeError LedgerLanguageNotAvailableError { sdeAffectedLang :: !PlutusLedgerLanguage -- ^ the script's ledger language - , sdeIntroPv :: !MajorProtocolVersion + , sdeIntroPv :: !MajorProtocolVersion -- ^ the major protocol version that will first introduce/enable the ledger language - , sdeThisPv :: !MajorProtocolVersion + , sdeThisPv :: !MajorProtocolVersion -- ^ the current protocol version } | PlutusCoreLanguageNotAvailableError { sdeAffectedVersion :: !UPLC.Version -- ^ the Plutus Core language of the script under execution. - , sdeThisLang :: !PlutusLedgerLanguage + , sdeThisLang :: !PlutusLedgerLanguage -- ^ the Plutus ledger language of the script under execution. - , sdeThisPv :: !MajorProtocolVersion + , sdeThisPv :: !MajorProtocolVersion -- ^ the current protocol version } deriving stock (Eq, Show) @@ -87,21 +87,26 @@ instance Pretty ScriptDecodeError where "Script was successfully deserialised, but" <+> pretty (BSL.length bs) <+> "more bytes were encountered after the script's position." - LedgerLanguageNotAvailableError{..} -> + LedgerLanguageNotAvailableError {..} -> "Your script has a Plutus Ledger Language version of" - <+> pretty sdeAffectedLang <> "." + <+> pretty sdeAffectedLang + <> "." <+> "This is not yet supported by the current major protocol version" - <+> pretty sdeThisPv <> "." + <+> pretty sdeThisPv + <> "." <+> "The major protocol version that introduces \ \this Plutus Ledger Language is" - <+> pretty sdeIntroPv <> "." - PlutusCoreLanguageNotAvailableError{..} -> + <+> pretty sdeIntroPv + <> "." + PlutusCoreLanguageNotAvailableError {..} -> "Your script has a Plutus Core version of" - <+> pretty sdeAffectedVersion <> "." + <+> pretty sdeAffectedVersion + <> "." <+> "This is not supported in" <+> pretty sdeThisLang <+> "and major protocol version" - <+> pretty sdeThisPv <> "." + <+> pretty sdeThisPv + <> "." {- Note [Size checking of constants in PLC programs] We impose a 64-byte *on-the-wire* limit on the constants inside PLC programs. This prevents @@ -130,9 +135,8 @@ data structures that include scripts (for example, transactions) no-longer benef from CBOR's ability to self-describe its format. -} -{- | Turns a program which was compiled using the \'PlutusTx\' toolchain into -a binary format that is understood by the network and can be stored on-chain. --} +-- | Turns a program which was compiled using the \'PlutusTx\' toolchain into +-- a binary format that is understood by the network and can be stored on-chain. serialiseCompiledCode :: forall a. CompiledCode a -> SerialisedScript serialiseCompiledCode = -- MAYBE: Instead of this `serialiseUPLC . toNameLess` we could instead @@ -145,9 +149,8 @@ serialiseCompiledCode = UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () toNameless = over UPLC.progTerm $ UPLC.termMapNames UPLC.unNameDeBruijn -{- | Turns a program's AST (most likely manually constructed) -into a binary format that is understood by the network and can be stored on-chain. --} +-- | Turns a program's AST (most likely manually constructed) +-- into a binary format that is understood by the network and can be stored on-chain. serialiseUPLC :: UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -> SerialisedScript serialiseUPLC = -- See Note [Using Flat for serialising/deserialising Script] @@ -155,12 +158,11 @@ serialiseUPLC = -- need to be careful about introducing a working version toShort . BSL.toStrict . serialise . SerialiseViaFlat . UPLC.UnrestrictedProgram -{- | Deserialises a 'SerialisedScript' back into an AST. Does *not* do -ledger-language-version-specific checks like for allowable builtins. --} +-- | Deserialises a 'SerialisedScript' back into an AST. Does *not* do +-- ledger-language-version-specific checks like for allowable builtins. uncheckedDeserialiseUPLC :: SerialisedScript -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () uncheckedDeserialiseUPLC = - UPLC.unUnrestrictedProgram . unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort + UPLC.unUnrestrictedProgram . unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort -- | A script with named de-bruijn indices. newtype ScriptNamedDeBruijn @@ -185,11 +187,10 @@ serialisedScript (UnsafeScriptForEvaluation s _) = s deserialisedScript :: ScriptForEvaluation -> ScriptNamedDeBruijn deserialisedScript (UnsafeScriptForEvaluation _ s) = s -{- | This decoder decodes the names directly into `NamedDeBruijn`s rather than `DeBruijn`s. -This is needed because the CEK machine expects `NameDeBruijn`s, but there are obviously no -names in the serialised form of a `Script`. Rather than traversing the term and inserting -fake names after deserialising, this lets us do at the same time as deserialising. --} +-- | This decoder decodes the names directly into `NamedDeBruijn`s rather than `DeBruijn`s. +-- This is needed because the CEK machine expects `NameDeBruijn`s, but there are obviously no +-- names in the serialised form of a `Script`. Rather than traversing the term and inserting +-- fake names after deserialising, this lets us do at the same time as deserialising. scriptCBORDecoder :: PlutusLedgerLanguage -> MajorProtocolVersion -> @@ -214,13 +215,12 @@ scriptCBORDecoder ll pv = decodeViaFlatWith flatDecoder pure $ coerce p -{- | The deserialization from a serialised script into a `ScriptForEvaluation`, -ready to be evaluated on-chain. -Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). --} +-- | The deserialization from a serialised script into a `ScriptForEvaluation`, +-- ready to be evaluated on-chain. +-- Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). deserialiseScript :: forall m. - (MonadError ScriptDecodeError m) => + MonadError ScriptDecodeError m => -- | the Plutus ledger language of the script. PlutusLedgerLanguage -> -- | which major protocol version the script was submitted in. @@ -235,7 +235,7 @@ deserialiseScript ll pv sScript = do throwing _ScriptDecodeError $ LedgerLanguageNotAvailableError ll llIntroPv pv - (remderBS, dScript@(ScriptNamedDeBruijn (UPLC.Program{}))) <- deserialiseSScript sScript + (remderBS, dScript@(ScriptNamedDeBruijn (UPLC.Program {}))) <- deserialiseSScript sScript when (ll /= PlutusV1 && ll /= PlutusV2 && remderBS /= mempty) $ throwing _ScriptDecodeError $ RemainderError remderBS diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index d61984ece95..c9d69a5d4ad 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -1,35 +1,37 @@ -- editorconfig-checker-disable-file {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} - -{- | This module contains the code for handling the various kinds of version that we care about: - -* Protocol versions -* Plutus ledger languages -* Plutus Core language versions --} -module PlutusLedgerApi.Common.Versions - ( -- * Cardano Protocol versions - module PlutusLedgerApi.Common.ProtocolVersions - -- * Plutus ledger languages - , PlutusLedgerLanguage (..) - -- * Plutus Core language versions - , Version (..) - -- * Version-testing functions - , ledgerLanguageIntroducedIn - , ledgerLanguagesAvailableIn - , plcVersionsIntroducedIn - , plcVersionsAvailableIn - , builtinsIntroducedIn - , builtinsAvailableIn - , batch1 - , batch2 - , batch3 - , batch4a - , batch4b - , batch5 - , batch6 - ) where +{-# LANGUAGE LambdaCase #-} + +-- | This module contains the code for handling the various kinds of version that we care about: +-- +-- * Protocol versions +-- * Plutus ledger languages +-- * Plutus Core language versions +module PlutusLedgerApi.Common.Versions ( + -- * Cardano Protocol versions + module PlutusLedgerApi.Common.ProtocolVersions, + + -- * Plutus ledger languages + PlutusLedgerLanguage (..), + + -- * Plutus Core language versions + Version (..), + + -- * Version-testing functions + ledgerLanguageIntroducedIn, + ledgerLanguagesAvailableIn, + plcVersionsIntroducedIn, + plcVersionsAvailableIn, + builtinsIntroducedIn, + builtinsAvailableIn, + batch1, + batch2, + batch3, + batch4a, + batch4b, + batch5, + batch6, +) where import PlutusCore import PlutusLedgerApi.Common.ProtocolVersions @@ -78,52 +80,53 @@ could do, just by tracking when they were removed. See also Note [Adding new builtins: protocol versions]. -} -{-| The Plutus ledger language. These are entirely different script languages from the ledger's perspective, -which on our side are interpreted in very similar ways. - -It is a simple enumerated datatype (there is no major and minor components as in protocol version) -and the __ordering of constructors__ is essential for deriving Enum,Ord,Bounded. - -IMPORTANT: this is different from the Plutus Core language version, `PlutusCore.Version` --} -data PlutusLedgerLanguage = - PlutusV1 -- ^ introduced in Alonzo HF - | PlutusV2 -- ^ introduced in Vasil HF - | PlutusV3 -- ^ introduced in Chang HF - deriving stock (Eq, Ord, Show, Generic, Enum, Bounded) - deriving anyclass (NFData, NoThunks, Serialise) +-- | The Plutus ledger language. These are entirely different script languages from the ledger's perspective, +-- which on our side are interpreted in very similar ways. +-- +-- It is a simple enumerated datatype (there is no major and minor components as in protocol version) +-- and the __ordering of constructors__ is essential for deriving Enum,Ord,Bounded. +-- +-- IMPORTANT: this is different from the Plutus Core language version, `PlutusCore.Version` +data PlutusLedgerLanguage + = -- | introduced in Alonzo HF + PlutusV1 + | -- | introduced in Vasil HF + PlutusV2 + | -- | introduced in Chang HF + PlutusV3 + deriving stock (Eq, Ord, Show, Generic, Enum, Bounded) + deriving anyclass (NFData, NoThunks, Serialise) instance Pretty PlutusLedgerLanguage where - pretty = viaShow + pretty = viaShow -{-| Query the protocol version that a specific Plutus ledger language was first introduced in. --} +-- | Query the protocol version that a specific Plutus ledger language was first introduced in. ledgerLanguageIntroducedIn :: PlutusLedgerLanguage -> MajorProtocolVersion ledgerLanguageIntroducedIn = \case - PlutusV1 -> alonzoPV - PlutusV2 -> vasilPV - PlutusV3 -> changPV - -{-| Which Plutus language versions are available in the given -'MajorProtocolVersion'? See Note [New builtins/language versions and protocol -versions]. This function (and others in this module) assumes that once a LL is -available it remains available in all later PVs and that if m <= n, PlutusVm is -introduced no later than PlutusVn. --} + PlutusV1 -> alonzoPV + PlutusV2 -> vasilPV + PlutusV3 -> changPV + +-- | Which Plutus language versions are available in the given +-- 'MajorProtocolVersion'? See Note [New builtins/language versions and protocol +-- versions]. This function (and others in this module) assumes that once a LL is +-- available it remains available in all later PVs and that if m <= n, PlutusVm is +-- introduced no later than PlutusVn. ledgerLanguagesAvailableIn :: MajorProtocolVersion -> Set.Set PlutusLedgerLanguage ledgerLanguagesAvailableIn searchPv = Set.fromList $ takeWhile (\ll -> ledgerLanguageIntroducedIn ll <= searchPv) enumerate -- | Given a map from PVs to a type `a`, return a `Set a` containing all of the -- entries with PV <= thisPv -collectUpTo - :: Ord a - => Map.Map MajorProtocolVersion (Set.Set a) - -> MajorProtocolVersion - -> Set.Set a +collectUpTo :: + Ord a => + Map.Map MajorProtocolVersion (Set.Set a) -> + MajorProtocolVersion -> + Set.Set a collectUpTo m thisPv = - fold $ -- ie, iterated `union` - Map.elems $ Map.takeWhileAntitone (<= thisPv) m + fold $ -- ie, iterated `union` + Map.elems $ + Map.takeWhileAntitone (<= thisPv) m {- Batches of builtins which were introduced in the same hard fork (but perhaps not for all LLs): see the Plutus Core specification and @@ -146,26 +149,68 @@ collectUpTo m thisPv = -- DO NOT CHANGE THIS. batch1 :: [DefaultFun] batch1 = - [ AddInteger, SubtractInteger, MultiplyInteger, DivideInteger, QuotientInteger - , RemainderInteger, ModInteger, EqualsInteger, LessThanInteger, LessThanEqualsInteger - , AppendByteString, ConsByteString, SliceByteString, LengthOfByteString - , IndexByteString, EqualsByteString, LessThanByteString, LessThanEqualsByteString - , Sha2_256, Sha3_256, Blake2b_256, VerifyEd25519Signature, AppendString, EqualsString - , EncodeUtf8, DecodeUtf8, IfThenElse, ChooseUnit, Trace, FstPair, SndPair, ChooseList - , MkCons, HeadList, TailList, NullList, ChooseData, ConstrData, MapData, ListData - , IData, BData, UnConstrData, UnMapData, UnListData, UnIData, UnBData, EqualsData - , MkPairData, MkNilData, MkNilPairData + [ AddInteger + , SubtractInteger + , MultiplyInteger + , DivideInteger + , QuotientInteger + , RemainderInteger + , ModInteger + , EqualsInteger + , LessThanInteger + , LessThanEqualsInteger + , AppendByteString + , ConsByteString + , SliceByteString + , LengthOfByteString + , IndexByteString + , EqualsByteString + , LessThanByteString + , LessThanEqualsByteString + , Sha2_256 + , Sha3_256 + , Blake2b_256 + , VerifyEd25519Signature + , AppendString + , EqualsString + , EncodeUtf8 + , DecodeUtf8 + , IfThenElse + , ChooseUnit + , Trace + , FstPair + , SndPair + , ChooseList + , MkCons + , HeadList + , TailList + , NullList + , ChooseData + , ConstrData + , MapData + , ListData + , IData + , BData + , UnConstrData + , UnMapData + , UnListData + , UnIData + , UnBData + , EqualsData + , MkPairData + , MkNilData + , MkNilPairData ] -- DO NOT CHANGE THIS. batch2 :: [DefaultFun] batch2 = - [ SerialiseData ] + [SerialiseData] -- DO NOT CHANGE THIS. batch3 :: [DefaultFun] batch3 = - [ VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature ] + [VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature] -- `cekCase` and `cekConstr` costs come between Batch 3 and Batch 4 in the -- PlutusV3 cost model parameters, although that's irrelevant here. @@ -174,14 +219,25 @@ batch3 = -- DO NOT CHANGE THIS. batch4a :: [DefaultFun] batch4a = - [ Bls12_381_G1_add, Bls12_381_G1_neg, Bls12_381_G1_scalarMul - , Bls12_381_G1_equal, Bls12_381_G1_hashToGroup - , Bls12_381_G1_compress, Bls12_381_G1_uncompress - , Bls12_381_G2_add, Bls12_381_G2_neg, Bls12_381_G2_scalarMul - , Bls12_381_G2_equal, Bls12_381_G2_hashToGroup - , Bls12_381_G2_compress, Bls12_381_G2_uncompress - , Bls12_381_millerLoop, Bls12_381_mulMlResult, Bls12_381_finalVerify - , Keccak_256, Blake2b_224 + [ Bls12_381_G1_add + , Bls12_381_G1_neg + , Bls12_381_G1_scalarMul + , Bls12_381_G1_equal + , Bls12_381_G1_hashToGroup + , Bls12_381_G1_compress + , Bls12_381_G1_uncompress + , Bls12_381_G2_add + , Bls12_381_G2_neg + , Bls12_381_G2_scalarMul + , Bls12_381_G2_equal + , Bls12_381_G2_hashToGroup + , Bls12_381_G2_compress + , Bls12_381_G2_uncompress + , Bls12_381_millerLoop + , Bls12_381_mulMlResult + , Bls12_381_finalVerify + , Keccak_256 + , Blake2b_224 ] {- batch4b: IntegerToByteString and ByteStringToInteger. These were enabled in @@ -200,7 +256,7 @@ batch4a = -- DO NOT CHANGE THIS. batch4b :: [DefaultFun] batch4b = - [ IntegerToByteString, ByteStringToInteger ] + [IntegerToByteString, ByteStringToInteger] -- DO NOT CHANGE THIS. batch4 :: [DefaultFun] @@ -209,9 +265,17 @@ batch4 = batch4a ++ batch4b -- DO NOT CHANGE THIS. batch5 :: [DefaultFun] batch5 = - [ AndByteString, OrByteString, XorByteString, ComplementByteString - , ReadBit, WriteBits, ReplicateByte - , ShiftByteString, RotateByteString, CountSetBits, FindFirstSetBit + [ AndByteString + , OrByteString + , XorByteString + , ComplementByteString + , ReadBit + , WriteBits + , ReplicateByte + , ShiftByteString + , RotateByteString + , CountSetBits + , FindFirstSetBit , Ripemd_160 ] @@ -220,69 +284,70 @@ batch5 = -- changed and open a new batch. batch6 :: [DefaultFun] batch6 = - [ ExpModInteger, DropList - , LengthOfArray, ListToArray, IndexArray - , Bls12_381_G1_multiScalarMul, Bls12_381_G2_multiScalarMul + [ ExpModInteger + , DropList + , LengthOfArray + , ListToArray + , IndexArray + , Bls12_381_G1_multiScalarMul + , Bls12_381_G2_multiScalarMul ] -{-| Given a ledger language, return a map indicating which builtin functions were - introduced in which 'MajorProtocolVersion'. This __must__ be updated when new - builtins are added. It is not necessary to add entries for protocol versions - where no new builtins are added. See Note [New builtins/language versions and - protocol versions] --} +-- | Given a ledger language, return a map indicating which builtin functions were +-- introduced in which 'MajorProtocolVersion'. This __must__ be updated when new +-- builtins are added. It is not necessary to add entries for protocol versions +-- where no new builtins are added. See Note [New builtins/language versions and +-- protocol versions] builtinsIntroducedIn :: PlutusLedgerLanguage -> Map.Map MajorProtocolVersion (Set.Set DefaultFun) builtinsIntroducedIn = \case PlutusV1 -> Map.fromList - [ (alonzoPV, Set.fromList batch1) - , (pv11PV, Set.fromList (batch2 ++ batch3 ++ batch4 ++ batch5 ++ batch6)) - ] + [ (alonzoPV, Set.fromList batch1) + , (pv11PV, Set.fromList (batch2 ++ batch3 ++ batch4 ++ batch5 ++ batch6)) + ] PlutusV2 -> Map.fromList - [ (vasilPV, Set.fromList (batch1 ++ batch2)) - , (valentinePV, Set.fromList batch3) - , (plominPV, Set.fromList batch4b) - , (pv11PV , Set.fromList (batch4a ++ batch5 ++ batch6)) - ] + [ (vasilPV, Set.fromList (batch1 ++ batch2)) + , (valentinePV, Set.fromList batch3) + , (plominPV, Set.fromList batch4b) + , (pv11PV, Set.fromList (batch4a ++ batch5 ++ batch6)) + ] PlutusV3 -> Map.fromList - [ (changPV, Set.fromList (batch1 ++ batch2 ++ batch3 ++ batch4)) - , (plominPV, Set.fromList batch5) - , (pv11PV, Set.fromList batch6) - ] + [ (changPV, Set.fromList (batch1 ++ batch2 ++ batch3 ++ batch4)) + , (plominPV, Set.fromList batch5) + , (pv11PV, Set.fromList batch6) + ] -{- | Return a set containing the builtins which are available in a given LL in a -given PV. All builtins are available in all LLs from `pv11PV` onwards. -} +-- | Return a set containing the builtins which are available in a given LL in a +-- given PV. All builtins are available in all LLs from `pv11PV` onwards. builtinsAvailableIn :: PlutusLedgerLanguage -> MajorProtocolVersion -> Set.Set DefaultFun builtinsAvailableIn = collectUpTo . builtinsIntroducedIn - -{-| A map indicating which Plutus Core versions were introduced in which -'MajorProtocolVersion' and 'PlutusLedgerLanguage'. Each version should appear at most once. -This __must__ be updated when new versions are added. -See Note [New builtins/language versions and protocol versions] --} +-- | A map indicating which Plutus Core versions were introduced in which +-- 'MajorProtocolVersion' and 'PlutusLedgerLanguage'. Each version should appear at most once. +-- This __must__ be updated when new versions are added. +-- See Note [New builtins/language versions and protocol versions] plcVersionsIntroducedIn :: PlutusLedgerLanguage -> Map.Map MajorProtocolVersion (Set.Set Version) plcVersionsIntroducedIn = \case PlutusV1 -> Map.fromList - [ (alonzoPV, Set.fromList [ plcVersion100 ]) - , (pv11PV, Set.fromList [ plcVersion110 ]) - ] + [ (alonzoPV, Set.fromList [plcVersion100]) + , (pv11PV, Set.fromList [plcVersion110]) + ] PlutusV2 -> Map.fromList - [ (vasilPV, Set.fromList [ plcVersion100 ]) - , (pv11PV, Set.fromList [ plcVersion110 ]) - ] + [ (vasilPV, Set.fromList [plcVersion100]) + , (pv11PV, Set.fromList [plcVersion110]) + ] PlutusV3 -> Map.fromList - [ (changPV, Set.fromList [ plcVersion100, plcVersion110 ]) - ] + [ (changPV, Set.fromList [plcVersion100, plcVersion110]) + ] -{-| Which Plutus Core language versions are available in the given 'PlutusLedgerLanguage' -and 'MajorProtocolVersion'? -} +-- | Which Plutus Core language versions are available in the given 'PlutusLedgerLanguage' +-- and 'MajorProtocolVersion'? plcVersionsAvailableIn :: PlutusLedgerLanguage -> MajorProtocolVersion -> Set.Set Version plcVersionsAvailableIn = collectUpTo . plcVersionsIntroducedIn diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs b/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs index ed707c9d1a7..84dbac20d8a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs @@ -173,10 +173,16 @@ module PlutusLedgerApi.Data.V1 ( import Data.SatInt import PlutusCore.Data qualified as PLC import PlutusCore.Evaluation.Machine.ExBudget as PLC -import PlutusLedgerApi.Common as Common hiding (deserialiseScript, evaluateScriptCounting, - evaluateScriptRestricting) -import PlutusLedgerApi.Common qualified as Common (deserialiseScript, evaluateScriptCounting, - evaluateScriptRestricting) +import PlutusLedgerApi.Common as Common hiding ( + deserialiseScript, + evaluateScriptCounting, + evaluateScriptRestricting, + ) +import PlutusLedgerApi.Common qualified as Common ( + deserialiseScript, + evaluateScriptCounting, + evaluateScriptRestricting, + ) import PlutusLedgerApi.V1.Bytes import PlutusLedgerApi.V1.Crypto import PlutusLedgerApi.V1.Data.Address @@ -190,9 +196,8 @@ import PlutusLedgerApi.V1.EvaluationContext import PlutusLedgerApi.V1.ParamName import PlutusLedgerApi.V1.Scripts as Scripts -{-| An alias to the Plutus ledger language this module exposes at runtime. - MAYBE: Use CPP '__FILE__' + some TH to automate this. --} +-- | An alias to the Plutus ledger language this module exposes at runtime. +-- MAYBE: Use CPP '__FILE__' + some TH to automate this. thisLedgerLanguage :: PlutusLedgerLanguage thisLedgerLanguage = PlutusV1 @@ -214,58 +219,55 @@ all the details: we're never going to remove anything, we're just going to creat new versions. -} -{-| The deserialization from a serialised script into a `ScriptForEvaluation`, -ready to be evaluated on-chain. -Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). --} -deserialiseScript - :: forall m - . (MonadError ScriptDecodeError m) - => MajorProtocolVersion - -- ^ which major protocol version the script was submitted in. - -> SerialisedScript - -- ^ the script to deserialise. - -> m ScriptForEvaluation +-- | The deserialization from a serialised script into a `ScriptForEvaluation`, +-- ready to be evaluated on-chain. +-- Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). +deserialiseScript :: + forall m. + MonadError ScriptDecodeError m => + -- | which major protocol version the script was submitted in. + MajorProtocolVersion -> + -- | the script to deserialise. + SerialisedScript -> + m ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{-| Evaluates a script, returning the minimum budget that the script would need -to evaluate successfully. lalaThis will take as long as the script takes, if you need to -limit the execution time of the script also, you can use 'evaluateScriptRestricting', which -also returns the used budget. --} -evaluateScriptCounting - :: MajorProtocolVersion - -- ^ Which major protocol version to run the operation in - -> VerboseMode - -- ^ Whether to produce log output - -> EvaluationContext - -- ^ Includes the cost model to use for tallying up the execution costs - -> ScriptForEvaluation - -- ^ The script to evaluate - -> [PLC.Data] - -- ^ The arguments to the script - -> (LogOutput, Either EvaluationError ExBudget) +-- | Evaluates a script, returning the minimum budget that the script would need +-- to evaluate successfully. lalaThis will take as long as the script takes, if you need to +-- limit the execution time of the script also, you can use 'evaluateScriptRestricting', which +-- also returns the used budget. +evaluateScriptCounting :: + -- | Which major protocol version to run the operation in + MajorProtocolVersion -> + -- | Whether to produce log output + VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + EvaluationContext -> + -- | The script to evaluate + ScriptForEvaluation -> + -- | The arguments to the script + [PLC.Data] -> + (LogOutput, Either EvaluationError ExBudget) evaluateScriptCounting = Common.evaluateScriptCounting thisLedgerLanguage -{-| Evaluates a script, with a cost model and a budget that restricts how many -resources it can use according to the cost model. Also returns the budget that -was actually used. - -Can be used to calculate budgets for scripts, but even in this case you must give -a limit to guard against scripts that run for a long time or loop. --} -evaluateScriptRestricting - :: MajorProtocolVersion - -- ^ Which major protocol version to run the operation in - -> VerboseMode - -- ^ Whether to produce log output - -> EvaluationContext - -- ^ Includes the cost model to use for tallying up the execution costs - -> ExBudget - -- ^ The resource budget which must not be exceeded during evaluation - -> ScriptForEvaluation - -- ^ The script to evaluate - -> [PLC.Data] - -- ^ The arguments to the script - -> (LogOutput, Either EvaluationError ExBudget) +-- | Evaluates a script, with a cost model and a budget that restricts how many +-- resources it can use according to the cost model. Also returns the budget that +-- was actually used. +-- +-- Can be used to calculate budgets for scripts, but even in this case you must give +-- a limit to guard against scripts that run for a long time or loop. +evaluateScriptRestricting :: + -- | Which major protocol version to run the operation in + MajorProtocolVersion -> + -- | Whether to produce log output + VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + EvaluationContext -> + -- | The resource budget which must not be exceeded during evaluation + ExBudget -> + -- | The script to evaluate + ScriptForEvaluation -> + -- | The arguments to the script + [PLC.Data] -> + (LogOutput, Either EvaluationError ExBudget) evaluateScriptRestricting = Common.evaluateScriptRestricting thisLedgerLanguage diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs b/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs index 13f2941e256..51e1f965ca0 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs @@ -197,67 +197,70 @@ import PlutusLedgerApi.V2.Data.Tx qualified as Tx import PlutusLedgerApi.V2.EvaluationContext qualified as EvaluationContext import PlutusLedgerApi.V2.ParamName qualified as ParamName -import PlutusTx.Data.AssocMap (Map, safeFromSOPList, toBuiltinList, toSOPList, - unsafeFromBuiltinList, unsafeFromDataList, unsafeFromSOPList) +import PlutusTx.Data.AssocMap ( + Map, + safeFromSOPList, + toBuiltinList, + toSOPList, + unsafeFromBuiltinList, + unsafeFromDataList, + unsafeFromSOPList, + ) -{-| An alias to the Plutus ledger language this module exposes at runtime. - MAYBE: Use CPP '__FILE__' + some TH to automate this. --} +-- | An alias to the Plutus ledger language this module exposes at runtime. +-- MAYBE: Use CPP '__FILE__' + some TH to automate this. thisLedgerLanguage :: Common.PlutusLedgerLanguage thisLedgerLanguage = Common.PlutusV2 -{-| The deserialization from a serialised script into a `ScriptForEvaluation`, -ready to be evaluated on-chain. -Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). --} -deserialiseScript - :: forall m - . (Common.MonadError Common.ScriptDecodeError m) - => Common.MajorProtocolVersion - -- ^ which major protocol version the script was submitted in. - -> Common.SerialisedScript - -- ^ the script to deserialise. - -> m Common.ScriptForEvaluation +-- | The deserialization from a serialised script into a `ScriptForEvaluation`, +-- ready to be evaluated on-chain. +-- Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). +deserialiseScript :: + forall m. + Common.MonadError Common.ScriptDecodeError m => + -- | which major protocol version the script was submitted in. + Common.MajorProtocolVersion -> + -- | the script to deserialise. + Common.SerialisedScript -> + m Common.ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{-| Evaluates a script, returning the minimum budget that the script would need -to evaluate successfully. This will take as long as the script takes, if you need to -limit the execution time of the script also, you can use 'evaluateScriptRestricting', which -also returns the used budget. --} -evaluateScriptCounting - :: Common.MajorProtocolVersion - -- ^ Which major protocol version to run the operation in - -> Common.VerboseMode - -- ^ Whether to produce log output - -> Common.EvaluationContext - -- ^ Includes the cost model to use for tallying up the execution costs - -> Common.ScriptForEvaluation - -- ^ The script to evaluate - -> [Common.Data] - -- ^ The arguments to the script - -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +-- | Evaluates a script, returning the minimum budget that the script would need +-- to evaluate successfully. This will take as long as the script takes, if you need to +-- limit the execution time of the script also, you can use 'evaluateScriptRestricting', which +-- also returns the used budget. +evaluateScriptCounting :: + -- | Which major protocol version to run the operation in + Common.MajorProtocolVersion -> + -- | Whether to produce log output + Common.VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + Common.EvaluationContext -> + -- | The script to evaluate + Common.ScriptForEvaluation -> + -- | The arguments to the script + [Common.Data] -> + (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptCounting = Common.evaluateScriptCounting thisLedgerLanguage -{-| Evaluates a script, with a cost model and a budget that restricts how many -resources it can use according to the cost model. Also returns the budget that -was actually used. - -Can be used to calculate budgets for scripts, but even in this case you must give -a limit to guard against scripts that run for a long time or loop. --} -evaluateScriptRestricting - :: Common.MajorProtocolVersion - -- ^ Which major protocol version to run the operation in - -> Common.VerboseMode - -- ^ Whether to produce log output - -> Common.EvaluationContext - -- ^ Includes the cost model to use for tallying up the execution costs - -> Common.ExBudget - -- ^ The resource budget which must not be exceeded during evaluation - -> Common.ScriptForEvaluation - -- ^ The script to evaluate - -> [Common.Data] - -- ^ The arguments to the script - -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +-- | Evaluates a script, with a cost model and a budget that restricts how many +-- resources it can use according to the cost model. Also returns the budget that +-- was actually used. +-- +-- Can be used to calculate budgets for scripts, but even in this case you must give +-- a limit to guard against scripts that run for a long time or loop. +evaluateScriptRestricting :: + -- | Which major protocol version to run the operation in + Common.MajorProtocolVersion -> + -- | Whether to produce log output + Common.VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + Common.EvaluationContext -> + -- | The resource budget which must not be exceeded during evaluation + Common.ExBudget -> + -- | The script to evaluate + Common.ScriptForEvaluation -> + -- | The arguments to the script + [Common.Data] -> + (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptRestricting = Common.evaluateScriptRestricting thisLedgerLanguage diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs b/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs index 6367f5e707e..7d11a98a166 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs @@ -270,66 +270,62 @@ import PlutusLedgerApi.V3.EvaluationContext qualified as EvaluationContext import PlutusLedgerApi.V3.ParamName qualified as ParamName import PlutusTx.Ratio qualified as Ratio -{-| An alias to the Plutus ledger language this module exposes at runtime. - MAYBE: Use CPP '__FILE__' + some TH to automate this. --} +-- | An alias to the Plutus ledger language this module exposes at runtime. +-- MAYBE: Use CPP '__FILE__' + some TH to automate this. thisLedgerLanguage :: Common.PlutusLedgerLanguage thisLedgerLanguage = Common.PlutusV3 -{-| The deserialization from a serialised script into a `ScriptForEvaluation`, -ready to be evaluated on-chain. -Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). --} -deserialiseScript - :: forall m - . (Common.MonadError Common.ScriptDecodeError m) - => Common.MajorProtocolVersion - -- ^ which major protocol version the script was submitted in. - -> Common.SerialisedScript - -- ^ the script to deserialise. - -> m Common.ScriptForEvaluation +-- | The deserialization from a serialised script into a `ScriptForEvaluation`, +-- ready to be evaluated on-chain. +-- Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). +deserialiseScript :: + forall m. + Common.MonadError Common.ScriptDecodeError m => + -- | which major protocol version the script was submitted in. + Common.MajorProtocolVersion -> + -- | the script to deserialise. + Common.SerialisedScript -> + m Common.ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{-| Evaluates a script, returning the minimum budget that the script would need -to evaluate successfully. This will take as long as the script takes, if you need to -limit the execution time of the script also, you can use 'evaluateScriptRestricting', which -also returns the used budget. --} -evaluateScriptCounting - :: Common.MajorProtocolVersion - -- ^ Which protocol version to run the operation in - -> Common.VerboseMode - -- ^ Whether to produce log output - -> EvaluationContext.EvaluationContext - -- ^ Includes the cost model to use for tallying up the execution costs - -> Common.ScriptForEvaluation - -- ^ The script to evaluate - -> Common.Data - -- ^ The @ScriptContext@ argument to the script - -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +-- | Evaluates a script, returning the minimum budget that the script would need +-- to evaluate successfully. This will take as long as the script takes, if you need to +-- limit the execution time of the script also, you can use 'evaluateScriptRestricting', which +-- also returns the used budget. +evaluateScriptCounting :: + -- | Which protocol version to run the operation in + Common.MajorProtocolVersion -> + -- | Whether to produce log output + Common.VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + EvaluationContext.EvaluationContext -> + -- | The script to evaluate + Common.ScriptForEvaluation -> + -- | The @ScriptContext@ argument to the script + Common.Data -> + (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptCounting mpv verbose ec s arg = Common.evaluateScriptCounting thisLedgerLanguage mpv verbose ec s [arg] -{-| Evaluates a script, with a cost model and a budget that restricts how many -resources it can use according to the cost model. Also returns the budget that -was actually used. - -Can be used to calculate budgets for scripts, but even in this case you must give -a limit to guard against scripts that run for a long time or loop. --} -evaluateScriptRestricting - :: Common.MajorProtocolVersion - -- ^ Which protocol version to run the operation in - -> Common.VerboseMode - -- ^ Whether to produce log output - -> EvaluationContext.EvaluationContext - -- ^ Includes the cost model to use for tallying up the execution costs - -> Common.ExBudget - -- ^ The resource budget which must not be exceeded during evaluation - -> Common.ScriptForEvaluation - -- ^ The script to evaluate - -> Common.Data - -- ^ The @ScriptContext@ argument to the script - -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +-- | Evaluates a script, with a cost model and a budget that restricts how many +-- resources it can use according to the cost model. Also returns the budget that +-- was actually used. +-- +-- Can be used to calculate budgets for scripts, but even in this case you must give +-- a limit to guard against scripts that run for a long time or loop. +evaluateScriptRestricting :: + -- | Which protocol version to run the operation in + Common.MajorProtocolVersion -> + -- | Whether to produce log output + Common.VerboseMode -> + -- | Includes the cost model to use for tallying up the execution costs + EvaluationContext.EvaluationContext -> + -- | The resource budget which must not be exceeded during evaluation + Common.ExBudget -> + -- | The script to evaluate + Common.ScriptForEvaluation -> + -- | The @ScriptContext@ argument to the script + Common.Data -> + (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptRestricting mpv verbose ec budget s arg = Common.evaluateScriptRestricting thisLedgerLanguage mpv verbose ec budget s [arg] diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Envelope.hs b/plutus-ledger-api/src/PlutusLedgerApi/Envelope.hs index 7d5ad402e8b..068a39c040e 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Envelope.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Envelope.hs @@ -19,117 +19,113 @@ import PlutusLedgerApi.Common.SerialisedScript (serialiseCompiledCode) import PlutusLedgerApi.Common.Versions (PlutusLedgerLanguage (..)) import PlutusTx.Code (CompiledCode) -{-| Produce a JSON envelope containing 'CompiledCode' serialised with -CBOR and encoded in Base 16 (aka. HEX), using PlutusV3 by default. - -"Envelope" is a JSON object with the following fields: -@ -{ - "type": "PlutusScriptV3", - "description": "A description of the code", - "cborHex": "..." -} -@ --} -compiledCodeEnvelope - :: Text - -- ^ Description of the code - -> CompiledCode a - -- ^ Compiled code to wrap in the envelope - -> Json.Value - -- ^ JSON envelope +-- | Produce a JSON envelope containing 'CompiledCode' serialised with +-- CBOR and encoded in Base 16 (aka. HEX), using PlutusV3 by default. +-- +-- "Envelope" is a JSON object with the following fields: +-- @ +-- { +-- "type": "PlutusScriptV3", +-- "description": "A description of the code", +-- "cborHex": "..." +-- } +-- @ +compiledCodeEnvelope :: + -- | Description of the code + Text -> + -- | Compiled code to wrap in the envelope + CompiledCode a -> + -- | JSON envelope + Json.Value compiledCodeEnvelope = compiledCodeEnvelopeForVersion PlutusV3 -{-| Produce a JSON envelope containing 'CompiledCode' serialised with -CBOR and encoded in Base 16 (aka. HEX). - -"Envelope" is a JSON object with the following fields: -@ -{ - "type": "PlutusScriptV2", - "description": "A description of the code", - "cborHex": "..." -} -@ --} -compiledCodeEnvelopeForVersion - :: PlutusLedgerLanguage - -- ^ Language of the compiled code, e.g. 'PlutusLedgerLanguage.PlutusV3' - -> Text - -- ^ Description of the code - -> CompiledCode a - -- ^ Compiled code to wrap in the envelope - -> Json.Value - -- ^ JSON envelope +-- | Produce a JSON envelope containing 'CompiledCode' serialised with +-- CBOR and encoded in Base 16 (aka. HEX). +-- +-- "Envelope" is a JSON object with the following fields: +-- @ +-- { +-- "type": "PlutusScriptV2", +-- "description": "A description of the code", +-- "cborHex": "..." +-- } +-- @ +compiledCodeEnvelopeForVersion :: + -- | Language of the compiled code, e.g. 'PlutusLedgerLanguage.PlutusV3' + PlutusLedgerLanguage -> + -- | Description of the code + Text -> + -- | Compiled code to wrap in the envelope + CompiledCode a -> + -- | JSON envelope + Json.Value compiledCodeEnvelopeForVersion lang desc code = Json.object [ "type" .= typ , "description" .= desc , "cborHex" .= hex ] - where - typ :: Text = - case lang of - PlutusV1 -> "PlutusScriptV1" - PlutusV2 -> "PlutusScriptV2" - PlutusV3 -> "PlutusScriptV3" + where + typ :: Text = + case lang of + PlutusV1 -> "PlutusScriptV1" + PlutusV2 -> "PlutusScriptV2" + PlutusV3 -> "PlutusScriptV3" - hex = decodeUtf8 (Base16.encode (BS.fromShort (serialiseCompiledCode code))) + hex = decodeUtf8 (Base16.encode (BS.fromShort (serialiseCompiledCode code))) -{-| -Write a JSON envelope containing 'CompiledCode' serialised with -CBOR and encoded in Base 16 (aka. HEX) to a file on disk, using PlutusV3 by default. - -"Envelope" is a JSON object with the following fields: -@ -{ - "type": "PlutusScriptV3", - "description": "A description of the code", - "cborHex": "..." -} -@ --} -writeCodeEnvelope - :: Text - -- ^ Description of the code - -> CompiledCode a - -- ^ Compiled code to wrap in the envelope - -> FilePath - -- ^ File path to write the envelope to - -> IO () +-- | +-- Write a JSON envelope containing 'CompiledCode' serialised with +-- CBOR and encoded in Base 16 (aka. HEX) to a file on disk, using PlutusV3 by default. +-- +-- "Envelope" is a JSON object with the following fields: +-- @ +-- { +-- "type": "PlutusScriptV3", +-- "description": "A description of the code", +-- "cborHex": "..." +-- } +-- @ +writeCodeEnvelope :: + -- | Description of the code + Text -> + -- | Compiled code to wrap in the envelope + CompiledCode a -> + -- | File path to write the envelope to + FilePath -> + IO () writeCodeEnvelope = writeCodeEnvelopeForVersion PlutusV3 -{-| -Write a JSON envelope containing 'CompiledCode' serialised with -CBOR and encoded in Base 16 (aka. HEX) to a file on disk. - -"Envelope" is a JSON object with the following fields: -@ -{ - "type": "PlutusScriptV2", - "description": "A description of the code", - "cborHex": "..." -} -@ --} -writeCodeEnvelopeForVersion - :: PlutusLedgerLanguage - -- ^ Language of the compiled code, e.g. 'PlutusLedgerLanguage.PlutusV3' - -> Text - -- ^ Description of the code - -> CompiledCode a - -- ^ Compiled code to wrap in the envelope - -> FilePath - -- ^ File path to write the envelope to - -> IO () +-- | +-- Write a JSON envelope containing 'CompiledCode' serialised with +-- CBOR and encoded in Base 16 (aka. HEX) to a file on disk. +-- +-- "Envelope" is a JSON object with the following fields: +-- @ +-- { +-- "type": "PlutusScriptV2", +-- "description": "A description of the code", +-- "cborHex": "..." +-- } +-- @ +writeCodeEnvelopeForVersion :: + -- | Language of the compiled code, e.g. 'PlutusLedgerLanguage.PlutusV3' + PlutusLedgerLanguage -> + -- | Description of the code + Text -> + -- | Compiled code to wrap in the envelope + CompiledCode a -> + -- | File path to write the envelope to + FilePath -> + IO () writeCodeEnvelopeForVersion lang desc code path = do let envelope = compiledCodeEnvelopeForVersion lang desc code -- aeson-pretty doesn't add a newline at the end, so we add it manually envelopePretty = Json.encodePretty' config envelope <> "\n" LBS.writeFile path envelopePretty - where - config = - Json.defConfig - { Json.confCompare = - Json.keyOrder ["type", "description", "cborHex"] - } + where + config = + Json.defConfig + { Json.confCompare = + Json.keyOrder ["type", "description", "cborHex"] + } diff --git a/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs b/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs index 32f0a8dd2a5..fbd02b831a1 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs @@ -5,27 +5,30 @@ import PlutusLedgerApi.Common import PlutusCore.Builtin (CaserBuiltin (..), caseBuiltin, unavailableCaserBuiltin) import PlutusCore.Default (BuiltinSemanticsVariant (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (cekCostModelForVariant) -import PlutusCore.Evaluation.Machine.MachineParameters (MachineParameters (..), - mkMachineVariantParameters) +import PlutusCore.Evaluation.Machine.MachineParameters ( + MachineParameters (..), + mkMachineVariantParameters, + ) import PlutusCore.Evaluation.Machine.MachineParameters.Default (DefaultMachineParameters) -machineParametersFor - :: PlutusLedgerLanguage - -> MajorProtocolVersion - -> DefaultMachineParameters +machineParametersFor :: + PlutusLedgerLanguage -> + MajorProtocolVersion -> + DefaultMachineParameters machineParametersFor ledgerLang majorPV = MachineParameters - (if majorPV < pv11PV + ( if majorPV < pv11PV then unavailableCaserBuiltin $ getMajorProtocolVersion majorPV - else CaserBuiltin caseBuiltin) - (mkMachineVariantParameters builtinSemVar $ cekCostModelForVariant builtinSemVar) - where - builtinSemVar = - case ledgerLang of - PlutusV1 -> conwayDependentVariant - PlutusV2 -> conwayDependentVariant - PlutusV3 -> DefaultFunSemanticsVariantC - conwayDependentVariant = - if majorPV < changPV - then DefaultFunSemanticsVariantA - else DefaultFunSemanticsVariantB + else CaserBuiltin caseBuiltin + ) + (mkMachineVariantParameters builtinSemVar $ cekCostModelForVariant builtinSemVar) + where + builtinSemVar = + case ledgerLang of + PlutusV1 -> conwayDependentVariant + PlutusV2 -> conwayDependentVariant + PlutusV3 -> DefaultFunSemanticsVariantC + conwayDependentVariant = + if majorPV < changPV + then DefaultFunSemanticsVariantA + else DefaultFunSemanticsVariantB diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1.hs index 3f7cad642ca..e69fec40590 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1.hs @@ -57,13 +57,13 @@ module PlutusLedgerApi.V1 ( EvaluationContext.CostModelApplyError (..), -- * Script Context - Contexts.TxInfo(..), - Contexts.ScriptContext(..), - Contexts.ScriptPurpose(..), + Contexts.TxInfo (..), + Contexts.ScriptContext (..), + Contexts.ScriptPurpose (..), Contexts.TxId (..), - Contexts.TxOut(..), - Contexts.TxOutRef(..), - Contexts.TxInInfo(..), + Contexts.TxOut (..), + Contexts.TxOutRef (..), + Contexts.TxInInfo (..), Contexts.findOwnInput, Contexts.findDatum, Contexts.findDatumHash, @@ -115,7 +115,7 @@ module PlutusLedgerApi.V1 ( Value.valueOf, -- ** Currency symbols - Value.CurrencySymbol(..), + Value.CurrencySymbol (..), Value.currencySymbol, Value.adaSymbol, Value.symbols, @@ -126,7 +126,7 @@ module PlutusLedgerApi.V1 ( Value.adaToken, -- ** Asset classes - Value.AssetClass(..), + Value.AssetClass (..), Value.assetClass, Value.assetClassValue, Value.assetClassValueOf, @@ -204,9 +204,8 @@ import PlutusLedgerApi.V1.Scripts as Scripts import PlutusLedgerApi.V1.Time qualified as Time import PlutusLedgerApi.V1.Value qualified as Value -{- | An alias to the Plutus ledger language this module exposes at runtime. - MAYBE: Use CPP '__FILE__' + some TH to automate this. --} +-- | An alias to the Plutus ledger language this module exposes at runtime. +-- MAYBE: Use CPP '__FILE__' + some TH to automate this. thisLedgerLanguage :: Common.PlutusLedgerLanguage thisLedgerLanguage = Common.PlutusV1 @@ -226,13 +225,12 @@ internally. That means we don't lose anything by exposing all the details: we're anything, we're just going to create new versions. -} -{- | The deserialization from a serialised script into a `ScriptForEvaluation`, -ready to be evaluated on-chain. -Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). --} +-- | The deserialization from a serialised script into a `ScriptForEvaluation`, +-- ready to be evaluated on-chain. +-- Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). deserialiseScript :: forall m. - (Common.MonadError Common.ScriptDecodeError m) => + Common.MonadError Common.ScriptDecodeError m => -- | which major protocol version the script was submitted in. Common.MajorProtocolVersion -> -- | the script to deserialise. @@ -240,11 +238,10 @@ deserialiseScript :: m Common.ScriptForEvaluation deserialiseScript = SerialisedScript.deserialiseScript thisLedgerLanguage -{- | Evaluates a script, returning the minimum budget that the script would need -to evaluate successfully. This will take as long as the script takes, if you need to -limit the execution time of the script also, you can use 'evaluateScriptRestricting', which -also returns the used budget. --} +-- | Evaluates a script, returning the minimum budget that the script would need +-- to evaluate successfully. This will take as long as the script takes, if you need to +-- limit the execution time of the script also, you can use 'evaluateScriptRestricting', which +-- also returns the used budget. evaluateScriptCounting :: -- | Which major protocol version to run the operation in Common.MajorProtocolVersion -> @@ -259,13 +256,12 @@ evaluateScriptCounting :: (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptCounting = Common.evaluateScriptCounting thisLedgerLanguage -{- | Evaluates a script, with a cost model and a budget that restricts how many -resources it can use according to the cost model. Also returns the budget that -was actually used. - -Can be used to calculate budgets for scripts, but even in this case you must give -a limit to guard against scripts that run for a long time or loop. --} +-- | Evaluates a script, with a cost model and a budget that restricts how many +-- resources it can use according to the cost model. Also returns the budget that +-- was actually used. +-- +-- Can be used to calculate budgets for scripts, but even in this case you must give +-- a limit to guard against scripts that run for a long time or loop. evaluateScriptRestricting :: -- | Which major protocol version to run the operation in Common.MajorProtocolVersion -> diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs index fb5b351f3d6..5c33405978e 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} -module PlutusLedgerApi.V1.Address - ( Address (..) - , pubKeyHashAddress - , toPubKeyHash - , toScriptHash - , scriptHashAddress - , stakingCredential - ) where +module PlutusLedgerApi.V1.Address ( + Address (..), + pubKeyHashAddress, + toPubKeyHash, + toScriptHash, + scriptHashAddress, + stakingCredential, +) where import Control.DeepSeq (NFData) import GHC.Generics (Generic) @@ -33,7 +33,7 @@ import Prettyprinter (Pretty (pretty), parens, (<+>)) -- | An address may contain two credentials, -- the payment credential and optionally a 'StakingCredential'. data Address = Address - { addressCredential :: Credential + { addressCredential :: Credential -- ^ the payment credential , addressStakingCredential :: Maybe StakingCredential -- ^ the staking credential @@ -66,14 +66,14 @@ pubKeyHashAddress pkh = Address (PubKeyCredential pkh) Nothing -- | The PubKeyHash of the address, if any toPubKeyHash :: Address -> Maybe PubKeyHash toPubKeyHash (Address (PubKeyCredential k) _) = Just k -toPubKeyHash _ = Nothing +toPubKeyHash _ = Nothing {-# INLINEABLE toScriptHash #-} -- | The validator hash of the address, if any toScriptHash :: Address -> Maybe ScriptHash toScriptHash (Address (ScriptCredential k) _) = Just k -toScriptHash _ = Nothing +toScriptHash _ = Nothing {-# INLINEABLE scriptHashAddress #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Bytes.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Bytes.hs index 4ecead08363..59a128428b2 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Bytes.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Bytes.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module PlutusLedgerApi.V1.Bytes - ( LedgerBytes (..) - , LedgerBytesError (..) - , fromHex - , bytes - , fromBytes - , encodeByteString - ) where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusLedgerApi.V1.Bytes ( + LedgerBytes (..), + LedgerBytesError (..), + fromHex, + bytes, + fromBytes, + encodeByteString, +) where import Control.DeepSeq (NFData) import Control.Exception (Exception) @@ -27,31 +27,35 @@ import Data.Text.Encoding qualified as TE import Data.Word (Word8) import GHC.Generics (Generic) import PlutusTx (FromData, ToData, UnsafeFromData, makeLift) -import PlutusTx.Blueprint (HasBlueprintDefinition, HasBlueprintSchema (..), SchemaInfo (title), - withSchemaInfo) +import PlutusTx.Blueprint ( + HasBlueprintDefinition, + HasBlueprintSchema (..), + SchemaInfo (title), + withSchemaInfo, + ) import PlutusTx.Prelude qualified as P import Prettyprinter.Extras (Pretty, PrettyShow (..)) -{- | An error that is encountered when converting a `ByteString` to a `LedgerBytes`. -} -data LedgerBytesError = - UnpairedDigit -- ^ Odd number of bytes in the original bytestring. - | NotHexit !Char -- ^ A non-hex digit character ([^A-Fa-f0-9]) encountered during decoding. - deriving stock (Show) - deriving anyclass (Exception) - -{- | Convert a hex-encoded (Base16) `ByteString` to a `LedgerBytes`. - May return an error (`LedgerBytesError`). --} +-- | An error that is encountered when converting a `ByteString` to a `LedgerBytes`. +data LedgerBytesError + = -- | Odd number of bytes in the original bytestring. + UnpairedDigit + | -- | A non-hex digit character ([^A-Fa-f0-9]) encountered during decoding. + NotHexit !Char + deriving stock (Show) + deriving anyclass (Exception) + +-- | Convert a hex-encoded (Base16) `ByteString` to a `LedgerBytes`. +-- May return an error (`LedgerBytesError`). fromHex :: BS.ByteString -> Either LedgerBytesError LedgerBytes fromHex = fmap (LedgerBytes . P.toBuiltin) . asBSLiteral - where - + where handleChar :: Word8 -> Either LedgerBytesError Word8 handleChar x - | x >= c2w '0' && x <= c2w '9' = Right (x - c2w '0') -- hexits 0-9 - | x >= c2w 'a' && x <= c2w 'f' = Right (x - c2w 'a' + 10) -- hexits a-f - | x >= c2w 'A' && x <= c2w 'F' = Right (x - c2w 'A' + 10) -- hexits A-F - | otherwise = Left $ NotHexit (w2c x) + | x >= c2w '0' && x <= c2w '9' = Right (x - c2w '0') -- hexits 0-9 + | x >= c2w 'a' && x <= c2w 'f' = Right (x - c2w 'a' + 10) -- hexits a-f + | x >= c2w 'A' && x <= c2w 'F' = Right (x - c2w 'A' + 10) -- hexits A-F + | otherwise = Left $ NotHexit (w2c x) -- turns a pair of bytes such as "a6" into a single Word8 handlePair :: Word8 -> Word8 -> Either LedgerBytesError Word8 @@ -61,31 +65,31 @@ fromHex = fmap (LedgerBytes . P.toBuiltin) . asBSLiteral pure $ (16 * n) + n' asBytes :: [Word8] -> Either LedgerBytesError [Word8] - asBytes [] = Right mempty - asBytes (c:c':cs) = (:) <$> handlePair c c' <*> asBytes cs - asBytes _ = Left UnpairedDigit + asBytes [] = Right mempty + asBytes (c : c' : cs) = (:) <$> handlePair c c' <*> asBytes cs + asBytes _ = Left UnpairedDigit -- parses a bytestring such as @a6b4@ into an actual bytestring asBSLiteral :: BS.ByteString -> Either LedgerBytesError BS.ByteString asBSLiteral = withBytes asBytes - where - withBytes :: - ([Word8] -> Either LedgerBytesError [Word8]) -> - BS.ByteString -> - Either LedgerBytesError BS.ByteString - withBytes f = fmap BS.pack . f . BS.unpack - -newtype LedgerBytes = LedgerBytes { getLedgerBytes :: P.BuiltinByteString } - deriving stock (Eq, Ord, Generic) - deriving newtype (P.Eq, P.Ord, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - deriving anyclass (NFData, HasBlueprintDefinition) - deriving Pretty via (PrettyShow LedgerBytes) + where + withBytes :: + ([Word8] -> Either LedgerBytesError [Word8]) -> + BS.ByteString -> + Either LedgerBytesError BS.ByteString + withBytes f = fmap BS.pack . f . BS.unpack + +newtype LedgerBytes = LedgerBytes {getLedgerBytes :: P.BuiltinByteString} + deriving stock (Eq, Ord, Generic) + deriving newtype (P.Eq, P.Ord, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving (Pretty) via (PrettyShow LedgerBytes) instance HasBlueprintSchema LedgerBytes referencedTypes where {-# INLINEABLE schema #-} schema = schema @P.BuiltinByteString - & withSchemaInfo \info -> info{title = Just "LedgerBytes"} + & withSchemaInfo \info -> info {title = Just "LedgerBytes"} -- | Lift a Haskell bytestring to the Plutus abstraction 'LedgerBytes' fromBytes :: BS.ByteString -> LedgerBytes @@ -95,25 +99,24 @@ fromBytes = LedgerBytes . P.toBuiltin bytes :: LedgerBytes -> BS.ByteString bytes = P.fromBuiltin . getLedgerBytes -{- | Read in arbitrary 'LedgerBytes' as a \"string\" (of characters). - -This is mostly used together with GHC's /OverloadedStrings/ extension -to specify at the source code any 'LedgerBytes' constants, -by utilizing Haskell's double-quoted string syntax. - -IMPORTANT: the 'LedgerBytes' are expected to be already hex-encoded (base16); otherwise, -'LedgerBytesError' will be raised as an 'GHC.Exception.Exception'. --} +-- | Read in arbitrary 'LedgerBytes' as a \"string\" (of characters). +-- +-- This is mostly used together with GHC's /OverloadedStrings/ extension +-- to specify at the source code any 'LedgerBytes' constants, +-- by utilizing Haskell's double-quoted string syntax. +-- +-- IMPORTANT: the 'LedgerBytes' are expected to be already hex-encoded (base16); otherwise, +-- 'LedgerBytesError' will be raised as an 'GHC.Exception.Exception'. instance IsString LedgerBytes where - fromString = unsafeFromEither . fromHex . fromString + fromString = unsafeFromEither . fromHex . fromString -{- | The `Show` instance of `LedgerBytes` is its Base16/Hex encoded bytestring, -decoded with UTF-8, unpacked to `String`. -} +-- | The `Show` instance of `LedgerBytes` is its Base16/Hex encoded bytestring, +-- decoded with UTF-8, unpacked to `String`. instance Show LedgerBytes where - show = Text.unpack . encodeByteString . bytes + show = Text.unpack . encodeByteString . bytes -{- | Encode a ByteString value to Base16 (i.e. hexadecimal), then -decode with UTF-8 to a `Text`. -} +-- | Encode a ByteString value to Base16 (i.e. hexadecimal), then +-- decode with UTF-8 to a `Text`. encodeByteString :: BS.ByteString -> Text.Text encodeByteString = TE.decodeUtf8 . Base16.encode diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs index 9b1394edd4d..ecb5b05aeb4 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs @@ -1,44 +1,43 @@ +{-# LANGUAGE DeriveAnyClass #-} -- editorconfig-checker-disable-file -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -{-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-specialise #-} -module PlutusLedgerApi.V1.Contexts - ( - -- * Pending transactions and related types - TxInfo(..) - , ScriptContext(..) - , ScriptPurpose(..) - , TxId (..) - , TxOut(..) - , TxOutRef(..) - , TxInInfo(..) - , findOwnInput - , findDatum - , findDatumHash - , findTxInByTxOutRef - , findContinuingOutputs - , getContinuingOutputs - -- * Validator functions - , pubKeyOutputsAt - , valuePaidTo - , spendsOutput - , txSignedBy - , valueSpent - , valueProduced - , ownCurrencySymbol - ) where +module PlutusLedgerApi.V1.Contexts ( + -- * Pending transactions and related types + TxInfo (..), + ScriptContext (..), + ScriptPurpose (..), + TxId (..), + TxOut (..), + TxOutRef (..), + TxInInfo (..), + findOwnInput, + findDatum, + findDatumHash, + findTxInByTxOutRef, + findContinuingOutputs, + getContinuingOutputs, + + -- * Validator functions + pubKeyOutputsAt, + valuePaidTo, + spendsOutput, + txSignedBy, + valueSpent, + valueProduced, + ownCurrencySymbol, +) where import PlutusTx import PlutusTx.Foldable qualified as F @@ -56,9 +55,9 @@ import PlutusLedgerApi.V1.Tx (TxId (..), TxOut (..), TxOutRef (..)) import PlutusLedgerApi.V1.Value (CurrencySymbol (..), Value) import PlutusTx.Blueprint (HasBlueprintDefinition (..)) import PlutusTx.Blueprint.Definition.Derive (definitionRef) -import Prelude qualified as Haskell import Prettyprinter (Pretty (pretty), nest, vsep, (<+>)) import Prettyprinter.Extras (PrettyShow (PrettyShow)) +import Prelude qualified as Haskell {- Note [Script types in pending transactions] To validate a transaction, we have to evaluate the validation script of each of @@ -73,134 +72,146 @@ redeemer and data scripts of all of its inputs and outputs. -- | An input of a pending transaction. data TxInInfo = TxInInfo - { txInInfoOutRef :: TxOutRef - , txInInfoResolved :: TxOut - } - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving anyclass (HasBlueprintDefinition) + { txInInfoOutRef :: TxOutRef + , txInInfoResolved :: TxOut + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving anyclass (HasBlueprintDefinition) instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' + TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = - pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved + pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = + pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -- | Purpose of the script that is currently running data ScriptPurpose - = Minting CurrencySymbol - | Spending TxOutRef - | Rewarding StakingCredential - | Certifying DCert - deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) - deriving anyclass (HasBlueprintDefinition) - deriving Pretty via (PrettyShow ScriptPurpose) + = Minting CurrencySymbol + | Spending TxOutRef + | Rewarding StakingCredential + | Certifying DCert + deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) + deriving anyclass (HasBlueprintDefinition) + deriving (Pretty) via (PrettyShow ScriptPurpose) instance Eq ScriptPurpose where - {-# INLINABLE (==) #-} - Minting cs == Minting cs' = cs == cs' - Spending ref == Spending ref' = ref == ref' - Rewarding sc == Rewarding sc' = sc == sc' - Certifying cert == Certifying cert' = cert == cert' - _ == _ = False + {-# INLINEABLE (==) #-} + Minting cs == Minting cs' = cs == cs' + Spending ref == Spending ref' = ref == ref' + Rewarding sc == Rewarding sc' = sc == sc' + Certifying cert == Certifying cert' = cert == cert' + _ == _ = False -- | A pending transaction. This is the view as seen by validator scripts, so some details are stripped out. data TxInfo = TxInfo - { txInfoInputs :: [TxInInfo] -- ^ Transaction inputs; cannot be an empty list - , txInfoOutputs :: [TxOut] -- ^ Transaction outputs - , txInfoFee :: Value -- ^ The fee paid by this transaction. - , txInfoMint :: Value -- ^ The 'Value' minted by this transaction. - , txInfoDCert :: [DCert] -- ^ Digests of certificates included in this transaction - , txInfoWdrl :: [(StakingCredential, Integer)] -- ^ Withdrawals - , txInfoValidRange :: POSIXTimeRange -- ^ The valid range for the transaction. - , txInfoSignatories :: [PubKeyHash] -- ^ Signatures provided with the transaction, attested that they all signed the tx - , txInfoData :: [(DatumHash, Datum)] -- ^ The lookup table of datums attached to the transaction - , txInfoId :: TxId -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) - } - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving anyclass (HasBlueprintDefinition) + { txInfoInputs :: [TxInInfo] + -- ^ Transaction inputs; cannot be an empty list + , txInfoOutputs :: [TxOut] + -- ^ Transaction outputs + , txInfoFee :: Value + -- ^ The fee paid by this transaction. + , txInfoMint :: Value + -- ^ The 'Value' minted by this transaction. + , txInfoDCert :: [DCert] + -- ^ Digests of certificates included in this transaction + , txInfoWdrl :: [(StakingCredential, Integer)] + -- ^ Withdrawals + , txInfoValidRange :: POSIXTimeRange + -- ^ The valid range for the transaction. + , txInfoSignatories :: [PubKeyHash] + -- ^ Signatures provided with the transaction, attested that they all signed the tx + , txInfoData :: [(DatumHash, Datum)] + -- ^ The lookup table of datums attached to the transaction + , txInfoId :: TxId + -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving anyclass (HasBlueprintDefinition) instance Eq TxInfo where - {-# INLINABLE (==) #-} - TxInfo i o f m c w r s d tid == TxInfo i' o' f' m' c' w' r' s' d' tid' = - i == i' && o == o' && f == f' && m == m' && c == c' && w == w' && r == r' && s == s' && d == d' && tid == tid' + {-# INLINEABLE (==) #-} + TxInfo i o f m c w r s d tid == TxInfo i' o' f' m' c' w' r' s' d' tid' = + i == i' && o == o' && f == f' && m == m' && c == c' && w == w' && r == r' && s == s' && d == d' && tid == tid' instance Pretty TxInfo where - pretty TxInfo{txInfoInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoData, txInfoId} = - vsep - [ "TxId:" <+> pretty txInfoId - , "Inputs:" <+> pretty txInfoInputs - , "Outputs:" <+> pretty txInfoOutputs - , "Fee:" <+> pretty txInfoFee - , "Value minted:" <+> pretty txInfoMint - , "DCerts:" <+> pretty txInfoDCert - , "Wdrl:" <+> pretty txInfoWdrl - , "Valid range:" <+> pretty txInfoValidRange - , "Signatories:" <+> pretty txInfoSignatories - , "Datums:" <+> pretty txInfoData - ] + pretty TxInfo {txInfoInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoData, txInfoId} = + vsep + [ "TxId:" <+> pretty txInfoId + , "Inputs:" <+> pretty txInfoInputs + , "Outputs:" <+> pretty txInfoOutputs + , "Fee:" <+> pretty txInfoFee + , "Value minted:" <+> pretty txInfoMint + , "DCerts:" <+> pretty txInfoDCert + , "Wdrl:" <+> pretty txInfoWdrl + , "Valid range:" <+> pretty txInfoValidRange + , "Signatories:" <+> pretty txInfoSignatories + , "Datums:" <+> pretty txInfoData + ] -- | The context that the currently-executing script can access. data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo -- ^ information about the transaction the currently-executing script is included in - , scriptContextPurpose :: ScriptPurpose -- ^ the purpose of the currently-executing script - } - deriving stock (Generic, Haskell.Eq, Haskell.Show) + { scriptContextTxInfo :: TxInfo + -- ^ information about the transaction the currently-executing script is included in + , scriptContextPurpose :: ScriptPurpose + -- ^ the purpose of the currently-executing script + } + deriving stock (Generic, Haskell.Eq, Haskell.Show) instance Eq ScriptContext where - {-# INLINABLE (==) #-} - ScriptContext info purpose == ScriptContext info' purpose' = info == info' && purpose == purpose' + {-# INLINEABLE (==) #-} + ScriptContext info purpose == ScriptContext info' purpose' = info == info' && purpose == purpose' instance Pretty ScriptContext where - pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = - vsep - [ "Purpose:" <+> pretty scriptContextPurpose - , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] - ] + pretty ScriptContext {scriptContextTxInfo, scriptContextPurpose} = + vsep + [ "Purpose:" <+> pretty scriptContextPurpose + , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] + ] -- | Find the input currently being validated. findOwnInput :: ScriptContext -> Maybe TxInInfo -findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} = - find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs +findOwnInput ScriptContext {scriptContextTxInfo = TxInfo {txInfoInputs}, scriptContextPurpose = Spending txOutRef} = + find (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs findOwnInput _ = Nothing -{-# INLINABLE findOwnInput #-} +{-# INLINEABLE findOwnInput #-} -- | Find the data corresponding to a data hash, if there is one findDatum :: DatumHash -> TxInfo -> Maybe Datum -findDatum dsh TxInfo{txInfoData} = snd <$> find f txInfoData - where - f (dsh', _) = dsh' == dsh -{-# INLINABLE findDatum #-} +findDatum dsh TxInfo {txInfoData} = snd <$> find f txInfoData + where + f (dsh', _) = dsh' == dsh +{-# INLINEABLE findDatum #-} -- | Find the hash of a datum, if it is part of the pending transaction's -- hashes findDatumHash :: Datum -> TxInfo -> Maybe DatumHash -findDatumHash ds TxInfo{txInfoData} = fst <$> find f txInfoData - where - f (_, ds') = ds' == ds -{-# INLINABLE findDatumHash #-} +findDatumHash ds TxInfo {txInfoData} = fst <$> find f txInfoData + where + f (_, ds') = ds' == ds +{-# INLINEABLE findDatumHash #-} -- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the transaction's inputs (`TxInInfo`). findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo -findTxInByTxOutRef outRef TxInfo{txInfoInputs} = - find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs -{-# INLINABLE findTxInByTxOutRef #-} +findTxInByTxOutRef outRef TxInfo {txInfoInputs} = + find (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs +{-# INLINEABLE findTxInByTxOutRef #-} -- | Finds all the outputs that pay to the same script address that we are currently spending from, if any. findContinuingOutputs :: ScriptContext -> [Integer] -findContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress +findContinuingOutputs ctx | Just TxInInfo {txInInfoResolved = TxOut {txOutAddress}} <- findOwnInput ctx = findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut {txOutAddress = otherAddress} = addr == otherAddress findContinuingOutputs _ = traceError "Le" -- "Can't find any continuing outputs" -{-# INLINABLE findContinuingOutputs #-} +{-# INLINEABLE findContinuingOutputs #-} -- | Get all the outputs that pay to the same script address we are currently spending from, if any. getContinuingOutputs :: ScriptContext -> [TxOut] -getContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress +getContinuingOutputs ctx | Just TxInInfo {txInInfoResolved = TxOut {txOutAddress}} <- findOwnInput ctx = filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut {txOutAddress = otherAddress} = addr == otherAddress getContinuingOutputs _ = traceError "Lf" -- "Can't get any continuing outputs" -{-# INLINABLE getContinuingOutputs #-} +{-# INLINEABLE getContinuingOutputs #-} {- Note [Hashes in validator scripts] @@ -228,52 +239,53 @@ them from the correct types in Haskell, and for comparing them (in -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> PubKeyHash -> Bool -txSignedBy TxInfo{txInfoSignatories} k = case find ((==) k) txInfoSignatories of - Just _ -> True - Nothing -> False -{-# INLINABLE txSignedBy #-} +txSignedBy TxInfo {txInfoSignatories} k = case find ((==) k) txInfoSignatories of + Just _ -> True + Nothing -> False +{-# INLINEABLE txSignedBy #-} -- | Get the values paid to a public key address by a pending transaction. pubKeyOutputsAt :: PubKeyHash -> TxInfo -> [Value] pubKeyOutputsAt pk p = - let flt TxOut{txOutAddress = Address (PubKeyCredential pk') _, txOutValue} | pk == pk' = Just txOutValue - flt _ = Nothing - in mapMaybe flt (txInfoOutputs p) -{-# INLINABLE pubKeyOutputsAt #-} + let flt TxOut {txOutAddress = Address (PubKeyCredential pk') _, txOutValue} | pk == pk' = Just txOutValue + flt _ = Nothing + in mapMaybe flt (txInfoOutputs p) +{-# INLINEABLE pubKeyOutputsAt #-} -- | Get the total value paid to a public key address by a pending transaction. valuePaidTo :: TxInfo -> PubKeyHash -> Value valuePaidTo ptx pkh = mconcat (pubKeyOutputsAt pkh ptx) -{-# INLINABLE valuePaidTo #-} +{-# INLINEABLE valuePaidTo #-} -- | Get the total value of inputs spent by this transaction. valueSpent :: TxInfo -> Value valueSpent = F.foldMap (txOutValue . txInInfoResolved) . txInfoInputs -{-# INLINABLE valueSpent #-} +{-# INLINEABLE valueSpent #-} -- | Get the total value of outputs produced by this transaction. valueProduced :: TxInfo -> Value valueProduced = F.foldMap txOutValue . txInfoOutputs -{-# INLINABLE valueProduced #-} +{-# INLINEABLE valueProduced #-} -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextPurpose=Minting cs} = cs -ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" -{-# INLINABLE ownCurrencySymbol #-} +ownCurrencySymbol ScriptContext {scriptContextPurpose = Minting cs} = cs +ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" +{-# INLINEABLE ownCurrencySymbol #-} -{- | Check if the pending transaction spends a specific transaction output -(identified by the hash of a transaction and an index into that -transactions' outputs) --} +-- | Check if the pending transaction spends a specific transaction output +-- (identified by the hash of a transaction and an index into that +-- transactions' outputs) spendsOutput :: TxInfo -> TxId -> Integer -> Bool spendsOutput p h i = - let spendsOutRef inp = - let outRef = txInInfoOutRef inp - in h == txOutRefId outRef - && i == txOutRefIdx outRef - in any spendsOutRef (txInfoInputs p) -{-# INLINABLE spendsOutput #-} + let spendsOutRef inp = + let outRef = txInInfoOutRef inp + in h + == txOutRefId outRef + && i + == txOutRefIdx outRef + in any spendsOutRef (txInfoInputs p) +{-# INLINEABLE spendsOutput #-} ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- @@ -286,11 +298,11 @@ $(makeLift ''ScriptContext) $(makeIsDataSchemaIndexed ''TxInInfo [('TxInInfo, 0)]) $(makeIsDataSchemaIndexed ''TxInfo [('TxInfo, 0)]) $( makeIsDataSchemaIndexed - ''ScriptPurpose - [ ('Minting, 0) - , ('Spending, 1) - , ('Rewarding, 2) - , ('Certifying, 3) - ] + ''ScriptPurpose + [ ('Minting, 0) + , ('Spending, 1) + , ('Rewarding, 2) + , ('Certifying, 3) + ] ) $(makeIsDataSchemaIndexed ''ScriptContext [('ScriptContext, 0)]) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs index 69350dc2e65..70fdf6ed44a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs @@ -1,21 +1,20 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-specialise #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-specialise #-} -- | Address and staking address credentials for outputs. -module PlutusLedgerApi.V1.Credential - ( StakingCredential(..) - , Credential(..) - ) where +module PlutusLedgerApi.V1.Credential ( + StakingCredential (..), + Credential (..), +) where import Control.DeepSeq (NFData) import GHC.Generics (Generic) @@ -30,55 +29,60 @@ import Prettyprinter (Pretty (..), (<+>)) -- | Staking credential used to assign rewards. data StakingCredential - -- | The staking hash is the `Credential` required to unlock a transaction output. Either + = -- | The staking hash is the `Credential` required to unlock a transaction output. Either -- a public key credential (`Crypto.PubKeyHash`) or -- a script credential (`ScriptHash`). Both are hashed with /BLAKE2b-244/. 28 byte. - = StakingHash Credential - -- | The certificate pointer, constructed by the given + StakingHash Credential + | -- | The certificate pointer, constructed by the given -- slot number, transaction and certificate indices. -- NB: The fields should really be all `Word64`, as they are implemented in `Word64`, -- but 'Integer' is our only integral type so we need to use it instead. - | StakingPtr - Integer -- ^ the slot number - Integer -- ^ the transaction index (within the block) - Integer -- ^ the certificate index (within the transaction) - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData, HasBlueprintDefinition) + StakingPtr + -- | the slot number + Integer + -- | the transaction index (within the block) + Integer + -- | the certificate index (within the transaction) + Integer + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData, HasBlueprintDefinition) instance Pretty StakingCredential where - pretty (StakingHash h) = "StakingHash" <+> pretty h - pretty (StakingPtr a b c) = "StakingPtr:" <+> pretty a <+> pretty b <+> pretty c + pretty (StakingHash h) = "StakingHash" <+> pretty h + pretty (StakingPtr a b c) = "StakingPtr:" <+> pretty a <+> pretty b <+> pretty c instance PlutusTx.Eq StakingCredential where - {-# INLINABLE (==) #-} - StakingHash l == StakingHash r = l PlutusTx.== r - StakingPtr a b c == StakingPtr a' b' c' = - a PlutusTx.== a' - PlutusTx.&& b PlutusTx.== b' - PlutusTx.&& c PlutusTx.== c' - _ == _ = False + {-# INLINEABLE (==) #-} + StakingHash l == StakingHash r = l PlutusTx.== r + StakingPtr a b c == StakingPtr a' b' c' = + a + PlutusTx.== a' + PlutusTx.&& b + PlutusTx.== b' + PlutusTx.&& c + PlutusTx.== c' + _ == _ = False -- | Credentials required to unlock a transaction output. data Credential - = - -- | The transaction that spends this output must be signed by the private key. + = -- | The transaction that spends this output must be signed by the private key. -- See `Crypto.PubKeyHash`. PubKeyCredential PubKeyHash - -- | The transaction that spends this output must include the validator script and + | -- | The transaction that spends this output must include the validator script and -- be accepted by the validator. See `ScriptHash`. - | ScriptCredential ScriptHash - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData, HasBlueprintDefinition) + ScriptCredential ScriptHash + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData, HasBlueprintDefinition) instance Pretty Credential where - pretty (PubKeyCredential pkh) = "PubKeyCredential:" <+> pretty pkh - pretty (ScriptCredential val) = "ScriptCredential:" <+> pretty val + pretty (PubKeyCredential pkh) = "PubKeyCredential:" <+> pretty pkh + pretty (ScriptCredential val) = "ScriptCredential:" <+> pretty val instance PlutusTx.Eq Credential where - {-# INLINABLE (==) #-} - PubKeyCredential l == PubKeyCredential r = l PlutusTx.== r - ScriptCredential a == ScriptCredential a' = a PlutusTx.== a' - _ == _ = False + {-# INLINEABLE (==) #-} + PubKeyCredential l == PubKeyCredential r = l PlutusTx.== r + ScriptCredential a == ScriptCredential a' = a PlutusTx.== a' + _ == _ = False ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Crypto.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Crypto.hs index 9037b262fe4..6b1493efd96 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Crypto.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Crypto.hs @@ -1,18 +1,17 @@ +{-# LANGUAGE DataKinds #-} -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -module PlutusLedgerApi.V1.Crypto - ( PubKeyHash (..) - ) where +module PlutusLedgerApi.V1.Crypto ( + PubKeyHash (..), +) where import Control.DeepSeq (NFData) import Data.String @@ -28,13 +27,12 @@ import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.Show qualified as PlutusTx import Prettyprinter -{- | The hash of a public key. This is frequently used to identify the public key, -rather than the key itself. Hashed with /BLAKE2b-224/. 28 bytes. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). --} +-- | The hash of a public key. This is frequently used to identify the public key, +-- rather than the key itself. Hashed with /BLAKE2b-224/. 28 bytes. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the +-- [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). newtype PubKeyHash = PubKeyHash {getPubKeyHash :: PlutusTx.BuiltinByteString} deriving stock (Eq, Ord, Generic) deriving anyclass (NFData) @@ -47,18 +45,18 @@ newtype PubKeyHash = PubKeyHash {getPubKeyHash :: PlutusTx.BuiltinByteString} , PlutusTx.UnsafeFromData ) deriving - ( IsString - -- ^ from hex encoding - , Show - -- ^ using hex encoding - , Pretty - -- ^ using hex encoding + ( -- | from hex encoding + IsString + , -- | using hex encoding + Show + , -- | using hex encoding + Pretty ) via LedgerBytes instance HasBlueprintSchema PubKeyHash referenedTypes where - {-# INLINABLE schema #-} - schema = SchemaBytes emptySchemaInfo { title = Just "PubKeyHash" } emptyBytesSchema + {-# INLINEABLE schema #-} + schema = SchemaBytes emptySchemaInfo {title = Just "PubKeyHash"} emptyBytesSchema instance HasBlueprintDefinition PubKeyHash where type Unroll PubKeyHash = '[PubKeyHash] diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs index 19930b1a719..02a04d6e944 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-specialise #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} -- | Digests of certificates that are included in transactions. -module PlutusLedgerApi.V1.DCert - ( DCert(..) - ) where +module PlutusLedgerApi.V1.DCert ( + DCert (..), +) where import Control.DeepSeq (NFData) import GHC.Generics (Generic) @@ -54,36 +54,36 @@ data DCert = DCertDelegRegKey StakingCredential | DCertDelegDeRegKey StakingCredential | DCertDelegDelegate + -- | delegator StakingCredential - -- ^ delegator + -- | delegatee PubKeyHash - -- ^ delegatee | -- | A digest of the PoolParams DCertPoolRegister + -- | poolId PubKeyHash - -- ^ poolId + -- | pool VFR PubKeyHash - -- ^ pool VFR | -- | The retirement certificate and the Epoch in which the retirement will take place DCertPoolRetire PubKeyHash Integer -- NB: Should be Word64 but we only have Integer on-chain | -- | A really terse Digest DCertGenesis | -- | Another really terse Digest DCertMir - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData, HasBlueprintDefinition) - deriving Pretty via (PrettyShow DCert) + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving (Pretty) via (PrettyShow DCert) instance P.Eq DCert where - {-# INLINABLE (==) #-} - DCertDelegRegKey sc == DCertDelegRegKey sc' = sc P.== sc' - DCertDelegDeRegKey sc == DCertDelegDeRegKey sc' = sc P.== sc' - DCertDelegDelegate sc pkh == DCertDelegDelegate sc' pkh' = sc P.== sc' && pkh P.== pkh' - DCertPoolRegister pid pvfr == DCertPoolRegister pid' pvfr' = pid P.== pid' && pvfr P.== pvfr' - DCertPoolRetire pkh i == DCertPoolRetire pkh' i' = pkh P.== pkh' && i P.== i' - DCertGenesis == DCertGenesis = True - DCertMir == DCertMir = True - _ == _ = False + {-# INLINEABLE (==) #-} + DCertDelegRegKey sc == DCertDelegRegKey sc' = sc P.== sc' + DCertDelegDeRegKey sc == DCertDelegDeRegKey sc' = sc P.== sc' + DCertDelegDelegate sc pkh == DCertDelegDelegate sc' pkh' = sc P.== sc' && pkh P.== pkh' + DCertPoolRegister pid pvfr == DCertPoolRegister pid' pvfr' = pid P.== pid' && pvfr P.== pvfr' + DCertPoolRetire pkh i == DCertPoolRetire pkh' i' = pkh P.== pkh' && i P.== i' + DCertGenesis == DCertGenesis = True + DCertMir == DCertMir = True + _ == _ = False ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs index bf609f2c9fd..204a83079e6 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -26,8 +26,12 @@ module PlutusLedgerApi.V1.Data.Address ( import Control.DeepSeq (NFData) import GHC.Generics (Generic) import PlutusLedgerApi.V1.Crypto (PubKeyHash) -import PlutusLedgerApi.V1.Data.Credential (Credential, StakingCredential, pattern PubKeyCredential, - pattern ScriptCredential) +import PlutusLedgerApi.V1.Data.Credential ( + Credential, + StakingCredential, + pattern PubKeyCredential, + pattern ScriptCredential, + ) import PlutusLedgerApi.V1.Scripts (ScriptHash) import PlutusTx qualified import PlutusTx.AsData qualified as PlutusTx @@ -36,9 +40,8 @@ import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import Prettyprinter (Pretty (pretty), parens, (<+>)) -{-| An address may contain two credentials, -the payment credential and optionally a 'StakingCredential'. --} +-- | An address may contain two credentials, +-- the payment credential and optionally a 'StakingCredential'. PlutusTx.asData [d| data Address = Address @@ -68,9 +71,8 @@ instance PlutusTx.Eq Address where {-# INLINEABLE pubKeyHashAddress #-} -{-| The address that should be targeted by a transaction output -locked by the public key with the given hash. --} +-- | The address that should be targeted by a transaction output +-- locked by the public key with the given hash. pubKeyHashAddress :: PubKeyHash -> Address pubKeyHashAddress pkh = Address (PubKeyCredential pkh) Nothing @@ -79,20 +81,19 @@ pubKeyHashAddress pkh = Address (PubKeyCredential pkh) Nothing -- | The PubKeyHash of the address, if any toPubKeyHash :: Address -> Maybe PubKeyHash toPubKeyHash (Address (PubKeyCredential k) _) = Just k -toPubKeyHash _ = Nothing +toPubKeyHash _ = Nothing {-# INLINEABLE toScriptHash #-} -- | The validator hash of the address, if any toScriptHash :: Address -> Maybe ScriptHash toScriptHash (Address (ScriptCredential k) _) = Just k -toScriptHash _ = Nothing +toScriptHash _ = Nothing {-# INLINEABLE scriptHashAddress #-} -{-| The address that should be used by a transaction output -locked by the given validator script hash. --} +-- | The address that should be used by a transaction output +-- locked by the given validator script hash. scriptHashAddress :: ScriptHash -> Address scriptHashAddress vh = Address (ScriptCredential vh) Nothing diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs index abea7c5eeae..aa443414bf0 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- needed for asData pattern synonyms +-- needed for asData pattern synonyms +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -79,9 +80,18 @@ import PlutusLedgerApi.V1.Data.Address (pattern Address) import PlutusLedgerApi.V1.Data.Credential (StakingCredential, pattern PubKeyCredential) import PlutusLedgerApi.V1.Data.DCert (DCert) import PlutusLedgerApi.V1.Data.Time (POSIXTimeRange) -import PlutusLedgerApi.V1.Data.Tx (TxId (..), TxOut, TxOutRef, pattern TxOut, pattern TxOutRef, - txOutAddress, txOutDatumHash, txOutRefId, txOutRefIdx, - txOutValue) +import PlutusLedgerApi.V1.Data.Tx ( + TxId (..), + TxOut, + TxOutRef, + txOutAddress, + txOutDatumHash, + txOutRefId, + txOutRefIdx, + txOutValue, + pattern TxOut, + pattern TxOutRef, + ) import PlutusLedgerApi.V1.Data.Value (CurrencySymbol (..), Value) import PlutusLedgerApi.V1.Scripts import Prelude qualified as Haskell @@ -101,12 +111,12 @@ redeemer and data scripts of all of its inputs and outputs. PlutusTx.asData [d| data TxInInfo = TxInInfo - { txInInfoOutRef :: TxOutRef + { txInInfoOutRef :: TxOutRef , txInInfoResolved :: TxOut } deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - |] + |] makeLift ''TxInInfo @@ -114,7 +124,7 @@ instance Eq TxInInfo where TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = + pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -- | Purpose of the script that is currently running @@ -127,51 +137,51 @@ PlutusTx.asData | Certifying DCert deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - deriving Pretty via (PrettyShow ScriptPurpose) - |] + deriving (Pretty) via (PrettyShow ScriptPurpose) + |] makeLift ''ScriptPurpose instance Eq ScriptPurpose where {-# INLINEABLE (==) #-} - Minting cs == Minting cs' = cs == cs' - Spending ref == Spending ref' = ref == ref' - Rewarding sc == Rewarding sc' = sc == sc' + Minting cs == Minting cs' = cs == cs' + Spending ref == Spending ref' = ref == ref' + Rewarding sc == Rewarding sc' = sc == sc' Certifying cert == Certifying cert' = cert == cert' - _ == _ = False + _ == _ = False -{-| A pending transaction. This is the view as seen by validator scripts, -so some details are stripped out. --} +-- | A pending transaction. This is the view as seen by validator scripts, +-- so some details are stripped out. PlutusTx.asData [d| data TxInfo = TxInfo - { txInfoInputs :: List TxInInfo - -- ^ Transaction inputs; cannot be an empty list - , txInfoOutputs :: List TxOut - -- ^ Transaction outputs - , txInfoFee :: Value - -- ^ The fee paid by this transaction. - , txInfoMint :: Value - -- ^ The 'Value' minted by this transaction. - , txInfoDCert :: List DCert - -- ^ Digests of certificates included in this transaction - -- TODO: is this a map? is this a list? - , txInfoWdrl :: List (StakingCredential, Integer) - -- ^ Withdrawals - , txInfoValidRange :: POSIXTimeRange - -- ^ The valid range for the transaction. - , txInfoSignatories :: List PubKeyHash - -- ^ Signatures provided with the transaction, attested that they all signed the tx - -- TODO: is this a map? is this a list? - , txInfoData :: List (DatumHash, Datum) - -- ^ The lookup table of datums attached to the transaction - , txInfoId :: TxId - -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + { txInfoInputs :: List TxInInfo + , -- \^ Transaction inputs; cannot be an empty list + txInfoOutputs :: List TxOut + , -- \^ Transaction outputs + txInfoFee :: Value + , -- \^ The fee paid by this transaction. + txInfoMint :: Value + , -- \^ The 'Value' minted by this transaction. + txInfoDCert :: List DCert + , -- \^ Digests of certificates included in this transaction + -- TODO: is this a map? is this a list? + txInfoWdrl :: List (StakingCredential, Integer) + , -- \^ Withdrawals + txInfoValidRange :: POSIXTimeRange + , -- \^ The valid range for the transaction. + txInfoSignatories :: List PubKeyHash + , -- \^ Signatures provided with the transaction, attested that they all signed the tx + -- TODO: is this a map? is this a list? + txInfoData :: List (DatumHash, Datum) + , -- \^ The lookup table of datums attached to the transaction + txInfoId :: TxId } + -- \^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - |] + |] makeLift ''TxInfo @@ -230,14 +240,15 @@ instance Pretty TxInfo where PlutusTx.asData [d| data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo - -- ^ information about the transaction the currently-executing script is included in - , scriptContextPurpose :: ScriptPurpose - -- ^ the purpose of the currently-executing script + { scriptContextTxInfo :: TxInfo + , -- \^ information about the transaction the currently-executing script is included in + scriptContextPurpose :: ScriptPurpose } + -- \^ the purpose of the currently-executing script + deriving stock (Generic, Haskell.Eq, Haskell.Show) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - |] + |] makeLift ''ScriptContext @@ -246,7 +257,7 @@ instance Eq ScriptContext where ScriptContext info purpose == ScriptContext info' purpose' = info == info' && purpose == purpose' instance Pretty ScriptContext where - pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = + pretty ScriptContext {scriptContextTxInfo, scriptContextPurpose} = vsep [ "Purpose:" <+> pretty scriptContextPurpose , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] @@ -256,79 +267,75 @@ instance Pretty ScriptContext where findOwnInput :: ScriptContext -> Maybe TxInInfo findOwnInput ScriptContext - { scriptContextTxInfo = TxInfo{txInfoInputs} + { scriptContextTxInfo = TxInfo {txInfoInputs} , scriptContextPurpose = Spending txOutRef } = Data.List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs findOwnInput _ = Nothing {-# INLINEABLE findOwnInput #-} -- | Find the data corresponding to a data hash, if there is one findDatum :: DatumHash -> TxInfo -> Maybe Datum -findDatum dsh TxInfo{txInfoData} = +findDatum dsh TxInfo {txInfoData} = snd <$> Data.List.find f txInfoData - where - f (dsh', _) = dsh' == dsh + where + f (dsh', _) = dsh' == dsh {-# INLINEABLE findDatum #-} -{-| Find the hash of a datum, if it is part of the pending transaction's - hashes --} +-- | Find the hash of a datum, if it is part of the pending transaction's +-- hashes findDatumHash :: Datum -> TxInfo -> Maybe DatumHash -findDatumHash ds TxInfo{txInfoData} = +findDatumHash ds TxInfo {txInfoData} = fst <$> Data.List.find f txInfoData - where - f (_, ds') = ds' == ds + where + f (_, ds') = ds' == ds {-# INLINEABLE findDatumHash #-} -{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of -the transaction's inputs (`TxInInfo`). --} +-- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of +-- the transaction's inputs (`TxInInfo`). findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo -findTxInByTxOutRef outRef TxInfo{txInfoInputs} = +findTxInByTxOutRef outRef TxInfo {txInfoInputs} = Data.List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs {-# INLINEABLE findTxInByTxOutRef #-} -{-| Finds all the outputs that pay to the same script address that we are -currently spending from, if any. --} +-- | Finds all the outputs that pay to the same script address that we are +-- currently spending from, if any. findContinuingOutputs :: ScriptContext -> List Integer findContinuingOutputs ctx | Just TxInInfo - { txInInfoResolved = TxOut{txOutAddress} + { txInInfoResolved = TxOut {txOutAddress} } <- findOwnInput ctx = Data.List.findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress = otherAddress} = - addr == otherAddress + where + f addr TxOut {txOutAddress = otherAddress} = + addr == otherAddress findContinuingOutputs _ = traceError "Le" -- "Can't find any continuing outputs" {-# INLINEABLE findContinuingOutputs #-} -{-| Get all the outputs that pay to the same script address we are currently -spending from, if any. --} +-- | Get all the outputs that pay to the same script address we are currently +-- spending from, if any. getContinuingOutputs :: ScriptContext -> List TxOut getContinuingOutputs ctx | Just TxInInfo - { txInInfoResolved = TxOut{txOutAddress} + { txInInfoResolved = TxOut {txOutAddress} } <- findOwnInput ctx = Data.List.filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress = otherAddress} = - addr == otherAddress + where + f addr TxOut {txOutAddress = otherAddress} = + addr == otherAddress getContinuingOutputs _ = traceError "Lf" -- "Can't get any continuing outputs" {-# INLINEABLE getContinuingOutputs #-} @@ -359,9 +366,9 @@ them from the correct types in Haskell, and for comparing them (in -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> PubKeyHash -> Bool -txSignedBy TxInfo{txInfoSignatories} k = +txSignedBy TxInfo {txInfoSignatories} k = case Data.List.find ((==) k) txInfoSignatories of - Just _ -> True + Just _ -> True Nothing -> False {-# INLINEABLE txSignedBy #-} @@ -394,15 +401,14 @@ valueProduced = Data.List.foldMap txOutValue . txInfoOutputs -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextPurpose = Minting cs} = cs +ownCurrencySymbol ScriptContext {scriptContextPurpose = Minting cs} = cs ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" {-# INLINEABLE ownCurrencySymbol #-} -{-| Check if the pending transaction spends a specific transaction output -(identified by the hash of a transaction and an index into that -transactions' outputs) --} +-- | Check if the pending transaction spends a specific transaction output +-- (identified by the hash of a transaction and an index into that +-- transactions' outputs) spendsOutput :: TxInfo -> TxId -> Integer -> Bool spendsOutput p h i = let spendsOutRef inp = diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs index 74743e60b43..4486edfcaf7 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -32,16 +32,15 @@ import PlutusTx.Eq qualified as PlutusTx import PlutusTx.Show (deriveShow) import Prettyprinter (Pretty (..), (<+>)) -{-| Credentials required to unlock a transaction output. - -The 'PubKeyCredential' constructor represents the transaction that -spends this output and must be signed by the private key. -See `Crypto.PubKeyHash`. - -The 'ScriptCredential' constructor represents the transaction that spends -this output must include the validator script and -be accepted by the validator. See `ScriptHash`. --} +-- | Credentials required to unlock a transaction output. +-- +-- The 'PubKeyCredential' constructor represents the transaction that +-- spends this output and must be signed by the private key. +-- See `Crypto.PubKeyHash`. +-- +-- The 'ScriptCredential' constructor represents the transaction that spends +-- this output must include the validator script and +-- be accepted by the validator. See `ScriptHash`. PlutusTx.asData [d| data Credential @@ -58,21 +57,20 @@ instance Pretty Credential where instance PlutusTx.Eq Credential where {-# INLINEABLE (==) #-} - PubKeyCredential l == PubKeyCredential r = l PlutusTx.== r + PubKeyCredential l == PubKeyCredential r = l PlutusTx.== r ScriptCredential a == ScriptCredential a' = a PlutusTx.== a' - _ == _ = False - -{-| Staking credential used to assign rewards. - -The staking hash constructor is the `Credential` required to unlock a -transaction output. Either a public key credential (`Crypto.PubKeyHash`) or -a script credential (`ScriptHash`). Both are hashed with /BLAKE2b-244/. 28 byte. + _ == _ = False -The 'StakingPtr' constructor is the certificate pointer, constructed by the given -slot number, transaction and certificate indices. -NB: The fields should really be all `Word64`, as they are implemented in `Word64`, -but 'Integer' is our only integral type so we need to use it instead. --} +-- | Staking credential used to assign rewards. +-- +-- The staking hash constructor is the `Credential` required to unlock a +-- transaction output. Either a public key credential (`Crypto.PubKeyHash`) or +-- a script credential (`ScriptHash`). Both are hashed with /BLAKE2b-244/. 28 byte. +-- +-- The 'StakingPtr' constructor is the certificate pointer, constructed by the given +-- slot number, transaction and certificate indices. +-- NB: The fields should really be all `Word64`, as they are implemented in `Word64`, +-- but 'Integer' is our only integral type so we need to use it instead. PlutusTx.asData [d| data StakingCredential @@ -90,7 +88,7 @@ PlutusTx.asData |] instance Pretty StakingCredential where - pretty (StakingHash h) = "StakingHash" <+> pretty h + pretty (StakingHash h) = "StakingHash" <+> pretty h pretty (StakingPtr a b c) = "StakingPtr:" <+> pretty a <+> pretty b <+> pretty c instance PlutusTx.Eq StakingCredential where diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs index 9b1c98baddc..1ba025be719 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs @@ -1,27 +1,27 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-specialise #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} -- | Digests of certificates that are included in transactions. -module PlutusLedgerApi.V1.Data.DCert - ( DCert - , pattern DCertDelegRegKey - , pattern DCertDelegDeRegKey - , pattern DCertDelegDelegate - , pattern DCertPoolRegister - , pattern DCertPoolRetire - , pattern DCertGenesis - , pattern DCertMir - ) where +module PlutusLedgerApi.V1.Data.DCert ( + DCert, + pattern DCertDelegRegKey, + pattern DCertDelegDeRegKey, + pattern DCertDelegDelegate, + pattern DCertPoolRegister, + pattern DCertPoolRetire, + pattern DCertGenesis, + pattern DCertMir, +) where import Control.DeepSeq (NFData) import GHC.Generics (Generic) @@ -45,26 +45,26 @@ PlutusTx.asData | DCertDelegDeRegKey StakingCredential | DCertDelegDelegate StakingCredential - -- ^ delegator + -- \^ delegator PubKeyHash - -- ^ delegatee - | -- | A digest of the PoolParams + | -- \^ delegatee + -- \| A digest of the PoolParams DCertPoolRegister PubKeyHash - -- ^ poolId + -- \^ poolId PubKeyHash - -- ^ pool VFR - | -- | The retirement certificate and the Epoch in which the retirement will take place + | -- \^ pool VFR + -- \| The retirement certificate and the Epoch in which the retirement will take place DCertPoolRetire PubKeyHash Integer -- NB: Should be Word64 but we only have Integer on-chain - | -- | A really terse Digest + | -- \| A really terse Digest DCertGenesis - | -- | Another really terse Digest + | -- \| Another really terse Digest DCertMir - deriving stock (Eq, Ord, Show, Generic) - deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - deriving anyclass (NFData, HasBlueprintDefinition) - deriving Pretty via (PrettyShow DCert) - |] + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving (Pretty) via (PrettyShow DCert) + |] {-# ANN DCertDelegRegKey (SchemaTitle "DCertDelegRegKey") #-} {-# ANN DCertDelegRegKey (SchemaDescription "Delegation key registration certificate") #-} @@ -87,17 +87,16 @@ PlutusTx.asData {-# ANN DCertMir (SchemaTitle "DCertMir") #-} {-# ANN DCertMir (SchemaDescription "MIR key") #-} - instance P.Eq DCert where - {-# INLINABLE (==) #-} - DCertDelegRegKey sc == DCertDelegRegKey sc' = sc P.== sc' - DCertDelegDeRegKey sc == DCertDelegDeRegKey sc' = sc P.== sc' - DCertDelegDelegate sc pkh == DCertDelegDelegate sc' pkh' = sc P.== sc' && pkh P.== pkh' - DCertPoolRegister pid pvfr == DCertPoolRegister pid' pvfr' = pid P.== pid' && pvfr P.== pvfr' - DCertPoolRetire pkh i == DCertPoolRetire pkh' i' = pkh P.== pkh' && i P.== i' - DCertGenesis == DCertGenesis = True - DCertMir == DCertMir = True - _ == _ = False + {-# INLINEABLE (==) #-} + DCertDelegRegKey sc == DCertDelegRegKey sc' = sc P.== sc' + DCertDelegDeRegKey sc == DCertDelegDeRegKey sc' = sc P.== sc' + DCertDelegDelegate sc pkh == DCertDelegDelegate sc' pkh' = sc P.== sc' && pkh P.== pkh' + DCertPoolRegister pid pvfr == DCertPoolRegister pid' pvfr' = pid P.== pid' && pvfr P.== pvfr' + DCertPoolRetire pkh i == DCertPoolRetire pkh' i' = pkh P.== pkh' && i P.== i' + DCertGenesis == DCertGenesis = True + DCertMir == DCertMir = True + _ == _ = False ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs index 076d28b3f2b..9e9a759ffc6 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -51,15 +51,20 @@ module PlutusLedgerApi.V1.Data.Interval ( import Control.DeepSeq (NFData) import GHC.Generics (Generic) -import Prelude qualified as Haskell import Prettyprinter (Pretty (pretty), comma, (<+>)) +import Prelude qualified as Haskell import PlutusTx qualified import PlutusTx.AsData qualified as PlutusTx import PlutusTx.Blueprint (ConstructorSchema (..), Schema (..)) import PlutusTx.Blueprint.Class (HasBlueprintSchema (schema)) -import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), HasSchemaDefinition, Unrolled, - definitionIdFromTypeK, definitionRef) +import PlutusTx.Blueprint.Definition ( + HasBlueprintDefinition (..), + HasSchemaDefinition, + Unrolled, + definitionIdFromTypeK, + definitionRef, + ) import PlutusTx.Blueprint.Definition.TF (Nub, type (++)) import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..), emptySchemaInfo) import PlutusTx.Eq as PlutusTx @@ -101,21 +106,20 @@ PlutusTx.asData -- See Note [Enumerable Intervals] -{-| An interval of @a@s. - -The interval may be either closed or open at either end, meaning -that the endpoints may or may not be included in the interval. - -The interval can also be unbounded on either side. - -The 'Eq' instance gives equality of the intervals, not structural equality. -There is no 'Ord' instance, but 'contains' gives a partial order. - -Note that some of the functions on `Interval` rely on `Enum` in order to -handle non-inclusive endpoints. For this reason, it may not be safe to -use `Interval`s with non-inclusive endpoints on types whose `Enum` -instances have partial methods. --} +-- | An interval of @a@s. +-- +-- The interval may be either closed or open at either end, meaning +-- that the endpoints may or may not be included in the interval. +-- +-- The interval can also be unbounded on either side. +-- +-- The 'Eq' instance gives equality of the intervals, not structural equality. +-- There is no 'Ord' instance, but 'contains' gives a partial order. +-- +-- Note that some of the functions on `Interval` rely on `Enum` in order to +-- handle non-inclusive endpoints. For this reason, it may not be safe to +-- use `Interval`s with non-inclusive endpoints on types whose `Enum` +-- instances have partial methods. PlutusTx.asData [d| data Interval a = Interval {ivFrom :: LowerBound a, ivTo :: UpperBound a} @@ -124,7 +128,7 @@ PlutusTx.asData deriving anyclass (NFData) |] -instance (HasBlueprintDefinition a) => HasBlueprintDefinition (Interval a) where +instance HasBlueprintDefinition a => HasBlueprintDefinition (Interval a) where type Unroll (Interval a) = Nub (Interval a ': (Unrolled (LowerBound a) ++ Unrolled (UpperBound a))) @@ -134,8 +138,8 @@ instance ( HasBlueprintDefinition a , HasSchemaDefinition (LowerBound a) referencedTypes , HasSchemaDefinition (UpperBound a) referencedTypes - ) - => HasBlueprintSchema (Interval a) referencedTypes + ) => + HasBlueprintSchema (Interval a) referencedTypes where {-# INLINEABLE schema #-} schema = @@ -148,37 +152,37 @@ instance ] ) -mapInterval - :: ( PlutusTx.ToData a1 - , PlutusTx.ToData a2 - , PlutusTx.UnsafeFromData a1 - , PlutusTx.UnsafeFromData a2 - ) - => (a1 -> a2) - -> Interval a1 - -> Interval a2 +mapInterval :: + ( PlutusTx.ToData a1 + , PlutusTx.ToData a2 + , PlutusTx.UnsafeFromData a1 + , PlutusTx.UnsafeFromData a2 + ) => + (a1 -> a2) -> + Interval a1 -> + Interval a2 mapInterval f (Interval fromA toA) = Interval (mapLowerBound f fromA) (mapUpperBound f toA) instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (Interval a) where pretty (Interval l h) = pretty l <+> comma <+> pretty h -instance (HasBlueprintDefinition a) => HasBlueprintDefinition (Extended a) where +instance HasBlueprintDefinition a => HasBlueprintDefinition (Extended a) where type Unroll (Extended a) = Extended a ': Unrolled a definitionId = definitionIdFromTypeK @_ @Extended Haskell.<> definitionId @a -mapExtended - :: (PlutusTx.ToData t, PlutusTx.ToData a, PlutusTx.UnsafeFromData t, PlutusTx.UnsafeFromData a) - => (t -> a) -> Extended t -> Extended a -mapExtended _ NegInf = NegInf +mapExtended :: + (PlutusTx.ToData t, PlutusTx.ToData a, PlutusTx.UnsafeFromData t, PlutusTx.UnsafeFromData a) => + (t -> a) -> Extended t -> Extended a +mapExtended _ NegInf = NegInf mapExtended f (Finite a) = Finite (f a) -mapExtended _ PosInf = PosInf +mapExtended _ PosInf = PosInf instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (Extended a) where - pretty NegInf = pretty "-∞" - pretty PosInf = pretty "+∞" + pretty NegInf = pretty "-∞" + pretty PosInf = pretty "+∞" pretty (Finite a) = pretty a -instance (HasBlueprintDefinition (Extended a)) => HasBlueprintDefinition (UpperBound a) where +instance HasBlueprintDefinition (Extended a) => HasBlueprintDefinition (UpperBound a) where type Unroll (UpperBound a) = UpperBound a ': (Unrolled Closure ++ Unrolled (Extended a)) definitionId = definitionIdFromTypeK @_ @UpperBound Haskell.<> definitionId @(Extended a) @@ -187,13 +191,13 @@ instance , HasBlueprintDefinition a , HasSchemaDefinition (Extended a) referencedTypes , HasSchemaDefinition Closure referencedTypes - ) - => HasBlueprintSchema (UpperBound a) referencedTypes + ) => + HasBlueprintSchema (UpperBound a) referencedTypes where {-# INLINEABLE schema #-} schema = SchemaConstructor - emptySchemaInfo{title = Just "UpperBound"} + emptySchemaInfo {title = Just "UpperBound"} ( MkConstructorSchema 0 [ definitionRef @(Extended a) @referencedTypes @@ -201,39 +205,38 @@ instance ] ) -{-| For an enumerable type, turn an upper bound into a single inclusive -bounding value. - -Since the type is enumerable, non-inclusive bounds are equivalent -to inclusive bounds on the predecessor. - -See Note [Enumerable Intervals] --} -inclusiveUpperBound - :: (Enum a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => UpperBound a -> Extended a +-- | For an enumerable type, turn an upper bound into a single inclusive +-- bounding value. +-- +-- Since the type is enumerable, non-inclusive bounds are equivalent +-- to inclusive bounds on the predecessor. +-- +-- See Note [Enumerable Intervals] +inclusiveUpperBound :: + (Enum a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => UpperBound a -> Extended a -- already inclusive -inclusiveUpperBound (UpperBound v True) = v +inclusiveUpperBound (UpperBound v True) = v -- take pred inclusiveUpperBound (UpperBound (Finite x) False) = Finite $ pred x -- an infinity: inclusive/non-inclusive makes no difference -inclusiveUpperBound (UpperBound v False) = v - -mapUpperBound - :: ( PlutusTx.ToData a1 - , PlutusTx.ToData a2 - , PlutusTx.UnsafeFromData a1 - , PlutusTx.UnsafeFromData a2 - ) - => (a1 -> a2) -> UpperBound a1 -> UpperBound a2 +inclusiveUpperBound (UpperBound v False) = v + +mapUpperBound :: + ( PlutusTx.ToData a1 + , PlutusTx.ToData a2 + , PlutusTx.UnsafeFromData a1 + , PlutusTx.UnsafeFromData a2 + ) => + (a1 -> a2) -> UpperBound a1 -> UpperBound a2 mapUpperBound f (UpperBound e c) = UpperBound (mapExtended f e) c instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (UpperBound a) where pretty (UpperBound PosInf _) = pretty "+∞)" pretty (UpperBound NegInf _) = pretty "-∞)" - pretty (UpperBound a True) = pretty a <+> pretty "]" - pretty (UpperBound a False) = pretty a <+> pretty ")" + pretty (UpperBound a True) = pretty a <+> pretty "]" + pretty (UpperBound a False) = pretty a <+> pretty ")" -instance (HasBlueprintDefinition (Extended a)) => HasBlueprintDefinition (LowerBound a) where +instance HasBlueprintDefinition (Extended a) => HasBlueprintDefinition (LowerBound a) where type Unroll (LowerBound a) = LowerBound a ': (Unrolled Closure ++ Unrolled (Extended a)) definitionId = definitionIdFromTypeK @_ @LowerBound Haskell.<> definitionId @(Extended a) @@ -242,13 +245,13 @@ instance , HasBlueprintDefinition a , HasSchemaDefinition (Extended a) referencedTypes , HasSchemaDefinition Closure referencedTypes - ) - => HasBlueprintSchema (LowerBound a) referencedTypes + ) => + HasBlueprintSchema (LowerBound a) referencedTypes where {-# INLINEABLE schema #-} schema = SchemaConstructor - emptySchemaInfo{title = Just "LowerBound"} + emptySchemaInfo {title = Just "LowerBound"} ( MkConstructorSchema 0 [ definitionRef @(Extended a) @referencedTypes @@ -256,56 +259,55 @@ instance ] ) -{-| For an enumerable type, turn an lower bound into a single inclusive -bounding value. - -Since the type is enumerable, non-inclusive bounds are equivalent -to inclusive bounds on the successor. - -See Note [Enumerable Intervals] --} -inclusiveLowerBound - :: (Enum a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => LowerBound a -> Extended a +-- | For an enumerable type, turn an lower bound into a single inclusive +-- bounding value. +-- +-- Since the type is enumerable, non-inclusive bounds are equivalent +-- to inclusive bounds on the successor. +-- +-- See Note [Enumerable Intervals] +inclusiveLowerBound :: + (Enum a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => LowerBound a -> Extended a -- already inclusive -inclusiveLowerBound (LowerBound v True) = v +inclusiveLowerBound (LowerBound v True) = v -- take succ inclusiveLowerBound (LowerBound (Finite x) False) = Finite $ succ x -- an infinity: inclusive/non-inclusive makes no difference -inclusiveLowerBound (LowerBound v False) = v - -mapLowerBound - :: ( PlutusTx.ToData a1 - , PlutusTx.ToData a2 - , PlutusTx.UnsafeFromData a1 - , PlutusTx.UnsafeFromData a2 - ) - => (a1 -> a2) -> LowerBound a1 -> LowerBound a2 +inclusiveLowerBound (LowerBound v False) = v + +mapLowerBound :: + ( PlutusTx.ToData a1 + , PlutusTx.ToData a2 + , PlutusTx.UnsafeFromData a1 + , PlutusTx.UnsafeFromData a2 + ) => + (a1 -> a2) -> LowerBound a1 -> LowerBound a2 mapLowerBound f (LowerBound e c) = LowerBound (mapExtended f e) c instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (LowerBound a) where pretty (LowerBound PosInf _) = pretty "(+∞" pretty (LowerBound NegInf _) = pretty "(-∞" - pretty (LowerBound a True) = pretty "[" <+> pretty a - pretty (LowerBound a False) = pretty "(" <+> pretty a + pretty (LowerBound a True) = pretty "[" <+> pretty a + pretty (LowerBound a False) = pretty "(" <+> pretty a instance (Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Eq (Extended a) where {-# INLINEABLE (==) #-} - NegInf == NegInf = True - PosInf == PosInf = True + NegInf == NegInf = True + PosInf == PosInf = True Finite l == Finite r = l == r - _ == _ = False + _ == _ = False instance (Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Haskell.Eq (Extended a) where (==) = (PlutusTx.==) instance (Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Ord (Extended a) where {-# INLINEABLE compare #-} - NegInf `compare` NegInf = EQ - NegInf `compare` _ = LT - _ `compare` NegInf = GT - PosInf `compare` PosInf = EQ - _ `compare` PosInf = LT - PosInf `compare` _ = GT + NegInf `compare` NegInf = EQ + NegInf `compare` _ = LT + _ `compare` NegInf = GT + PosInf `compare` PosInf = EQ + _ `compare` PosInf = LT + PosInf `compare` _ = GT Finite l `compare` Finite r = l `compare` r instance (Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Haskell.Ord (Extended a) where @@ -317,117 +319,113 @@ instance (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Eq (Upp b1 == b2 = inclusiveUpperBound b1 == inclusiveUpperBound b2 instance - (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Haskell.Eq (UpperBound a) + (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Haskell.Eq (UpperBound a) where (==) = (PlutusTx.==) -- See Note [Enumerable Intervals] instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Ord (UpperBound a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Ord (UpperBound a) where {-# INLINEABLE compare #-} b1 `compare` b2 = inclusiveUpperBound b1 `compare` inclusiveUpperBound b2 instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Haskell.Ord (UpperBound a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Haskell.Ord (UpperBound a) where compare = PlutusTx.compare -- See Note [Enumerable Intervals] instance - (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Eq (LowerBound a) + (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Eq (LowerBound a) where {-# INLINEABLE (==) #-} b1 == b2 = inclusiveLowerBound b1 == inclusiveLowerBound b2 instance - (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Haskell.Eq (LowerBound a) + (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Haskell.Eq (LowerBound a) where (==) = (PlutusTx.==) -- See Note [Enumerable Intervals] instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Ord (LowerBound a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Ord (LowerBound a) where {-# INLINEABLE compare #-} b1 `compare` b2 = inclusiveLowerBound b1 `compare` inclusiveLowerBound b2 instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Haskell.Ord (LowerBound a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Haskell.Ord (LowerBound a) where compare = PlutusTx.compare -{-| Construct a strict upper bound from a value. -The resulting bound includes all values that are (strictly) smaller than the input value. --} +-- | Construct a strict upper bound from a value. +-- The resulting bound includes all values that are (strictly) smaller than the input value. strictUpperBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> UpperBound a strictUpperBound a = UpperBound (Finite a) False {-# INLINEABLE strictUpperBound #-} -{-| Construct a strict lower bound from a value. -The resulting bound includes all values that are (strictly) greater than the input value. --} +-- | Construct a strict lower bound from a value. +-- The resulting bound includes all values that are (strictly) greater than the input value. strictLowerBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> LowerBound a strictLowerBound a = LowerBound (Finite a) False {-# INLINEABLE strictLowerBound #-} -{-| Construct a lower bound from a value. -The resulting bound includes all values that are equal or greater than the input value. --} +-- | Construct a lower bound from a value. +-- The resulting bound includes all values that are equal or greater than the input value. lowerBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> LowerBound a lowerBound a = LowerBound (Finite a) True {-# INLINEABLE lowerBound #-} -{-| Construct an upper bound from a value. -The resulting bound includes all values that are equal or smaller than the input value. --} +-- | Construct an upper bound from a value. +-- The resulting bound includes all values that are equal or smaller than the input value. upperBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> UpperBound a upperBound a = UpperBound (Finite a) True {-# INLINEABLE upperBound #-} -- See Note [Enumerable Intervals] instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => JoinSemiLattice (Interval a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + JoinSemiLattice (Interval a) where {-# INLINEABLE (\/) #-} (\/) = hull -- See Note [Enumerable Intervals] instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => BoundedJoinSemiLattice (Interval a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + BoundedJoinSemiLattice (Interval a) where {-# INLINEABLE bottom #-} bottom = never -- See Note [Enumerable Intervals] instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => MeetSemiLattice (Interval a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + MeetSemiLattice (Interval a) where {-# INLINEABLE (/\) #-} (/\) = intersection -- See Note [Enumerable Intervals] instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => BoundedMeetSemiLattice (Interval a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + BoundedMeetSemiLattice (Interval a) where {-# INLINEABLE top #-} top = always -- See Note [Enumerable Intervals] instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Eq (Interval a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Eq (Interval a) where {-# INLINEABLE (==) #-} -- Degenerate case: both the intervals are empty. @@ -437,36 +435,32 @@ instance (Interval lb1 ub1) == (Interval lb2 ub2) = lb1 == lb2 && ub1 == ub2 instance - (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Haskell.Eq (Interval a) + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Haskell.Eq (Interval a) where {-# INLINEABLE (==) #-} (==) = (PlutusTx.==) -{-| @interval a b@ includes all values that are greater than or equal to @a@ -and smaller than or equal to @b@. Therefore it includes @a@ and @b@. In math. notation: [a,b] --} +-- | @interval a b@ includes all values that are greater than or equal to @a@ +-- and smaller than or equal to @b@. Therefore it includes @a@ and @b@. In math. notation: [a,b] interval :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> a -> Interval a interval s s' = Interval (lowerBound s) (upperBound s') {-# INLINEABLE interval #-} -{-| Create an interval that includes just a single concrete point @a@, -i.e. having the same non-strict lower and upper bounds. In math.notation: [a,a] --} +-- | Create an interval that includes just a single concrete point @a@, +-- i.e. having the same non-strict lower and upper bounds. In math.notation: [a,a] singleton :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> Interval a singleton s = interval s s {-# INLINEABLE singleton #-} -{-| @from a@ is an 'Interval' that includes all values that are - greater than or equal to @a@. In math. notation: [a,+∞] --} +-- | @from a@ is an 'Interval' that includes all values that are +-- greater than or equal to @a@. In math. notation: [a,+∞] from :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> Interval a from s = Interval (lowerBound s) (UpperBound PosInf True) {-# INLINEABLE from #-} -{-| @to a@ is an 'Interval' that includes all values that are - smaller than or equal to @a@. In math. notation: [-∞,a] --} +-- | @to a@ is an 'Interval' that includes all values that are +-- smaller than or equal to @a@. In math. notation: [-∞,a] to :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> Interval a to s = Interval (LowerBound NegInf True) (upperBound s) {-# INLINEABLE to #-} @@ -476,53 +470,49 @@ always :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Interval a always = Interval (LowerBound NegInf True) (UpperBound PosInf True) {-# INLINEABLE always #-} -{-| An 'Interval' that is empty. -There can be many empty intervals, see `isEmpty`. -The empty interval `never` is arbitrarily set to [+∞,-∞]. --} +-- | An 'Interval' that is empty. +-- There can be many empty intervals, see `isEmpty`. +-- The empty interval `never` is arbitrarily set to [+∞,-∞]. never :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Interval a never = Interval (LowerBound PosInf True) (UpperBound NegInf True) {-# INLINEABLE never #-} -- | Check whether a value is in an interval. -member - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => a -> Interval a -> Bool +member :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + a -> Interval a -> Bool member a i = i `contains` singleton a {-# INLINEABLE member #-} -{-| Check whether two intervals overlap, that is, whether there is a value that - is a member of both intervals. --} -overlaps - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Interval a -> Interval a -> Bool +-- | Check whether two intervals overlap, that is, whether there is a value that +-- is a member of both intervals. +overlaps :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Interval a -> Interval a -> Bool overlaps l r = not $ isEmpty (l `intersection` r) {-# INLINEABLE overlaps #-} -{-| 'intersection a b' is the largest interval that is contained in 'a' and in - 'b', if it exists. --} -intersection - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Interval a -> Interval a -> Interval a +-- | 'intersection a b' is the largest interval that is contained in 'a' and in +-- 'b', if it exists. +intersection :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Interval a -> Interval a -> Interval a intersection (Interval l1 h1) (Interval l2 h2) = Interval (max l1 l2) (min h1 h2) {-# INLINEABLE intersection #-} -- | 'hull a b' is the smallest interval containing 'a' and 'b'. -hull - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Interval a -> Interval a -> Interval a +hull :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Interval a -> Interval a -> Interval a hull (Interval l1 h1) (Interval l2 h2) = Interval (min l1 l2) (max h1 h2) {-# INLINEABLE hull #-} -{-| @a `contains` b@ is true if the 'Interval' @b@ is entirely contained in -@a@. That is, @a `contains` b@ if for every entry @s@, if @member s b@ then -@member s a@. --} -contains - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Interval a -> Interval a -> Bool +-- | @a `contains` b@ is true if the 'Interval' @b@ is entirely contained in +-- @a@. That is, @a `contains` b@ if for every entry @s@, if @member s b@ then +-- @member s a@. +contains :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Interval a -> Interval a -> Bool -- Everything contains the empty interval contains _ i2 | isEmpty i2 = True -- Nothing is contained in the empty interval (except the empty interval, @@ -534,9 +524,9 @@ contains (Interval l1 h1) (Interval l2 h2) = l1 <= l2 && h2 <= h1 {-# INLINEABLE contains #-} -- | Check if an 'Interval' is empty. -isEmpty - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => Interval a -> Bool +isEmpty :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + Interval a -> Bool isEmpty (Interval lb ub) = case inclusiveLowerBound lb `compare` inclusiveUpperBound ub of -- We have at least two possible values, the lower bound and the upper bound LT -> False @@ -547,16 +537,16 @@ isEmpty (Interval lb ub) = case inclusiveLowerBound lb `compare` inclusiveUpperB {-# INLINEABLE isEmpty #-} -- | Check if a value is earlier than the beginning of an 'Interval'. -before - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => a -> Interval a -> Bool +before :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + a -> Interval a -> Bool before h (Interval f _) = lowerBound h < f {-# INLINEABLE before #-} -- | Check if a value is later than the end of an 'Interval'. -after - :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) - => a -> Interval a -> Bool +after :: + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => + a -> Interval a -> Bool after h (Interval _ t) = upperBound h > t {-# INLINEABLE after #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs index 4f131663cb1..e67cccff039 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} -- Otherwise we get a complaint about the 'fromIntegral' -- call in the generated instance of 'Integral' for 'Ada' {-# OPTIONS_GHC -Wno-identities #-} @@ -54,11 +54,10 @@ newtype DiffMilliSeconds = DiffMilliSeconds Integer ) instance HasBlueprintSchema DiffMilliSeconds referencedTypes where - schema = SchemaInteger emptySchemaInfo{title = Just "DiffMilliSeconds"} emptyIntegerSchema + schema = SchemaInteger emptySchemaInfo {title = Just "DiffMilliSeconds"} emptyIntegerSchema -{-| POSIX time is measured as the number of /milliseconds/ since 1970-01-01T00:00:00Z. -This is not the same as Haskell's `Data.Time.Clock.POSIX.POSIXTime` --} +-- | POSIX time is measured as the number of /milliseconds/ since 1970-01-01T00:00:00Z. +-- This is not the same as Haskell's `Data.Time.Clock.POSIX.POSIXTime` newtype POSIXTime = POSIXTime {getPOSIXTime :: Integer} deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Generic) deriving anyclass (NFData, HasBlueprintDefinition) @@ -79,7 +78,7 @@ newtype POSIXTime = POSIXTime {getPOSIXTime :: Integer} ) instance HasBlueprintSchema POSIXTime referencedTypes where - schema = SchemaInteger emptySchemaInfo{title = Just "POSIXTime"} emptyIntegerSchema + schema = SchemaInteger emptySchemaInfo {title = Just "POSIXTime"} emptyIntegerSchema instance Pretty POSIXTime where pretty (POSIXTime i) = "POSIXTime" <+> pretty i diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs index 151b6bdd671..9a51bb78a2f 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +-- needed for asData pattern synonyms +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- needed for asData pattern synonyms {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -59,40 +60,37 @@ import PlutusLedgerApi.V1.Data.Address import PlutusLedgerApi.V1.Data.Value import PlutusLedgerApi.V1.Scripts -{-| A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file --} +-- | A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the +-- [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file newtype TxId = TxId {getTxId :: PlutusTx.BuiltinByteString} deriving stock (Eq, Ord, Generic) deriving anyclass (NFData) deriving newtype (PlutusTx.Eq, PlutusTx.Ord) deriving - ( IsString - -- ^ from hex encoding - , Show - -- ^ using hex encoding - , Pretty - -- ^ using hex encoding + ( -- | from hex encoding + IsString + , -- | using hex encoding + Show + , -- | using hex encoding + Pretty ) via LedgerBytes PlutusTx.makeLift ''TxId PlutusTx.makeIsDataIndexed ''TxId [('TxId, 0)] -{-| A tag indicating the type of script that we are pointing to. - -See also 'PlutusLedgerApi.V1.ScriptPurpose' --} +-- | A tag indicating the type of script that we are pointing to. +-- +-- See also 'PlutusLedgerApi.V1.ScriptPurpose' data ScriptTag = Spend | Mint | Cert | Reward deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData) -{-| A redeemer pointer is a pair of a script type tag ('ScriptTag') `t` and an index `i`, -picking out the i-th script of type `t` in the transaction. --} +-- | A redeemer pointer is a pair of a script type tag ('ScriptTag') `t` and an index `i`, +-- picking out the i-th script of type `t` in the transaction. data RedeemerPtr = RedeemerPtr ScriptTag Integer deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData) @@ -100,25 +98,25 @@ data RedeemerPtr = RedeemerPtr ScriptTag Integer -- | Redeemers is a `Map` of redeemer pointer ('RedeemerPtr') and its 'Redeemer'. type Redeemers = Map RedeemerPtr Redeemer -{-| A reference to a transaction output. This is a -pair of a transaction ID (`TxId`), and an index indicating which of the outputs -of that transaction we are referring to. --} +-- | A reference to a transaction output. This is a +-- pair of a transaction ID (`TxId`), and an index indicating which of the outputs +-- of that transaction we are referring to. PlutusTx.asData [d| data TxOutRef = TxOutRef - { txOutRefId :: TxId - -- ^ The transaction ID. - , txOutRefIdx :: Integer - -- ^ Index into the referenced transaction's outputs + { txOutRefId :: TxId + , -- \^ The transaction ID. + txOutRefIdx :: Integer } + -- \^ Index into the referenced transaction's outputs + deriving stock (Show, Eq, Ord, Generic) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) deriving anyclass (NFData) - |] + |] instance Pretty TxOutRef where - pretty TxOutRef{txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx + pretty TxOutRef {txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx instance PlutusTx.Eq TxOutRef where {-# INLINEABLE (==) #-} @@ -128,22 +126,21 @@ instance PlutusTx.Eq TxOutRef where PlutusTx.&& txOutRefIdx l PlutusTx.== txOutRefIdx r -{-| A transaction output, consisting of a target address ('Address'), a value ('Value'), -and optionally a datum hash ('DatumHash'). --} +-- | A transaction output, consisting of a target address ('Address'), a value ('Value'), +-- and optionally a datum hash ('DatumHash'). PlutusTx.asData [d| data TxOut = TxOut - { txOutAddress :: Address - , txOutValue :: Value + { txOutAddress :: Address + , txOutValue :: Value , txOutDatumHash :: Maybe DatumHash } deriving stock (Show, Eq, Generic) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - |] + |] instance Pretty TxOut where - pretty TxOut{txOutAddress, txOutValue} = + pretty TxOut {txOutAddress, txOutValue} = hang 2 $ vsep ["-" <+> pretty txOutValue <+> "addressed to", pretty txOutAddress] instance PlutusTx.Eq TxOut where @@ -158,29 +155,28 @@ instance PlutusTx.Eq TxOut where -- | The datum attached to a 'TxOut', if there is one. txOutDatum :: TxOut -> Maybe DatumHash -txOutDatum TxOut{txOutDatumHash} = txOutDatumHash +txOutDatum TxOut {txOutDatumHash} = txOutDatumHash -- | The public key attached to a 'TxOut', if there is one. txOutPubKey :: TxOut -> Maybe PubKeyHash -txOutPubKey TxOut{txOutAddress} = toPubKeyHash txOutAddress +txOutPubKey TxOut {txOutAddress} = toPubKeyHash txOutAddress -- | The validator hash attached to a 'TxOut', if there is one. txOutScriptHash :: TxOut -> Maybe ScriptHash -txOutScriptHash TxOut{txOutAddress} = toScriptHash txOutAddress +txOutScriptHash TxOut {txOutAddress} = toScriptHash txOutAddress -- | The address of a transaction output. outAddress :: Lens' TxOut Address outAddress = lens txOutAddress s - where - s tx a = tx{txOutAddress = a} + where + s tx a = tx {txOutAddress = a} -{-| The value of a transaction output. -| TODO: Compute address again --} +-- | The value of a transaction output. +-- | TODO: Compute address again outValue :: Lens' TxOut Value outValue = lens txOutValue s - where - s tx v = tx{txOutValue = v} + where + s tx v = tx {txOutValue = v} -- | Whether the output is a pay-to-pubkey output. isPubKeyOut :: TxOut -> Bool @@ -194,7 +190,6 @@ isPayToScriptOut = isJust . txOutScriptHash pubKeyHashTxOut :: Value -> PubKeyHash -> TxOut pubKeyHashTxOut v pkh = TxOut (pubKeyHashAddress pkh) v Nothing - PlutusTx.makeLift ''TxOut PlutusTx.makeLift ''TxOutRef diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 6ad084a9fd6..4b7439b51a5 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -1,18 +1,18 @@ -- TODO: this module adds a copy of the 'Value' type -- in which the underlying maps are 'Data.AssocMap'. -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- Prevent unboxing, which the plugin can't deal with {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} @@ -79,8 +79,11 @@ import Data.Text.Encoding qualified as E import GHC.Generics (Generic) import PlutusLedgerApi.V1.Bytes (LedgerBytes (LedgerBytes), encodeByteString) import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) -import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), definitionIdFromType, - definitionRef) +import PlutusTx.Blueprint.Definition ( + HasBlueprintDefinition (..), + definitionIdFromType, + definitionRef, + ) import PlutusTx.Blueprint.Schema (MapSchema (..), PairSchema (..), Schema (..), withSchemaInfo) import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..), emptySchemaInfo) import PlutusTx.Builtins qualified as B @@ -96,25 +99,24 @@ import PlutusTx.These (These (..)) import Prettyprinter (Pretty, (<>)) import Prettyprinter.Extras (PrettyShow (PrettyShow)) -{-| ByteString representing the currency, hashed with /BLAKE2b-224/. -It is empty for `Ada`, 28 bytes for `MintingPolicyHash`. -Forms an `AssetClass` along with `TokenName`. -A `Value` is a map from `CurrencySymbol`'s to a map from `TokenName` to an `Integer`. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file --} +-- | ByteString representing the currency, hashed with /BLAKE2b-224/. +-- It is empty for `Ada`, 28 bytes for `MintingPolicyHash`. +-- Forms an `AssetClass` along with `TokenName`. +-- A `Value` is a map from `CurrencySymbol`'s to a map from `TokenName` to an `Integer`. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the +-- [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file newtype CurrencySymbol = CurrencySymbol { unCurrencySymbol :: PlutusTx.BuiltinByteString } deriving - ( IsString - -- ^ from hex encoding - , Haskell.Show - -- ^ using hex encoding - , Pretty - -- ^ using hex encoding + ( -- | from hex encoding + IsString + , -- | using hex encoding + Haskell.Show + , -- | using hex encoding + Pretty ) via LedgerBytes deriving stock (Generic, Data) @@ -134,22 +136,21 @@ instance HasBlueprintSchema CurrencySymbol referencedTypes where schema = schema @PlutusTx.BuiltinByteString & withSchemaInfo \info -> - info{title = Just "CurrencySymbol"} + info {title = Just "CurrencySymbol"} -- | Creates `CurrencySymbol` from raw `ByteString`. currencySymbol :: BS.ByteString -> CurrencySymbol currencySymbol = CurrencySymbol . PlutusTx.toBuiltin {-# INLINEABLE currencySymbol #-} -{-| ByteString of a name of a token. -Shown as UTF-8 string when possible. -Should be no longer than 32 bytes, empty for Ada. -Forms an `AssetClass` along with a `CurrencySymbol`. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file --} +-- | ByteString of a name of a token. +-- Shown as UTF-8 string when possible. +-- Should be no longer than 32 bytes, empty for Ada. +-- Forms an `AssetClass` along with a `CurrencySymbol`. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the +-- [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file newtype TokenName = TokenName {unTokenName :: PlutusTx.BuiltinByteString} deriving stock (Generic, Data) deriving newtype @@ -173,7 +174,7 @@ instance HasBlueprintSchema TokenName referencedTypes where schema = schema @PlutusTx.BuiltinByteString & withSchemaInfo \info -> - info{title = Just "TokenName"} + info {title = Just "TokenName"} -- | Creates `TokenName` from raw `BS.ByteString`. tokenName :: BS.ByteString -> TokenName @@ -196,10 +197,9 @@ asBase16 bs = Text.concat ["0x", encodeByteString bs] quoted :: Text -> Text quoted s = Text.concat ["\"", s, "\""] -{-| Turn a TokenName to a hex-encoded 'String' - -Compared to `show` , it will not surround the string with double-quotes. --} +-- | Turn a TokenName to a hex-encoded 'String' +-- +-- Compared to `show` , it will not surround the string with double-quotes. toString :: TokenName -> Haskell.String toString = Text.unpack . fromTokenName asBase16 id @@ -270,27 +270,26 @@ See https://github.com/IntersectMBO/plutus/pull/5779 for details on the experime -- See Note [Value vs value]. -- See Note [Optimising Value]. -{-| The 'Value' type represents a collection of amounts of different currencies. -We can think of 'Value' as a vector space whose dimensions are currencies. - -Operations on currencies are usually implemented /pointwise/. That is, -we apply the operation to the quantities for each currency in turn. So -when we add two 'Value's the resulting 'Value' has, for each currency, -the sum of the quantities of /that particular/ currency in the argument -'Value'. The effect of this is that the currencies in the 'Value' are "independent", -and are operated on separately. - -Whenever we need to get the quantity of a currency in a 'Value' where there -is no explicit quantity of that currency in the 'Value', then the quantity is -taken to be zero. - -There is no 'Ord Value' instance since 'Value' is only a partial order, so 'compare' can't -do the right thing in some cases. --} +-- | The 'Value' type represents a collection of amounts of different currencies. +-- We can think of 'Value' as a vector space whose dimensions are currencies. +-- +-- Operations on currencies are usually implemented /pointwise/. That is, +-- we apply the operation to the quantities for each currency in turn. So +-- when we add two 'Value's the resulting 'Value' has, for each currency, +-- the sum of the quantities of /that particular/ currency in the argument +-- 'Value'. The effect of this is that the currencies in the 'Value' are "independent", +-- and are operated on separately. +-- +-- Whenever we need to get the quantity of a currency in a 'Value' where there +-- is no explicit quantity of that currency in the 'Value', then the quantity is +-- taken to be zero. +-- +-- There is no 'Ord Value' instance since 'Value' is only a partial order, so 'compare' can't +-- do the right thing in some cases. newtype Value = Value {getValue :: Map CurrencySymbol (Map TokenName Integer)} deriving stock (Generic, Haskell.Show) deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - deriving Pretty via (PrettyShow Value) + deriving (Pretty) via (PrettyShow Value) instance HasBlueprintDefinition Value where type Unroll Value = '[Value, CurrencySymbol, TokenName, Integer] @@ -359,34 +358,31 @@ instance MeetSemiLattice Value where {-# INLINEABLE (/\) #-} (/\) = unionWith Ord.min -{-| Get the quantity of the given currency in the 'Value'. -Assumes that the underlying map doesn't contain duplicate keys. --} +-- | Get the quantity of the given currency in the 'Value'. +-- Assumes that the underlying map doesn't contain duplicate keys. valueOf :: Value -> CurrencySymbol -> TokenName -> Integer valueOf value cur tn = withCurrencySymbol cur value 0 \tokens -> case Map.lookup tn tokens of Nothing -> 0 - Just v -> v + Just v -> v {-# INLINEABLE valueOf #-} -{-| Apply a continuation function to the token quantities of the given currency -symbol in the value or return a default value if the currency symbol is not present -in the value. --} +-- | Apply a continuation function to the token quantities of the given currency +-- symbol in the value or return a default value if the currency symbol is not present +-- in the value. withCurrencySymbol :: CurrencySymbol -> Value -> a -> (Map TokenName Integer -> a) -> a withCurrencySymbol currency value def k = case Map.lookup currency (getValue value) of - Nothing -> def + Nothing -> def Just tokenQuantities -> k tokenQuantities {-# INLINEABLE withCurrencySymbol #-} -{-| Get the total value of the currency symbol in the 'Value' map. -Assumes that the underlying map doesn't contain duplicate keys. - -Note that each token of the currency symbol may have a value that is positive, -zero or negative. --} +-- | Get the total value of the currency symbol in the 'Value' map. +-- Assumes that the underlying map doesn't contain duplicate keys. +-- +-- Note that each token of the currency symbol may have a value that is positive, +-- zero or negative. currencySymbolValueOf :: Value -> CurrencySymbol -> Integer currencySymbolValueOf value cur = withCurrencySymbol cur value 0 \tokens -> -- This is more efficient than `PlutusTx.sum (Map.elems tokens)`, because @@ -430,43 +426,41 @@ unionVal (Value l) (Value r) = let combined = Map.union l r unThese k = case k of - This a -> Map.map This a - That b -> Map.map That b + This a -> Map.map This a + That b -> Map.map That b These a b -> Map.union a b in Map.map unThese combined {-# INLINEABLE unionVal #-} -{-| Combine two 'Value' maps with the argument function. -Assumes the well-definedness of the two maps. --} +-- | Combine two 'Value' maps with the argument function. +-- Assumes the well-definedness of the two maps. unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value unionWith f ls rs = let combined = unionVal ls rs unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b + This a -> f a 0 + That b -> f 0 b These a b -> f a b in Value (Map.map (Map.map unThese) combined) {-# INLINEABLE unionWith #-} -{-| Convert a 'Value' to a simple list, keeping only the non-zero amounts. -Note that the result isn't sorted, meaning @v1 == v2@ doesn't generally imply -@flattenValue v1 == flattenValue v2@. -Also assumes that there are no duplicate keys in the 'Value' 'Map'. --} +-- | Convert a 'Value' to a simple list, keeping only the non-zero amounts. +-- Note that the result isn't sorted, meaning @v1 == v2@ doesn't generally imply +-- @flattenValue v1 == flattenValue v2@. +-- Also assumes that there are no duplicate keys in the 'Value' 'Map'. flattenValue :: Value -> [(CurrencySymbol, TokenName, Integer)] flattenValue v = goOuter [] (Map.toSOPList $ getValue v) - where - goOuter acc [] = acc - goOuter acc ((cs, m) : tl) = goOuter (goInner cs acc (Map.toSOPList m)) tl - - goInner _ acc [] = acc - goInner cs acc ((tn, a) : tl) - | a /= 0 = goInner cs ((cs, tn, a) : acc) tl - | otherwise = goInner cs acc tl + where + goOuter acc [] = acc + goOuter acc ((cs, m) : tl) = goOuter (goInner cs acc (Map.toSOPList m)) tl + + goInner _ acc [] = acc + goInner cs acc ((tn, a) : tl) + | a /= 0 = goInner cs ((cs, tn, a) : acc) tl + | otherwise = goInner cs acc tl {-# INLINEABLE flattenValue #-} -- Num operations @@ -476,9 +470,8 @@ isZero :: Value -> Bool isZero (Value xs) = Map.all (Map.all (\i -> 0 == i)) xs {-# INLINEABLE isZero #-} -{-| Checks whether a predicate holds for all the values in a 'Value' -union. Assumes the well-definedness of the two underlying 'Map's. --} +-- | Checks whether a predicate holds for all the values in a 'Value' +-- union. Assumes the well-definedness of the two underlying 'Map's. checkPred :: (These Integer Integer -> Bool) -> Value -> Value -> Bool checkPred f l r = let @@ -488,203 +481,196 @@ checkPred f l r = Map.all inner (unionVal l r) {-# INLINEABLE checkPred #-} -{-| Check whether a binary relation holds for value pairs of two 'Value' maps, - supplying 0 where a key is only present in one of them. --} +-- | Check whether a binary relation holds for value pairs of two 'Value' maps, +-- supplying 0 where a key is only present in one of them. checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool checkBinRel f l r = let unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b + This a -> f a 0 + That b -> f 0 b These a b -> f a b in checkPred unThese l r {-# INLINEABLE checkBinRel #-} -{-| Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation -of how operations on 'Value's work. --} +-- | Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation +-- of how operations on 'Value's work. geq :: Value -> Value -> Bool -- If both are zero then checkBinRel will be vacuously true, but this is fine. geq = checkBinRel (>=) {-# INLINEABLE geq #-} -{-| Check whether one 'Value' is less than or equal to another. See 'Value' for an explanation of -how operations on 'Value's work. --} +-- | Check whether one 'Value' is less than or equal to another. See 'Value' for an explanation of +-- how operations on 'Value's work. leq :: Value -> Value -> Bool -- If both are zero then checkBinRel will be vacuously true, but this is fine. leq = checkBinRel (<=) {-# INLINEABLE leq #-} -{-| Check whether one 'Value' is strictly greater than another. -This is *not* a pointwise operation. @gt l r@ means @geq l r && not (eq l r)@. --} +-- | Check whether one 'Value' is strictly greater than another. +-- This is *not* a pointwise operation. @gt l r@ means @geq l r && not (eq l r)@. gt :: Value -> Value -> Bool gt l r = geq l r && not (eq l r) {-# INLINEABLE gt #-} -{-| Check whether one 'Value' is strictly less than another. -This is *not* a pointwise operation. @lt l r@ means @leq l r && not (eq l r)@. --} +-- | Check whether one 'Value' is strictly less than another. +-- This is *not* a pointwise operation. @lt l r@ means @leq l r && not (eq l r)@. lt :: Value -> Value -> Bool lt l r = leq l r && not (eq l r) {-# INLINEABLE lt #-} -{-| Split a 'Value' into its positive and negative parts. The first element of - the tuple contains the negative parts of the 'Value', the second element - contains the positive parts. - - @negate (fst (split a)) `plus` (snd (split a)) == a@ --} +-- | Split a 'Value' into its positive and negative parts. The first element of +-- the tuple contains the negative parts of the 'Value', the second element +-- contains the positive parts. +-- +-- @negate (fst (split a)) `plus` (snd (split a)) == a@ split :: Value -> (Value, Value) split (Value mp) = (negate (Value neg), Value pos) - where - (neg, pos) = Map.mapThese splitIntl mp + where + (neg, pos) = Map.mapThese splitIntl mp - splitIntl :: Map TokenName Integer -> These (Map TokenName Integer) (Map TokenName Integer) - splitIntl mp' = These l r - where - (l, r) = Map.mapThese (\i -> if i <= 0 then This i else That i) mp' + splitIntl :: Map TokenName Integer -> These (Map TokenName Integer) (Map TokenName Integer) + splitIntl mp' = These l r + where + (l, r) = Map.mapThese (\i -> if i <= 0 then This i else That i) mp' {-# INLINEABLE split #-} -{-| Check equality of two lists of distinct key-value pairs, each value being uniquely -identified by a key, given a function checking whether a 'Value' is zero and a function -checking equality of values. Note that the caller must ensure that the two lists are -well-defined in this sense. This is not checked or enforced in `unordEqWith`, and therefore -it might yield undefined results for ill-defined input. - -This function recurses on both the lists in parallel and checks whether the key-value pairs are -equal pointwise. If there is a mismatch, then it tries to find the left key-value pair in the right -list. If that succeeds then the pair is removed from both the lists and recursion proceeds pointwise -as before until there's another mismatch. If at some point a key-value pair from the left list is -not found in the right one, then the function returns 'False'. If the left list is exhausted, but -the right one still has some non-zero elements, the function returns 'False' as well. - -We check equality of values of two key-value pairs right after ensuring that the keys match. This is -disadvantageous if the values are big and there's a key that is present in one of the lists but not -in the other, since in that case computing equality of values was expensive and pointless. However - -1. we've checked and on the chain 'Value's very rarely contain 'CurrencySymbol's with more than 3 - 'TokenName's associated with them, so we optimize for the most common use case -2. computing equality of values before ensuring equality of all the keys certainly does help when we - check equality of 'TokenName'-value pairs, since the value of a 'TokenName' is an 'Integer' and - @(==) :: Integer -> Integer -> Bool@ is generally much faster than repeatedly searching for keys - in a list -3. having some clever logic for computing equality of values right away in some cases, but not in - others would not only complicate the algorithm, but also increase the size of the function and - this resource is quite scarce as the size of a program growing beyond what's acceptable by the - network can be a real deal breaker, while general performance concerns don't seem to be as - pressing - -The algorithm we use here is very similar, if not identical, to @valueEqualsValue4@ from -https://github.com/IntersectMBO/plutus/issues/5135 --} -unordEqWith - :: (BuiltinData -> Bool) - -> (BuiltinData -> BuiltinData -> Bool) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> Bool +-- | Check equality of two lists of distinct key-value pairs, each value being uniquely +-- identified by a key, given a function checking whether a 'Value' is zero and a function +-- checking equality of values. Note that the caller must ensure that the two lists are +-- well-defined in this sense. This is not checked or enforced in `unordEqWith`, and therefore +-- it might yield undefined results for ill-defined input. +-- +-- This function recurses on both the lists in parallel and checks whether the key-value pairs are +-- equal pointwise. If there is a mismatch, then it tries to find the left key-value pair in the right +-- list. If that succeeds then the pair is removed from both the lists and recursion proceeds pointwise +-- as before until there's another mismatch. If at some point a key-value pair from the left list is +-- not found in the right one, then the function returns 'False'. If the left list is exhausted, but +-- the right one still has some non-zero elements, the function returns 'False' as well. +-- +-- We check equality of values of two key-value pairs right after ensuring that the keys match. This is +-- disadvantageous if the values are big and there's a key that is present in one of the lists but not +-- in the other, since in that case computing equality of values was expensive and pointless. However +-- +-- 1. we've checked and on the chain 'Value's very rarely contain 'CurrencySymbol's with more than 3 +-- 'TokenName's associated with them, so we optimize for the most common use case +-- 2. computing equality of values before ensuring equality of all the keys certainly does help when we +-- check equality of 'TokenName'-value pairs, since the value of a 'TokenName' is an 'Integer' and +-- @(==) :: Integer -> Integer -> Bool@ is generally much faster than repeatedly searching for keys +-- in a list +-- 3. having some clever logic for computing equality of values right away in some cases, but not in +-- others would not only complicate the algorithm, but also increase the size of the function and +-- this resource is quite scarce as the size of a program growing beyond what's acceptable by the +-- network can be a real deal breaker, while general performance concerns don't seem to be as +-- pressing +-- +-- The algorithm we use here is very similar, if not identical, to @valueEqualsValue4@ from +-- https://github.com/IntersectMBO/plutus/issues/5135 +unordEqWith :: + (BuiltinData -> Bool) -> + (BuiltinData -> BuiltinData -> Bool) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + Bool unordEqWith is0 eqV = goBoth - where - goBoth - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> Bool - goBoth l1 l2 = - B.matchList - l1 - -- null l1 case - ( \() -> - B.matchList - l2 - -- null l2 case - (\() -> True) - -- non-null l2 case - (\_ _ -> Map.all is0 (Map.unsafeFromBuiltinList l2 :: Map BuiltinData BuiltinData)) - ) - -- non-null l1 case - ( \hd1 tl1 -> - B.matchList - l2 - -- null l2 case - (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1 :: Map BuiltinData BuiltinData)) - -- non-null l2 case - ( \hd2 tl2 -> - let - k1 = BI.fst hd1 - v1 = BI.snd hd1 - k2 = BI.fst hd2 - v2 = BI.snd hd2 - in - if k1 == k2 - then - if eqV v1 v2 - then goBoth tl1 tl2 - else False - else - if is0 v1 - then goBoth tl1 l2 - else - let - goRight - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> Bool - goRight acc l = - B.matchList - l - -- null l case - (\() -> False) - -- non-null l case - ( \hd tl -> - let - k = BI.fst hd - v = BI.snd hd - in - if is0 v - then goRight acc tl - else - if k == k1 - then - if eqV v1 v - then goBoth tl1 (revAppend' acc tl) - else False - else goRight (hd `BI.mkCons` acc) tl - ) - in - goRight - ( if is0 v2 - then BI.mkNilPairData BI.unitval - else hd2 `BI.mkCons` BI.mkNilPairData BI.unitval - ) - tl2 - ) - ) - - revAppend' = rev - where - rev l acc = + where + goBoth :: + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + Bool + goBoth l1 l2 = B.matchList - l - (\() -> acc) - ( \hd tl -> - rev tl (hd `BI.mkCons` acc) + l1 + -- null l1 case + ( \() -> + B.matchList + l2 + -- null l2 case + (\() -> True) + -- non-null l2 case + (\_ _ -> Map.all is0 (Map.unsafeFromBuiltinList l2 :: Map BuiltinData BuiltinData)) + ) + -- non-null l1 case + ( \hd1 tl1 -> + B.matchList + l2 + -- null l2 case + (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1 :: Map BuiltinData BuiltinData)) + -- non-null l2 case + ( \hd2 tl2 -> + let + k1 = BI.fst hd1 + v1 = BI.snd hd1 + k2 = BI.fst hd2 + v2 = BI.snd hd2 + in + if k1 == k2 + then + if eqV v1 v2 + then goBoth tl1 tl2 + else False + else + if is0 v1 + then goBoth tl1 l2 + else + let + goRight :: + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + Bool + goRight acc l = + B.matchList + l + -- null l case + (\() -> False) + -- non-null l case + ( \hd tl -> + let + k = BI.fst hd + v = BI.snd hd + in + if is0 v + then goRight acc tl + else + if k == k1 + then + if eqV v1 v + then goBoth tl1 (revAppend' acc tl) + else False + else goRight (hd `BI.mkCons` acc) tl + ) + in + goRight + ( if is0 v2 + then BI.mkNilPairData BI.unitval + else hd2 `BI.mkCons` BI.mkNilPairData BI.unitval + ) + tl2 + ) ) + + revAppend' = rev + where + rev l acc = + B.matchList + l + (\() -> acc) + ( \hd tl -> + rev tl (hd `BI.mkCons` acc) + ) {-# INLINEABLE unordEqWith #-} -- | Check equality of two maps of maps indexed by 'CurrencySymbol's, --- given a function checking whether a value is zero and a function -- checking equality of values. -eqMapOfMapsWith - :: (Map TokenName Integer -> Bool) - -> (Map TokenName Integer -> Map TokenName Integer -> Bool) - -> Map CurrencySymbol (Map TokenName Integer) - -> Map CurrencySymbol (Map TokenName Integer) - -> Bool +eqMapOfMapsWith :: + (Map TokenName Integer -> Bool) -> + (Map TokenName Integer -> Map TokenName Integer -> Bool) -> + Map CurrencySymbol (Map TokenName Integer) -> + Map CurrencySymbol (Map TokenName Integer) -> + Bool eqMapOfMapsWith is0 eqV map1 map2 = let xs1 = Map.toBuiltinList map1 xs2 = Map.toBuiltinList map2 @@ -693,15 +679,14 @@ eqMapOfMapsWith is0 eqV map1 map2 = in unordEqWith is0' eqV' xs1 xs2 {-# INLINEABLE eqMapOfMapsWith #-} -{-| Check equality of two 'Map Token Integer's given a function checking whether a value is zero and a function -checking equality of values. --} -eqMapWith - :: (Integer -> Bool) - -> (Integer -> Integer -> Bool) - -> Map TokenName Integer - -> Map TokenName Integer - -> Bool +-- | Check equality of two 'Map Token Integer's given a function checking whether a value is zero and a function +-- checking equality of values. +eqMapWith :: + (Integer -> Bool) -> + (Integer -> Integer -> Bool) -> + Map TokenName Integer -> + Map TokenName Integer -> + Bool eqMapWith is0 eqV map1 map2 = let xs1 = Map.toBuiltinList map1 xs2 = Map.toBuiltinList map2 @@ -710,11 +695,10 @@ eqMapWith is0 eqV map1 map2 = in unordEqWith is0' eqV' xs1 xs2 {-# INLINEABLE eqMapWith #-} -{-| Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack -of empty values (such as a token whose quantity is zero or a currency that has a bunch of such -tokens or no tokens at all), but does assume that no currencies or tokens within a single -currency have multiple entries. --} +-- | Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack +-- of empty values (such as a token whose quantity is zero or a currency that has a bunch of such +-- tokens or no tokens at all), but does assume that no currencies or tokens within a single +-- currency have multiple entries. eq :: Value -> Value -> Bool eq (Value currs1) (Value currs2) = eqMapOfMapsWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index 0c1fcd6ec1b..d81b9b1abc8 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -20,34 +20,36 @@ import Control.Monad import Control.Monad.Writer.Strict import Data.Int (Int64) -{-| Build the 'EvaluationContext'. - -The input is a list of cost model parameters (which are integer values) passed -from the ledger. - -IMPORTANT: the cost model parameters __MUST__ appear in the correct order, -matching the names in `PlutusLedgerApi.V1.ParamName`. If the parameters are -supplied in the wrong order then script cost calculations will be incorrect. - -IMPORTANT: The evaluation context of every Plutus version must be recreated upon -a protocol update with the updated cost model parameters. --} -mkEvaluationContext - :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) - => [Int64] -- ^ the (updated) cost model parameters of the protocol - -> m EvaluationContext +-- | Build the 'EvaluationContext'. +-- +-- The input is a list of cost model parameters (which are integer values) passed +-- from the ledger. +-- +-- IMPORTANT: the cost model parameters __MUST__ appear in the correct order, +-- matching the names in `PlutusLedgerApi.V1.ParamName`. If the parameters are +-- supplied in the wrong order then script cost calculations will be incorrect. +-- +-- IMPORTANT: The evaluation context of every Plutus version must be recreated upon +-- a protocol update with the updated cost model parameters. +mkEvaluationContext :: + (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => + -- | the (updated) cost model parameters of the protocol + [Int64] -> + m EvaluationContext mkEvaluationContext = tagWithParamNames @V1.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - PlutusV1 - (\pv -> + PlutusV1 + ( \pv -> if pv < pv11PV then unavailableCaserBuiltin $ getMajorProtocolVersion pv - else CaserBuiltin caseBuiltin) - [DefaultFunSemanticsVariantA, DefaultFunSemanticsVariantB] - -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. - (\pv -> + else CaserBuiltin caseBuiltin + ) + [DefaultFunSemanticsVariantA, DefaultFunSemanticsVariantB] + -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. + ( \pv -> if pv < changPV then DefaultFunSemanticsVariantA - else DefaultFunSemanticsVariantB) + else DefaultFunSemanticsVariantB + ) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs index b896562ec05..792fca995a3 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs @@ -1,54 +1,58 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -- | A type for intervals and associated functions. -module PlutusLedgerApi.V1.Interval - ( Interval(..) - , UpperBound(..) - , LowerBound(..) - , Extended(..) - , Closure - , member - , interval - , from - , to - , always - , never - , singleton - , hull - , intersection - , overlaps - , contains - , isEmpty - , before - , after - , lowerBound - , upperBound - , strictLowerBound - , strictUpperBound - ) where +module PlutusLedgerApi.V1.Interval ( + Interval (..), + UpperBound (..), + LowerBound (..), + Extended (..), + Closure, + member, + interval, + from, + to, + always, + never, + singleton, + hull, + intersection, + overlaps, + contains, + isEmpty, + before, + after, + lowerBound, + upperBound, + strictLowerBound, + strictUpperBound, +) where import Control.DeepSeq (NFData) import GHC.Generics (Generic) -import Prelude qualified as Haskell import Prettyprinter (Pretty (pretty), comma, (<+>)) +import Prelude qualified as Haskell import PlutusTx.Blueprint (ConstructorSchema (..), Schema (..)) import PlutusTx.Blueprint.Class (HasBlueprintSchema (schema)) -import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), HasSchemaDefinition, Unrolled, - definitionIdFromTypeK, definitionRef) +import PlutusTx.Blueprint.Definition ( + HasBlueprintDefinition (..), + HasSchemaDefinition, + Unrolled, + definitionIdFromTypeK, + definitionRef, + ) import PlutusTx.Blueprint.Definition.TF (Nub, type (++)) import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..), emptySchemaInfo) import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed) @@ -59,28 +63,29 @@ import PlutusTx.Ord as PlutusTx import PlutusTx.Prelude -- See Note [Enumerable Intervals] -{- | An interval of @a@s. - -The interval may be either closed or open at either end, meaning -that the endpoints may or may not be included in the interval. -The interval can also be unbounded on either side. - -The 'Eq' instance gives equality of the intervals, not structural equality. -There is no 'Ord' instance, but 'contains' gives a partial order. - -Note that some of the functions on `Interval` rely on `Enum` in order to -handle non-inclusive endpoints. For this reason, it may not be safe to -use `Interval`s with non-inclusive endpoints on types whose `Enum` -instances have partial methods. --} -data Interval a = Interval { ivFrom :: LowerBound a, ivTo :: UpperBound a } - deriving stock (Haskell.Show, Generic) - deriving anyclass (NFData) - -instance (HasBlueprintDefinition a) => HasBlueprintDefinition (Interval a) where - type Unroll (Interval a) = - Nub (Interval a ': (Unrolled (LowerBound a) ++ Unrolled (UpperBound a))) +-- | An interval of @a@s. +-- +-- The interval may be either closed or open at either end, meaning +-- that the endpoints may or may not be included in the interval. +-- +-- The interval can also be unbounded on either side. +-- +-- The 'Eq' instance gives equality of the intervals, not structural equality. +-- There is no 'Ord' instance, but 'contains' gives a partial order. +-- +-- Note that some of the functions on `Interval` rely on `Enum` in order to +-- handle non-inclusive endpoints. For this reason, it may not be safe to +-- use `Interval`s with non-inclusive endpoints on types whose `Enum` +-- instances have partial methods. +data Interval a = Interval {ivFrom :: LowerBound a, ivTo :: UpperBound a} + deriving stock (Haskell.Show, Generic) + deriving anyclass (NFData) + +instance HasBlueprintDefinition a => HasBlueprintDefinition (Interval a) where + type + Unroll (Interval a) = + Nub (Interval a ': (Unrolled (LowerBound a) ++ Unrolled (UpperBound a))) definitionId = definitionIdFromTypeK @_ @Interval Haskell.<> definitionId @a instance @@ -105,37 +110,38 @@ instance Functor Interval where fmap f (Interval fromA toA) = Interval (f <$> fromA) (f <$> toA) instance Pretty a => Pretty (Interval a) where - pretty (Interval l h) = pretty l <+> comma <+> pretty h + pretty (Interval l h) = pretty l <+> comma <+> pretty h -- | A set extended with a positive and negative infinity. data Extended a = NegInf | Finite a | PosInf - deriving stock (Haskell.Show, Generic) - deriving anyclass (NFData) + deriving stock (Haskell.Show, Generic) + deriving anyclass (NFData) -instance (HasBlueprintDefinition a) => HasBlueprintDefinition (Extended a) where +instance HasBlueprintDefinition a => HasBlueprintDefinition (Extended a) where type Unroll (Extended a) = Extended a ': Unrolled a definitionId = definitionIdFromTypeK @_ @Extended Haskell.<> definitionId @a instance Functor Extended where - fmap _ NegInf = NegInf + fmap _ NegInf = NegInf fmap f (Finite a) = Finite (f a) - fmap _ PosInf = PosInf + fmap _ PosInf = PosInf instance Pretty a => Pretty (Extended a) where - pretty NegInf = pretty "-∞" - pretty PosInf = pretty "+∞" - pretty (Finite a) = pretty a + pretty NegInf = pretty "-∞" + pretty PosInf = pretty "+∞" + pretty (Finite a) = pretty a -- See Note [Enumerable Intervals] + -- | Whether a bound is inclusive or not. type Closure = Bool -- | The upper bound of an interval. data UpperBound a = UpperBound (Extended a) Closure - deriving stock (Haskell.Show, Generic) - deriving anyclass (NFData) + deriving stock (Haskell.Show, Generic) + deriving anyclass (NFData) -instance (HasBlueprintDefinition (Extended a)) => HasBlueprintDefinition (UpperBound a) where +instance HasBlueprintDefinition (Extended a) => HasBlueprintDefinition (UpperBound a) where type Unroll (UpperBound a) = UpperBound a ': (Unrolled Closure ++ Unrolled (Extended a)) definitionId = definitionIdFromTypeK @_ @UpperBound Haskell.<> definitionId @(Extended a) @@ -150,7 +156,7 @@ instance {-# INLINEABLE schema #-} schema = SchemaConstructor - emptySchemaInfo { title = Just "UpperBound"} + emptySchemaInfo {title = Just "UpperBound"} ( MkConstructorSchema 0 [ definitionRef @(Extended a) @referencedTypes @@ -167,27 +173,27 @@ instance -- See Note [Enumerable Intervals] inclusiveUpperBound :: Enum a => UpperBound a -> Extended a -- already inclusive -inclusiveUpperBound (UpperBound v True) = v +inclusiveUpperBound (UpperBound v True) = v -- take pred inclusiveUpperBound (UpperBound (Finite x) False) = Finite $ pred x -- an infinity: inclusive/non-inclusive makes no difference -inclusiveUpperBound (UpperBound v False) = v +inclusiveUpperBound (UpperBound v False) = v instance Functor UpperBound where fmap f (UpperBound e c) = UpperBound (f <$> e) c instance Pretty a => Pretty (UpperBound a) where - pretty (UpperBound PosInf _) = pretty "+∞)" - pretty (UpperBound NegInf _) = pretty "-∞)" - pretty (UpperBound a True) = pretty a <+> pretty "]" - pretty (UpperBound a False) = pretty a <+> pretty ")" + pretty (UpperBound PosInf _) = pretty "+∞)" + pretty (UpperBound NegInf _) = pretty "-∞)" + pretty (UpperBound a True) = pretty a <+> pretty "]" + pretty (UpperBound a False) = pretty a <+> pretty ")" -- | The lower bound of an interval. data LowerBound a = LowerBound (Extended a) Closure - deriving stock (Haskell.Show, Generic) - deriving anyclass (NFData) + deriving stock (Haskell.Show, Generic) + deriving anyclass (NFData) -instance (HasBlueprintDefinition (Extended a)) => HasBlueprintDefinition (LowerBound a) where +instance HasBlueprintDefinition (Extended a) => HasBlueprintDefinition (LowerBound a) where type Unroll (LowerBound a) = LowerBound a ': (Unrolled Closure ++ Unrolled (Extended a)) definitionId = definitionIdFromTypeK @_ @LowerBound Haskell.<> definitionId @(Extended a) @@ -202,7 +208,7 @@ instance {-# INLINEABLE schema #-} schema = SchemaConstructor - emptySchemaInfo { title = Just "LowerBound"} + emptySchemaInfo {title = Just "LowerBound"} ( MkConstructorSchema 0 [ definitionRef @(Extended a) @referencedTypes @@ -219,200 +225,194 @@ instance -- See Note [Enumerable Intervals] inclusiveLowerBound :: Enum a => LowerBound a -> Extended a -- already inclusive -inclusiveLowerBound (LowerBound v True) = v +inclusiveLowerBound (LowerBound v True) = v -- take succ inclusiveLowerBound (LowerBound (Finite x) False) = Finite $ succ x -- an infinity: inclusive/non-inclusive makes no difference -inclusiveLowerBound (LowerBound v False) = v +inclusiveLowerBound (LowerBound v False) = v instance Functor LowerBound where fmap f (LowerBound e c) = LowerBound (f <$> e) c instance Pretty a => Pretty (LowerBound a) where - pretty (LowerBound PosInf _) = pretty "(+∞" - pretty (LowerBound NegInf _) = pretty "(-∞" - pretty (LowerBound a True) = pretty "[" <+> pretty a - pretty (LowerBound a False) = pretty "(" <+> pretty a + pretty (LowerBound PosInf _) = pretty "(+∞" + pretty (LowerBound NegInf _) = pretty "(-∞" + pretty (LowerBound a True) = pretty "[" <+> pretty a + pretty (LowerBound a False) = pretty "(" <+> pretty a instance Eq a => Eq (Extended a) where - {-# INLINABLE (==) #-} - NegInf == NegInf = True - PosInf == PosInf = True - Finite l == Finite r = l == r - _ == _ = False + {-# INLINEABLE (==) #-} + NegInf == NegInf = True + PosInf == PosInf = True + Finite l == Finite r = l == r + _ == _ = False instance Eq a => Haskell.Eq (Extended a) where - (==) = (PlutusTx.==) + (==) = (PlutusTx.==) instance Ord a => Ord (Extended a) where - {-# INLINABLE compare #-} - NegInf `compare` NegInf = EQ - NegInf `compare` _ = LT - _ `compare` NegInf = GT - PosInf `compare` PosInf = EQ - _ `compare` PosInf = LT - PosInf `compare` _ = GT - Finite l `compare` Finite r = l `compare` r + {-# INLINEABLE compare #-} + NegInf `compare` NegInf = EQ + NegInf `compare` _ = LT + _ `compare` NegInf = GT + PosInf `compare` PosInf = EQ + _ `compare` PosInf = LT + PosInf `compare` _ = GT + Finite l `compare` Finite r = l `compare` r instance Ord a => Haskell.Ord (Extended a) where - compare = PlutusTx.compare + compare = PlutusTx.compare -- See Note [Enumerable Intervals] instance (Enum a, Eq a) => Eq (UpperBound a) where - {-# INLINABLE (==) #-} - b1 == b2 = inclusiveUpperBound b1 == inclusiveUpperBound b2 + {-# INLINEABLE (==) #-} + b1 == b2 = inclusiveUpperBound b1 == inclusiveUpperBound b2 instance (Enum a, Eq a) => Haskell.Eq (UpperBound a) where - (==) = (PlutusTx.==) + (==) = (PlutusTx.==) -- See Note [Enumerable Intervals] instance (Enum a, Ord a) => Ord (UpperBound a) where - {-# INLINABLE compare #-} - b1 `compare` b2 = inclusiveUpperBound b1 `compare` inclusiveUpperBound b2 + {-# INLINEABLE compare #-} + b1 `compare` b2 = inclusiveUpperBound b1 `compare` inclusiveUpperBound b2 instance (Enum a, Ord a) => Haskell.Ord (UpperBound a) where - compare = PlutusTx.compare + compare = PlutusTx.compare -- See Note [Enumerable Intervals] instance (Enum a, Eq a) => Eq (LowerBound a) where - {-# INLINABLE (==) #-} - b1 == b2 = inclusiveLowerBound b1 == inclusiveLowerBound b2 + {-# INLINEABLE (==) #-} + b1 == b2 = inclusiveLowerBound b1 == inclusiveLowerBound b2 instance (Enum a, Eq a) => Haskell.Eq (LowerBound a) where - (==) = (PlutusTx.==) + (==) = (PlutusTx.==) -- See Note [Enumerable Intervals] instance (Enum a, Ord a) => Ord (LowerBound a) where - {-# INLINABLE compare #-} - b1 `compare` b2 = inclusiveLowerBound b1 `compare` inclusiveLowerBound b2 + {-# INLINEABLE compare #-} + b1 `compare` b2 = inclusiveLowerBound b1 `compare` inclusiveLowerBound b2 instance (Enum a, Ord a) => Haskell.Ord (LowerBound a) where - compare = PlutusTx.compare + compare = PlutusTx.compare -{- | Construct a strict upper bound from a value. -The resulting bound includes all values that are (strictly) smaller than the input value. --} +-- | Construct a strict upper bound from a value. +-- The resulting bound includes all values that are (strictly) smaller than the input value. strictUpperBound :: a -> UpperBound a strictUpperBound a = UpperBound (Finite a) False -{-# INLINABLE strictUpperBound #-} +{-# INLINEABLE strictUpperBound #-} -{- | Construct a strict lower bound from a value. -The resulting bound includes all values that are (strictly) greater than the input value. --} +-- | Construct a strict lower bound from a value. +-- The resulting bound includes all values that are (strictly) greater than the input value. strictLowerBound :: a -> LowerBound a strictLowerBound a = LowerBound (Finite a) False -{-# INLINABLE strictLowerBound #-} +{-# INLINEABLE strictLowerBound #-} -{- | Construct a lower bound from a value. -The resulting bound includes all values that are equal or greater than the input value. --} +-- | Construct a lower bound from a value. +-- The resulting bound includes all values that are equal or greater than the input value. lowerBound :: a -> LowerBound a lowerBound a = LowerBound (Finite a) True -{-# INLINABLE lowerBound #-} +{-# INLINEABLE lowerBound #-} -{- | Construct an upper bound from a value. -The resulting bound includes all values that are equal or smaller than the input value. --} +-- | Construct an upper bound from a value. +-- The resulting bound includes all values that are equal or smaller than the input value. upperBound :: a -> UpperBound a upperBound a = UpperBound (Finite a) True -{-# INLINABLE upperBound #-} +{-# INLINEABLE upperBound #-} -- See Note [Enumerable Intervals] instance (Enum a, Ord a) => JoinSemiLattice (Interval a) where - {-# INLINABLE (\/) #-} - (\/) = hull + {-# INLINEABLE (\/) #-} + (\/) = hull -- See Note [Enumerable Intervals] instance (Enum a, Ord a) => BoundedJoinSemiLattice (Interval a) where - {-# INLINABLE bottom #-} - bottom = never + {-# INLINEABLE bottom #-} + bottom = never -- See Note [Enumerable Intervals] instance (Enum a, Ord a) => MeetSemiLattice (Interval a) where - {-# INLINABLE (/\) #-} - (/\) = intersection + {-# INLINEABLE (/\) #-} + (/\) = intersection -- See Note [Enumerable Intervals] instance (Enum a, Ord a) => BoundedMeetSemiLattice (Interval a) where - {-# INLINABLE top #-} - top = always + {-# INLINEABLE top #-} + top = always -- See Note [Enumerable Intervals] instance (Enum a, Ord a) => Eq (Interval a) where - {-# INLINABLE (==) #-} - -- Degenerate case: both the intervals are empty. - -- There can be many empty intervals, so we check for this case - -- explicitly - iv1 == iv2 | isEmpty iv1 && isEmpty iv2 = True - (Interval lb1 ub1) == (Interval lb2 ub2) = lb1 == lb2 && ub1 == ub2 + {-# INLINEABLE (==) #-} + -- Degenerate case: both the intervals are empty. + -- There can be many empty intervals, so we check for this case + -- explicitly + iv1 == iv2 | isEmpty iv1 && isEmpty iv2 = True + (Interval lb1 ub1) == (Interval lb2 ub2) = lb1 == lb2 && ub1 == ub2 instance (Enum a, Ord a) => Haskell.Eq (Interval a) where - {-# INLINABLE (==) #-} - (==) = (PlutusTx.==) + {-# INLINEABLE (==) #-} + (==) = (PlutusTx.==) -- | @interval a b@ includes all values that are greater than or equal to @a@ -- and smaller than or equal to @b@. Therefore it includes @a@ and @b@. In math. notation: [a,b] interval :: a -> a -> Interval a interval s s' = Interval (lowerBound s) (upperBound s') -{-# INLINABLE interval #-} +{-# INLINEABLE interval #-} -- | Create an interval that includes just a single concrete point @a@, -- i.e. having the same non-strict lower and upper bounds. In math.notation: [a,a] singleton :: a -> Interval a singleton s = interval s s -{-# INLINABLE singleton #-} +{-# INLINEABLE singleton #-} -- | @from a@ is an 'Interval' that includes all values that are -- greater than or equal to @a@. In math. notation: [a,+∞] from :: a -> Interval a from s = Interval (lowerBound s) (UpperBound PosInf True) -{-# INLINABLE from #-} +{-# INLINEABLE from #-} -- | @to a@ is an 'Interval' that includes all values that are -- smaller than or equal to @a@. In math. notation: [-∞,a] to :: a -> Interval a to s = Interval (LowerBound NegInf True) (upperBound s) -{-# INLINABLE to #-} +{-# INLINEABLE to #-} -- | An 'Interval' that covers every slot. In math. notation [-∞,+∞] always :: Interval a always = Interval (LowerBound NegInf True) (UpperBound PosInf True) -{-# INLINABLE always #-} +{-# INLINEABLE always #-} -{- | An 'Interval' that is empty. -There can be many empty intervals, see `isEmpty`. -The empty interval `never` is arbitrarily set to [+∞,-∞]. --} +-- | An 'Interval' that is empty. +-- There can be many empty intervals, see `isEmpty`. +-- The empty interval `never` is arbitrarily set to [+∞,-∞]. never :: Interval a never = Interval (LowerBound PosInf True) (UpperBound NegInf True) -{-# INLINABLE never #-} +{-# INLINEABLE never #-} -- | Check whether a value is in an interval. member :: (Enum a, Ord a) => a -> Interval a -> Bool member a i = i `contains` singleton a -{-# INLINABLE member #-} +{-# INLINEABLE member #-} -- | Check whether two intervals overlap, that is, whether there is a value that -- is a member of both intervals. overlaps :: (Enum a, Ord a) => Interval a -> Interval a -> Bool overlaps l r = not $ isEmpty (l `intersection` r) -{-# INLINABLE overlaps #-} +{-# INLINEABLE overlaps #-} -- | 'intersection a b' is the largest interval that is contained in 'a' and in -- 'b', if it exists. intersection :: (Enum a, Ord a) => Interval a -> Interval a -> Interval a intersection (Interval l1 h1) (Interval l2 h2) = Interval (max l1 l2) (min h1 h2) -{-# INLINABLE intersection #-} +{-# INLINEABLE intersection #-} -- | 'hull a b' is the smallest interval containing 'a' and 'b'. hull :: (Enum a, Ord a) => Interval a -> Interval a -> Interval a hull (Interval l1 h1) (Interval l2 h2) = Interval (min l1 l2) (max h1 h2) -{-# INLINABLE hull #-} +{-# INLINEABLE hull #-} -{- | @a `contains` b@ is true if the 'Interval' @b@ is entirely contained in -@a@. That is, @a `contains` b@ if for every entry @s@, if @member s b@ then -@member s a@. --} +-- | @a `contains` b@ is true if the 'Interval' @b@ is entirely contained in +-- @a@. That is, @a `contains` b@ if for every entry @s@, if @member s b@ then +-- @member s a@. contains :: (Enum a, Ord a) => Interval a -> Interval a -> Bool -- Everything contains the empty interval contains _ i2 | isEmpty i2 = True @@ -422,28 +422,28 @@ contains i1 _ | isEmpty i1 = False -- Otherwise we check the endpoints. This doesn't work for empty intervals, -- hence the cases above. contains (Interval l1 h1) (Interval l2 h2) = l1 <= l2 && h2 <= h1 -{-# INLINABLE contains #-} +{-# INLINEABLE contains #-} -{- | Check if an 'Interval' is empty. -} +-- | Check if an 'Interval' is empty. isEmpty :: (Enum a, Ord a) => Interval a -> Bool isEmpty (Interval lb ub) = case inclusiveLowerBound lb `compare` inclusiveUpperBound ub of - -- We have at least two possible values, the lower bound and the upper bound - LT -> False - -- We have one possible value, the lower bound/upper bound - EQ -> False - -- We have no possible values - GT -> True -{-# INLINABLE isEmpty #-} + -- We have at least two possible values, the lower bound and the upper bound + LT -> False + -- We have one possible value, the lower bound/upper bound + EQ -> False + -- We have no possible values + GT -> True +{-# INLINEABLE isEmpty #-} -- | Check if a value is earlier than the beginning of an 'Interval'. before :: (Enum a, Ord a) => a -> Interval a -> Bool before h (Interval f _) = lowerBound h < f -{-# INLINABLE before #-} +{-# INLINEABLE before #-} -- | Check if a value is later than the end of an 'Interval'. -after :: (Enum a , Ord a) => a -> Interval a -> Bool +after :: (Enum a, Ord a) => a -> Interval a -> Bool after h (Interval _ t) = upperBound h > t -{-# INLINABLE after #-} +{-# INLINEABLE after #-} {- Note [Enumerable Intervals] The 'Interval' type is set up to handle open intervals, where we have non-inclusive diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs index f88ee3aa730..19f75849179 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs @@ -1,21 +1,21 @@ {-# LANGUAGE DerivingVia #-} -module PlutusLedgerApi.V1.ParamName - ( ParamName (..) - , tagWithParamNames - ) where + +module PlutusLedgerApi.V1.ParamName ( + ParamName (..), + tagWithParamNames, +) where import Data.Ix import GHC.Generics import PlutusLedgerApi.Common.ParamName -{-| The enumeration of all possible cost model parameter names for this language version. - -IMPORTANT: The order of appearance of the data constructors here matters. DO NOT REORDER. -See Note [Quotation marks in cost model parameter constructors] -See Note [Cost model parameters from the ledger's point of view] --} -data ParamName = - AddInteger'cpu'arguments'intercept +-- | The enumeration of all possible cost model parameter names for this language version. +-- +-- IMPORTANT: The order of appearance of the data constructors here matters. DO NOT REORDER. +-- See Note [Quotation marks in cost model parameter constructors] +-- See Note [Cost model parameters from the ledger's point of view] +data ParamName + = AddInteger'cpu'arguments'intercept | AddInteger'cpu'arguments'slope | AddInteger'memory'arguments'intercept | AddInteger'memory'arguments'slope @@ -181,9 +181,9 @@ data ParamName = | VerifyEd25519Signature'cpu'arguments'intercept | VerifyEd25519Signature'cpu'arguments'slope | VerifyEd25519Signature'memory'arguments - -- End of original cost model parameters - -- Remaining parameters to be deployed in PV11 - | SerialiseData'cpu'arguments'intercept + | -- End of original cost model parameters + -- Remaining parameters to be deployed in PV11 + SerialiseData'cpu'arguments'intercept | SerialiseData'cpu'arguments'slope | SerialiseData'memory'arguments'intercept | SerialiseData'memory'arguments'slope @@ -318,6 +318,5 @@ data ParamName = | Bls12_381_G2_multiScalarMul'cpu'arguments'intercept | Bls12_381_G2_multiScalarMul'cpu'arguments'slope | Bls12_381_G2_multiScalarMul'memory'arguments - deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) - deriving IsParamName via (GenericParamName ParamName) - + deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) + deriving (IsParamName) via (GenericParamName ParamName) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Scripts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Scripts.hs index 3b787fa65f2..26388c7a58a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Scripts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Scripts.hs @@ -1,12 +1,12 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -67,7 +67,7 @@ newtype Datum = Datum {getDatum :: BuiltinData} deriving anyclass (NFData, HasBlueprintDefinition) instance HasBlueprintSchema Datum referencedTypes where - schema = SchemaBuiltInData emptySchemaInfo{title = Just "Datum"} + schema = SchemaBuiltInData emptySchemaInfo {title = Just "Datum"} -- See Note [Serialise instances for Datum and Redeemer] instance Serialise Datum where @@ -81,19 +81,18 @@ newtype Redeemer = Redeemer {getRedeemer :: BuiltinData} deriving anyclass (NFData, HasBlueprintDefinition) instance HasBlueprintSchema Redeemer referencedTypes where - schema = SchemaBuiltInData emptySchemaInfo{title = Just "Redeemer"} + schema = SchemaBuiltInData emptySchemaInfo {title = Just "Redeemer"} -- See Note [Serialise instances for Datum and Redeemer] instance Serialise Redeemer where encode (Redeemer (BuiltinData d)) = encode d decode = Redeemer . BuiltinData Haskell.<$> decode -{- | Type representing the /BLAKE2b-224/ hash of a script. 28 bytes. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. -See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). --} +-- | Type representing the /BLAKE2b-224/ hash of a script. 28 bytes. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. +-- See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). newtype ScriptHash = ScriptHash {getScriptHash :: Builtins.BuiltinByteString} deriving ( -- | from hex encoding @@ -109,14 +108,13 @@ newtype ScriptHash = ScriptHash {getScriptHash :: Builtins.BuiltinByteString} deriving anyclass (NFData, HasBlueprintDefinition) instance HasBlueprintSchema ScriptHash referencedTypes where - schema = SchemaBytes emptySchemaInfo{title = Just "ScriptHash"} emptyBytesSchema - -{- | Type representing the /BLAKE2b-256/ hash of a datum. 32 bytes. + schema = SchemaBytes emptySchemaInfo {title = Just "ScriptHash"} emptyBytesSchema -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. -See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). --} +-- | Type representing the /BLAKE2b-256/ hash of a datum. 32 bytes. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. +-- See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). newtype DatumHash = DatumHash Builtins.BuiltinByteString deriving ( -- | from hex encoding @@ -132,14 +130,13 @@ newtype DatumHash = DatumHash Builtins.BuiltinByteString deriving anyclass (NFData, HasBlueprintDefinition) instance HasBlueprintSchema DatumHash referencedTypes where - schema = SchemaBytes emptySchemaInfo{title = Just "DatumHash"} emptyBytesSchema - -{- | Type representing the /BLAKE2b-256/ hash of a redeemer. 32 bytes. + schema = SchemaBytes emptySchemaInfo {title = Just "DatumHash"} emptyBytesSchema -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. -See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). --} +-- | Type representing the /BLAKE2b-256/ hash of a redeemer. 32 bytes. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. +-- See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). newtype RedeemerHash = RedeemerHash Builtins.BuiltinByteString deriving ( -- | from hex encoding @@ -155,11 +152,10 @@ newtype RedeemerHash = RedeemerHash Builtins.BuiltinByteString deriving anyclass (NFData, HasBlueprintDefinition) instance HasBlueprintSchema RedeemerHash referencedTypes where - schema = SchemaBytes emptySchemaInfo{title = Just "RedeemerHash"} emptyBytesSchema + schema = SchemaBytes emptySchemaInfo {title = Just "RedeemerHash"} emptyBytesSchema -{- | Information about the state of the blockchain and about the transaction - that is currently being validated, represented as a value in 'Data'. --} +-- | Information about the state of the blockchain and about the transaction +-- that is currently being validated, represented as a value in 'Data'. newtype Context = Context BuiltinData deriving newtype (Pretty, Haskell.Show) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Time.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Time.hs index d259177f74f..f2b1fc5a6e0 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Time.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Time.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} -- Otherwise we get a complaint about the 'fromIntegral' -- call in the generated instance of 'Integral' for 'Ada' {-# OPTIONS_GHC -Wno-identities #-} @@ -55,11 +55,10 @@ newtype DiffMilliSeconds = DiffMilliSeconds Integer ) instance HasBlueprintSchema DiffMilliSeconds referencedTypes where - schema = SchemaInteger emptySchemaInfo{title = Just "DiffMilliSeconds"} emptyIntegerSchema + schema = SchemaInteger emptySchemaInfo {title = Just "DiffMilliSeconds"} emptyIntegerSchema -{- | POSIX time is measured as the number of /milliseconds/ since 1970-01-01T00:00:00Z. -This is not the same as Haskell's `Data.Time.Clock.POSIX.POSIXTime` --} +-- | POSIX time is measured as the number of /milliseconds/ since 1970-01-01T00:00:00Z. +-- This is not the same as Haskell's `Data.Time.Clock.POSIX.POSIXTime` newtype POSIXTime = POSIXTime {getPOSIXTime :: Integer} deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Generic) deriving anyclass (NFData, HasBlueprintDefinition) @@ -80,7 +79,7 @@ newtype POSIXTime = POSIXTime {getPOSIXTime :: Integer} ) instance HasBlueprintSchema POSIXTime referencedTypes where - schema = SchemaInteger emptySchemaInfo{title = Just "POSIXTime"} emptyIntegerSchema + schema = SchemaInteger emptySchemaInfo {title = Just "POSIXTime"} emptyIntegerSchema instance Pretty POSIXTime where pretty (POSIXTime i) = "POSIXTime" <+> pretty i diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs index fdce01c1653..e7c8d7fd4db 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs @@ -1,15 +1,15 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -55,12 +55,11 @@ import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V1.Scripts (DatumHash, Redeemer, ScriptHash) import PlutusLedgerApi.V1.Value (Value) -{- | A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. -See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). --} +-- | A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. +-- See the [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). newtype TxId = TxId {getTxId :: PlutusTx.BuiltinByteString} deriving stock (Eq, Ord, Generic) deriving anyclass (NFData, HasBlueprintDefinition) @@ -75,17 +74,15 @@ newtype TxId = TxId {getTxId :: PlutusTx.BuiltinByteString} ) via LedgerBytes -{- | A tag indicating the type of script that we are pointing to. - -See also 'PlutusLedgerApi.V1.ScriptPurpose' --} +-- | A tag indicating the type of script that we are pointing to. +-- +-- See also 'PlutusLedgerApi.V1.ScriptPurpose' data ScriptTag = Spend | Mint | Cert | Reward deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, HasBlueprintDefinition) -{- | A redeemer pointer is a pair of a script type tag ('ScriptTag') `t` and an index `i`, -picking out the i-th script of type `t` in the transaction. --} +-- | A redeemer pointer is a pair of a script type tag ('ScriptTag') `t` and an index `i`, +-- picking out the i-th script of type `t` in the transaction. data RedeemerPtr = RedeemerPtr ScriptTag Integer deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, HasBlueprintDefinition) @@ -93,12 +90,11 @@ data RedeemerPtr = RedeemerPtr ScriptTag Integer -- | Redeemers is a `Map` of redeemer pointer ('RedeemerPtr') and its 'Redeemer'. type Redeemers = Map RedeemerPtr Redeemer -{- | A reference to a transaction output. This is a -pair of a transaction ID (`TxId`), and an index indicating which of the outputs -of that transaction we are referring to. --} +-- | A reference to a transaction output. This is a +-- pair of a transaction ID (`TxId`), and an index indicating which of the outputs +-- of that transaction we are referring to. data TxOutRef = TxOutRef - { txOutRefId :: TxId + { txOutRefId :: TxId -- ^ The transaction ID. , txOutRefIdx :: Integer -- ^ Index into the referenced transaction's outputs @@ -107,7 +103,7 @@ data TxOutRef = TxOutRef deriving anyclass (NFData, HasBlueprintDefinition) instance Pretty TxOutRef where - pretty TxOutRef{txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx + pretty TxOutRef {txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx instance PlutusTx.Eq TxOutRef where {-# INLINEABLE (==) #-} @@ -117,19 +113,18 @@ instance PlutusTx.Eq TxOutRef where PlutusTx.&& txOutRefIdx l PlutusTx.== txOutRefIdx r -{- | A transaction output, consisting of a target address ('Address'), a value ('Value'), -and optionally a datum hash ('DatumHash'). --} +-- | A transaction output, consisting of a target address ('Address'), a value ('Value'), +-- and optionally a datum hash ('DatumHash'). data TxOut = TxOut - { txOutAddress :: Address - , txOutValue :: Value + { txOutAddress :: Address + , txOutValue :: Value , txOutDatumHash :: Maybe DatumHash } deriving stock (Show, Eq, Generic) deriving anyclass (NFData, HasBlueprintDefinition) instance Pretty TxOut where - pretty TxOut{txOutAddress, txOutValue} = + pretty TxOut {txOutAddress, txOutValue} = hang 2 $ vsep ["-" <+> pretty txOutValue <+> "addressed to", pretty txOutAddress] instance PlutusTx.Eq TxOut where @@ -144,29 +139,28 @@ instance PlutusTx.Eq TxOut where -- | The datum attached to a 'TxOut', if there is one. txOutDatum :: TxOut -> Maybe DatumHash -txOutDatum TxOut{txOutDatumHash} = txOutDatumHash +txOutDatum TxOut {txOutDatumHash} = txOutDatumHash -- | The public key attached to a 'TxOut', if there is one. txOutPubKey :: TxOut -> Maybe PubKeyHash -txOutPubKey TxOut{txOutAddress} = toPubKeyHash txOutAddress +txOutPubKey TxOut {txOutAddress} = toPubKeyHash txOutAddress -- | The validator hash attached to a 'TxOut', if there is one. txOutScriptHash :: TxOut -> Maybe ScriptHash -txOutScriptHash TxOut{txOutAddress} = toScriptHash txOutAddress +txOutScriptHash TxOut {txOutAddress} = toScriptHash txOutAddress -- | The address of a transaction output. outAddress :: Lens' TxOut Address outAddress = lens txOutAddress s - where - s tx a = tx{txOutAddress = a} + where + s tx a = tx {txOutAddress = a} -{- | The value of a transaction output. -| TODO: Compute address again --} +-- | The value of a transaction output. +-- | TODO: Compute address again outValue :: Lens' TxOut Value outValue = lens txOutValue s - where - s tx v = tx{txOutValue = v} + where + s tx v = tx {txOutValue = v} -- | Whether the output is a pay-to-pubkey output. isPubKeyOut :: TxOut -> Bool diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs index 4f2c146164a..e786e6a10a9 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs @@ -1,65 +1,69 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-spec-constr #-} {-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- We need -fexpose-all-unfoldings to compile the Marlowe validator -- TODO. Look into this more closely: see https://github.com/IntersectMBO/plutus/issues/6172. -- | Functions for working with 'Value'. module PlutusLedgerApi.V1.Value ( - -- ** Currency symbols - CurrencySymbol(..) - , currencySymbol - , adaSymbol - -- ** Token names - , TokenName(..) - , tokenName - , toString - , adaToken - -- * Asset classes - , AssetClass(..) - , assetClass - , assetClassValue - , assetClassValueOf - -- ** Value - , Value(..) - , singleton - , valueOf - , withCurrencySymbol - , currencySymbolValueOf - , lovelaceValue - , lovelaceValueOf - , scale - , symbols - -- * Partial order operations - , geq - , gt - , leq - , lt - -- * Etc. - , isZero - , split - , unionWith - , flattenValue - , Lovelace (..) - ) where + -- ** Currency symbols + CurrencySymbol (..), + currencySymbol, + adaSymbol, + + -- ** Token names + TokenName (..), + tokenName, + toString, + adaToken, + + -- * Asset classes + AssetClass (..), + assetClass, + assetClassValue, + assetClassValueOf, + + -- ** Value + Value (..), + singleton, + valueOf, + withCurrencySymbol, + currencySymbolValueOf, + lovelaceValue, + lovelaceValueOf, + scale, + symbols, + + -- * Partial order operations + geq, + gt, + leq, + lt, + + -- * Etc. + isZero, + split, + unionWith, + flattenValue, + Lovelace (..), +) where import Prelude qualified as Haskell @@ -76,10 +80,18 @@ import PlutusTx.AssocMap (Map) import PlutusTx.AssocMap qualified as Map import PlutusTx.Blueprint (emptySchemaInfo) import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) -import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), definitionIdFromType, - definitionRef) -import PlutusTx.Blueprint.Schema (MapSchema (..), PairSchema (..), Schema (..), emptyIntegerSchema, - withSchemaInfo) +import PlutusTx.Blueprint.Definition ( + HasBlueprintDefinition (..), + definitionIdFromType, + definitionRef, + ) +import PlutusTx.Blueprint.Schema ( + MapSchema (..), + PairSchema (..), + Schema (..), + emptyIntegerSchema, + withSchemaInfo, + ) import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..)) import PlutusTx.Lift (makeLift) import PlutusTx.List qualified as List @@ -90,15 +102,14 @@ import PlutusTx.These (These (..)) import Prettyprinter (Pretty, (<>)) import Prettyprinter.Extras (PrettyShow (PrettyShow)) -{- | ByteString representing the currency, hashed with /BLAKE2b-224/. -It is empty for `Ada`, 28 bytes for `MintingPolicyHash`. -Forms an `AssetClass` along with `TokenName`. -A `Value` is a map from `CurrencySymbol`'s to a map from `TokenName` to an `Integer`. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). --} +-- | ByteString representing the currency, hashed with /BLAKE2b-224/. +-- It is empty for `Ada`, 28 bytes for `MintingPolicyHash`. +-- Forms an `AssetClass` along with `TokenName`. +-- A `Value` is a map from `CurrencySymbol`'s to a map from `TokenName` to an `Integer`. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the +-- [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). newtype CurrencySymbol = CurrencySymbol {unCurrencySymbol :: PlutusTx.BuiltinByteString} deriving stock (Generic, Data) deriving anyclass (NFData, HasBlueprintDefinition) @@ -120,25 +131,25 @@ newtype CurrencySymbol = CurrencySymbol {unCurrencySymbol :: PlutusTx.BuiltinByt via LedgerBytes instance HasBlueprintSchema CurrencySymbol referencedTypes where - {-# INLINABLE schema #-} - schema = schema @PlutusTx.BuiltinByteString - & withSchemaInfo \info -> - info { title = Just "CurrencySymbol" } + {-# INLINEABLE schema #-} + schema = + schema @PlutusTx.BuiltinByteString + & withSchemaInfo \info -> + info {title = Just "CurrencySymbol"} -- | Creates `CurrencySymbol` from raw `ByteString`. currencySymbol :: BS.ByteString -> CurrencySymbol currencySymbol = CurrencySymbol . PlutusTx.toBuiltin -{-# INLINABLE currencySymbol #-} - -{- | ByteString of a name of a token. -Shown as UTF-8 string when possible. -Should be no longer than 32 bytes, empty for Ada. -Forms an `AssetClass` along with a `CurrencySymbol`. +{-# INLINEABLE currencySymbol #-} -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). --} +-- | ByteString of a name of a token. +-- Shown as UTF-8 string when possible. +-- Should be no longer than 32 bytes, empty for Ada. +-- Forms an `AssetClass` along with a `CurrencySymbol`. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the +-- [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). newtype TokenName = TokenName {unTokenName :: PlutusTx.BuiltinByteString} deriving stock (Generic, Data) deriving newtype @@ -154,15 +165,16 @@ newtype TokenName = TokenName {unTokenName :: PlutusTx.BuiltinByteString} deriving (Pretty) via (PrettyShow TokenName) instance HasBlueprintSchema TokenName referencedTypes where - {-# INLINABLE schema #-} - schema = schema @PlutusTx.BuiltinByteString - & withSchemaInfo \info -> - info { title = Just "TokenName" } + {-# INLINEABLE schema #-} + schema = + schema @PlutusTx.BuiltinByteString + & withSchemaInfo \info -> + info {title = Just "TokenName"} -- | Creates `TokenName` from raw `BS.ByteString`. tokenName :: BS.ByteString -> TokenName tokenName = TokenName . PlutusTx.toBuiltin -{-# INLINABLE tokenName #-} +{-# INLINEABLE tokenName #-} fromTokenName :: (BS.ByteString -> r) -> (Text -> r) -> TokenName -> r fromTokenName handleBytestring handleText (TokenName bs) = either (\_ -> handleBytestring $ PlutusTx.fromBuiltin bs) handleText $ E.decodeUtf8' (PlutusTx.fromBuiltin bs) @@ -175,25 +187,24 @@ asBase16 bs = Text.concat ["0x", encodeByteString bs] quoted :: Text -> Text quoted s = Text.concat ["\"", s, "\""] -{- | Turn a TokenName to a hex-encoded 'String' - -Compared to `show` , it will not surround the string with double-quotes. --} +-- | Turn a TokenName to a hex-encoded 'String' +-- +-- Compared to `show` , it will not surround the string with double-quotes. toString :: TokenName -> Haskell.String toString = Text.unpack . fromTokenName asBase16 id instance Haskell.Show TokenName where - show = Text.unpack . fromTokenName asBase16 quoted + show = Text.unpack . fromTokenName asBase16 quoted -- | The 'CurrencySymbol' of the 'Ada' currency. adaSymbol :: CurrencySymbol adaSymbol = CurrencySymbol emptyByteString -{-# INLINABLE adaSymbol #-} +{-# INLINEABLE adaSymbol #-} -- | The 'TokenName' of the 'Ada' currency. adaToken :: TokenName adaToken = TokenName emptyByteString -{-# INLINABLE adaToken #-} +{-# INLINEABLE adaToken #-} -- | An asset class, identified by a `CurrencySymbol` and a `TokenName`. newtype AssetClass = AssetClass {unAssetClass :: (CurrencySymbol, TokenName)} @@ -212,10 +223,10 @@ newtype AssetClass = AssetClass {unAssetClass :: (CurrencySymbol, TokenName)} deriving (Pretty) via (PrettyShow (CurrencySymbol, TokenName)) instance HasBlueprintSchema AssetClass referencedTypes where - {-# INLINABLE schema #-} + {-# INLINEABLE schema #-} schema = - SchemaBuiltInPair emptySchemaInfo $ - MkPairSchema + SchemaBuiltInPair emptySchemaInfo + $ MkPairSchema { left = schema @CurrencySymbol , right = schema @TokenName } @@ -223,7 +234,7 @@ instance HasBlueprintSchema AssetClass referencedTypes where -- | The curried version of 'AssetClass' constructor assetClass :: CurrencySymbol -> TokenName -> AssetClass assetClass s t = AssetClass (s, t) -{-# INLINABLE assetClass #-} +{-# INLINEABLE assetClass #-} {- Note [Value vs value] We call two completely different things "values": the 'Value' type and a value within a key-value @@ -248,92 +259,95 @@ See https://github.com/IntersectMBO/plutus/pull/5779 for details on the experime -- See Note [Value vs value]. -- See Note [Optimising Value]. -{- | The 'Value' type represents a collection of amounts of different currencies. -We can think of 'Value' as a vector space whose dimensions are currencies. - -Operations on currencies are usually implemented /pointwise/. That is, -we apply the operation to the quantities for each currency in turn. So -when we add two 'Value's the resulting 'Value' has, for each currency, -the sum of the quantities of /that particular/ currency in the argument -'Value'. The effect of this is that the currencies in the 'Value' are "independent", -and are operated on separately. - -Whenever we need to get the quantity of a currency in a 'Value' where there -is no explicit quantity of that currency in the 'Value', then the quantity is -taken to be zero. - -There is no 'Ord Value' instance since 'Value' is only a partial order, so 'compare' can't -do the right thing in some cases. - -} -newtype Value = Value { getValue :: Map CurrencySymbol (Map TokenName Integer) } - deriving stock (Generic, Data, Haskell.Show) - deriving anyclass (NFData) - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - deriving Pretty via (PrettyShow Value) + +-- | The 'Value' type represents a collection of amounts of different currencies. +-- We can think of 'Value' as a vector space whose dimensions are currencies. +-- +-- Operations on currencies are usually implemented /pointwise/. That is, +-- we apply the operation to the quantities for each currency in turn. So +-- when we add two 'Value's the resulting 'Value' has, for each currency, +-- the sum of the quantities of /that particular/ currency in the argument +-- 'Value'. The effect of this is that the currencies in the 'Value' are "independent", +-- and are operated on separately. +-- +-- Whenever we need to get the quantity of a currency in a 'Value' where there +-- is no explicit quantity of that currency in the 'Value', then the quantity is +-- taken to be zero. +-- +-- There is no 'Ord Value' instance since 'Value' is only a partial order, so 'compare' can't +-- do the right thing in some cases. +newtype Value = Value {getValue :: Map CurrencySymbol (Map TokenName Integer)} + deriving stock (Generic, Data, Haskell.Show) + deriving anyclass (NFData) + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving (Pretty) via (PrettyShow Value) instance HasBlueprintDefinition Value where type Unroll Value = '[Value, CurrencySymbol, TokenName, Integer] definitionId = definitionIdFromType @Value instance HasBlueprintSchema Value referencedTypes where - {-# INLINABLE schema #-} + {-# INLINEABLE schema #-} schema = SchemaMap emptySchemaInfo - { title = Just "Value" } + { title = Just "Value" + } MkMapSchema { keySchema = definitionRef @CurrencySymbol , valueSchema = - SchemaMap emptySchemaInfo MkMapSchema - { keySchema = definitionRef @TokenName - , valueSchema = definitionRef @Integer - , minItems = Nothing - , maxItems = Nothing - } + SchemaMap + emptySchemaInfo + MkMapSchema + { keySchema = definitionRef @TokenName + , valueSchema = definitionRef @Integer + , minItems = Nothing + , maxItems = Nothing + } , minItems = Nothing , maxItems = Nothing } instance Haskell.Eq Value where - (==) = eq + (==) = eq instance Eq Value where - {-# INLINABLE (==) #-} - (==) = eq + {-# INLINEABLE (==) #-} + (==) = eq instance Haskell.Semigroup Value where - (<>) = unionWith (+) + (<>) = unionWith (+) instance Semigroup Value where - {-# INLINABLE (<>) #-} - (<>) = unionWith (+) + {-# INLINEABLE (<>) #-} + (<>) = unionWith (+) instance Haskell.Monoid Value where - mempty = Value Map.empty + mempty = Value Map.empty instance Monoid Value where - {-# INLINABLE mempty #-} - mempty = Value Map.empty + {-# INLINEABLE mempty #-} + mempty = Value Map.empty instance Group Value where - {-# INLINABLE inv #-} - inv = scale @Integer @Value (-1) + {-# INLINEABLE inv #-} + inv = scale @Integer @Value (-1) deriving via (Additive Value) instance AdditiveSemigroup Value deriving via (Additive Value) instance AdditiveMonoid Value deriving via (Additive Value) instance AdditiveGroup Value instance Module Integer Value where - {-# INLINABLE scale #-} - scale i (Value xs) = Value (fmap (fmap (\i' -> i * i')) xs) + {-# INLINEABLE scale #-} + scale i (Value xs) = Value (fmap (fmap (\i' -> i * i')) xs) instance JoinSemiLattice Value where - {-# INLINABLE (\/) #-} - (\/) = unionWith Ord.max + {-# INLINEABLE (\/) #-} + (\/) = unionWith Ord.max instance MeetSemiLattice Value where - {-# INLINABLE (/\) #-} - (/\) = unionWith Ord.min + {-# INLINEABLE (/\) #-} + (/\) = unionWith Ord.min -- | Get the quantity of the given currency in the 'Value'. -- Assumes that the underlying map doesn't contain duplicate keys. @@ -342,87 +356,87 @@ valueOf value cur tn = withCurrencySymbol cur value 0 \tokens -> case Map.lookup tn tokens of Nothing -> 0 - Just v -> v -{-# INLINABLE valueOf #-} + Just v -> v +{-# INLINEABLE valueOf #-} -{- | Apply a continuation function to the token quantities of the given currency -symbol in the value or return a default value if the currency symbol is not present -in the value. --} +-- | Apply a continuation function to the token quantities of the given currency +-- symbol in the value or return a default value if the currency symbol is not present +-- in the value. withCurrencySymbol :: CurrencySymbol -> Value -> a -> (Map TokenName Integer -> a) -> a withCurrencySymbol currency value def k = case Map.lookup currency (getValue value) of - Nothing -> def + Nothing -> def Just tokenQuantities -> k tokenQuantities -{-# INLINABLE withCurrencySymbol #-} +{-# INLINEABLE withCurrencySymbol #-} -{- | Get the total value of the currency symbol in the 'Value' map. -Assumes that the underlying map doesn't contain duplicate keys. - -Note that each token of the currency symbol may have a value that is positive, -zero or negative. --} +-- | Get the total value of the currency symbol in the 'Value' map. +-- Assumes that the underlying map doesn't contain duplicate keys. +-- +-- Note that each token of the currency symbol may have a value that is positive, +-- zero or negative. currencySymbolValueOf :: Value -> CurrencySymbol -> Integer currencySymbolValueOf value cur = withCurrencySymbol cur value 0 \tokens -> -- This is more efficient than `PlutusTx.sum (Map.elems tokens)`, because -- the latter materializes the intermediate result of `Map.elems tokens`. List.foldr (\(_, amt) acc -> amt + acc) 0 (Map.toList tokens) -{-# INLINABLE currencySymbolValueOf #-} +{-# INLINEABLE currencySymbolValueOf #-} -- | The list of 'CurrencySymbol's of a 'Value'. symbols :: Value -> [CurrencySymbol] symbols (Value mp) = Map.keys mp -{-# INLINABLE symbols #-} +{-# INLINEABLE symbols #-} -- | Make a 'Value' containing only the given quantity of the given currency. singleton :: CurrencySymbol -> TokenName -> Integer -> Value singleton c tn i = Value (Map.singleton c (Map.singleton tn i)) -{-# INLINABLE singleton #-} +{-# INLINEABLE singleton #-} -- | A 'Value' containing the given quantity of Lovelace. lovelaceValue :: Lovelace -> Value lovelaceValue = singleton adaSymbol adaToken . getLovelace -{-# INLINABLE lovelaceValue #-} +{-# INLINEABLE lovelaceValue #-} -- | Get the quantity of Lovelace in the 'Value'. lovelaceValueOf :: Value -> Lovelace lovelaceValueOf v = Lovelace (valueOf v adaSymbol adaToken) -{-# INLINABLE lovelaceValueOf #-} +{-# INLINEABLE lovelaceValueOf #-} -- | A 'Value' containing the given amount of the asset class. assetClassValue :: AssetClass -> Integer -> Value assetClassValue (AssetClass (c, t)) = singleton c t -{-# INLINABLE assetClassValue #-} +{-# INLINEABLE assetClassValue #-} -- | Get the quantity of the given 'AssetClass' class in the 'Value'. assetClassValueOf :: Value -> AssetClass -> Integer assetClassValueOf v (AssetClass (c, t)) = valueOf v c t -{-# INLINABLE assetClassValueOf #-} +{-# INLINEABLE assetClassValueOf #-} -- | Combine two 'Value' maps, assumes the well-definedness of the two maps. unionVal :: Value -> Value -> Map CurrencySymbol (Map TokenName (These Integer Integer)) unionVal (Value l) (Value r) = - let - combined = Map.union l r - unThese k = case k of - This a -> This <$> a - That b -> That <$> b - These a b -> Map.union a b - in unThese <$> combined -{-# INLINABLE unionVal #-} + let + combined = Map.union l r + unThese k = case k of + This a -> This <$> a + That b -> That <$> b + These a b -> Map.union a b + in + unThese <$> combined +{-# INLINEABLE unionVal #-} -- | Combine two 'Value' maps with the argument function. -- Assumes the well-definedness of the two maps. unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value unionWith f ls rs = - let - combined = unionVal ls rs - unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b - These a b -> f a b - in Value (fmap (fmap unThese) combined) -{-# INLINABLE unionWith #-} + let + combined = unionVal ls rs + unThese k' = case k' of + This a -> f a 0 + That b -> f 0 b + These a b -> f a b + in + Value (fmap (fmap unThese) combined) +{-# INLINEABLE unionWith #-} -- | Convert a 'Value' to a simple list, keeping only the non-zero amounts. -- Note that the result isn't sorted, meaning @v1 == v2@ doesn't generally imply @@ -434,160 +448,162 @@ unionWith f ls rs = flattenValue :: Value -> [(CurrencySymbol, TokenName, Integer)] flattenValue v = goOuter [] (Map.toList $ getValue v) where - goOuter acc [] = acc + goOuter acc [] = acc goOuter acc ((cs, m) : tl) = goOuter (goInner cs acc (Map.toList m)) tl goInner _ acc [] = acc goInner cs acc ((tn, a) : tl) - | a /= 0 = goInner cs ((cs, tn, a) : acc) tl - | otherwise = goInner cs acc tl -{-# INLINABLE flattenValue #-} + | a /= 0 = goInner cs ((cs, tn, a) : acc) tl + | otherwise = goInner cs acc tl +{-# INLINEABLE flattenValue #-} -- Num operations -- | Check whether a 'Value' is zero. isZero :: Value -> Bool isZero (Value xs) = Map.all (Map.all (\i -> 0 == i)) xs -{-# INLINABLE isZero #-} +{-# INLINEABLE isZero #-} -- | Checks whether a predicate holds for all the values in a 'Value' -- union. Assumes the well-definedness of the two underlying 'Map's. checkPred :: (These Integer Integer -> Bool) -> Value -> Value -> Bool checkPred f l r = - let - inner :: Map TokenName (These Integer Integer) -> Bool - inner = Map.all f - in - Map.all inner (unionVal l r) -{-# INLINABLE checkPred #-} + let + inner :: Map TokenName (These Integer Integer) -> Bool + inner = Map.all f + in + Map.all inner (unionVal l r) +{-# INLINEABLE checkPred #-} -- | Check whether a binary relation holds for value pairs of two 'Value' maps, -- supplying 0 where a key is only present in one of them. checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool checkBinRel f l r = - let - unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b - These a b -> f a b - in checkPred unThese l r -{-# INLINABLE checkBinRel #-} + let + unThese k' = case k' of + This a -> f a 0 + That b -> f 0 b + These a b -> f a b + in + checkPred unThese l r +{-# INLINEABLE checkBinRel #-} -- | Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation -- of how operations on 'Value's work. geq :: Value -> Value -> Bool -- If both are zero then checkBinRel will be vacuously true, but this is fine. geq = checkBinRel (>=) -{-# INLINABLE geq #-} +{-# INLINEABLE geq #-} -- | Check whether one 'Value' is less than or equal to another. See 'Value' for an explanation of -- how operations on 'Value's work. leq :: Value -> Value -> Bool -- If both are zero then checkBinRel will be vacuously true, but this is fine. leq = checkBinRel (<=) -{-# INLINABLE leq #-} +{-# INLINEABLE leq #-} -- | Check whether one 'Value' is strictly greater than another. -- This is *not* a pointwise operation. @gt l r@ means @geq l r && not (eq l r)@. gt :: Value -> Value -> Bool gt l r = geq l r && not (eq l r) -{-# INLINABLE gt #-} +{-# INLINEABLE gt #-} -- | Check whether one 'Value' is strictly less than another. -- This is *not* a pointwise operation. @lt l r@ means @leq l r && not (eq l r)@. lt :: Value -> Value -> Bool lt l r = leq l r && not (eq l r) -{-# INLINABLE lt #-} +{-# INLINEABLE lt #-} -- | Split a 'Value' into its positive and negative parts. The first element of -- the tuple contains the negative parts of the 'Value', the second element -- contains the positive parts. -- -- @negate (fst (split a)) `plus` (snd (split a)) == a@ --- split :: Value -> (Value, Value) -split (Value mp) = (negate (Value neg), Value pos) where - (neg, pos) = Map.mapThese splitIntl mp - - splitIntl :: Map TokenName Integer -> These (Map TokenName Integer) (Map TokenName Integer) - splitIntl mp' = These l r where - (l, r) = Map.mapThese (\i -> if i <= 0 then This i else That i) mp' -{-# INLINABLE split #-} - -{- | Check equality of two lists of distinct key-value pairs, each value being uniquely -identified by a key, given a function checking whether a 'Value' is zero and a function -checking equality of values. Note that the caller must ensure that the two lists are -well-defined in this sense. This is not checked or enforced in `unordEqWith`, and therefore -it might yield undefined results for ill-defined input. - -This function recurses on both the lists in parallel and checks whether the key-value pairs are -equal pointwise. If there is a mismatch, then it tries to find the left key-value pair in the right -list. If that succeeds then the pair is removed from both the lists and recursion proceeds pointwise -as before until there's another mismatch. If at some point a key-value pair from the left list is -not found in the right one, then the function returns 'False'. If the left list is exhausted, but -the right one still has some non-zero elements, the function returns 'False' as well. - -We check equality of values of two key-value pairs right after ensuring that the keys match. This is -disadvantageous if the values are big and there's a key that is present in one of the lists but not -in the other, since in that case computing equality of values was expensive and pointless. However - -1. we've checked and on the chain 'Value's very rarely contain 'CurrencySymbol's with more than 3 - 'TokenName's associated with them, so we optimize for the most common use case -2. computing equality of values before ensuring equality of all the keys certainly does help when we - check equality of 'TokenName'-value pairs, since the value of a 'TokenName' is an 'Integer' and - @(==) :: Integer -> Integer -> Bool@ is generally much faster than repeatedly searching for keys - in a list -3. having some clever logic for computing equality of values right away in some cases, but not in - others would not only complicate the algorithm, but also increase the size of the function and - this resource is quite scarce as the size of a program growing beyond what's acceptable by the - network can be a real deal breaker, while general performance concerns don't seem to be as - pressing - -The algorithm we use here is very similar, if not identical, to @valueEqualsValue4@ from -https://github.com/IntersectMBO/plutus/issues/5135 --} +split (Value mp) = (negate (Value neg), Value pos) + where + (neg, pos) = Map.mapThese splitIntl mp + + splitIntl :: Map TokenName Integer -> These (Map TokenName Integer) (Map TokenName Integer) + splitIntl mp' = These l r + where + (l, r) = Map.mapThese (\i -> if i <= 0 then This i else That i) mp' +{-# INLINEABLE split #-} + +-- | Check equality of two lists of distinct key-value pairs, each value being uniquely +-- identified by a key, given a function checking whether a 'Value' is zero and a function +-- checking equality of values. Note that the caller must ensure that the two lists are +-- well-defined in this sense. This is not checked or enforced in `unordEqWith`, and therefore +-- it might yield undefined results for ill-defined input. +-- +-- This function recurses on both the lists in parallel and checks whether the key-value pairs are +-- equal pointwise. If there is a mismatch, then it tries to find the left key-value pair in the right +-- list. If that succeeds then the pair is removed from both the lists and recursion proceeds pointwise +-- as before until there's another mismatch. If at some point a key-value pair from the left list is +-- not found in the right one, then the function returns 'False'. If the left list is exhausted, but +-- the right one still has some non-zero elements, the function returns 'False' as well. +-- +-- We check equality of values of two key-value pairs right after ensuring that the keys match. This is +-- disadvantageous if the values are big and there's a key that is present in one of the lists but not +-- in the other, since in that case computing equality of values was expensive and pointless. However +-- +-- 1. we've checked and on the chain 'Value's very rarely contain 'CurrencySymbol's with more than 3 +-- 'TokenName's associated with them, so we optimize for the most common use case +-- 2. computing equality of values before ensuring equality of all the keys certainly does help when we +-- check equality of 'TokenName'-value pairs, since the value of a 'TokenName' is an 'Integer' and +-- @(==) :: Integer -> Integer -> Bool@ is generally much faster than repeatedly searching for keys +-- in a list +-- 3. having some clever logic for computing equality of values right away in some cases, but not in +-- others would not only complicate the algorithm, but also increase the size of the function and +-- this resource is quite scarce as the size of a program growing beyond what's acceptable by the +-- network can be a real deal breaker, while general performance concerns don't seem to be as +-- pressing +-- +-- The algorithm we use here is very similar, if not identical, to @valueEqualsValue4@ from +-- https://github.com/IntersectMBO/plutus/issues/5135 unordEqWith :: forall k v. Eq k => (v -> Bool) -> (v -> v -> Bool) -> [(k, v)] -> [(k, v)] -> Bool -unordEqWith is0 eqV = goBoth where +unordEqWith is0 eqV = goBoth + where -- Recurse on the spines of both the lists simultaneously. goBoth :: [(k, v)] -> [(k, v)] -> Bool -- One spine is longer than the other one, but this still can result in a succeeding equality -- check if the non-empty list only contains zero values. - goBoth [] kvsR = List.all (is0 . snd) kvsR + goBoth [] kvsR = List.all (is0 . snd) kvsR -- Symmetric to the previous case. - goBoth kvsL [] = List.all (is0 . snd) kvsL + goBoth kvsL [] = List.all (is0 . snd) kvsL -- Both spines are non-empty. goBoth ((kL, vL) : kvsL') kvsR0@(kvR0@(kR0, vR0) : kvsR0') - -- We could've avoided having this clause if we always searched for the right key-value pair - -- using @goRight@, however the sheer act of invoking that function, passing an empty list - -- to it as an accumulator and calling 'revAppend' afterwards affects performance quite a - -- bit, considering that all of that happens for every single element of the left list. - -- Hence we handle the special case of lists being equal pointwise (or at least their - -- prefixes being equal pointwise) with a bit of additional logic to get some easy - -- performance gains. - | kL == kR0 = if vL `eqV` vR0 then goBoth kvsL' kvsR0' else False - | is0 vL = goBoth kvsL' kvsR0 - | otherwise = goRight [kvR0 | not $ is0 vR0] kvsR0' - where - -- Recurse on the spine of the right list looking for a key-value pair whose key matches - -- @kL@, i.e. the first key in the remaining part of the left list. The accumulator - -- contains (in reverse order) all elements of the right list processed so far whose - -- keys are not equal to @kL@ and values are non-zero. - goRight :: [(k, v)] -> [(k, v)] -> Bool - goRight _ [] = False - goRight acc (kvR@(kR, vR) : kvsR') - | is0 vR = goRight acc kvsR' - -- @revAppend@ recreates @kvsR0'@ with @(kR, vR)@ removed, since that pair - -- equals @(kL, vL)@ from the left list, hence we throw both of them away. - | kL == kR = if vL `eqV` vR then goBoth kvsL' (List.revAppend acc kvsR') else False - | otherwise = goRight (kvR : acc) kvsR' -{-# INLINABLE unordEqWith #-} + -- We could've avoided having this clause if we always searched for the right key-value pair + -- using @goRight@, however the sheer act of invoking that function, passing an empty list + -- to it as an accumulator and calling 'revAppend' afterwards affects performance quite a + -- bit, considering that all of that happens for every single element of the left list. + -- Hence we handle the special case of lists being equal pointwise (or at least their + -- prefixes being equal pointwise) with a bit of additional logic to get some easy + -- performance gains. + | kL == kR0 = if vL `eqV` vR0 then goBoth kvsL' kvsR0' else False + | is0 vL = goBoth kvsL' kvsR0 + | otherwise = goRight [kvR0 | not $ is0 vR0] kvsR0' + where + -- Recurse on the spine of the right list looking for a key-value pair whose key matches + -- @kL@, i.e. the first key in the remaining part of the left list. The accumulator + -- contains (in reverse order) all elements of the right list processed so far whose + -- keys are not equal to @kL@ and values are non-zero. + goRight :: [(k, v)] -> [(k, v)] -> Bool + goRight _ [] = False + goRight acc (kvR@(kR, vR) : kvsR') + | is0 vR = goRight acc kvsR' + -- @revAppend@ recreates @kvsR0'@ with @(kR, vR)@ removed, since that pair + -- equals @(kL, vL)@ from the left list, hence we throw both of them away. + | kL == kR = if vL `eqV` vR then goBoth kvsL' (List.revAppend acc kvsR') else False + | otherwise = goRight (kvR : acc) kvsR' +{-# INLINEABLE unordEqWith #-} -- | Check equality of two 'Map's given a function checking whether a value is zero and a function -- checking equality of values. eqMapWith :: - forall k v. Eq k => (v -> Bool) -> (v -> v -> Bool) -> Map k v -> Map k v -> Bool + forall k v. Eq k => (v -> Bool) -> (v -> v -> Bool) -> Map k v -> Map k v -> Bool eqMapWith is0 eqV (Map.toList -> xs1) (Map.toList -> xs2) = unordEqWith is0 eqV xs1 xs2 -{-# INLINABLE eqMapWith #-} +{-# INLINEABLE eqMapWith #-} -- | Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack -- of empty values (such as a token whose quantity is zero or a currency that has a bunch of such @@ -595,9 +611,9 @@ eqMapWith is0 eqV (Map.toList -> xs1) (Map.toList -> xs2) = unordEqWith is0 eqV -- currency have multiple entries. eq :: Value -> Value -> Bool eq (Value currs1) (Value currs2) = eqMapWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 -{-# INLINABLE eq #-} +{-# INLINEABLE eq #-} -newtype Lovelace = Lovelace { getLovelace :: Integer } +newtype Lovelace = Lovelace {getLovelace :: Integer} deriving stock (Generic) deriving (Pretty) via (PrettyShow Lovelace) deriving anyclass (HasBlueprintDefinition) @@ -620,10 +636,10 @@ newtype Lovelace = Lovelace { getLovelace :: Integer } ) instance HasBlueprintSchema Lovelace referencedTypes where - {-# INLINABLE schema #-} + {-# INLINEABLE schema #-} schema = SchemaInteger info emptyIntegerSchema - where - info = emptySchemaInfo { title = Just "Lovelace" } + where + info = emptySchemaInfo {title = Just "Lovelace"} ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2.hs index bdcdbe49088..bf07f94a752 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2.hs @@ -138,19 +138,17 @@ import PlutusLedgerApi.V2.Tx qualified as Tx import PlutusTx.AssocMap (Map, unsafeFromList) -{- | An alias to the Plutus ledger language this module exposes at runtime. - MAYBE: Use CPP '__FILE__' + some TH to automate this. --} +-- | An alias to the Plutus ledger language this module exposes at runtime. +-- MAYBE: Use CPP '__FILE__' + some TH to automate this. thisLedgerLanguage :: Common.PlutusLedgerLanguage thisLedgerLanguage = Common.PlutusV2 -{- | The deserialization from a serialised script into a `ScriptForEvaluation`, -ready to be evaluated on-chain. -Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). --} +-- | The deserialization from a serialised script into a `ScriptForEvaluation`, +-- ready to be evaluated on-chain. +-- Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). deserialiseScript :: forall m. - (Common.MonadError Common.ScriptDecodeError m) => + Common.MonadError Common.ScriptDecodeError m => -- | which major protocol version the script was submitted in. Common.MajorProtocolVersion -> -- | the script to deserialise. @@ -158,11 +156,10 @@ deserialiseScript :: m Common.ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{- | Evaluates a script, returning the minimum budget that the script would need -to evaluate successfully. This will take as long as the script takes, if you need to -limit the execution time of the script also, you can use 'evaluateScriptRestricting', which -also returns the used budget. --} +-- | Evaluates a script, returning the minimum budget that the script would need +-- to evaluate successfully. This will take as long as the script takes, if you need to +-- limit the execution time of the script also, you can use 'evaluateScriptRestricting', which +-- also returns the used budget. evaluateScriptCounting :: -- | Which major protocol version to run the operation in Common.MajorProtocolVersion -> @@ -177,13 +174,12 @@ evaluateScriptCounting :: (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptCounting = Common.evaluateScriptCounting thisLedgerLanguage -{- | Evaluates a script, with a cost model and a budget that restricts how many -resources it can use according to the cost model. Also returns the budget that -was actually used. - -Can be used to calculate budgets for scripts, but even in this case you must give -a limit to guard against scripts that run for a long time or loop. --} +-- | Evaluates a script, with a cost model and a budget that restricts how many +-- resources it can use according to the cost model. Also returns the budget that +-- was actually used. +-- +-- Can be used to calculate budgets for scripts, but even in this case you must give +-- a limit to guard against scripts that run for a long time or loop. evaluateScriptRestricting :: -- | Which major protocol version to run the operation in Common.MajorProtocolVersion -> diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs index e1387212652..0df90acf7ae 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs @@ -1,45 +1,44 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -{-# OPTIONS_GHC -fno-strictness #-} -{-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} -module PlutusLedgerApi.V2.Contexts - ( - -- * Pending transactions and related types - TxInfo(..) - , ScriptContext(..) - , ScriptPurpose(..) - , TxId (..) - , TxOut(..) - , TxOutRef(..) - , TxInInfo(..) - , findOwnInput - , findDatum - , findDatumHash - , findTxInByTxOutRef - , findContinuingOutputs - , getContinuingOutputs - -- * Validator functions - , pubKeyOutputsAt - , valuePaidTo - , spendsOutput - , txSignedBy - , valueSpent - , valueProduced - , ownCurrencySymbol - ) where +module PlutusLedgerApi.V2.Contexts ( + -- * Pending transactions and related types + TxInfo (..), + ScriptContext (..), + ScriptPurpose (..), + TxId (..), + TxOut (..), + TxOutRef (..), + TxInInfo (..), + findOwnInput, + findDatum, + findDatumHash, + findTxInByTxOutRef, + findContinuingOutputs, + getContinuingOutputs, + + -- * Validator functions + pubKeyOutputsAt, + valuePaidTo, + spendsOutput, + txSignedBy, + valueSpent, + valueProduced, + ownCurrencySymbol, +) where import PlutusTx.Prelude import Prelude qualified as Haskell @@ -65,163 +64,176 @@ import Prettyprinter (Pretty (..), nest, vsep, (<+>)) -- | An input of a pending transaction. data TxInInfo = TxInInfo - { txInInfoOutRef :: TxOutRef - , txInInfoResolved :: TxOut - } - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving anyclass (HasBlueprintDefinition) + { txInInfoOutRef :: TxOutRef + , txInInfoResolved :: TxOut + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving anyclass (HasBlueprintDefinition) instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' + TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = - pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved + pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = + pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -- | A pending transaction. This is the view as seen by validator scripts, so some details are stripped out. data TxInfo = TxInfo - { txInfoInputs :: [TxInInfo] -- ^ Transaction inputs; cannot be an empty list - , txInfoReferenceInputs :: [TxInInfo] -- ^ /Added in V2:/ Transaction reference inputs - , txInfoOutputs :: [TxOut] -- ^ Transaction outputs - , txInfoFee :: Value -- ^ The fee paid by this transaction. - , txInfoMint :: Value -- ^ The 'Value' minted by this transaction. - , txInfoDCert :: [DCert] -- ^ Digests of certificates included in this transaction - , txInfoWdrl :: Map StakingCredential Integer -- ^ Withdrawals - -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' - , txInfoValidRange :: POSIXTimeRange -- ^ The valid range for the transaction. - , txInfoSignatories :: [PubKeyHash] -- ^ Signatures provided with the transaction, attested that they all signed the tx - , txInfoRedeemers :: Map ScriptPurpose Redeemer -- ^ /Added in V2:/ a table of redeemers attached to the transaction - , txInfoData :: Map DatumHash Datum -- ^ The lookup table of datums attached to the transaction - -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' - , txInfoId :: TxId -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) - } - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving anyclass (HasBlueprintDefinition) + { txInfoInputs :: [TxInInfo] + -- ^ Transaction inputs; cannot be an empty list + , txInfoReferenceInputs :: [TxInInfo] + -- ^ /Added in V2:/ Transaction reference inputs + , txInfoOutputs :: [TxOut] + -- ^ Transaction outputs + , txInfoFee :: Value + -- ^ The fee paid by this transaction. + , txInfoMint :: Value + -- ^ The 'Value' minted by this transaction. + , txInfoDCert :: [DCert] + -- ^ Digests of certificates included in this transaction + , txInfoWdrl :: Map StakingCredential Integer + -- ^ Withdrawals + -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' + , txInfoValidRange :: POSIXTimeRange + -- ^ The valid range for the transaction. + , txInfoSignatories :: [PubKeyHash] + -- ^ Signatures provided with the transaction, attested that they all signed the tx + , txInfoRedeemers :: Map ScriptPurpose Redeemer + -- ^ /Added in V2:/ a table of redeemers attached to the transaction + , txInfoData :: Map DatumHash Datum + -- ^ The lookup table of datums attached to the transaction + -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' + , txInfoId :: TxId + -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving anyclass (HasBlueprintDefinition) instance Pretty TxInfo where - pretty TxInfo{txInfoInputs, txInfoReferenceInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoRedeemers, txInfoData, txInfoId} = - vsep - [ "TxId:" <+> pretty txInfoId - , "Inputs:" <+> pretty txInfoInputs - , "Reference inputs:" <+> pretty txInfoReferenceInputs - , "Outputs:" <+> pretty txInfoOutputs - , "Fee:" <+> pretty txInfoFee - , "Value minted:" <+> pretty txInfoMint - , "DCerts:" <+> pretty txInfoDCert - , "Wdrl:" <+> pretty txInfoWdrl - , "Valid range:" <+> pretty txInfoValidRange - , "Signatories:" <+> pretty txInfoSignatories - , "Redeemers:" <+> pretty txInfoRedeemers - , "Datums:" <+> pretty txInfoData - ] + pretty TxInfo {txInfoInputs, txInfoReferenceInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoRedeemers, txInfoData, txInfoId} = + vsep + [ "TxId:" <+> pretty txInfoId + , "Inputs:" <+> pretty txInfoInputs + , "Reference inputs:" <+> pretty txInfoReferenceInputs + , "Outputs:" <+> pretty txInfoOutputs + , "Fee:" <+> pretty txInfoFee + , "Value minted:" <+> pretty txInfoMint + , "DCerts:" <+> pretty txInfoDCert + , "Wdrl:" <+> pretty txInfoWdrl + , "Valid range:" <+> pretty txInfoValidRange + , "Signatories:" <+> pretty txInfoSignatories + , "Redeemers:" <+> pretty txInfoRedeemers + , "Datums:" <+> pretty txInfoData + ] -- | The context that the currently-executing script can access. data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo -- ^ information about the transaction the currently-executing script is included in - , scriptContextPurpose :: ScriptPurpose -- ^ the purpose of the currently-executing script - } - deriving stock (Generic, Haskell.Eq, Haskell.Show) + { scriptContextTxInfo :: TxInfo + -- ^ information about the transaction the currently-executing script is included in + , scriptContextPurpose :: ScriptPurpose + -- ^ the purpose of the currently-executing script + } + deriving stock (Generic, Haskell.Eq, Haskell.Show) instance Pretty ScriptContext where - pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = - vsep - [ "Purpose:" <+> pretty scriptContextPurpose - , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] - ] + pretty ScriptContext {scriptContextTxInfo, scriptContextPurpose} = + vsep + [ "Purpose:" <+> pretty scriptContextPurpose + , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] + ] -- | Find the input currently being validated. findOwnInput :: ScriptContext -> Maybe TxInInfo -findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} = - find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs +findOwnInput ScriptContext {scriptContextTxInfo = TxInfo {txInfoInputs}, scriptContextPurpose = Spending txOutRef} = + find (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs findOwnInput _ = Nothing -{-# INLINABLE findOwnInput #-} +{-# INLINEABLE findOwnInput #-} -- | Find the data corresponding to a data hash, if there is one findDatum :: DatumHash -> TxInfo -> Maybe Datum -findDatum dsh TxInfo{txInfoData} = lookup dsh txInfoData -{-# INLINABLE findDatum #-} +findDatum dsh TxInfo {txInfoData} = lookup dsh txInfoData +{-# INLINEABLE findDatum #-} -- | Find the hash of a datum, if it is part of the pending transaction's -- hashes findDatumHash :: Datum -> TxInfo -> Maybe DatumHash -findDatumHash ds TxInfo{txInfoData} = fst <$> find f (toList txInfoData) - where - f (_, ds') = ds' == ds -{-# INLINABLE findDatumHash #-} - -{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the transaction's inputs (`TxInInfo`). -Note: this only searches the true transaction inputs and not the referenced transaction inputs. --} +findDatumHash ds TxInfo {txInfoData} = fst <$> find f (toList txInfoData) + where + f (_, ds') = ds' == ds +{-# INLINEABLE findDatumHash #-} + +-- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the transaction's inputs (`TxInInfo`). +-- Note: this only searches the true transaction inputs and not the referenced transaction inputs. findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo -findTxInByTxOutRef outRef TxInfo{txInfoInputs} = - find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs -{-# INLINABLE findTxInByTxOutRef #-} +findTxInByTxOutRef outRef TxInfo {txInfoInputs} = + find (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs +{-# INLINEABLE findTxInByTxOutRef #-} -- | Find the indices of all the outputs that pay to the same script address we are currently spending from, if any. findContinuingOutputs :: ScriptContext -> [Integer] -findContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress +findContinuingOutputs ctx | Just TxInInfo {txInInfoResolved = TxOut {txOutAddress}} <- findOwnInput ctx = findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut {txOutAddress = otherAddress} = addr == otherAddress findContinuingOutputs _ = traceError "Le" -- "Can't find any continuing outputs" -{-# INLINABLE findContinuingOutputs #-} +{-# INLINEABLE findContinuingOutputs #-} -- | Get all the outputs that pay to the same script address we are currently spending from, if any. getContinuingOutputs :: ScriptContext -> [TxOut] -getContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress +getContinuingOutputs ctx | Just TxInInfo {txInInfoResolved = TxOut {txOutAddress}} <- findOwnInput ctx = filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut {txOutAddress = otherAddress} = addr == otherAddress getContinuingOutputs _ = traceError "Lf" -- "Can't get any continuing outputs" -{-# INLINABLE getContinuingOutputs #-} +{-# INLINEABLE getContinuingOutputs #-} -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> PubKeyHash -> Bool -txSignedBy TxInfo{txInfoSignatories} k = case find ((==) k) txInfoSignatories of - Just _ -> True - Nothing -> False -{-# INLINABLE txSignedBy #-} +txSignedBy TxInfo {txInfoSignatories} k = case find ((==) k) txInfoSignatories of + Just _ -> True + Nothing -> False +{-# INLINEABLE txSignedBy #-} -- | Get the values paid to a public key address by a pending transaction. pubKeyOutputsAt :: PubKeyHash -> TxInfo -> [Value] pubKeyOutputsAt pk p = - let flt TxOut{txOutAddress = Address (PubKeyCredential pk') _, txOutValue} | pk == pk' = Just txOutValue - flt _ = Nothing - in mapMaybe flt (txInfoOutputs p) -{-# INLINABLE pubKeyOutputsAt #-} + let flt TxOut {txOutAddress = Address (PubKeyCredential pk') _, txOutValue} | pk == pk' = Just txOutValue + flt _ = Nothing + in mapMaybe flt (txInfoOutputs p) +{-# INLINEABLE pubKeyOutputsAt #-} -- | Get the total value paid to a public key address by a pending transaction. valuePaidTo :: TxInfo -> PubKeyHash -> Value valuePaidTo ptx pkh = mconcat (pubKeyOutputsAt pkh ptx) -{-# INLINABLE valuePaidTo #-} +{-# INLINEABLE valuePaidTo #-} -- | Get the total value of inputs spent by this transaction. valueSpent :: TxInfo -> Value valueSpent = F.foldMap (txOutValue . txInInfoResolved) . txInfoInputs -{-# INLINABLE valueSpent #-} +{-# INLINEABLE valueSpent #-} -- | Get the total value of outputs produced by this transaction. valueProduced :: TxInfo -> Value valueProduced = F.foldMap txOutValue . txInfoOutputs -{-# INLINABLE valueProduced #-} +{-# INLINEABLE valueProduced #-} -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextPurpose=Minting cs} = cs -ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" -{-# INLINABLE ownCurrencySymbol #-} - -{- | Check if the pending transaction spends a specific transaction output -(identified by the hash of a transaction and an index into that -transactions' outputs) --} +ownCurrencySymbol ScriptContext {scriptContextPurpose = Minting cs} = cs +ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" +{-# INLINEABLE ownCurrencySymbol #-} + +-- | Check if the pending transaction spends a specific transaction output +-- (identified by the hash of a transaction and an index into that +-- transactions' outputs) spendsOutput :: TxInfo -> TxId -> Integer -> Bool spendsOutput p h i = - let spendsOutRef inp = - let outRef = txInInfoOutRef inp - in h == txOutRefId outRef - && i == txOutRefIdx outRef - - in any spendsOutRef (txInfoInputs p) -{-# INLINABLE spendsOutput #-} + let spendsOutRef inp = + let outRef = txInInfoOutRef inp + in h + == txOutRefId outRef + && i + == txOutRefIdx outRef + in any spendsOutRef (txInfoInputs p) +{-# INLINEABLE spendsOutput #-} ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs index 075f3cb7925..80533d2481c 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- needed for asData pattern synonyms +-- needed for asData pattern synonyms +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-strictness #-} @@ -81,16 +82,31 @@ import Prettyprinter (Pretty (..), nest, vsep, (<+>)) import PlutusLedgerApi.V1.Crypto (PubKeyHash (..)) import PlutusLedgerApi.V1.Data.Address (pattern Address) -import PlutusLedgerApi.V1.Data.Contexts (ScriptPurpose, pattern Certifying, pattern Minting, - pattern Rewarding, pattern Spending) +import PlutusLedgerApi.V1.Data.Contexts ( + ScriptPurpose, + pattern Certifying, + pattern Minting, + pattern Rewarding, + pattern Spending, + ) import PlutusLedgerApi.V1.Data.Credential (StakingCredential, pattern PubKeyCredential) import PlutusLedgerApi.V1.Data.DCert (DCert) import PlutusLedgerApi.V1.Data.Time (POSIXTimeRange) import PlutusLedgerApi.V1.Data.Value (CurrencySymbol, Value) import PlutusLedgerApi.V1.Scripts -import PlutusLedgerApi.V2.Data.Tx (TxId (..), TxOut, TxOutRef, pattern TxOut, pattern TxOutRef, - txOutAddress, txOutDatum, txOutRefId, txOutRefIdx, - txOutReferenceScript, txOutValue) +import PlutusLedgerApi.V2.Data.Tx ( + TxId (..), + TxOut, + TxOutRef, + txOutAddress, + txOutDatum, + txOutRefId, + txOutRefIdx, + txOutReferenceScript, + txOutValue, + pattern TxOut, + pattern TxOutRef, + ) import Prelude qualified as Haskell @@ -98,12 +114,12 @@ import Prelude qualified as Haskell PlutusTx.asData [d| data TxInInfo = TxInInfo - { txInInfoOutRef :: TxOutRef + { txInInfoOutRef :: TxOutRef , txInInfoResolved :: TxOut } deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - |] + |] makeLift ''TxInInfo @@ -111,45 +127,45 @@ instance Eq TxInInfo where TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = + pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -{-| A pending transaction. This is the view as seen by validator scripts, -so some details are stripped out. --} +-- | A pending transaction. This is the view as seen by validator scripts, +-- so some details are stripped out. PlutusTx.asData [d| data TxInfo = TxInfo - { txInfoInputs :: List TxInInfo - -- ^ Transaction inputs; cannot be an empty list - , txInfoReferenceInputs :: List TxInInfo - -- ^ /Added in V2:/ Transaction reference inputs - , txInfoOutputs :: List TxOut - -- ^ Transaction outputs - , txInfoFee :: Value - -- ^ The fee paid by this transaction. - , txInfoMint :: Value - -- ^ The 'Value' minted by this transaction. - , txInfoDCert :: List DCert - -- ^ Digests of certificates included in this transaction - , txInfoWdrl :: Map StakingCredential Integer - -- ^ Withdrawals - -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' - , txInfoValidRange :: POSIXTimeRange - -- ^ The valid range for the transaction. - , txInfoSignatories :: List PubKeyHash - -- ^ Signatures provided with the transaction, attested that they all signed the tx - , txInfoRedeemers :: Map ScriptPurpose Redeemer - -- ^ /Added in V2:/ a table of redeemers attached to the transaction - , txInfoData :: Map DatumHash Datum - -- ^ The lookup table of datums attached to the transaction - -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' - , txInfoId :: TxId - -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + { txInfoInputs :: List TxInInfo + , -- \^ Transaction inputs; cannot be an empty list + txInfoReferenceInputs :: List TxInInfo + , -- \^ /Added in V2:/ Transaction reference inputs + txInfoOutputs :: List TxOut + , -- \^ Transaction outputs + txInfoFee :: Value + , -- \^ The fee paid by this transaction. + txInfoMint :: Value + , -- \^ The 'Value' minted by this transaction. + txInfoDCert :: List DCert + , -- \^ Digests of certificates included in this transaction + txInfoWdrl :: Map StakingCredential Integer + , -- \^ Withdrawals + -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' + txInfoValidRange :: POSIXTimeRange + , -- \^ The valid range for the transaction. + txInfoSignatories :: List PubKeyHash + , -- \^ Signatures provided with the transaction, attested that they all signed the tx + txInfoRedeemers :: Map ScriptPurpose Redeemer + , -- \^ /Added in V2:/ a table of redeemers attached to the transaction + txInfoData :: Map DatumHash Datum + , -- \^ The lookup table of datums attached to the transaction + -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' + txInfoId :: TxId } + -- \^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + deriving stock (Generic, Haskell.Show) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - |] + |] makeLift ''TxInfo @@ -188,19 +204,20 @@ instance Pretty TxInfo where PlutusTx.asData [d| data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo - -- ^ information about the transaction the currently-executing script is included in - , scriptContextPurpose :: ScriptPurpose - -- ^ the purpose of the currently-executing script + { scriptContextTxInfo :: TxInfo + , -- \^ information about the transaction the currently-executing script is included in + scriptContextPurpose :: ScriptPurpose } + -- \^ the purpose of the currently-executing script + deriving stock (Generic, Haskell.Show) deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) - |] + |] makeLift ''ScriptContext instance Pretty ScriptContext where - pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = + pretty ScriptContext {scriptContextTxInfo, scriptContextPurpose} = vsep [ "Purpose:" <+> pretty scriptContextPurpose , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] @@ -210,78 +227,74 @@ instance Pretty ScriptContext where findOwnInput :: ScriptContext -> Maybe TxInInfo findOwnInput ScriptContext - { scriptContextTxInfo = TxInfo{txInfoInputs} + { scriptContextTxInfo = TxInfo {txInfoInputs} , scriptContextPurpose = Spending txOutRef } = Data.List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs findOwnInput _ = Nothing {-# INLINEABLE findOwnInput #-} -- | Find the data corresponding to a data hash, if there is one findDatum :: DatumHash -> TxInfo -> Maybe Datum -findDatum dsh TxInfo{txInfoData} = lookup dsh txInfoData +findDatum dsh TxInfo {txInfoData} = lookup dsh txInfoData {-# INLINEABLE findDatum #-} -{-| Find the hash of a datum, if it is part of the pending transaction's -hashes --} +-- | Find the hash of a datum, if it is part of the pending transaction's +-- hashes findDatumHash :: Datum -> TxInfo -> Maybe DatumHash -findDatumHash ds TxInfo{txInfoData} = fst <$> List.find f (toSOPList txInfoData) - where - f (_, ds') = ds' == ds +findDatumHash ds TxInfo {txInfoData} = fst <$> List.find f (toSOPList txInfoData) + where + f (_, ds') = ds' == ds {-# INLINEABLE findDatumHash #-} -{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one -of the transaction's inputs (`TxInInfo`). -Note: this only searches the true transaction inputs and not the referenced -transaction inputs. --} +-- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one +-- of the transaction's inputs (`TxInInfo`). +-- Note: this only searches the true transaction inputs and not the referenced +-- transaction inputs. findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo -findTxInByTxOutRef outRef TxInfo{txInfoInputs} = +findTxInByTxOutRef outRef TxInfo {txInfoInputs} = Data.List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs {-# INLINEABLE findTxInByTxOutRef #-} -{-| Find the indices of all the outputs that pay to the same script address -we are currently spending from, if any. --} +-- | Find the indices of all the outputs that pay to the same script address +-- we are currently spending from, if any. findContinuingOutputs :: ScriptContext -> List Integer findContinuingOutputs ctx | Just TxInInfo - { txInInfoResolved = TxOut{txOutAddress = addr} + { txInInfoResolved = TxOut {txOutAddress = addr} } <- findOwnInput ctx = Data.List.findIndices (f addr) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress = otherAddress} = addr == otherAddress + where + f addr TxOut {txOutAddress = otherAddress} = addr == otherAddress findContinuingOutputs _ = traceError "Le" -- "Can't find any continuing outputs" {-# INLINEABLE findContinuingOutputs #-} -{-| Get all the outputs that pay to the same script address we are currently spending -from, if any. --} +-- | Get all the outputs that pay to the same script address we are currently spending +-- from, if any. getContinuingOutputs :: ScriptContext -> List TxOut getContinuingOutputs ctx | Just TxInInfo - { txInInfoResolved = TxOut{txOutAddress = addr} + { txInInfoResolved = TxOut {txOutAddress = addr} } <- findOwnInput ctx = Data.List.filter (f addr) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress = otherAddress} = addr == otherAddress + where + f addr TxOut {txOutAddress = otherAddress} = addr == otherAddress getContinuingOutputs _ = traceError "Lf" -- "Can't get any continuing outputs" {-# INLINEABLE getContinuingOutputs #-} -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> PubKeyHash -> Bool -txSignedBy TxInfo{txInfoSignatories} k = +txSignedBy TxInfo {txInfoSignatories} k = case Data.List.find ((==) k) txInfoSignatories of - Just _ -> True + Just _ -> True Nothing -> False {-# INLINEABLE txSignedBy #-} @@ -314,15 +327,14 @@ valueProduced = Data.List.foldMap txOutValue . txInfoOutputs -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextPurpose = Minting cs} = cs +ownCurrencySymbol ScriptContext {scriptContextPurpose = Minting cs} = cs ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" {-# INLINEABLE ownCurrencySymbol #-} -{-| Check if the pending transaction spends a specific transaction output -(identified by the hash of a transaction and an index into that -transactions' outputs) --} +-- | Check if the pending transaction spends a specific transaction output +-- (identified by the hash of a transaction and an index into that +-- transactions' outputs) spendsOutput :: TxInfo -> TxId -> Integer -> Bool spendsOutput p h i = let spendsOutRef inp = diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs index 87dcedf467b..11278e5935b 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +-- needed for asData pattern synonyms +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- needed for asData pattern synonyms {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -57,15 +58,25 @@ import PlutusTx.Eq qualified as PlutusTx import PlutusLedgerApi.V1.Crypto import PlutusLedgerApi.V1.Data.Address -import PlutusLedgerApi.V1.Data.Tx hiding (TxOut, isPayToScriptOut, isPubKeyOut, outAddress, - outValue, pattern TxOut, pubKeyHashTxOut, txOutAddress, - txOutDatum, txOutDatumHash, txOutPubKey, txOutValue) +import PlutusLedgerApi.V1.Data.Tx hiding ( + TxOut, + isPayToScriptOut, + isPubKeyOut, + outAddress, + outValue, + pubKeyHashTxOut, + txOutAddress, + txOutDatum, + txOutDatumHash, + txOutPubKey, + txOutValue, + pattern TxOut, + ) import PlutusLedgerApi.V1.Data.Value import PlutusLedgerApi.V1.Scripts -{-| The datum attached to an output: either nothing; a datum hash; -or the datum itself (an "inline datum"). --} +-- | The datum attached to an output: either nothing; a datum hash; +-- or the datum itself (an "inline datum"). PlutusTx.asData [d| data OutputDatum = NoOutputDatum | OutputDatumHash DatumHash | OutputDatum Datum @@ -76,19 +87,18 @@ PlutusTx.asData instance PlutusTx.Eq OutputDatum where {-# INLINEABLE (==) #-} - NoOutputDatum == NoOutputDatum = True + NoOutputDatum == NoOutputDatum = True (OutputDatumHash dh) == (OutputDatumHash dh') = dh PlutusTx.== dh' - (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' - _ == _ = False + (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' + _ == _ = False instance Pretty OutputDatum where - pretty NoOutputDatum = "no datum" + pretty NoOutputDatum = "no datum" pretty (OutputDatumHash dh) = "datum hash: " <+> pretty dh - pretty (OutputDatum d) = "inline datum : " <+> pretty d + pretty (OutputDatum d) = "inline datum : " <+> pretty d -{-| A transaction output, consisting of a target address, a value, -optionally a datum/datum hash, and optionally a reference script. --} +-- | A transaction output, consisting of a target address, a value, +-- optionally a datum/datum hash, and optionally a reference script. PlutusTx.asData [d| data TxOut = TxOut @@ -102,7 +112,7 @@ PlutusTx.asData |] instance Pretty TxOut where - pretty TxOut{txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = + pretty TxOut {txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = hang 2 $ vsep [ "-" <+> pretty txOutValue <+> "addressed to" @@ -137,28 +147,27 @@ txOutScriptHash = toScriptHash . txOutAddress -- | The address of a transaction output. outAddress :: Lens' TxOut Address outAddress = lens txOutAddress s - where - s tx a = tx{txOutAddress = a} + where + s tx a = tx {txOutAddress = a} -- | The datum attached to a 'TxOut'. outDatum :: Lens' TxOut OutputDatum outDatum = lens txOutDatum s - where - s tx v = tx{txOutDatum = v} + where + s tx v = tx {txOutDatum = v} -{-| The value of a transaction output. -| TODO: Compute address again --} +-- | The value of a transaction output. +-- | TODO: Compute address again outValue :: Lens' TxOut Value outValue = lens txOutValue s - where - s tx v = tx{txOutValue = v} + where + s tx v = tx {txOutValue = v} -- | The reference script attached to a 'TxOut'. outReferenceScript :: Lens' TxOut (Maybe ScriptHash) outReferenceScript = lens txOutReferenceScript s - where - s tx v = tx{txOutReferenceScript = v} + where + s tx v = tx {txOutReferenceScript = v} -- | Whether the output is a pay-to-pubkey output. isPubKeyOut :: TxOut -> Bool diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 80bf7ea4373..82d6687b1d5 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -1,13 +1,14 @@ -- editorconfig-checker-disable {-# LANGUAGE TypeApplications #-} -module PlutusLedgerApi.V2.EvaluationContext - ( EvaluationContext - , mkEvaluationContext - , CostModelParams - , assertWellFormedCostModelParams - , toMachineParameters - , CostModelApplyError (..) - ) where + +module PlutusLedgerApi.V2.EvaluationContext ( + EvaluationContext, + mkEvaluationContext, + CostModelParams, + assertWellFormedCostModelParams, + toMachineParameters, + CostModelApplyError (..), +) where import PlutusLedgerApi.Common import PlutusLedgerApi.V2.ParamName as V2 @@ -19,34 +20,36 @@ import Control.Monad import Control.Monad.Writer.Strict import Data.Int (Int64) -{-| Build the 'EvaluationContext'. - -The input is a list of cost model parameters (which are integer values) passed -from the ledger. - -IMPORTANT: the cost model parameters __MUST__ appear in the correct order, -matching the names in `PlutusLedgerApi.V2.ParamName`. If the parameters are -supplied in the wrong order then script cost calculations will be incorrect. - -IMPORTANT: The evaluation context of every Plutus version must be recreated upon -a protocol update with the updated cost model parameters. --} -mkEvaluationContext - :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) - => [Int64] -- ^ the (updated) cost model parameters of the protocol - -> m EvaluationContext +-- | Build the 'EvaluationContext'. +-- +-- The input is a list of cost model parameters (which are integer values) passed +-- from the ledger. +-- +-- IMPORTANT: the cost model parameters __MUST__ appear in the correct order, +-- matching the names in `PlutusLedgerApi.V2.ParamName`. If the parameters are +-- supplied in the wrong order then script cost calculations will be incorrect. +-- +-- IMPORTANT: The evaluation context of every Plutus version must be recreated upon +-- a protocol update with the updated cost model parameters. +mkEvaluationContext :: + (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => + -- | the (updated) cost model parameters of the protocol + [Int64] -> + m EvaluationContext mkEvaluationContext = tagWithParamNames @V2.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - PlutusV2 - (\pv -> + PlutusV2 + ( \pv -> if pv < pv11PV then unavailableCaserBuiltin $ getMajorProtocolVersion pv - else CaserBuiltin caseBuiltin) - [DefaultFunSemanticsVariantA, DefaultFunSemanticsVariantB] - -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. - (\pv -> + else CaserBuiltin caseBuiltin + ) + [DefaultFunSemanticsVariantA, DefaultFunSemanticsVariantB] + -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. + ( \pv -> if pv < changPV then DefaultFunSemanticsVariantA - else DefaultFunSemanticsVariantB) + else DefaultFunSemanticsVariantB + ) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs index c56ad46f51e..8b417aef162 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs @@ -1,21 +1,21 @@ {-# LANGUAGE DerivingVia #-} -module PlutusLedgerApi.V2.ParamName - ( ParamName (..) - , tagWithParamNames - ) where + +module PlutusLedgerApi.V2.ParamName ( + ParamName (..), + tagWithParamNames, +) where import Data.Ix import GHC.Generics import PlutusLedgerApi.Common.ParamName -{-| The enumeration of all possible cost model parameter names for this language version. - -IMPORTANT: The order of appearance of the data constructors here matters. DO NOT REORDER. -See Note [Quotation marks in cost model parameter constructors] -See Note [Cost model parameters from the ledger's point of view] --} -data ParamName = - AddInteger'cpu'arguments'intercept +-- | The enumeration of all possible cost model parameter names for this language version. +-- +-- IMPORTANT: The order of appearance of the data constructors here matters. DO NOT REORDER. +-- See Note [Quotation marks in cost model parameter constructors] +-- See Note [Cost model parameters from the ledger's point of view] +data ParamName + = AddInteger'cpu'arguments'intercept | AddInteger'cpu'arguments'slope | AddInteger'memory'arguments'intercept | AddInteger'memory'arguments'slope @@ -190,9 +190,9 @@ data ParamName = | VerifySchnorrSecp256k1Signature'cpu'arguments'intercept | VerifySchnorrSecp256k1Signature'cpu'arguments'slope | VerifySchnorrSecp256k1Signature'memory'arguments - -- End of original cost model parameters - -- `integerToByteString` and `byteStringToInteger` enabled in V2 at Plomin - | IntegerToByteString'cpu'arguments'c0 + | -- End of original cost model parameters + -- `integerToByteString` and `byteStringToInteger` enabled in V2 at Plomin + IntegerToByteString'cpu'arguments'c0 | IntegerToByteString'cpu'arguments'c1 | IntegerToByteString'cpu'arguments'c2 | IntegerToByteString'memory'arguments'intercept @@ -202,8 +202,8 @@ data ParamName = | ByteStringToInteger'cpu'arguments'c2 | ByteStringToInteger'memory'arguments'intercept | ByteStringToInteger'memory'arguments'slope - -- Remaining parameters to be deployed in PV11 - | CekConstrCost'exBudgetCPU + | -- Remaining parameters to be deployed in PV11 + CekConstrCost'exBudgetCPU | CekConstrCost'exBudgetMemory | CekCaseCost'exBudgetCPU | CekCaseCost'exBudgetMemory @@ -297,8 +297,8 @@ data ParamName = | Ripemd_160'cpu'arguments'intercept | Ripemd_160'cpu'arguments'slope | Ripemd_160'memory'arguments - -- To be deployed in PV11 - | ExpModInteger'cpu'arguments'coefficient00 + | -- To be deployed in PV11 + ExpModInteger'cpu'arguments'coefficient00 | ExpModInteger'cpu'arguments'coefficient11 | ExpModInteger'cpu'arguments'coefficient12 | ExpModInteger'memory'arguments'intercept @@ -320,5 +320,5 @@ data ParamName = | Bls12_381_G2_multiScalarMul'cpu'arguments'intercept | Bls12_381_G2_multiScalarMul'cpu'arguments'slope | Bls12_381_G2_multiScalarMul'memory'arguments - deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) - deriving IsParamName via (GenericParamName ParamName) + deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) + deriving (IsParamName) via (GenericParamName ParamName) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs index 158c5317074..b230f6b6459 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -47,46 +47,52 @@ import PlutusTx.Lift (makeLift) import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress, toPubKeyHash, toScriptHash) import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V1.Scripts (Datum, DatumHash, ScriptHash) -import PlutusLedgerApi.V1.Tx hiding (TxOut (..), isPayToScriptOut, isPubKeyOut, outAddress, - outValue, pubKeyHashTxOut, txOutDatum, txOutPubKey) +import PlutusLedgerApi.V1.Tx hiding ( + TxOut (..), + isPayToScriptOut, + isPubKeyOut, + outAddress, + outValue, + pubKeyHashTxOut, + txOutDatum, + txOutPubKey, + ) import PlutusLedgerApi.V1.Value (Value) import PlutusTx.Blueprint.Definition (HasBlueprintDefinition, definitionRef) -{- | The datum attached to an output: - either nothing; - a datum hash; - or the datum itself (an "inline datum"). --} +-- | The datum attached to an output: +-- either nothing; +-- a datum hash; +-- or the datum itself (an "inline datum"). data OutputDatum = NoOutputDatum | OutputDatumHash DatumHash | OutputDatum Datum deriving stock (Show, Eq, Generic) deriving anyclass (NFData, HasBlueprintDefinition) instance PlutusTx.Eq OutputDatum where {-# INLINEABLE (==) #-} - NoOutputDatum == NoOutputDatum = True + NoOutputDatum == NoOutputDatum = True (OutputDatumHash dh) == (OutputDatumHash dh') = dh PlutusTx.== dh' - (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' - _ == _ = False + (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' + _ == _ = False instance Pretty OutputDatum where - pretty NoOutputDatum = "no datum" + pretty NoOutputDatum = "no datum" pretty (OutputDatumHash dh) = "datum hash: " <+> pretty dh - pretty (OutputDatum d) = "inline datum : " <+> pretty d + pretty (OutputDatum d) = "inline datum : " <+> pretty d -{- | A transaction output, consisting of a target address, a value, -optionally a datum/datum hash, and optionally a reference script. --} +-- | A transaction output, consisting of a target address, a value, +-- optionally a datum/datum hash, and optionally a reference script. data TxOut = TxOut - { txOutAddress :: Address - , txOutValue :: Value - , txOutDatum :: OutputDatum + { txOutAddress :: Address + , txOutValue :: Value + , txOutDatum :: OutputDatum , txOutReferenceScript :: Maybe ScriptHash } deriving stock (Show, Eq, Generic) deriving anyclass (NFData, HasBlueprintDefinition) instance Pretty TxOut where - pretty TxOut{txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = + pretty TxOut {txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = hang 2 $ vsep [ "-" @@ -114,37 +120,36 @@ instance PlutusTx.Eq TxOut where -- | The public key attached to a 'TxOut', if there is one. txOutPubKey :: TxOut -> Maybe PubKeyHash -txOutPubKey TxOut{txOutAddress} = toPubKeyHash txOutAddress +txOutPubKey TxOut {txOutAddress} = toPubKeyHash txOutAddress -- | The validator hash attached to a 'TxOut', if there is one. txOutScriptHash :: TxOut -> Maybe ScriptHash -txOutScriptHash TxOut{txOutAddress} = toScriptHash txOutAddress +txOutScriptHash TxOut {txOutAddress} = toScriptHash txOutAddress -- | The address of a transaction output. outAddress :: Lens' TxOut Address outAddress = lens txOutAddress s - where - s tx a = tx{txOutAddress = a} + where + s tx a = tx {txOutAddress = a} -- | The datum attached to a 'TxOut'. outDatum :: Lens' TxOut OutputDatum outDatum = lens txOutDatum s - where - s tx v = tx{txOutDatum = v} + where + s tx v = tx {txOutDatum = v} -{- | The value of a transaction output. -| TODO: Compute address again --} +-- | The value of a transaction output. +-- | TODO: Compute address again outValue :: Lens' TxOut Value outValue = lens txOutValue s - where - s tx v = tx{txOutValue = v} + where + s tx v = tx {txOutValue = v} -- | The reference script attached to a 'TxOut'. outReferenceScript :: Lens' TxOut (Maybe ScriptHash) outReferenceScript = lens txOutReferenceScript s - where - s tx v = tx{txOutReferenceScript = v} + where + s tx v = tx {txOutReferenceScript = v} -- | Whether the output is a pay-to-pubkey output. isPubKeyOut :: TxOut -> Bool @@ -165,10 +170,10 @@ $(makeLift ''OutputDatum) $(makeLift ''TxOut) $( makeIsDataSchemaIndexed - ''OutputDatum - [ ('NoOutputDatum, 0) - , ('OutputDatumHash, 1) - , ('OutputDatum, 2) - ] + ''OutputDatum + [ ('NoOutputDatum, 0) + , ('OutputDatumHash, 1) + , ('OutputDatum, 2) + ] ) $(makeIsDataSchemaIndexed ''TxOut [('TxOut, 0)]) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3.hs index 6b00a3dff89..06a4a0dda0e 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3.hs @@ -164,19 +164,17 @@ import PlutusLedgerApi.V3.ParamName qualified as ParamName import PlutusLedgerApi.V3.Tx qualified as Tx import PlutusTx.Ratio qualified as Ratio -{- | An alias to the Plutus ledger language this module exposes at runtime. - MAYBE: Use CPP '__FILE__' + some TH to automate this. --} +-- | An alias to the Plutus ledger language this module exposes at runtime. +-- MAYBE: Use CPP '__FILE__' + some TH to automate this. thisLedgerLanguage :: Common.PlutusLedgerLanguage thisLedgerLanguage = Common.PlutusV3 -{- | The deserialization from a serialised script into a `ScriptForEvaluation`, -ready to be evaluated on-chain. -Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). --} +-- | The deserialization from a serialised script into a `ScriptForEvaluation`, +-- ready to be evaluated on-chain. +-- Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). deserialiseScript :: forall m. - (Common.MonadError Common.ScriptDecodeError m) => + Common.MonadError Common.ScriptDecodeError m => -- | which major protocol version the script was submitted in. Common.MajorProtocolVersion -> -- | the script to deserialise. @@ -184,11 +182,10 @@ deserialiseScript :: m Common.ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{- | Evaluates a script, returning the minimum budget that the script would need -to evaluate successfully. This will take as long as the script takes, if you need to -limit the execution time of the script also, you can use 'evaluateScriptRestricting', which -also returns the used budget. --} +-- | Evaluates a script, returning the minimum budget that the script would need +-- to evaluate successfully. This will take as long as the script takes, if you need to +-- limit the execution time of the script also, you can use 'evaluateScriptRestricting', which +-- also returns the used budget. evaluateScriptCounting :: -- | Which protocol version to run the operation in Common.MajorProtocolVersion -> @@ -204,13 +201,12 @@ evaluateScriptCounting :: evaluateScriptCounting mpv verbose ec s arg = Common.evaluateScriptCounting thisLedgerLanguage mpv verbose ec s [arg] -{- | Evaluates a script, with a cost model and a budget that restricts how many -resources it can use according to the cost model. Also returns the budget that -was actually used. - -Can be used to calculate budgets for scripts, but even in this case you must give -a limit to guard against scripts that run for a long time or loop. --} +-- | Evaluates a script, with a cost model and a budget that restricts how many +-- resources it can use according to the cost model. Also returns the budget that +-- was actually used. +-- +-- Can be used to calculate budgets for scripts, but even in this case you must give +-- a limit to guard against scripts that run for a long time or loop. evaluateScriptRestricting :: -- | Which protocol version to run the operation in Common.MajorProtocolVersion -> diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs index e123ff31392..c9dd46d1f65 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs @@ -1,16 +1,16 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -63,8 +63,14 @@ import PlutusLedgerApi.V3.Tx qualified as V3 import PlutusTx (makeIsDataSchemaIndexed) import PlutusTx qualified import PlutusTx.AssocMap (Map, lookup, toList) -import PlutusTx.Blueprint (HasBlueprintDefinition, HasBlueprintSchema, HasSchemaDefinition, - Schema (SchemaBuiltInData), SchemaInfo (..), emptySchemaInfo) +import PlutusTx.Blueprint ( + HasBlueprintDefinition, + HasBlueprintSchema, + HasSchemaDefinition, + Schema (SchemaBuiltInData), + SchemaInfo (..), + emptySchemaInfo, + ) import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) import PlutusTx.Blueprint.Definition.Derive (definitionRef) import PlutusTx.Blueprint.Schema (withSchemaInfo) @@ -73,9 +79,9 @@ import PlutusTx.Lift (makeLift) import PlutusTx.List qualified as List import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.Ratio (Rational) -import Prelude qualified as Haskell import Prettyprinter (nest, vsep, (<+>)) import Prettyprinter.Extras (Pretty (pretty), PrettyShow (PrettyShow)) +import Prelude qualified as Haskell newtype ColdCommitteeCredential = ColdCommitteeCredential V2.Credential deriving stock (Generic) @@ -99,7 +105,7 @@ instance where schema = schema @V2.Credential @referencedTypes - & withSchemaInfo \info -> info{title = Just "ColdCommitteeCredential"} + & withSchemaInfo \info -> info {title = Just "ColdCommitteeCredential"} newtype HotCommitteeCredential = HotCommitteeCredential V2.Credential deriving stock (Generic) @@ -123,7 +129,7 @@ instance where schema = schema @V2.Credential - & withSchemaInfo \info -> info{title = Just "HotCommitteeCredential"} + & withSchemaInfo \info -> info {title = Just "HotCommitteeCredential"} newtype DRepCredential = DRepCredential V2.Credential deriving stock (Generic) @@ -147,7 +153,7 @@ instance where schema = schema @V2.Credential - & withSchemaInfo \info -> info{title = Just "DRepCredential"} + & withSchemaInfo \info -> info {title = Just "DRepCredential"} data DRep = DRep DRepCredential @@ -159,10 +165,10 @@ data DRep instance PlutusTx.Eq DRep where {-# INLINEABLE (==) #-} - DRep a == DRep a' = a PlutusTx.== a' - DRepAlwaysAbstain == DRepAlwaysAbstain = Haskell.True + DRep a == DRep a' = a PlutusTx.== a' + DRepAlwaysAbstain == DRepAlwaysAbstain = Haskell.True DRepAlwaysNoConfidence == DRepAlwaysNoConfidence = Haskell.True - _ == _ = Haskell.False + _ == _ = Haskell.False data Delegatee = DelegStake V2.PubKeyHash @@ -262,21 +268,21 @@ data Vote instance PlutusTx.Eq Vote where {-# INLINEABLE (==) #-} - VoteNo == VoteNo = Haskell.True + VoteNo == VoteNo = Haskell.True VoteYes == VoteYes = Haskell.True Abstain == Abstain = Haskell.True - _ == _ = Haskell.False + _ == _ = Haskell.False -- | Similar to TxOutRef, but for GovActions data GovernanceActionId = GovernanceActionId - { gaidTxId :: V3.TxId + { gaidTxId :: V3.TxId , gaidGovActionIx :: Haskell.Integer } deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) deriving anyclass (HasBlueprintDefinition) instance Pretty GovernanceActionId where - pretty GovernanceActionId{..} = + pretty GovernanceActionId {..} = vsep [ "gaidTxId:" <+> pretty gaidTxId , "gaidGovActionIx:" <+> pretty gaidGovActionIx @@ -290,14 +296,14 @@ instance PlutusTx.Eq GovernanceActionId where data Committee = Committee { committeeMembers :: Map ColdCommitteeCredential Haskell.Integer -- ^ Committee members with epoch number when each of them expires - , committeeQuorum :: PlutusTx.Rational + , committeeQuorum :: PlutusTx.Rational -- ^ Quorum of the committee that is necessary for a successful vote } deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) deriving anyclass (HasBlueprintDefinition) instance Pretty Committee where - pretty Committee{..} = + pretty Committee {..} = vsep [ "committeeMembers:" <+> pretty committeeMembers , "committeeQuorum:" <+> pretty committeeQuorum @@ -326,7 +332,7 @@ data ProtocolVersion = ProtocolVersion deriving anyclass (HasBlueprintDefinition) instance Pretty ProtocolVersion where - pretty ProtocolVersion{..} = + pretty ProtocolVersion {..} = vsep [ "pvMajor:" <+> pretty pvMajor , "pvMinor:" <+> pretty pvMinor @@ -337,33 +343,32 @@ instance PlutusTx.Eq ProtocolVersion where ProtocolVersion a b == ProtocolVersion a' b' = a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' -{- | A Plutus Data object containing proposed parameter changes. The Data object contains -a @Map@ with one entry per changed parameter, from the parameter ID to the new value. -Unchanged parameters are not included. - -The mapping from parameter IDs to parameters can be found in -[conway.cddl](https://github.com/IntersectMBO/cardano-ledger/blob/master/eras/conway/impl/cddl-files/conway.cddl). - -/Invariant:/ This map is non-empty, and the keys are stored in ascending order. - -This `Data` object has the following format (in pseudocode): - -ChangedParametersData = Map ChangedIdData ChangedManyValueData -ChangedIdData = I Integer -ChangedManyValueData = - ChangedSingleValueData - | List[ChangedSingleValueData...] - -- ^ an arbitrary-length, heterogeneous (integer or ratio) list of values (to support sub-parameters) - -ChangedSingleValueData = - I Integer -- a proposed integer value - | List[I Integer, I Integer] -- a proposed numerator,denominator (ratio value) - -- ^ a 2-exact element list; *BE CAREFUL* because this can be alternatively (ambiguously) interpreted - -- as a many-value data (sub-parameter) of two integer single-value data. - -, where Map,I,List are the constructors of `PlutusCore.Data` -and Integer is the usual arbitrary-precision PlutusTx/Haskell Integer. --} +-- | A Plutus Data object containing proposed parameter changes. The Data object contains +-- a @Map@ with one entry per changed parameter, from the parameter ID to the new value. +-- Unchanged parameters are not included. +-- +-- The mapping from parameter IDs to parameters can be found in +-- [conway.cddl](https://github.com/IntersectMBO/cardano-ledger/blob/master/eras/conway/impl/cddl-files/conway.cddl). +-- +-- /Invariant:/ This map is non-empty, and the keys are stored in ascending order. +-- +-- This `Data` object has the following format (in pseudocode): +-- +-- ChangedParametersData = Map ChangedIdData ChangedManyValueData +-- ChangedIdData = I Integer +-- ChangedManyValueData = +-- ChangedSingleValueData +-- | List[ChangedSingleValueData...] +-- -- ^ an arbitrary-length, heterogeneous (integer or ratio) list of values (to support sub-parameters) +-- +-- ChangedSingleValueData = +-- I Integer -- a proposed integer value +-- | List[I Integer, I Integer] -- a proposed numerator,denominator (ratio value) +-- -- ^ a 2-exact element list; *BE CAREFUL* because this can be alternatively (ambiguously) interpreted +-- -- as a many-value data (sub-parameter) of two integer single-value data. +-- +-- , where Map,I,List are the constructors of `PlutusCore.Data` +-- and Integer is the usual arbitrary-precision PlutusTx/Haskell Integer. newtype ChangedParameters = ChangedParameters {getChangedParameters :: PlutusTx.BuiltinData} deriving stock (Generic, Haskell.Show) deriving anyclass (HasBlueprintDefinition) @@ -378,7 +383,7 @@ newtype ChangedParameters = ChangedParameters {getChangedParameters :: PlutusTx. ) instance HasBlueprintSchema ChangedParameters referencedTypes where - schema = SchemaBuiltInData emptySchemaInfo{title = Just "ChangedParameters"} + schema = SchemaBuiltInData emptySchemaInfo {title = Just "ChangedParameters"} data GovernanceAction = -- | Hash of the constitution script @@ -409,15 +414,15 @@ data GovernanceAction -- | A proposal procedure. The optional anchor is omitted. data ProposalProcedure = ProposalProcedure - { ppDeposit :: V2.Lovelace - , ppReturnAddr :: V2.Credential + { ppDeposit :: V2.Lovelace + , ppReturnAddr :: V2.Credential , ppGovernanceAction :: GovernanceAction } deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) deriving anyclass (HasBlueprintDefinition) instance Pretty ProposalProcedure where - pretty ProposalProcedure{..} = + pretty ProposalProcedure {..} = vsep [ "ppDeposit:" <+> pretty ppDeposit , "ppReturnAddr:" <+> pretty ppReturnAddr @@ -462,7 +467,7 @@ data ScriptInfo -- | An input of a pending transaction. data TxInInfo = TxInInfo - { txInInfoOutRef :: V3.TxOutRef + { txInInfoOutRef :: V3.TxOutRef , txInInfoResolved :: V2.TxOut } deriving stock (Generic, Haskell.Show, Haskell.Eq) @@ -473,37 +478,37 @@ instance PlutusTx.Eq TxInInfo where ref PlutusTx.== ref' PlutusTx.&& res PlutusTx.== res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = + pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -- | TxInfo for PlutusV3 data TxInfo = TxInfo - { txInfoInputs :: [TxInInfo] - , txInfoReferenceInputs :: [TxInInfo] - , txInfoOutputs :: [V2.TxOut] - , txInfoFee :: V2.Lovelace - , txInfoMint :: V3.MintValue + { txInfoInputs :: [TxInInfo] + , txInfoReferenceInputs :: [TxInInfo] + , txInfoOutputs :: [V2.TxOut] + , txInfoFee :: V2.Lovelace + , txInfoMint :: V3.MintValue -- ^ The 'Value' minted by this transaction. -- -- /Invariant:/ This field does not contain Ada with zero quantity, unlike -- their namesakes in Plutus V1 and V2's ScriptContexts. - , txInfoTxCerts :: [TxCert] - , txInfoWdrl :: Map V2.Credential V2.Lovelace - , txInfoValidRange :: V2.POSIXTimeRange - , txInfoSignatories :: [V2.PubKeyHash] - , txInfoRedeemers :: Map ScriptPurpose V2.Redeemer - , txInfoData :: Map V2.DatumHash V2.Datum - , txInfoId :: V3.TxId - , txInfoVotes :: Map Voter (Map GovernanceActionId Vote) - , txInfoProposalProcedures :: [ProposalProcedure] + , txInfoTxCerts :: [TxCert] + , txInfoWdrl :: Map V2.Credential V2.Lovelace + , txInfoValidRange :: V2.POSIXTimeRange + , txInfoSignatories :: [V2.PubKeyHash] + , txInfoRedeemers :: Map ScriptPurpose V2.Redeemer + , txInfoData :: Map V2.DatumHash V2.Datum + , txInfoId :: V3.TxId + , txInfoVotes :: Map Voter (Map GovernanceActionId Vote) + , txInfoProposalProcedures :: [ProposalProcedure] , txInfoCurrentTreasuryAmount :: Haskell.Maybe V2.Lovelace - , txInfoTreasuryDonation :: Haskell.Maybe V2.Lovelace + , txInfoTreasuryDonation :: Haskell.Maybe V2.Lovelace } deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving anyclass (HasBlueprintDefinition) instance Pretty TxInfo where - pretty TxInfo{..} = + pretty TxInfo {..} = vsep [ "TxId:" <+> pretty txInfoId , "Inputs:" <+> pretty txInfoInputs @@ -525,9 +530,9 @@ instance Pretty TxInfo where -- | The context that the currently-executing script can access. data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo + { scriptContextTxInfo :: TxInfo -- ^ information about the transaction the currently-executing script is included in - , scriptContextRedeemer :: V2.Redeemer + , scriptContextRedeemer :: V2.Redeemer -- ^ Redeemer for the currently-executing script , scriptContextScriptInfo :: ScriptInfo -- ^ the purpose of the currently-executing script, along with information associated @@ -537,7 +542,7 @@ data ScriptContext = ScriptContext deriving anyclass (HasBlueprintDefinition) instance Pretty ScriptContext where - pretty ScriptContext{..} = + pretty ScriptContext {..} = vsep [ "ScriptInfo:" <+> pretty scriptContextScriptInfo , nest 2 (vsep ["TxInfo:", pretty scriptContextTxInfo]) @@ -548,82 +553,77 @@ instance Pretty ScriptContext where findOwnInput :: ScriptContext -> Haskell.Maybe TxInInfo findOwnInput ScriptContext - { scriptContextTxInfo = TxInfo{txInfoInputs} + { scriptContextTxInfo = TxInfo {txInfoInputs} , scriptContextScriptInfo = SpendingScript txOutRef _ } = List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef PlutusTx.== txOutRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef PlutusTx.== txOutRef) txInfoInputs findOwnInput _ = Haskell.Nothing {-# INLINEABLE findOwnInput #-} -- | Find the data corresponding to a data hash, if there is one findDatum :: V2.DatumHash -> TxInfo -> Haskell.Maybe V2.Datum -findDatum dsh TxInfo{txInfoData} = lookup dsh txInfoData +findDatum dsh TxInfo {txInfoData} = lookup dsh txInfoData {-# INLINEABLE findDatum #-} -{- | Find the hash of a datum, if it is part of the pending transaction's -hashes --} +-- | Find the hash of a datum, if it is part of the pending transaction's +-- hashes findDatumHash :: V2.Datum -> TxInfo -> Haskell.Maybe V2.DatumHash -findDatumHash ds TxInfo{txInfoData} = +findDatumHash ds TxInfo {txInfoData} = PlutusTx.fst PlutusTx.<$> List.find f (toList txInfoData) - where - f (_, ds') = ds' PlutusTx.== ds + where + f (_, ds') = ds' PlutusTx.== ds {-# INLINEABLE findDatumHash #-} -{- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the -transaction's inputs (`TxInInfo`). - -Note: this only searches the true transaction inputs and not the referenced transaction inputs. --} +-- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the +-- transaction's inputs (`TxInInfo`). +-- +-- Note: this only searches the true transaction inputs and not the referenced transaction inputs. findTxInByTxOutRef :: V3.TxOutRef -> TxInfo -> Haskell.Maybe TxInInfo -findTxInByTxOutRef outRef TxInfo{txInfoInputs} = +findTxInByTxOutRef outRef TxInfo {txInfoInputs} = List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef PlutusTx.== outRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef PlutusTx.== outRef) txInfoInputs - {-# INLINEABLE findTxInByTxOutRef #-} -{- | Find the indices of all the outputs that pay to the same script address we are -currently spending from, if any. --} +-- | Find the indices of all the outputs that pay to the same script address we are +-- currently spending from, if any. findContinuingOutputs :: ScriptContext -> [Haskell.Integer] findContinuingOutputs ctx - | Haskell.Just TxInInfo{txInInfoResolved = V2.TxOut{txOutAddress}} <- + | Haskell.Just TxInInfo {txInInfoResolved = V2.TxOut {txOutAddress}} <- findOwnInput ctx = List.findIndices (f txOutAddress) (txInfoOutputs (scriptContextTxInfo ctx)) - where - f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress + where + f addr V2.TxOut {txOutAddress = otherAddress} = addr PlutusTx.== otherAddress findContinuingOutputs _ = PlutusTx.traceError "Le" -- "Can't find any continuing outputs" {-# INLINEABLE findContinuingOutputs #-} -{- | Get all the outputs that pay to the same script address we are currently spending -from, if any. --} +-- | Get all the outputs that pay to the same script address we are currently spending +-- from, if any. getContinuingOutputs :: ScriptContext -> [V2.TxOut] getContinuingOutputs ctx - | Haskell.Just TxInInfo{txInInfoResolved = V2.TxOut{txOutAddress}} <- + | Haskell.Just TxInInfo {txInInfoResolved = V2.TxOut {txOutAddress}} <- findOwnInput ctx = List.filter (f txOutAddress) (txInfoOutputs (scriptContextTxInfo ctx)) - where - f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress + where + f addr V2.TxOut {txOutAddress = otherAddress} = addr PlutusTx.== otherAddress getContinuingOutputs _ = PlutusTx.traceError "Lf" -- "Can't get any continuing outputs" {-# INLINEABLE getContinuingOutputs #-} -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> V2.PubKeyHash -> Haskell.Bool -txSignedBy TxInfo{txInfoSignatories} k = case List.find ((PlutusTx.==) k) txInfoSignatories of - Haskell.Just _ -> Haskell.True +txSignedBy TxInfo {txInfoSignatories} k = case List.find ((PlutusTx.==) k) txInfoSignatories of + Haskell.Just _ -> Haskell.True Haskell.Nothing -> Haskell.False {-# INLINEABLE txSignedBy #-} -- | Get the values paid to a public key address by a pending transaction. pubKeyOutputsAt :: V2.PubKeyHash -> TxInfo -> [V2.Value] pubKeyOutputsAt pk p = - let flt V2.TxOut{txOutAddress = V2.Address (V2.PubKeyCredential pk') _, txOutValue} + let flt V2.TxOut {txOutAddress = V2.Address (V2.PubKeyCredential pk') _, txOutValue} | pk PlutusTx.== pk' = Haskell.Just txOutValue flt _ = Haskell.Nothing in PlutusTx.mapMaybe flt (txInfoOutputs p) @@ -647,16 +647,15 @@ valueProduced = F.foldMap V2.txOutValue PlutusTx.. txInfoOutputs -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> V2.CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextScriptInfo = MintingScript cs} = cs +ownCurrencySymbol ScriptContext {scriptContextScriptInfo = MintingScript cs} = cs ownCurrencySymbol _ = -- "Can't get currency symbol of the current validator script" PlutusTx.traceError "Lh" {-# INLINEABLE ownCurrencySymbol #-} -{- | Check if the pending transaction spends a specific transaction output -(identified by the hash of a transaction and an index into that -transactions' outputs) --} +-- | Check if the pending transaction spends a specific transaction output +-- (identified by the hash of a transaction and an index into that +-- transactions' outputs) spendsOutput :: TxInfo -> V3.TxId -> Haskell.Integer -> Haskell.Bool spendsOutput txInfo txId i = let spendsOutRef inp = @@ -677,55 +676,55 @@ $(makeLift ''DRepCredential) $(makeLift ''DRep) $( makeIsDataSchemaIndexed - ''DRep - [ ('DRep, 0) - , ('DRepAlwaysAbstain, 1) - , ('DRepAlwaysNoConfidence, 2) - ] + ''DRep + [ ('DRep, 0) + , ('DRepAlwaysAbstain, 1) + , ('DRepAlwaysNoConfidence, 2) + ] ) $(makeLift ''Delegatee) $( makeIsDataSchemaIndexed - ''Delegatee - [ ('DelegStake, 0) - , ('DelegVote, 1) - , ('DelegStakeVote, 2) - ] + ''Delegatee + [ ('DelegStake, 0) + , ('DelegVote, 1) + , ('DelegStakeVote, 2) + ] ) $(makeLift ''TxCert) $( makeIsDataSchemaIndexed - ''TxCert - [ ('TxCertRegStaking, 0) - , ('TxCertUnRegStaking, 1) - , ('TxCertDelegStaking, 2) - , ('TxCertRegDeleg, 3) - , ('TxCertRegDRep, 4) - , ('TxCertUpdateDRep, 5) - , ('TxCertUnRegDRep, 6) - , ('TxCertPoolRegister, 7) - , ('TxCertPoolRetire, 8) - , ('TxCertAuthHotCommittee, 9) - , ('TxCertResignColdCommittee, 10) - ] + ''TxCert + [ ('TxCertRegStaking, 0) + , ('TxCertUnRegStaking, 1) + , ('TxCertDelegStaking, 2) + , ('TxCertRegDeleg, 3) + , ('TxCertRegDRep, 4) + , ('TxCertUpdateDRep, 5) + , ('TxCertUnRegDRep, 6) + , ('TxCertPoolRegister, 7) + , ('TxCertPoolRetire, 8) + , ('TxCertAuthHotCommittee, 9) + , ('TxCertResignColdCommittee, 10) + ] ) $(makeLift ''Voter) $( makeIsDataSchemaIndexed - ''Voter - [ ('CommitteeVoter, 0) - , ('DRepVoter, 1) - , ('StakePoolVoter, 2) - ] + ''Voter + [ ('CommitteeVoter, 0) + , ('DRepVoter, 1) + , ('StakePoolVoter, 2) + ] ) $(makeLift ''Vote) $( makeIsDataSchemaIndexed - ''Vote - [ ('VoteNo, 0) - , ('VoteYes, 1) - , ('Abstain, 2) - ] + ''Vote + [ ('VoteNo, 0) + , ('VoteYes, 1) + , ('Abstain, 2) + ] ) $(makeLift ''GovernanceActionId) @@ -743,15 +742,15 @@ $(makeIsDataSchemaIndexed ''ProtocolVersion [('ProtocolVersion, 0)]) $(makeLift ''ChangedParameters) $(makeLift ''GovernanceAction) $( makeIsDataSchemaIndexed - ''GovernanceAction - [ ('ParameterChange, 0) - , ('HardForkInitiation, 1) - , ('TreasuryWithdrawals, 2) - , ('NoConfidence, 3) - , ('UpdateCommittee, 4) - , ('NewConstitution, 5) - , ('InfoAction, 6) - ] + ''GovernanceAction + [ ('ParameterChange, 0) + , ('HardForkInitiation, 1) + , ('TreasuryWithdrawals, 2) + , ('NoConfidence, 3) + , ('UpdateCommittee, 4) + , ('NewConstitution, 5) + , ('InfoAction, 6) + ] ) $(makeLift ''ProposalProcedure) @@ -759,26 +758,26 @@ $(makeIsDataSchemaIndexed ''ProposalProcedure [('ProposalProcedure, 0)]) $(makeLift ''ScriptPurpose) $( makeIsDataSchemaIndexed - ''ScriptPurpose - [ ('Minting, 0) - , ('Spending, 1) - , ('Rewarding, 2) - , ('Certifying, 3) - , ('Voting, 4) - , ('Proposing, 5) - ] + ''ScriptPurpose + [ ('Minting, 0) + , ('Spending, 1) + , ('Rewarding, 2) + , ('Certifying, 3) + , ('Voting, 4) + , ('Proposing, 5) + ] ) $(makeLift ''ScriptInfo) $( makeIsDataSchemaIndexed - ''ScriptInfo - [ ('MintingScript, 0) - , ('SpendingScript, 1) - , ('RewardingScript, 2) - , ('CertifyingScript, 3) - , ('VotingScript, 4) - , ('ProposingScript, 5) - ] + ''ScriptInfo + [ ('MintingScript, 0) + , ('SpendingScript, 1) + , ('RewardingScript, 2) + , ('CertifyingScript, 3) + , ('VotingScript, 4) + , ('ProposingScript, 5) + ] ) ---------------------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs index 7efb5b9271c..32b771a7450 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- needed for asData pattern synonyms +-- needed for asData pattern synonyms +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-strictness #-} @@ -206,10 +207,10 @@ PlutusTx.makeLift ''DRep instance PlutusTx.Eq DRep where {-# INLINEABLE (==) #-} - DRep a == DRep a' = a PlutusTx.== a' - DRepAlwaysAbstain == DRepAlwaysAbstain = Haskell.True + DRep a == DRep a' = a PlutusTx.== a' + DRepAlwaysAbstain == DRepAlwaysAbstain = Haskell.True DRepAlwaysNoConfidence == DRepAlwaysNoConfidence = Haskell.True - _ == _ = Haskell.False + _ == _ = Haskell.False PlutusTx.asData [d| @@ -329,10 +330,10 @@ PlutusTx.makeLift ''Vote instance PlutusTx.Eq Vote where {-# INLINEABLE (==) #-} - VoteNo == VoteNo = Haskell.True + VoteNo == VoteNo = Haskell.True VoteYes == VoteYes = Haskell.True Abstain == Abstain = Haskell.True - _ == _ = Haskell.False + _ == _ = Haskell.False -- | Similar to TxOutRef, but for GovActions PlutusTx.asData @@ -348,7 +349,7 @@ PlutusTx.asData PlutusTx.makeLift ''GovernanceActionId instance Pretty GovernanceActionId where - pretty GovernanceActionId{..} = + pretty GovernanceActionId {..} = vsep [ "gaidTxId:" <+> pretty gaidTxId , "gaidGovActionIx:" <+> pretty gaidGovActionIx @@ -375,7 +376,7 @@ PlutusTx.asData PlutusTx.makeLift ''Committee instance Pretty Committee where - pretty Committee{..} = + pretty Committee {..} = vsep [ "committeeMembers:" <+> pretty committeeMembers , "committeeQuorum:" <+> pretty committeeQuorum @@ -411,7 +412,7 @@ PlutusTx.asData PlutusTx.makeLift ''ProtocolVersion instance Pretty ProtocolVersion where - pretty ProtocolVersion{..} = + pretty ProtocolVersion {..} = vsep [ "pvMajor:" <+> pretty pvMajor , "pvMinor:" <+> pretty pvMinor @@ -422,15 +423,14 @@ instance PlutusTx.Eq ProtocolVersion where ProtocolVersion a b == ProtocolVersion a' b' = a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' -{-| A Plutus Data object containing proposed parameter changes. The Data object contains -a @Map@ with one entry per changed parameter, from the parameter ID to the new value. -Unchanged parameters are not included. - -The mapping from parameter IDs to parameters can be found in -[conway.cddl](https://github.com/IntersectMBO/cardano-ledger/blob/master/eras/conway/impl/cddl-files/conway.cddl). -- editorconfig-checker-disable-file - -/Invariant:/ This map is non-empty, and the keys are stored in ascending order. --} +-- | A Plutus Data object containing proposed parameter changes. The Data object contains +-- a @Map@ with one entry per changed parameter, from the parameter ID to the new value. +-- Unchanged parameters are not included. +-- +-- The mapping from parameter IDs to parameters can be found in +-- [conway.cddl](https://github.com/IntersectMBO/cardano-ledger/blob/master/eras/conway/impl/cddl-files/conway.cddl). -- editorconfig-checker-disable-file +-- +-- /Invariant:/ This map is non-empty, and the keys are stored in ascending order. newtype ChangedParameters = ChangedParameters {getChangedParameters :: PlutusTx.BuiltinData} deriving stock (Generic, Haskell.Show) deriving newtype @@ -492,7 +492,7 @@ PlutusTx.asData PlutusTx.makeLift ''ProposalProcedure instance Pretty ProposalProcedure where - pretty ProposalProcedure{..} = + pretty ProposalProcedure {..} = vsep [ "ppDeposit:" <+> pretty ppDeposit , "ppReturnAddr:" <+> pretty ppReturnAddr @@ -563,7 +563,7 @@ instance PlutusTx.Eq TxInInfo where ref PlutusTx.== ref' PlutusTx.&& res PlutusTx.== res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = + pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -- | TxInfo for PlutusV3 @@ -622,11 +622,11 @@ PlutusTx.makeLift ''ScriptContext findOwnInput :: ScriptContext -> Haskell.Maybe TxInInfo findOwnInput ScriptContext - { scriptContextTxInfo = TxInfo{txInfoInputs} + { scriptContextTxInfo = TxInfo {txInfoInputs} , scriptContextScriptInfo = SpendingScript txOutRef _ } = Data.List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef PlutusTx.== txOutRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef PlutusTx.== txOutRef) txInfoInputs findOwnInput _ = Haskell.Nothing @@ -634,68 +634,64 @@ findOwnInput _ = Haskell.Nothing -- | Find the data corresponding to a data hash, if there is one findDatum :: V2.DatumHash -> TxInfo -> Haskell.Maybe V2.Datum -findDatum dsh TxInfo{txInfoData} = lookup dsh txInfoData +findDatum dsh TxInfo {txInfoData} = lookup dsh txInfoData {-# INLINEABLE findDatumHash #-} -{-| Find the hash of a datum, if it is part of the pending transaction's -hashes --} +-- | Find the hash of a datum, if it is part of the pending transaction's +-- hashes findDatumHash :: V2.Datum -> TxInfo -> Haskell.Maybe V2.DatumHash -findDatumHash ds TxInfo{txInfoData} = +findDatumHash ds TxInfo {txInfoData} = PlutusTx.fst PlutusTx.<$> List.find f (toSOPList txInfoData) - where - f (_, ds') = ds' PlutusTx.== ds + where + f (_, ds') = ds' PlutusTx.== ds {-# INLINEABLE findTxInByTxOutRef #-} -{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the -transaction's inputs (`TxInInfo`). - -Note: this only searches the true transaction inputs and not the referenced transaction inputs. --} +-- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the +-- transaction's inputs (`TxInInfo`). +-- +-- Note: this only searches the true transaction inputs and not the referenced transaction inputs. findTxInByTxOutRef :: V3.TxOutRef -> TxInfo -> Haskell.Maybe TxInInfo -findTxInByTxOutRef outRef TxInfo{txInfoInputs} = +findTxInByTxOutRef outRef TxInfo {txInfoInputs} = Data.List.find - (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef PlutusTx.== outRef) + (\TxInInfo {txInInfoOutRef} -> txInInfoOutRef PlutusTx.== outRef) txInfoInputs {-# INLINEABLE findContinuingOutputs #-} -{-| Find the indices of all the outputs that pay to the same script address we are -currently spending from, if any. --} +-- | Find the indices of all the outputs that pay to the same script address we are +-- currently spending from, if any. findContinuingOutputs :: ScriptContext -> List Haskell.Integer findContinuingOutputs ctx - | Haskell.Just TxInInfo{txInInfoResolved = V2.TxOut{txOutAddress}} <- + | Haskell.Just TxInInfo {txInInfoResolved = V2.TxOut {txOutAddress}} <- findOwnInput ctx = Data.List.findIndices (f txOutAddress) (txInfoOutputs (scriptContextTxInfo ctx)) - where - f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress + where + f addr V2.TxOut {txOutAddress = otherAddress} = addr PlutusTx.== otherAddress findContinuingOutputs _ = PlutusTx.traceError "Le" -- "Can't find any continuing outputs" {-# INLINEABLE getContinuingOutputs #-} -{-| Get all the outputs that pay to the same script address we are currently spending -from, if any. --} +-- | Get all the outputs that pay to the same script address we are currently spending +-- from, if any. getContinuingOutputs :: ScriptContext -> List V2.TxOut getContinuingOutputs ctx - | Haskell.Just TxInInfo{txInInfoResolved = V2.TxOut{txOutAddress}} <- + | Haskell.Just TxInInfo {txInInfoResolved = V2.TxOut {txOutAddress}} <- findOwnInput ctx = Data.List.filter (f txOutAddress) (txInfoOutputs (scriptContextTxInfo ctx)) - where - f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress + where + f addr V2.TxOut {txOutAddress = otherAddress} = addr PlutusTx.== otherAddress getContinuingOutputs _ = PlutusTx.traceError "Lf" -- "Can't get any continuing outputs" {-# INLINEABLE txSignedBy #-} -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> V2.PubKeyHash -> Haskell.Bool -txSignedBy TxInfo{txInfoSignatories} k = case Data.List.find ((PlutusTx.==) k) txInfoSignatories of - Haskell.Just _ -> Haskell.True +txSignedBy TxInfo {txInfoSignatories} k = case Data.List.find ((PlutusTx.==) k) txInfoSignatories of + Haskell.Just _ -> Haskell.True Haskell.Nothing -> Haskell.False {-# INLINEABLE pubKeyOutputsAt #-} @@ -703,7 +699,7 @@ txSignedBy TxInfo{txInfoSignatories} k = case Data.List.find ((PlutusTx.==) k) t -- | Get the values paid to a public key address by a pending transaction. pubKeyOutputsAt :: V2.PubKeyHash -> TxInfo -> List V2.Value pubKeyOutputsAt pk p = - let flt V2.TxOut{txOutAddress = V2.Address (V2.PubKeyCredential pk') _, txOutValue} + let flt V2.TxOut {txOutAddress = V2.Address (V2.PubKeyCredential pk') _, txOutValue} | pk PlutusTx.== pk' = Haskell.Just txOutValue flt _ = Haskell.Nothing in Data.List.mapMaybe flt (txInfoOutputs p) @@ -731,17 +727,16 @@ valueProduced = Data.List.foldMap V2.txOutValue PlutusTx.. txInfoOutputs -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> V2.CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextScriptInfo = MintingScript cs} = cs +ownCurrencySymbol ScriptContext {scriptContextScriptInfo = MintingScript cs} = cs ownCurrencySymbol _ = -- "Can't get currency symbol of the current validator script" PlutusTx.traceError "Lh" {-# INLINEABLE spendsOutput #-} -{-| Check if the pending transaction spends a specific transaction output -(identified by the hash of a transaction and an index into that -transactions' outputs) --} +-- | Check if the pending transaction spends a specific transaction output +-- (identified by the hash of a transaction and an index into that +-- transactions' outputs) spendsOutput :: TxInfo -> V3.TxId -> Haskell.Integer -> Haskell.Bool spendsOutput txInfo txId i = let spendsOutRef inp = @@ -753,7 +748,7 @@ spendsOutput txInfo txId i = in Data.List.any spendsOutRef (txInfoInputs txInfo) instance Pretty TxInfo where - pretty TxInfo{..} = + pretty TxInfo {..} = vsep [ "TxId:" <+> pretty txInfoId , "Inputs:" <+> pretty txInfoInputs @@ -774,7 +769,7 @@ instance Pretty TxInfo where ] instance Pretty ScriptContext where - pretty ScriptContext{..} = + pretty ScriptContext {..} = vsep [ "ScriptInfo:" <+> pretty scriptContextScriptInfo , nest 2 (vsep ["TxInfo:", pretty scriptContextTxInfo]) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs index 01b56468d2c..7f2bb154ccb 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -16,13 +16,13 @@ {-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} {-# OPTIONS_GHC -fno-unbox-strict-fields #-} -module PlutusLedgerApi.V3.Data.MintValue - ( MintValue (..) -- Constructor is exported for testing - , emptyMintValue - , mintValueToMap - , mintValueMinted - , mintValueBurned - ) +module PlutusLedgerApi.V3.Data.MintValue ( + MintValue (..), -- Constructor is exported for testing + emptyMintValue, + mintValueToMap, + mintValueMinted, + mintValueBurned, +) where import PlutusTx.Prelude @@ -30,16 +30,19 @@ import PlutusTx.Prelude import GHC.Generics (Generic) import PlutusLedgerApi.V1.Data.Value (CurrencySymbol, TokenName, Value (..)) import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) -import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), definitionIdFromType, - definitionRef) +import PlutusTx.Blueprint.Definition ( + HasBlueprintDefinition (..), + definitionIdFromType, + definitionRef, + ) import PlutusTx.Blueprint.Schema (MapSchema (..), Schema (..)) import PlutusTx.Blueprint.Schema.Annotation (emptySchemaInfo, title) import PlutusTx.Data.AssocMap (Map) import PlutusTx.Data.AssocMap qualified as Map import PlutusTx.Lift (makeLift) -import Prelude qualified as Haskell import Prettyprinter (Pretty) import Prettyprinter.Extras (PrettyShow (PrettyShow)) +import Prelude qualified as Haskell {- Note [MintValue vs Value] @@ -69,7 +72,7 @@ instance HasBlueprintDefinition MintValue where instance HasBlueprintSchema MintValue referencedTypes where schema = SchemaMap - emptySchemaInfo{title = Just "MintValue"} + emptySchemaInfo {title = Just "MintValue"} MkMapSchema { keySchema = definitionRef @CurrencySymbol , valueSchema = @@ -100,18 +103,17 @@ mintValueMinted (UnsafeMintValue m) = mapMaybeQuantities (\x -> if x > 0 then Just x else Nothing) m {-# INLINEABLE mintValueMinted #-} -{- | Get the 'Value' burned by the 'MintValue'. -All the negative quantities in the 'MintValue' become positive in the resulting 'Value'. --} +-- | Get the 'Value' burned by the 'MintValue'. +-- All the negative quantities in the 'MintValue' become positive in the resulting 'Value'. mintValueBurned :: MintValue -> Value mintValueBurned (UnsafeMintValue m) = mapMaybeQuantities (\x -> if x < 0 then Just (abs x) else Nothing) m {-# INLINEABLE mintValueBurned #-} -mapMaybeQuantities - :: (Integer -> Maybe Integer) - -> Map CurrencySymbol (Map TokenName Integer) - -> Value +mapMaybeQuantities :: + (Integer -> Maybe Integer) -> + Map CurrencySymbol (Map TokenName Integer) -> + Value mapMaybeQuantities mapMaybeQuantity = Value . Map.mapMaybe mapMaybeCurrencies where {-# INLINEABLE mapMaybeCurrencies #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs index 110ac1e0eb8..cf0d5928948 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -40,22 +40,21 @@ import PlutusTx.Lift (makeLift) import PlutusTx.Ord qualified as PlutusTx import Prettyprinter (Pretty, pretty) -{-| A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the Shelley ledger specification. --} +-- | A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the Shelley ledger specification. newtype TxId = TxId {getTxId :: PlutusTx.BuiltinByteString} deriving stock (Eq, Ord, Generic) deriving anyclass (NFData, HasBlueprintDefinition) deriving newtype (PlutusTx.Eq, PlutusTx.Ord, ToData, FromData, UnsafeFromData) deriving - ( IsString - -- ^ from hex encoding - , Show - -- ^ using hex encoding - , Pretty - -- ^ using hex encoding + ( -- | from hex encoding + IsString + , -- | using hex encoding + Show + , -- | using hex encoding + Pretty ) via LedgerBytes @@ -63,12 +62,11 @@ instance HasBlueprintSchema TxId referencedTypes where schema = schema @PlutusTx.BuiltinByteString & withSchemaInfo \info -> - info{title = Just "TxId"} + info {title = Just "TxId"} -{-| A reference to a transaction output. This is a -pair of a transaction ID (`TxId`), and an index indicating which of the outputs -of that transaction we are referring to. --} +-- | A reference to a transaction output. This is a +-- pair of a transaction ID (`TxId`), and an index indicating which of the outputs +-- of that transaction we are referring to. PlutusTx.asData [d| data TxOutRef = TxOutRef @@ -84,7 +82,7 @@ PlutusTx.asData |] instance Pretty TxOutRef where - pretty TxOutRef{txOutRefId = id', txOutRefIdx = idx} = pretty id' <> "!" <> pretty idx + pretty TxOutRef {txOutRefId = id', txOutRefIdx = idx} = pretty id' <> "!" <> pretty idx instance PlutusTx.Eq TxOutRef where {-# INLINEABLE (==) #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index 29c0001941f..3af58b0d34b 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -1,12 +1,13 @@ {-# LANGUAGE TypeApplications #-} -module PlutusLedgerApi.V3.EvaluationContext - ( EvaluationContext - , mkEvaluationContext - , CostModelParams - , assertWellFormedCostModelParams - , toMachineParameters - , CostModelApplyError (..) - ) where + +module PlutusLedgerApi.V3.EvaluationContext ( + EvaluationContext, + mkEvaluationContext, + CostModelParams, + assertWellFormedCostModelParams, + toMachineParameters, + CostModelApplyError (..), +) where import PlutusLedgerApi.Common import PlutusLedgerApi.V3.ParamName as V3 @@ -18,31 +19,32 @@ import Control.Monad import Control.Monad.Writer.Strict import Data.Int (Int64) -{-| Build the 'EvaluationContext'. - -The input is a list of cost model parameters (which are integer values) passed -from the ledger. - -IMPORTANT: the cost model parameters __MUST__ appear in the correct order, -matching the names in `PlutusLedgerApi.V3.ParamName`. If the parameters are -supplied in the wrong order then script cost calculations will be incorrect. - -IMPORTANT: The evaluation context of every Plutus version must be recreated upon -a protocol update with the updated cost model parameters. --} -mkEvaluationContext - :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) - => [Int64] -- ^ the (updated) cost model parameters of the protocol - -> m EvaluationContext +-- | Build the 'EvaluationContext'. +-- +-- The input is a list of cost model parameters (which are integer values) passed +-- from the ledger. +-- +-- IMPORTANT: the cost model parameters __MUST__ appear in the correct order, +-- matching the names in `PlutusLedgerApi.V3.ParamName`. If the parameters are +-- supplied in the wrong order then script cost calculations will be incorrect. +-- +-- IMPORTANT: The evaluation context of every Plutus version must be recreated upon +-- a protocol update with the updated cost model parameters. +mkEvaluationContext :: + (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => + -- | the (updated) cost model parameters of the protocol + [Int64] -> + m EvaluationContext mkEvaluationContext = tagWithParamNames @V3.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - PlutusV3 - (\pv -> + PlutusV3 + ( \pv -> if pv < pv11PV then unavailableCaserBuiltin $ getMajorProtocolVersion pv - else CaserBuiltin caseBuiltin) - [DefaultFunSemanticsVariantC] - -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. - (const DefaultFunSemanticsVariantC) + else CaserBuiltin caseBuiltin + ) + [DefaultFunSemanticsVariantC] + -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. + (const DefaultFunSemanticsVariantC) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs index cc86e75218d..56e055b9f69 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -16,13 +16,13 @@ {-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} {-# OPTIONS_GHC -fno-unbox-strict-fields #-} -module PlutusLedgerApi.V3.MintValue - ( MintValue (..) -- Constructor is exported for testing - , emptyMintValue - , mintValueToMap - , mintValueMinted - , mintValueBurned - ) +module PlutusLedgerApi.V3.MintValue ( + MintValue (..), -- Constructor is exported for testing + emptyMintValue, + mintValueToMap, + mintValueMinted, + mintValueBurned, +) where import PlutusTx.Prelude @@ -34,16 +34,19 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol, TokenName, Value (..)) import PlutusTx.AssocMap (Map) import PlutusTx.AssocMap qualified as Map import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) -import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), definitionIdFromType, - definitionRef) +import PlutusTx.Blueprint.Definition ( + HasBlueprintDefinition (..), + definitionIdFromType, + definitionRef, + ) import PlutusTx.Blueprint.Schema (MapSchema (..), Schema (..)) import PlutusTx.Blueprint.Schema.Annotation (emptySchemaInfo, title) import PlutusTx.Lift (makeLift) import PlutusTx.List qualified as List import PlutusTx.Traversable qualified as T -import Prelude qualified as Haskell import Prettyprinter (Pretty) import Prettyprinter.Extras (PrettyShow (PrettyShow)) +import Prelude qualified as Haskell {- Note [MintValue vs Value] @@ -58,7 +61,7 @@ Users should project 'MintValue' into 'Value' using 'mintValueMinted' or 'mintVa -} -- | A 'MintValue' represents assets that are minted and burned in a transaction. -newtype MintValue = UnsafeMintValue {unMintValue ::(Map CurrencySymbol (Map TokenName Integer))} +newtype MintValue = UnsafeMintValue {unMintValue :: (Map CurrencySymbol (Map TokenName Integer))} deriving stock (Generic, Data, Haskell.Show) deriving anyclass (NFData) deriving newtype (ToData, FromData, UnsafeFromData) @@ -74,7 +77,7 @@ instance HasBlueprintDefinition MintValue where instance HasBlueprintSchema MintValue referencedTypes where schema = SchemaMap - emptySchemaInfo{title = Just "MintValue"} + emptySchemaInfo {title = Just "MintValue"} MkMapSchema { keySchema = definitionRef @CurrencySymbol , valueSchema = @@ -104,9 +107,8 @@ mintValueMinted :: MintValue -> Value mintValueMinted (UnsafeMintValue values) = filterQuantities (\x -> [x | x > 0]) values {-# INLINEABLE mintValueMinted #-} -{- | Get the 'Value' burned by the 'MintValue'. -All the negative quantities in the 'MintValue' become positive in the resulting 'Value'. --} +-- | Get the 'Value' burned by the 'MintValue'. +-- All the negative quantities in the 'MintValue' become positive in the resulting 'Value'. mintValueBurned :: MintValue -> Value mintValueBurned (UnsafeMintValue values) = filterQuantities (\x -> [abs x | x < 0]) values {-# INLINEABLE mintValueBurned #-} @@ -116,13 +118,13 @@ filterQuantities mapQuantity values = Value (Map.unsafeFromList (List.foldr filterTokenQuantities [] (Map.toList values))) where {-# INLINEABLE filterTokenQuantities #-} - filterTokenQuantities - :: (CurrencySymbol, Map TokenName Integer) - -> [(CurrencySymbol, Map TokenName Integer)] - -> [(CurrencySymbol, Map TokenName Integer)] + filterTokenQuantities :: + (CurrencySymbol, Map TokenName Integer) -> + [(CurrencySymbol, Map TokenName Integer)] -> + [(CurrencySymbol, Map TokenName Integer)] filterTokenQuantities (currency, tokenQuantities) = case List.concatMap (T.traverse mapQuantity) (Map.toList tokenQuantities) of - [] -> id + [] -> id quantities -> ((currency, Map.unsafeFromList quantities) :) {-# INLINEABLE filterQuantities #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs index 737ff91e12c..85c995d2625 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs @@ -1,21 +1,21 @@ {-# LANGUAGE DerivingVia #-} -module PlutusLedgerApi.V3.ParamName - ( ParamName (..) - , tagWithParamNames - ) where + +module PlutusLedgerApi.V3.ParamName ( + ParamName (..), + tagWithParamNames, +) where import Data.Ix import GHC.Generics import PlutusLedgerApi.Common.ParamName -{-| The enumeration of all possible cost model parameter names for this language version. - -IMPORTANT: The order of appearance of the data constructors here matters. DO NOT REORDER. -See Note [Quotation marks in cost model parameter constructors] -See Note [Cost model parameters from the ledger's point of view] --} -data ParamName = - AddInteger'cpu'arguments'intercept +-- | The enumeration of all possible cost model parameter names for this language version. +-- +-- IMPORTANT: The order of appearance of the data constructors here matters. DO NOT REORDER. +-- See Note [Quotation marks in cost model parameter constructors] +-- See Note [Cost model parameters from the ledger's point of view] +data ParamName + = AddInteger'cpu'arguments'intercept | AddInteger'cpu'arguments'slope | AddInteger'memory'arguments'intercept | AddInteger'memory'arguments'slope @@ -266,8 +266,8 @@ data ParamName = | ByteStringToInteger'cpu'arguments'c2 | ByteStringToInteger'memory'arguments'intercept | ByteStringToInteger'memory'arguments'slope --- Plomin - | AndByteString'cpu'arguments'intercept + | -- Plomin + AndByteString'cpu'arguments'intercept | AndByteString'cpu'arguments'slope1 | AndByteString'cpu'arguments'slope2 | AndByteString'memory'arguments'intercept @@ -313,8 +313,8 @@ data ParamName = | Ripemd_160'cpu'arguments'intercept | Ripemd_160'cpu'arguments'slope | Ripemd_160'memory'arguments - -- To be deployed in PV11 - | ExpModInteger'cpu'arguments'coefficient00 + | -- To be deployed in PV11 + ExpModInteger'cpu'arguments'coefficient00 | ExpModInteger'cpu'arguments'coefficient11 | ExpModInteger'cpu'arguments'coefficient12 | ExpModInteger'memory'arguments'intercept @@ -336,5 +336,5 @@ data ParamName = | Bls12_381_G2_multiScalarMul'cpu'arguments'intercept | Bls12_381_G2_multiScalarMul'cpu'arguments'slope | Bls12_381_G2_multiScalarMul'memory'arguments - deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) - deriving IsParamName via (GenericParamName ParamName) + deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) + deriving (IsParamName) via (GenericParamName ParamName) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs index 98171b2a7d6..cbdb60258ff 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -34,11 +34,10 @@ import PlutusTx.Lift (makeLift) import PlutusTx.Ord qualified as PlutusTx import Prettyprinter (Pretty, pretty) -{- | A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. - -This is a simple type without any validation, __use with caution__. -You may want to add checks for its invariants. See the Shelley ledger specification. --} +-- | A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. +-- +-- This is a simple type without any validation, __use with caution__. +-- You may want to add checks for its invariants. See the Shelley ledger specification. newtype TxId = TxId {getTxId :: PlutusTx.BuiltinByteString} deriving stock (Eq, Ord, Generic) deriving anyclass (NFData, HasBlueprintDefinition) @@ -57,14 +56,13 @@ instance HasBlueprintSchema TxId referencedTypes where schema = schema @PlutusTx.BuiltinByteString & withSchemaInfo \info -> - info{title = Just "TxId"} + info {title = Just "TxId"} -{- | A reference to a transaction output. This is a -pair of a transaction ID (`TxId`), and an index indicating which of the outputs -of that transaction we are referring to. --} +-- | A reference to a transaction output. This is a +-- pair of a transaction ID (`TxId`), and an index indicating which of the outputs +-- of that transaction we are referring to. data TxOutRef = TxOutRef - { txOutRefId :: TxId + { txOutRefId :: TxId -- ^ The transaction ID. , txOutRefIdx :: Integer -- ^ Index into the referenced transaction's outputs @@ -73,7 +71,7 @@ data TxOutRef = TxOutRef deriving anyclass (NFData, HasBlueprintDefinition) instance Pretty TxOutRef where - pretty TxOutRef{txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx + pretty TxOutRef {txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx instance PlutusTx.Eq TxOutRef where {-# INLINEABLE (==) #-} diff --git a/plutus-ledger-api/src/Prettyprinter/Extras.hs b/plutus-ledger-api/src/Prettyprinter/Extras.hs index 44d8c00e79a..37166869240 100644 --- a/plutus-ledger-api/src/Prettyprinter/Extras.hs +++ b/plutus-ledger-api/src/Prettyprinter/Extras.hs @@ -1,11 +1,12 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Prettyprinter.Extras - ( PrettyShow(..) - , Pretty(..) - , PrettyFoldable(..) - , Tagged(Tagged) - ) where + +module Prettyprinter.Extras ( + PrettyShow (..), + Pretty (..), + PrettyFoldable (..), + Tagged (Tagged), +) where import Data.Foldable (Foldable (toList)) import Data.Proxy (Proxy (..)) @@ -15,14 +16,14 @@ import GHC.TypeLits (KnownSymbol, symbolVal) import Prettyprinter -- | Newtype wrapper for deriving 'Pretty' via a 'Show' instance -newtype PrettyShow a = PrettyShow { unPrettyShow :: a } +newtype PrettyShow a = PrettyShow {unPrettyShow :: a} instance Show a => Pretty (PrettyShow a) where pretty = viaShow . unPrettyShow -- | Newtype wrapper for deriving 'Pretty' for a 'Foldable' container by -- calling 'toList'. -newtype PrettyFoldable f a = PrettyFoldable { unPrettyFoldable :: f a } +newtype PrettyFoldable f a = PrettyFoldable {unPrettyFoldable :: f a} instance (Foldable f, Pretty a) => Pretty (PrettyFoldable f a) where pretty = pretty . toList . unPrettyFoldable diff --git a/plutus-ledger-api/test-plugin/Spec/Budget.hs b/plutus-ledger-api/test-plugin/Spec/Budget.hs index 36c0b1fdd5a..0d25b672419 100644 --- a/plutus-ledger-api/test-plugin/Spec/Budget.hs +++ b/plutus-ledger-api/test-plugin/Spec/Budget.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Spec.Budget where @@ -23,15 +23,16 @@ import PlutusTx.AssocMap as Map import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString) import PlutusTx.Code import PlutusTx.Lift (liftCodeDef) -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test tests :: TestTree tests = runTestNested ["test-plugin", "Spec", "Budget"] . pure . testNestedGhc $ - [ goldenPirReadable "gt" compiledGt - , goldenPirReadable "currencySymbolValueOf" compiledCurrencySymbolValueOf - ] ++ testCases + [ goldenPirReadable "gt" compiledGt + , goldenPirReadable "currencySymbolValueOf" compiledCurrencySymbolValueOf + ] + ++ testCases compiledGt :: CompiledCode (Value -> Value -> Bool) compiledGt = $$(compile [||gt||]) @@ -44,7 +45,7 @@ compiledCurrencySymbolValueOf = $$(compile [||currencySymbolValueOf||]) mkValue :: [(Integer, [(Integer, Integer)])] -> Value mkValue = - Value . Map.unsafeFromList . fmap (bimap toSymbol (Map.unsafeFromList . fmap (first toToken))) + Value . Map.unsafeFromList . fmap (bimap toSymbol (Map.unsafeFromList . fmap (first toToken))) toSymbol :: Integer -> CurrencySymbol toSymbol = currencySymbol . fromString . show diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget.hs b/plutus-ledger-api/test-plugin/Spec/Data/Budget.hs index 28f084b4ab5..e1437da0c72 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget.hs +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Spec.Data.Budget where @@ -23,15 +23,16 @@ import PlutusLedgerApi.V3.Data.MintValue qualified as MintValue import PlutusTx.Code import PlutusTx.Data.AssocMap as Map import PlutusTx.Lift (liftCodeDef) -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test tests :: TestTree tests = runTestNested ["test-plugin", "Spec", "Data", "Budget"] . pure . testNestedGhc $ - [ goldenPirReadable "gt" compiledGt - , goldenPirReadable "currencySymbolValueOf" compiledCurrencySymbolValueOf - ] ++ testCases + [ goldenPirReadable "gt" compiledGt + , goldenPirReadable "currencySymbolValueOf" compiledCurrencySymbolValueOf + ] + ++ testCases compiledGt :: CompiledCode (Value -> Value -> Bool) compiledGt = $$(compile [||gt||]) @@ -55,8 +56,8 @@ mkMintValue :: [(Integer, [(Integer, Integer)])] -> MintValue.MintValue mkMintValue = MintValue.UnsafeMintValue . mkCurrencyMap mkCurrencyMap :: [(Integer, [(Integer, Integer)])] -> Map CurrencySymbol (Map TokenName Integer) -mkCurrencyMap - = Map.unsafeFromSOPList +mkCurrencyMap = + Map.unsafeFromSOPList . fmap (bimap toSymbol (Map.unsafeFromSOPList . fmap (first toToken))) toSymbol :: Integer -> CurrencySymbol @@ -98,15 +99,14 @@ value3 = , (5, [(500, 501), (502, 503), (504, 505), (506, 507), (508, 509)]) ] - value4 :: MintValue.MintValue value4 = mkMintValue [ (1, [(100, -101)]) - , (2, [(200, -201), (202, 203)]) + , (2, [(200, -201), (202, 203)]) , (3, [(300, -301), (302, -303), (304, -305), (306, -307)]) - , (4, [(400, -401), (402, 403), (404, 405), (406, 407)]) - , (5, [(500, -501), (502, 503), (504, 505), (506, 507), (508, -509)]) + , (4, [(400, -401), (402, 403), (404, 405), (406, 407)]) + , (5, [(500, -501), (502, 503), (504, 505), (506, 507), (508, -509)]) ] testCases :: [TestNested] diff --git a/plutus-ledger-api/test-plugin/Spec/Data/MintValue/V3.hs b/plutus-ledger-api/test-plugin/Spec/Data/MintValue/V3.hs index e6a49a4c404..94623b2535e 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/MintValue/V3.hs +++ b/plutus-ledger-api/test-plugin/Spec/Data/MintValue/V3.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -26,12 +26,12 @@ import PlutusTx.Code (CompiledCode, unsafeApplyCode) import PlutusTx.Data.AssocMap qualified as Map import PlutusTx.Data.List qualified as List import PlutusTx.Lift (liftCodeDef) -import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import PlutusTx.TH (compile) -import Prelude qualified as Haskell +import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import Test.QuickCheck qualified as QC import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (Property, testProperty, (===)) +import Prelude qualified as Haskell tests :: TestTree tests = testGroup "Data.MintValue" [testPropsInHaskell, testPropsInPlinth] @@ -43,7 +43,7 @@ prop_MintValueBuiltinData :: Either Value MintValue -> Bool prop_MintValueBuiltinData values = let (value, mintValue) = case values of - Left v -> (v, coerce v) + Left v -> (v, coerce v) Right mv -> (coerce mv, mv) in toBuiltinData mintValue == toBuiltinData value @@ -143,7 +143,7 @@ test_Plinth_MintValueBurnedIsPositive = -------------------------------------------------------------------------------- -- Helper functions ------------------------------------------------------------ -scaleTestsBy :: (QC.Testable prop) => Haskell.Int -> prop -> QC.Property +scaleTestsBy :: QC.Testable prop => Haskell.Int -> prop -> QC.Property scaleTestsBy factor = QC.withMaxSuccess (100 Haskell.* factor) . QC.mapSize (Haskell.* factor) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/ScriptContext.hs b/plutus-ledger-api/test-plugin/Spec/Data/ScriptContext.hs index 670740355e4..14b456e61ba 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/ScriptContext.hs +++ b/plutus-ledger-api/test-plugin/Spec/Data/ScriptContext.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Spec.Data.ScriptContext where @@ -21,8 +21,8 @@ import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.Code import PlutusTx.IsData qualified as PlutusTx import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test tests :: TestTree tests = @@ -44,7 +44,7 @@ succeedsIfHasDatum d = PlutusTx.check $ case PlutusTx.unsafeFromBuiltinData d of V3D.ScriptContext _ _ (V3D.SpendingScript _ (Just _)) -> True - _ -> False + _ -> False compiledAlwaysSucceeds :: CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit) compiledAlwaysSucceeds = $$(compile [||alwaysSucceeds||]) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value.hs b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs index 6fc2cc7e1ce..13ee37dbbb4 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value.hs +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Spec.Data.Value where @@ -54,34 +53,34 @@ scalingFactor = 4 -- was described in the previous point. patternOptions :: [[(Integer, Integer)]] patternOptions = - [ [] - , [(1,0)] - , [(1,1)] - , [(1,1), (2,2)] - , [(1,0), (2,2), (1,1)] - , [(2,3), (1,0), (2,2), (1,1)] - , [(2,2), (2,3), (1,0), (2,4), (1,1)] - , [(2,2), (2,3), (1,0), (3,5), (2,4), (1,1)] - , [(2,2), (2,3), (1,0), (3,5), (3,6), (2,4), (1,1)] - , [(2,2), (2,3), (1,0), (3,5), (3,6), (2,4), (1,1), (2,7)] - , [(1,9), (2,2), (6,10), (2,3), (1,0), (4,10), (3,5), (5,0), (3,6), (2,4), (1,1), (2,7), (4,8)] - ] + [ [] + , [(1, 0)] + , [(1, 1)] + , [(1, 1), (2, 2)] + , [(1, 0), (2, 2), (1, 1)] + , [(2, 3), (1, 0), (2, 2), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (2, 4), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (3, 5), (2, 4), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (3, 5), (3, 6), (2, 4), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (3, 5), (3, 6), (2, 4), (1, 1), (2, 7)] + , [(1, 9), (2, 2), (6, 10), (2, 3), (1, 0), (4, 10), (3, 5), (5, 0), (3, 6), (2, 4), (1, 1), (2, 7), (4, 8)] + ] {-# INLINEABLE patternOptions #-} i2Bs :: Integer -> BuiltinByteString i2Bs n = - if n < 0 - then "-" `appendByteString` i2Bs (negate n) - -- @48@ is the ASCII code of @0@. - else List.foldr (consByteString . (48 +)) emptyByteString $ toDigits n + if n < 0 + then "-" `appendByteString` i2Bs (negate n) + -- @48@ is the ASCII code of @0@. + else List.foldr (consByteString . (48 +)) emptyByteString $ toDigits n {-# INLINEABLE i2Bs #-} -- | Like 'i2Bs but generates longer bytestrings, so that repeated recalculations of -- currency/token name comparisons get reflected in the budget tests in a visible manner. replicateToByteString :: Integer -> BuiltinByteString replicateToByteString i = - List.foldr id emptyByteString $ - List.replicate iTo6 (appendByteString $ i2Bs i) + List.foldr id emptyByteString + $ List.replicate iTo6 (appendByteString $ i2Bs i) where iTo2 = i * i iTo4 = iTo2 * iTo2 @@ -90,26 +89,27 @@ replicateToByteString i = tokenListOptions :: [[(TokenName, Integer)]] tokenListOptions = - List.map - (List.map $ \(i, x) -> (TokenName $ replicateToByteString i, x)) - patternOptions + List.map + (List.map $ \(i, x) -> (TokenName $ replicateToByteString i, x)) + patternOptions {-# INLINEABLE tokenListOptions #-} currencyListOptions :: [[(CurrencySymbol, [(TokenName, Integer)])]] currencyListOptions = - List.map - (List.map $ \(i, x) -> - ( CurrencySymbol $ replicateToByteString i - , tokenListOptions List.!! x - )) - patternOptions + List.map + ( List.map $ \(i, x) -> + ( CurrencySymbol $ replicateToByteString i + , tokenListOptions List.!! x + ) + ) + patternOptions {-# INLINEABLE currencyListOptions #-} -- | A \"long\" list of currencies each with a \"long\" list of tokens for stress-testing (one -- doesn't need many elements to stress-test Plutus Tx, hence the quotes). longCurrencyChunk :: [(CurrencySymbol, [(TokenName, Integer)])] -longCurrencyChunk - = List.concatMap Tx.sequence +longCurrencyChunk = + List.concatMap Tx.sequence . List.zip (List.map (CurrencySymbol . replicateToByteString) [1 .. scalingFactor]) $ List.replicate scalingFactor tokenListOptions {-# INLINEABLE longCurrencyChunk #-} @@ -125,25 +125,25 @@ longCurrencyChunk -- ["*ab*cd*","ab*cd*","*ab*cd","ab*cd","*abcd*","abcd*","*abcd","abcd"] insertHooks :: [a] -> [[Maybe a]] insertHooks xs0 = do - -- The fast and slow pointers trick to find the middle of the list. Check out - -- https://medium.com/@arifimran5/fast-and-slow-pointer-pattern-in-linked-list-43647869ac99 - -- if you're not familiar with the idea. - let go (_ : _ : xsFast) (x : xsSlow) = do - xs' <- go xsFast xsSlow - [Just x : xs'] - go _ xsSlow = do - prefix <- [[Nothing], []] - suffix <- [[Nothing], []] - [prefix List.++ List.map Just xsSlow List.++ suffix] - xs0' <- go xs0 xs0 - [Nothing : xs0', xs0'] + -- The fast and slow pointers trick to find the middle of the list. Check out + -- https://medium.com/@arifimran5/fast-and-slow-pointer-pattern-in-linked-list-43647869ac99 + -- if you're not familiar with the idea. + let go (_ : _ : xsFast) (x : xsSlow) = do + xs' <- go xsFast xsSlow + [Just x : xs'] + go _ xsSlow = do + prefix <- [[Nothing], []] + suffix <- [[Nothing], []] + [prefix List.++ List.map Just xsSlow List.++ suffix] + xs0' <- go xs0 xs0 + [Nothing : xs0', xs0'] {-# INLINEABLE insertHooks #-} -- | The last and the biggest list of currencies from 'currencyListOptions' with 'longCurrencyChunk' -- inserted in it in various ways as per 'insertHooks'. currencyLongListOptions :: [[(CurrencySymbol, [(TokenName, Integer)])]] currencyLongListOptions = - insertHooks (List.last currencyListOptions) <&> \currencyListWithHooks -> + insertHooks (List.last currencyListOptions) <&> \currencyListWithHooks -> List.concatMap (maybe longCurrencyChunk pure) currencyListWithHooks {-# INLINEABLE currencyLongListOptions #-} @@ -156,25 +156,29 @@ valueToLists = List.map (fmap AssocMap.toSOPList) . AssocMap.toSOPList . getValu -- | Check equality of two compiled 'Value's through UPLC evaluation and annotate the result with -- the cost of evaluation. eqValueCode :: CompiledCode Value -> CompiledCode Value -> (Bool, PLC.CountingSt) -eqValueCode valueCode1 valueCode2 = (res, cost) where +eqValueCode valueCode1 valueCode2 = (res, cost) + where prog = - $$(compile [|| \value1 value2 -> toOpaque ((value1 :: Value) == value2) ||]) - `unsafeApplyCode` valueCode1 `unsafeApplyCode` valueCode2 - (errOrRes, cost) - = PLC.runCekNoEmit PLC.defaultCekParametersForTesting PLC.counting + $$(compile [||\value1 value2 -> toOpaque ((value1 :: Value) == value2)||]) + `unsafeApplyCode` valueCode1 + `unsafeApplyCode` valueCode2 + (errOrRes, cost) = + PLC.runCekNoEmit PLC.defaultCekParametersForTesting PLC.counting . PLC.runQuote . PLC.unDeBruijnTermWith (Haskell.error "Free variable") . PLC._progTerm $ getPlc prog res = - either Haskell.throw id $ - errOrRes >>= PLC.readKnownSelf + either Haskell.throw id + $ errOrRes + >>= PLC.readKnownSelf -- | Check equality of two compiled 'Value's directly in Haskell. haskellEqValue :: Value -> Value -> Bool -haskellEqValue value1 value2 = toMap value1 Haskell.== toMap value2 where - toMap - = Map.filter (Haskell.not . Map.null) +haskellEqValue value1 value2 = toMap value1 Haskell.== toMap value2 + where + toMap = + Map.filter (Haskell.not . Map.null) . Haskell.fmap (Map.filter (Haskell./= 0)) . Map.fromListWith (Map.unionWith (Haskell.+)) . Haskell.map (Haskell.fmap $ Map.fromListWith (Haskell.+)) @@ -182,11 +186,15 @@ haskellEqValue value1 value2 = toMap value1 Haskell.== toMap value2 where -- | Check whether all currencies and tokens within each of the currencies occur uniquely. allDistinct :: Value -> Bool -allDistinct - = Haskell.and +allDistinct = + Haskell.and . Map.fromListWith (\_ _ -> False) - . Haskell.map (Haskell.fmap $ - Haskell.and . Map.fromListWith (\_ _ -> False) . Haskell.map (Haskell.fmap $ \_ -> True)) + . Haskell.map + ( Haskell.fmap + $ Haskell.and + . Map.fromListWith (\_ _ -> False) + . Haskell.map (Haskell.fmap $ \_ -> True) + ) . valueToLists -- | Return all the pairs of elements of the given list. @@ -196,37 +204,43 @@ allDistinct -- >>> pairs "abc" -- [('a','a'),('a','b'),('b','b'),('b','c'),('c','c')] pairs :: [a] -> [(a, a)] -pairs [] = [] -pairs [x] = [(x, x)] +pairs [] = [] +pairs [x] = [(x, x)] pairs (x : y : xs) = (x, x) : (x, y) : pairs (y : xs) -- | Convert each list of currencies to a 'Value', check whether those 'Value' are equal to each -- other and dump the costs of all the checks to a golden file. test_EqCurrencyList :: Haskell.String -> [[(CurrencySymbol, [(TokenName, Integer)])]] -> TestNested test_EqCurrencyList name currencyLists = - nestedGoldenVsDoc name ".stat" . Pretty.vsep $ - let attachCode value = (value, liftCodeDef value) - valuesWithCodes = List.map (attachCode . listsToValue) currencyLists - in pairs valuesWithCodes Haskell.<&> \((value1, valueCode1), (value2, valueCode2)) -> + nestedGoldenVsDoc name ".stat" + . Pretty.vsep + $ let attachCode value = (value, liftCodeDef value) + valuesWithCodes = List.map (attachCode . listsToValue) currencyLists + in pairs valuesWithCodes Haskell.<&> \((value1, valueCode1), (value2, valueCode2)) -> let eqResExp = value1 `haskellEqValue` value2 (eqResAct, PLC.CountingSt budget) = valueCode1 `eqValueCode` valueCode2 - -- We need the 'allDistinct' checks, because duplicated - -- currencies/tokens-within-the-same-currency result in undefined behavior when - -- checking 'Value's for equality. - in if allDistinct value1 && allDistinct value2 && eqResAct /= eqResExp - then Haskell.error $ Haskell.intercalate "\n" - [ "Error when checking equality of" - , " " Haskell.++ Haskell.show value1 - , "and" - , " " Haskell.++ Haskell.show value2 - , "Expected " Haskell.++ Haskell.show eqResExp - , "But got " Haskell.++ Haskell.show eqResAct - ] - else Pretty.group $ Pretty.pretty budget + in -- We need the 'allDistinct' checks, because duplicated + -- currencies/tokens-within-the-same-currency result in undefined behavior when + -- checking 'Value's for equality. + if allDistinct value1 && allDistinct value2 && eqResAct /= eqResExp + then + Haskell.error + $ Haskell.intercalate + "\n" + [ "Error when checking equality of" + , " " Haskell.++ Haskell.show value1 + , "and" + , " " Haskell.++ Haskell.show value2 + , "Expected " Haskell.++ Haskell.show eqResExp + , "But got " Haskell.++ Haskell.show eqResAct + ] + else Pretty.group $ Pretty.pretty budget test_EqValue :: TestTree test_EqValue = - runTestNested ["test-plugin", "Spec", "Data", "Value"] . pure . testNestedGhc $ - [ test_EqCurrencyList "Short" currencyListOptions - , test_EqCurrencyList "Long" currencyLongListOptions - ] + runTestNested ["test-plugin", "Spec", "Data", "Value"] + . pure + . testNestedGhc + $ [ test_EqCurrencyList "Short" currencyListOptions + , test_EqCurrencyList "Long" currencyLongListOptions + ] diff --git a/plutus-ledger-api/test-plugin/Spec/Envelope.hs b/plutus-ledger-api/test-plugin/Spec/Envelope.hs index 250e2378abe..1991a022525 100644 --- a/plutus-ledger-api/test-plugin/Spec/Envelope.hs +++ b/plutus-ledger-api/test-plugin/Spec/Envelope.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Spec.Envelope where @@ -21,12 +21,12 @@ testTrivialEnvelope = "A trivial function that computes 2 + 2" $$(PlutusTx.compile [||(2 :: Integer) P.+ 2||]) actual - where - basePath :: FilePath - basePath = "test-plugin/golden" + where + basePath :: FilePath + basePath = "test-plugin/golden" - actual :: FilePath - actual = basePath "envelope.actual.json" + actual :: FilePath + actual = basePath "envelope.actual.json" - golden :: FilePath - golden = basePath "envelope.json" + golden :: FilePath + golden = basePath "envelope.json" diff --git a/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs b/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs index e43d2b4b5a6..804dc36ed00 100644 --- a/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs +++ b/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -26,12 +26,12 @@ import PlutusTx.AssocMap qualified as Map import PlutusTx.Code (CompiledCode, unsafeApplyCode) import PlutusTx.Lift (liftCodeDef) import PlutusTx.List qualified as List -import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import PlutusTx.TH (compile) -import Prelude qualified as Haskell +import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import Test.QuickCheck qualified as QC import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (Property, testProperty, (===)) +import Prelude qualified as Haskell tests :: TestTree tests = testGroup "MintValue" [testPropsInHaskell, testPropsInPlinth] @@ -43,7 +43,7 @@ prop_MintValueBuiltinData :: Either Value MintValue -> Bool prop_MintValueBuiltinData values = let (value, mintValue) = case values of - Left v -> (v, coerce v) + Left v -> (v, coerce v) Right mv -> (coerce mv, mv) in toBuiltinData mintValue == toBuiltinData value @@ -143,10 +143,9 @@ test_Plinth_MintValueBurnedIsPositive = -------------------------------------------------------------------------------- -- Helper functions ------------------------------------------------------------ -scaleTestsBy :: (QC.Testable prop) => Haskell.Int -> prop -> QC.Property +scaleTestsBy :: QC.Testable prop => Haskell.Int -> prop -> QC.Property scaleTestsBy factor = QC.withMaxSuccess (100 Haskell.* factor) . QC.mapSize (Haskell.* factor) cekProp :: CompiledCode Bool -> Property cekProp code = evaluationResultMatchesHaskell code (===) True - diff --git a/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs b/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs index 4a44e76cc1a..babf76ddf93 100644 --- a/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs +++ b/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=SumsOfProducts #-} module Spec.ReturnUnit.V3 where @@ -49,7 +48,7 @@ expectSuccess :: Data -> TestTree expectSuccess name code arg = testCase name $ case res of - Left _ -> assertFailure "fails" + Left _ -> assertFailure "fails" Right _ -> pure () where sScript = serialiseCompiledCode code @@ -65,8 +64,8 @@ expectFailure :: TestTree expectFailure name code arg = testCase name $ case res of Left InvalidReturnValue -> pure () - Left _ -> assertFailure "evaluation failed for a different reason" - Right _ -> assertFailure "evaluation succeeded" + Left _ -> assertFailure "evaluation failed for a different reason" + Right _ -> assertFailure "evaluation succeeded" where sScript = serialiseCompiledCode code script = either (error . show) id $ V3.deserialiseScript changPV sScript diff --git a/plutus-ledger-api/test-plugin/Spec/Value.hs b/plutus-ledger-api/test-plugin/Spec/Value.hs index 35e099f12e3..773b5897a68 100644 --- a/plutus-ledger-api/test-plugin/Spec/Value.hs +++ b/plutus-ledger-api/test-plugin/Spec/Value.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Spec.Value where @@ -54,34 +53,34 @@ scalingFactor = 4 -- was described in the previous point. patternOptions :: [[(Integer, Integer)]] patternOptions = - [ [] - , [(1,0)] - , [(1,1)] - , [(1,1), (2,2)] - , [(1,0), (2,2), (1,1)] - , [(2,3), (1,0), (2,2), (1,1)] - , [(2,2), (2,3), (1,0), (2,4), (1,1)] - , [(2,2), (2,3), (1,0), (3,5), (2,4), (1,1)] - , [(2,2), (2,3), (1,0), (3,5), (3,6), (2,4), (1,1)] - , [(2,2), (2,3), (1,0), (3,5), (3,6), (2,4), (1,1), (2,7)] - , [(1,9), (2,2), (6,10), (2,3), (1,0), (4,10), (3,5), (5,0), (3,6), (2,4), (1,1), (2,7), (4,8)] - ] + [ [] + , [(1, 0)] + , [(1, 1)] + , [(1, 1), (2, 2)] + , [(1, 0), (2, 2), (1, 1)] + , [(2, 3), (1, 0), (2, 2), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (2, 4), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (3, 5), (2, 4), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (3, 5), (3, 6), (2, 4), (1, 1)] + , [(2, 2), (2, 3), (1, 0), (3, 5), (3, 6), (2, 4), (1, 1), (2, 7)] + , [(1, 9), (2, 2), (6, 10), (2, 3), (1, 0), (4, 10), (3, 5), (5, 0), (3, 6), (2, 4), (1, 1), (2, 7), (4, 8)] + ] {-# INLINEABLE patternOptions #-} i2Bs :: Integer -> BuiltinByteString i2Bs n = - if n < 0 - then "-" `appendByteString` i2Bs (negate n) - -- @48@ is the ASCII code of @0@. - else List.foldr (consByteString . (48 +)) emptyByteString $ toDigits n + if n < 0 + then "-" `appendByteString` i2Bs (negate n) + -- @48@ is the ASCII code of @0@. + else List.foldr (consByteString . (48 +)) emptyByteString $ toDigits n {-# INLINEABLE i2Bs #-} -- | Like 'i2Bs but generates longer bytestrings, so that repeated recalculations of -- currency/token name comparisons get reflected in the budget tests in a visible manner. replicateToByteString :: Integer -> BuiltinByteString replicateToByteString i = - List.foldr id emptyByteString $ - List.replicate iTo6 (appendByteString $ i2Bs i) + List.foldr id emptyByteString + $ List.replicate iTo6 (appendByteString $ i2Bs i) where iTo2 = i * i iTo4 = iTo2 * iTo2 @@ -90,26 +89,27 @@ replicateToByteString i = tokenListOptions :: [[(TokenName, Integer)]] tokenListOptions = - List.map - (List.map $ \(i, x) -> (TokenName $ replicateToByteString i, x)) - patternOptions + List.map + (List.map $ \(i, x) -> (TokenName $ replicateToByteString i, x)) + patternOptions {-# INLINEABLE tokenListOptions #-} currencyListOptions :: [[(CurrencySymbol, [(TokenName, Integer)])]] currencyListOptions = - List.map - (List.map $ \(i, x) -> - ( CurrencySymbol $ replicateToByteString i - , tokenListOptions List.!! x - )) - patternOptions + List.map + ( List.map $ \(i, x) -> + ( CurrencySymbol $ replicateToByteString i + , tokenListOptions List.!! x + ) + ) + patternOptions {-# INLINEABLE currencyListOptions #-} -- | A \"long\" list of currencies each with a \"long\" list of tokens for stress-testing (one -- doesn't need many elements to stress-test Plutus Tx, hence the quotes). longCurrencyChunk :: [(CurrencySymbol, [(TokenName, Integer)])] -longCurrencyChunk - = List.concatMap Tx.sequence +longCurrencyChunk = + List.concatMap Tx.sequence . List.zip (List.map (CurrencySymbol . replicateToByteString) [1 .. scalingFactor]) $ List.replicate scalingFactor tokenListOptions {-# INLINEABLE longCurrencyChunk #-} @@ -125,25 +125,25 @@ longCurrencyChunk -- ["*ab*cd*","ab*cd*","*ab*cd","ab*cd","*abcd*","abcd*","*abcd","abcd"] insertHooks :: [a] -> [[Maybe a]] insertHooks xs0 = do - -- The fast and slow pointers trick to find the middle of the list. Check out - -- https://medium.com/@arifimran5/fast-and-slow-pointer-pattern-in-linked-list-43647869ac99 - -- if you're not familiar with the idea. - let go (_ : _ : xsFast) (x : xsSlow) = do - xs' <- go xsFast xsSlow - [Just x : xs'] - go _ xsSlow = do - prefix <- [[Nothing], []] - suffix <- [[Nothing], []] - [prefix List.++ List.map Just xsSlow List.++ suffix] - xs0' <- go xs0 xs0 - [Nothing : xs0', xs0'] + -- The fast and slow pointers trick to find the middle of the list. Check out + -- https://medium.com/@arifimran5/fast-and-slow-pointer-pattern-in-linked-list-43647869ac99 + -- if you're not familiar with the idea. + let go (_ : _ : xsFast) (x : xsSlow) = do + xs' <- go xsFast xsSlow + [Just x : xs'] + go _ xsSlow = do + prefix <- [[Nothing], []] + suffix <- [[Nothing], []] + [prefix List.++ List.map Just xsSlow List.++ suffix] + xs0' <- go xs0 xs0 + [Nothing : xs0', xs0'] {-# INLINEABLE insertHooks #-} -- | The last and the biggest list of currencies from 'currencyListOptions' with 'longCurrencyChunk' -- inserted in it in various ways as per 'insertHooks'. currencyLongListOptions :: [[(CurrencySymbol, [(TokenName, Integer)])]] currencyLongListOptions = - insertHooks (List.last currencyListOptions) <&> \currencyListWithHooks -> + insertHooks (List.last currencyListOptions) <&> \currencyListWithHooks -> List.concatMap (maybe longCurrencyChunk pure) currencyListWithHooks {-# INLINEABLE currencyLongListOptions #-} @@ -156,25 +156,29 @@ valueToLists = List.map (fmap AssocMap.toList) . AssocMap.toList . getValue -- | Check equality of two compiled 'Value's through UPLC evaluation and annotate the result with -- the cost of evaluation. eqValueCode :: CompiledCode Value -> CompiledCode Value -> (Bool, PLC.CountingSt) -eqValueCode valueCode1 valueCode2 = (res, cost) where +eqValueCode valueCode1 valueCode2 = (res, cost) + where prog = - $$(compile [|| \value1 value2 -> toOpaque ((value1 :: Value) == value2) ||]) - `unsafeApplyCode` valueCode1 `unsafeApplyCode` valueCode2 - (errOrRes, cost) - = PLC.runCekNoEmit PLC.defaultCekParametersForTesting PLC.counting + $$(compile [||\value1 value2 -> toOpaque ((value1 :: Value) == value2)||]) + `unsafeApplyCode` valueCode1 + `unsafeApplyCode` valueCode2 + (errOrRes, cost) = + PLC.runCekNoEmit PLC.defaultCekParametersForTesting PLC.counting . PLC.runQuote . PLC.unDeBruijnTermWith (Haskell.error "Free variable") . PLC._progTerm $ getPlc prog res = - either Haskell.throw id $ - errOrRes >>= PLC.readKnownSelf + either Haskell.throw id + $ errOrRes + >>= PLC.readKnownSelf -- | Check equality of two compiled 'Value's directly in Haskell. haskellEqValue :: Value -> Value -> Bool -haskellEqValue value1 value2 = toMap value1 Haskell.== toMap value2 where - toMap - = Map.filter (Haskell.not . Map.null) +haskellEqValue value1 value2 = toMap value1 Haskell.== toMap value2 + where + toMap = + Map.filter (Haskell.not . Map.null) . Haskell.fmap (Map.filter (Haskell./= 0)) . Map.fromListWith (Map.unionWith (Haskell.+)) . Haskell.map (Haskell.fmap $ Map.fromListWith (Haskell.+)) @@ -182,11 +186,15 @@ haskellEqValue value1 value2 = toMap value1 Haskell.== toMap value2 where -- | Check whether all currencies and tokens within each of the currencies occur uniquely. allDistinct :: Value -> Bool -allDistinct - = Haskell.and +allDistinct = + Haskell.and . Map.fromListWith (\_ _ -> False) - . Haskell.map (Haskell.fmap $ - Haskell.and . Map.fromListWith (\_ _ -> False) . Haskell.map (Haskell.fmap $ \_ -> True)) + . Haskell.map + ( Haskell.fmap + $ Haskell.and + . Map.fromListWith (\_ _ -> False) + . Haskell.map (Haskell.fmap $ \_ -> True) + ) . valueToLists -- | Return all the pairs of elements of the given list. @@ -196,37 +204,43 @@ allDistinct -- >>> pairs "abc" -- [('a','a'),('a','b'),('b','b'),('b','c'),('c','c')] pairs :: [a] -> [(a, a)] -pairs [] = [] -pairs [x] = [(x, x)] +pairs [] = [] +pairs [x] = [(x, x)] pairs (x : y : xs) = (x, x) : (x, y) : pairs (y : xs) -- | Convert each list of currencies to a 'Value', check whether those 'Value' are equal to each -- other and dump the costs of all the checks to a golden file. test_EqCurrencyList :: Haskell.String -> [[(CurrencySymbol, [(TokenName, Integer)])]] -> TestNested test_EqCurrencyList name currencyLists = - nestedGoldenVsDoc name ".stat" . Pretty.vsep $ - let attachCode value = (value, liftCodeDef value) - valuesWithCodes = List.map (attachCode . listsToValue) currencyLists - in pairs valuesWithCodes Haskell.<&> \((value1, valueCode1), (value2, valueCode2)) -> + nestedGoldenVsDoc name ".stat" + . Pretty.vsep + $ let attachCode value = (value, liftCodeDef value) + valuesWithCodes = List.map (attachCode . listsToValue) currencyLists + in pairs valuesWithCodes Haskell.<&> \((value1, valueCode1), (value2, valueCode2)) -> let eqResExp = value1 `haskellEqValue` value2 (eqResAct, PLC.CountingSt budget) = valueCode1 `eqValueCode` valueCode2 - -- We need the 'allDistinct' checks, because duplicated - -- currencies/tokens-within-the-same-currency result in undefined behavior when - -- checking 'Value's for equality. - in if allDistinct value1 && allDistinct value2 && eqResAct /= eqResExp - then Haskell.error $ Haskell.intercalate "\n" - [ "Error when checking equality of" - , " " Haskell.++ Haskell.show value1 - , "and" - , " " Haskell.++ Haskell.show value2 - , "Expected " Haskell.++ Haskell.show eqResExp - , "But got " Haskell.++ Haskell.show eqResAct - ] - else Pretty.group $ Pretty.pretty budget + in -- We need the 'allDistinct' checks, because duplicated + -- currencies/tokens-within-the-same-currency result in undefined behavior when + -- checking 'Value's for equality. + if allDistinct value1 && allDistinct value2 && eqResAct /= eqResExp + then + Haskell.error + $ Haskell.intercalate + "\n" + [ "Error when checking equality of" + , " " Haskell.++ Haskell.show value1 + , "and" + , " " Haskell.++ Haskell.show value2 + , "Expected " Haskell.++ Haskell.show eqResExp + , "But got " Haskell.++ Haskell.show eqResAct + ] + else Pretty.group $ Pretty.pretty budget test_EqValue :: TestTree test_EqValue = - runTestNested ["test-plugin", "Spec", "Value"] . pure . testNestedGhc $ - [ test_EqCurrencyList "Short" currencyListOptions - , test_EqCurrencyList "Long" currencyLongListOptions - ] + runTestNested ["test-plugin", "Spec", "Value"] + . pure + . testNestedGhc + $ [ test_EqCurrencyList "Short" currencyListOptions + , test_EqCurrencyList "Long" currencyLongListOptions + ] diff --git a/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs b/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs index 5a9f0dfbd6a..b8f073779d3 100644 --- a/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs +++ b/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -22,19 +22,27 @@ import Data.ByteString (ByteString) import PlutusCore.Generators.QuickCheck.Builtin (ArbitraryBuiltin (arbitraryBuiltin), shrinkBuiltin) import PlutusLedgerApi.Test.V1.Value () import PlutusLedgerApi.Test.V3.MintValue () -import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), Value (..), currencySymbol, - singleton, symbols, tokenName, unCurrencySymbol, - withCurrencySymbol) +import PlutusLedgerApi.V1.Value ( + CurrencySymbol (..), + TokenName (..), + Value (..), + currencySymbol, + singleton, + symbols, + tokenName, + unCurrencySymbol, + withCurrencySymbol, + ) import PlutusTx.AssocMap qualified as Map import PlutusTx.Code (CompiledCode, unsafeApplyCode) import PlutusTx.Lift (liftCodeDef) import PlutusTx.List qualified as List -import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import PlutusTx.TH (compile) -import Prelude qualified as Haskell +import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) +import Prelude qualified as Haskell tests :: TestTree tests = testGroup "withCurrencySymbol" [testPropsInHaskell, testPropsInPlinth] @@ -46,8 +54,8 @@ prop_EachCurrencySymbolGetsContinuationApplied :: Value -> Bool prop_EachCurrencySymbolGetsContinuationApplied v = List.all (\cs -> withCurrencySymbol cs v False (const True)) (symbols v) -prop_CorrectTokenQuantitiesAreSelected - :: (CurrencySymbol, TokenName, Integer) -> Bool +prop_CorrectTokenQuantitiesAreSelected :: + (CurrencySymbol, TokenName, Integer) -> Bool prop_CorrectTokenQuantitiesAreSelected (cs, tn, q) = [(tn, q)] == withCurrencySymbol cs (singleton cs tn q) [] Map.toList @@ -102,7 +110,7 @@ test_Plinth_CorrectTokenQuantitiesAreSelected = -------------------------------------------------------------------------------- -- Helper functions ------------------------------------------------------------ -scaleTestsBy :: (Testable prop) => Haskell.Int -> prop -> Property +scaleTestsBy :: Testable prop => Haskell.Int -> prop -> Property scaleTestsBy factor = withMaxSuccess (100 Haskell.* factor) . mapSize (Haskell.* factor) diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index b0ca1635941..6fb992eb7df 100644 --- a/plutus-ledger-api/test/Spec.hs +++ b/plutus-ledger-api/test/Spec.hs @@ -38,11 +38,10 @@ v1_evalCtxForTesting = fst . unsafeFromRight . runWriterT . V1.mkEvaluationContext $ fmap snd V1.costModelParamsForTesting -{-| Constructing a V3 context with the first 223 parameters. -As a result, the cost model parameters for `integerToByteString` -and `byteStringToInteger` should be set to large numbers, preventing -them from being used. --} +-- | Constructing a V3 context with the first 223 parameters. +-- As a result, the cost model parameters for `integerToByteString` +-- and `byteStringToInteger` should be set to large numbers, preventing +-- them from being used. v3_evalCtxTooFewParams :: V3.EvaluationContext v3_evalCtxTooFewParams = fst . unsafeFromRight . runWriterT $ @@ -146,7 +145,7 @@ saltedFunction = void res === void res' .&&. fWhich - === isRight res + === isRight res , testProperty "unsaturated" \(n :: Word8) (n' :: Word8) salt fWhich -> let f = ( if fWhich diff --git a/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs b/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs index 8c1b5059489..52117ffe34e 100644 --- a/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs +++ b/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} module Spec.CBOR.DeserialiseFailureInfo (tests) where @@ -19,55 +19,55 @@ tests = "cbor failure" [ testGroup "intepretation tests" - [ testCase "end-of-input" - $ (CBOR.decodeBytes `failsWith` CBOR.EndOfInput) [] - , testCase "expected-bytes" - $ (CBOR.decodeBytes `failsWith` CBOR.ExpectedBytes) [0x5c] - , testCase "other" - $ (CBOR.decodeBool `failsWith` CBOR.OtherReason "expected bool") [0x5c] + [ testCase "end-of-input" $ + (CBOR.decodeBytes `failsWith` CBOR.EndOfInput) [] + , testCase "expected-bytes" $ + (CBOR.decodeBytes `failsWith` CBOR.ExpectedBytes) [0x5c] + , testCase "other" $ + (CBOR.decodeBool `failsWith` CBOR.OtherReason "expected bool") [0x5c] ] , testGroup "pretty-printing" - [ testCase "end-of-input" - $ renderPretty + [ testCase "end-of-input" $ + renderPretty CBOR.DeserialiseFailureInfo { CBOR.dfOffset = 123425678900000 , CBOR.dfReason = CBOR.EndOfInput } - @?= "CBOR deserialisation failed at the offset 123425678900000 \ - \for the following reason: reached the end of input \ - \while more data was expected." - , testCase "expected-bytes" - $ renderPretty + @?= "CBOR deserialisation failed at the offset 123425678900000 \ + \for the following reason: reached the end of input \ + \while more data was expected." + , testCase "expected-bytes" $ + renderPretty CBOR.DeserialiseFailureInfo { CBOR.dfOffset = 123425678900000 , CBOR.dfReason = CBOR.ExpectedBytes } - @?= "CBOR deserialisation failed at the offset 123425678900000 \ - \for the following reason: \ - \the bytes inside the input are malformed." - , testCase "other" - $ let reason = "expected bool" - in renderPretty - CBOR.DeserialiseFailureInfo - { CBOR.dfOffset = 123425678900000 - , CBOR.dfReason = CBOR.OtherReason reason - } - @?= "CBOR deserialisation failed at the offset 123425678900000 \ - \for the following reason: " + @?= "CBOR deserialisation failed at the offset 123425678900000 \ + \for the following reason: \ + \the bytes inside the input are malformed." + , testCase "other" $ + let reason = "expected bool" + in renderPretty + CBOR.DeserialiseFailureInfo + { CBOR.dfOffset = 123425678900000 + , CBOR.dfReason = CBOR.OtherReason reason + } + @?= "CBOR deserialisation failed at the offset 123425678900000 \ + \for the following reason: " <> reason ] ] - where - failsWith :: - (Eq a, Show a) => - (forall s. CBOR.Decoder s a) -> - CBOR.DeserialiseFailureReason -> - LBS.ByteString -> - Assertion - failsWith decoder reason inp = - let res = CBOR.deserialiseFromBytes decoder inp - in Left reason @=? first (CBOR.dfReason . CBOR.readDeserialiseFailureInfo) res + where + failsWith :: + (Eq a, Show a) => + (forall s. CBOR.Decoder s a) -> + CBOR.DeserialiseFailureReason -> + LBS.ByteString -> + Assertion + failsWith decoder reason inp = + let res = CBOR.deserialiseFromBytes decoder inp + in Left reason @=? first (CBOR.dfReason . CBOR.readDeserialiseFailureInfo) res - renderPretty :: (Pretty a) => a -> String - renderPretty = show . pretty + renderPretty :: Pretty a => a -> String + renderPretty = show . pretty diff --git a/plutus-ledger-api/test/Spec/ContextDecoding.hs b/plutus-ledger-api/test/Spec/ContextDecoding.hs index 5a4bc255d67..7fe2d6c5576 100644 --- a/plutus-ledger-api/test/Spec/ContextDecoding.hs +++ b/plutus-ledger-api/test/Spec/ContextDecoding.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-} + module Spec.ContextDecoding where import Codec.Serialise qualified as S @@ -13,16 +14,19 @@ import Test.Tasty import Test.Tasty.HUnit tests :: TestTree -tests = testGroup "context decoding" [ test_v1Context ] +tests = testGroup "context decoding" [test_v1Context] test_v1Context :: TestTree test_v1Context = testCase "v1context" $ do input <- BSL.readFile "test/Spec/v1-context-data" let (d :: Data) = S.deserialise input - assertBool "can't parse as V1 context" + assertBool + "can't parse as V1 context" (isJust $ fromBuiltinData @V1.ScriptContext (V1.BuiltinData d)) -- Note, these should return Nothing and not throw - assertBool "can parse as V2 context" + assertBool + "can parse as V2 context" (isNothing $ fromBuiltinData @V2.ScriptContext (V2.BuiltinData d)) - assertBool "can parse as V3 context" + assertBool + "can parse as V3 context" (isNothing $ fromBuiltinData @V3.ScriptContext (V3.BuiltinData d)) diff --git a/plutus-ledger-api/test/Spec/CostModelParams.hs b/plutus-ledger-api/test/Spec/CostModelParams.hs index d1ef5c458b8..394eefd3d4c 100644 --- a/plutus-ledger-api/test/Spec/CostModelParams.hs +++ b/plutus-ledger-api/test/Spec/CostModelParams.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Spec.CostModelParams where -import PlutusLedgerApi.Common (CostModelApplyWarn (CMTooManyParamsWarn, cmActual, cmExpected), - IsParamName (readParamName, showParamName)) +import PlutusLedgerApi.Common ( + CostModelApplyWarn (CMTooManyParamsWarn, cmActual, cmExpected), + IsParamName (readParamName, showParamName), + ) import PlutusLedgerApi.Test.V3.EvaluationContext qualified as V3 import PlutusLedgerApi.V1 qualified as V1 import PlutusLedgerApi.V2 qualified as V2 @@ -41,14 +43,14 @@ tests = for_ v3_ParamNames \p -> assertBool "tripping v3 cm params failed" $ Just p == readParamName (showParamName p) - -- The introduction of the new bitwise builtins has + , -- The introduction of the new bitwise builtins has -- messed this up because defaultCostModelParamsForTesting is the cost -- model parameters for model C, -- which now includes the new bitwise builtins. -- , embed $ testCase "default values costmodelparamsfortesting" do -- defaultCostModelParamsForTesting -- @=? Just (toCostModelParams V3.costModelParamsForTesting) - , embed $ testCase "context length" do + embed $ testCase "context length" do let costValuesForTesting = fmap snd V3.costModelParamsForTesting -- the `costModelParamsForTesting` reflects only the latest -- version (V3), so this should succeed because the lengths match @@ -90,21 +92,21 @@ tests = do pure (Text.unlines (map showParamName v3_ParamNames)) Text.isPrefixOf ] - where - hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool - hasWarnMoreParams - testExpected - testActual - (Right (_, [CMTooManyParamsWarn{..}])) - | testExpected == cmExpected && testActual == cmActual = True - hasWarnMoreParams _ _ _ = False + where + hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool + hasWarnMoreParams + testExpected + testActual + (Right (_, [CMTooManyParamsWarn {..}])) + | testExpected == cmExpected && testActual == cmActual = True + hasWarnMoreParams _ _ _ = False - paramSubset pA pB = - Set.fromList (showParamName <$> pA) - `isSubsetOf` Set.fromList (showParamName <$> pB) + paramSubset pA pB = + Set.fromList (showParamName <$> pA) + `isSubsetOf` Set.fromList (showParamName <$> pB) - paramEqual pA pB = paramSubset pA pB && paramSubset pB pA + paramEqual pA pB = paramSubset pA pB && paramSubset pB pA - v1_ParamNames = enumerate @V1.ParamName - v2_ParamNames = enumerate @V2.ParamName - v3_ParamNames = enumerate @V3.ParamName + v1_ParamNames = enumerate @V1.ParamName + v2_ParamNames = enumerate @V2.ParamName + v3_ParamNames = enumerate @V3.ParamName diff --git a/plutus-ledger-api/test/Spec/Data/CostModelParams.hs b/plutus-ledger-api/test/Spec/Data/CostModelParams.hs index a4b889aa544..2c0d296ce68 100644 --- a/plutus-ledger-api/test/Spec/Data/CostModelParams.hs +++ b/plutus-ledger-api/test/Spec/Data/CostModelParams.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Spec.Data.CostModelParams where -import PlutusLedgerApi.Common (CostModelApplyWarn (CMTooManyParamsWarn, cmActual, cmExpected), - IsParamName (readParamName, showParamName)) +import PlutusLedgerApi.Common ( + CostModelApplyWarn (CMTooManyParamsWarn, cmActual, cmExpected), + IsParamName (readParamName, showParamName), + ) import PlutusLedgerApi.Data.V1 qualified as V1 import PlutusLedgerApi.Data.V2 qualified as V2 import PlutusLedgerApi.Data.V3 qualified as V3 @@ -91,21 +93,21 @@ tests = do pure (Text.unlines (map showParamName v3_ParamNames)) Text.isPrefixOf ] - where - hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool - hasWarnMoreParams - testExpected - testActual - (Right (_, [CMTooManyParamsWarn{..}])) - | testExpected == cmExpected && testActual == cmActual = True - hasWarnMoreParams _ _ _ = False + where + hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool + hasWarnMoreParams + testExpected + testActual + (Right (_, [CMTooManyParamsWarn {..}])) + | testExpected == cmExpected && testActual == cmActual = True + hasWarnMoreParams _ _ _ = False - paramSubset pA pB = - Set.fromList (showParamName <$> pA) - `isSubsetOf` Set.fromList (showParamName <$> pB) + paramSubset pA pB = + Set.fromList (showParamName <$> pA) + `isSubsetOf` Set.fromList (showParamName <$> pB) - paramEqual pA pB = paramSubset pA pB && paramSubset pB pA + paramEqual pA pB = paramSubset pA pB && paramSubset pB pA - v1_ParamNames = enumerate @V1.ParamName - v2_ParamNames = enumerate @V2.ParamName - v3_ParamNames = enumerate @V3.ParamName + v1_ParamNames = enumerate @V1.ParamName + v2_ParamNames = enumerate @V2.ParamName + v3_ParamNames = enumerate @V3.ParamName diff --git a/plutus-ledger-api/test/Spec/Data/Versions.hs b/plutus-ledger-api/test/Spec/Data/Versions.hs index 172c5ff5485..9354f644ff1 100644 --- a/plutus-ledger-api/test/Spec/Data/Versions.hs +++ b/plutus-ledger-api/test/Spec/Data/Versions.hs @@ -27,7 +27,9 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck tests :: TestTree -tests = testGroup "versions" +tests = + testGroup + "versions" [ testLedgerLanguages , testLanguageVersions , testPermittedBuiltins @@ -36,22 +38,22 @@ tests = testGroup "versions" ] allPVs :: [MajorProtocolVersion] -allPVs = [ shelleyPV .. newestPV ] +allPVs = [shelleyPV .. newestPV] showPV :: MajorProtocolVersion -> String showPV (MajorProtocolVersion pv) = case pv of - 2 -> "Shelley (PV2)" - 3 -> "Allegra (PV3)" - 4 -> "Mary (PV4)" - 5 -> "Alonzo (PV5)" - 6 -> "(Lobster) (PV6)" - 7 -> "Vasil (PV7)" - 8 -> "Valentine (PV8)" - 9 -> "Chang (PV9)" + 2 -> "Shelley (PV2)" + 3 -> "Allegra (PV3)" + 4 -> "Mary (PV4)" + 5 -> "Alonzo (PV5)" + 6 -> "(Lobster) (PV6)" + 7 -> "Vasil (PV7)" + 8 -> "Valentine (PV8)" + 9 -> "Chang (PV9)" 10 -> "Plomin (PV10)" 11 -> "Anon (PV11)" - _ -> " (PV" ++ show pv ++ ")" + _ -> " (PV" ++ show pv ++ ")" -- Some scripts for use in the version tests. errorScript :: SerialisedScript @@ -74,24 +76,26 @@ badCaseScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Case () (UPLC.Error ()) and return them as `Left` values. Any other errors will cause `error` to be invoked. -} -mkTestTerm - :: PlutusLedgerLanguage - -> MajorProtocolVersion - -> UPLC.Program DeBruijn DefaultUni DefaultFun () - -> Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) +mkTestTerm :: + PlutusLedgerLanguage -> + MajorProtocolVersion -> + UPLC.Program DeBruijn DefaultUni DefaultFun () -> + Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) mkTestTerm ll pv prog = - case deserialiseScript ll pv $ serialiseUPLC prog - of Right s -> - case mkTermToEvaluate ll pv s [] - of Right t -> Right t - Left (CodecError e) -> Left e - Left e -> Prelude.error $ show e - Left e -> Left e + case deserialiseScript ll pv $ serialiseUPLC prog of + Right s -> + case mkTermToEvaluate ll pv s [] of + Right t -> Right t + Left (CodecError e) -> Left e + Left e -> Prelude.error $ show e + Left e -> Left e -- Test that the different Plutus Core ledger languages are available in the -- expected protocol versions and not in others. testLedgerLanguages :: TestTree -testLedgerLanguages = testGroup "ledger languages" +testLedgerLanguages = + testGroup + "ledger languages" [ testProperty "PlutusV1 not before but after" $ prop_notBeforeButAfter V1.deserialiseScript alonzoPV , testProperty "PlutusV2 not before but after" $ prop_notBeforeButAfter V2.deserialiseScript vasilPV , testProperty "PlutusV3 not before but after" $ prop_notBeforeButAfter V3.deserialiseScript changPV @@ -99,20 +103,21 @@ testLedgerLanguages = testGroup "ledger languages" \pvA pvB -> pvA < pvB ==> ledgerLanguagesAvailableIn pvA `Set.isSubsetOf` ledgerLanguagesAvailableIn pvB ] where - prop_notBeforeButAfter - :: (MajorProtocolVersion -> SerialisedScript -> Either ScriptDecodeError b) - -> MajorProtocolVersion -> MajorProtocolVersion -> Bool + prop_notBeforeButAfter :: + (MajorProtocolVersion -> SerialisedScript -> Either ScriptDecodeError b) -> + MajorProtocolVersion -> + MajorProtocolVersion -> + Bool prop_notBeforeButAfter phase1Func expectedPv genPv = - -- run phase 1 on an example script - let resPhase1 = phase1Func genPv errorScript - in if genPv < expectedPv - -- generated an old protocol version - then - case resPhase1 of - Left LedgerLanguageNotAvailableError{} -> True - _ -> False - -- generated an eq or gt the expected protocol version - else isRight resPhase1 + -- run phase 1 on an example script + let resPhase1 = phase1Func genPv errorScript + in if genPv < expectedPv + -- generated an old protocol version + then case resPhase1 of + Left LedgerLanguageNotAvailableError {} -> True + _ -> False + -- generated an eq or gt the expected protocol version + else isRight resPhase1 -- Test that the different Plutus Core language versions are available in the -- expected LL/PV combinations. @@ -121,41 +126,51 @@ testLanguageVersions = testGroup "Plutus Core language versions" $ let expectGood prog ll pv = testCase ("Ok in " ++ showPV pv) $ - assertBool ("v110" ++ " not allowed in " ++ show ll ++" @" ++ showPV pv) $ - isRight $ mkTestTerm ll pv prog + assertBool ("v110" ++ " not allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isRight $ + mkTestTerm ll pv prog expectBad prog ll pv = testCase ("Not in " ++ showPV pv) $ - assertBool ("v110" ++ " should not be allowed in " ++ show ll ++" @" ++ showPV pv) $ - isLeft $ mkTestTerm ll pv prog + assertBool ("v110" ++ " should not be allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isLeft $ + mkTestTerm ll pv prog testOkFrom ll firstGood prog = - let expectedGood = [ firstGood .. newestPV ] - in testGroup (show ll) $ - fmap (expectBad prog ll) (allPVs \\ expectedGood) ++ - fmap (expectGood prog ll) expectedGood - in [ testGroup "v1.1.0 availability" - [ testOkFrom PlutusV1 newestPV v110script - , testOkFrom PlutusV2 newestPV v110script - , testOkFrom PlutusV3 changPV v110script - ] - -- Check that case and constr are not allowed in 1.1.0 in any LL/PV combination - , testCase "case is not available in v1.0.0 ever" $ - sequence_ [ assertBool ("case unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ - isLeft $ mkTestTerm ll pv badCaseScript - | ll <- enumerate, pv <- allPVs ] - - , testCase "constr is not available in v1.0.0 ever" $ - sequence_ [ assertBool ("constr unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ - isLeft $ mkTestTerm ll pv badConstrScript - | ll <- enumerate, pv <- allPVs ] - ] + let expectedGood = [firstGood .. newestPV] + in testGroup (show ll) $ + fmap (expectBad prog ll) (allPVs \\ expectedGood) + ++ fmap (expectGood prog ll) expectedGood + in [ testGroup + "v1.1.0 availability" + [ testOkFrom PlutusV1 newestPV v110script + , testOkFrom PlutusV2 newestPV v110script + , testOkFrom PlutusV3 changPV v110script + ] + , -- Check that case and constr are not allowed in 1.1.0 in any LL/PV combination + testCase "case is not available in v1.0.0 ever" $ + sequence_ + [ assertBool ("case unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ + isLeft $ + mkTestTerm ll pv badCaseScript + | ll <- enumerate + , pv <- allPVs + ] + , testCase "constr is not available in v1.0.0 ever" $ + sequence_ + [ assertBool ("constr unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ + isLeft $ + mkTestTerm ll pv badConstrScript + | ll <- enumerate + , pv <- allPVs + ] + ] -- Testing deserialisation checks for builtins -{- | Make small scripts containing each builtin and check that the expected - builtins are successfully deserialised in each PV/LL combination (and - unexpected builtins cause an error during deserialisation. These MUST BE - EXTENDED when new builtins are deployed. --} +-- | Make small scripts containing each builtin and check that the expected +-- builtins are successfully deserialised in each PV/LL combination (and +-- unexpected builtins cause an error during deserialisation. These MUST BE +-- EXTENDED when new builtins are deployed. + -- Should we test plcVersion110 as well? mkScriptForBuiltin :: DefaultFun -> (String, SerialisedScript) mkScriptForBuiltin fun = @@ -186,18 +201,22 @@ builtins6 :: [(String, SerialisedScript)] builtins6 = mkScriptsForBuiltins batch6 allBuiltins :: [(String, SerialisedScript)] -allBuiltins = builtins1 ++ builtins2 - ++ builtins3 ++ builtins4a - ++ builtins4b ++ builtins5 - ++ builtins6 - -{-| Test that the builtins that we expect to be allowed in each LL/PV - combination can be successfully deserialised and that the rest cannot. This - is mostly testing that `builtinsAvailableIn` does what it's supposed to. - This should be updated when new builtins, ledger languages, or protocol - versions are added, but we expect that after Anon all builtins will be - allowed in all ledger languages. --} +allBuiltins = + builtins1 + ++ builtins2 + ++ builtins3 + ++ builtins4a + ++ builtins4b + ++ builtins5 + ++ builtins6 + +-- | Test that the builtins that we expect to be allowed in each LL/PV +-- combination can be successfully deserialised and that the rest cannot. This +-- is mostly testing that `builtinsAvailableIn` does what it's supposed to. +-- This should be updated when new builtins, ledger languages, or protocol +-- versions are added, but we expect that after Anon all builtins will be +-- allowed in all ledger languages. + {- FIXME: Ideally we'd test that for PV11 scripts, all of the newer builtins have the same cost in each Plutus ledger language. That would involve having appropriate sets of cost model parameters to feed into the parameter update @@ -208,53 +227,59 @@ testPermittedBuiltins = let testBuiltins ll deserialise pv expectedGood = let expectGood scripts = for_ scripts $ \(name, script) -> - assertBool (name ++ " not allowed in " ++ show ll ++" @" ++ showPV pv) $ - isRight $ deserialise pv script + assertBool (name ++ " not allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isRight $ + deserialise pv script expectBad scripts = for_ scripts $ \(name, script) -> - assertBool (name ++ " should be allowed in " ++ show ll ++" @" ++ showPV pv) $ - isLeft $ deserialise pv script - in testCase (showPV pv) $ do - expectGood expectedGood - expectBad (allBuiltins \\ expectedGood) - in testGroup "Builtins allowed" - [ let mkTest = testBuiltins PlutusV1 V1.deserialiseScript - in testGroup "PlutusV1" - [ mkTest shelleyPV [] - , mkTest allegraPV [] - , mkTest maryPV [] - , mkTest alonzoPV builtins1 - , mkTest vasilPV builtins1 - , mkTest valentinePV builtins1 - , mkTest changPV builtins1 - , mkTest plominPV builtins1 - , mkTest newestPV allBuiltins - ] - , let mkTest = testBuiltins PlutusV2 V2.deserialiseScript - in testGroup "PlutusV2" - [ mkTest shelleyPV [] - , mkTest allegraPV [] - , mkTest maryPV [] - , mkTest alonzoPV [] - , mkTest vasilPV $ builtins1 ++ builtins2 - , mkTest valentinePV $ builtins1 ++ builtins2 ++ builtins3 - , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 - , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4b - , mkTest newestPV allBuiltins - ] - , let mkTest = testBuiltins PlutusV3 V3.deserialiseScript - in testGroup "PlutusV3" - [ mkTest shelleyPV [] - , mkTest allegraPV [] - , mkTest maryPV [] - , mkTest alonzoPV [] - , mkTest vasilPV [] - , mkTest valentinePV [] - , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b - , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b ++ builtins5 - , mkTest newestPV allBuiltins - ] - ] + assertBool (name ++ " should be allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isLeft $ + deserialise pv script + in testCase (showPV pv) $ do + expectGood expectedGood + expectBad (allBuiltins \\ expectedGood) + in testGroup + "Builtins allowed" + [ let mkTest = testBuiltins PlutusV1 V1.deserialiseScript + in testGroup + "PlutusV1" + [ mkTest shelleyPV [] + , mkTest allegraPV [] + , mkTest maryPV [] + , mkTest alonzoPV builtins1 + , mkTest vasilPV builtins1 + , mkTest valentinePV builtins1 + , mkTest changPV builtins1 + , mkTest plominPV builtins1 + , mkTest newestPV allBuiltins + ] + , let mkTest = testBuiltins PlutusV2 V2.deserialiseScript + in testGroup + "PlutusV2" + [ mkTest shelleyPV [] + , mkTest allegraPV [] + , mkTest maryPV [] + , mkTest alonzoPV [] + , mkTest vasilPV $ builtins1 ++ builtins2 + , mkTest valentinePV $ builtins1 ++ builtins2 ++ builtins3 + , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 + , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4b + , mkTest newestPV allBuiltins + ] + , let mkTest = testBuiltins PlutusV3 V3.deserialiseScript + in testGroup + "PlutusV3" + [ mkTest shelleyPV [] + , mkTest allegraPV [] + , mkTest maryPV [] + , mkTest alonzoPV [] + , mkTest vasilPV [] + , mkTest valentinePV [] + , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b + , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b ++ builtins5 + , mkTest newestPV allBuiltins + ] + ] {- It's important that the results returned by `builtinsAvailableIn` don't change. The implementation changed when we enabled all builtins in all ledger @@ -269,79 +294,167 @@ testPermittedBuiltins = {- DON'T CHANGE THIS: it tests only up to PV10 and should never need to be extended. -} testBuiltinAvailabilityCompatibility :: TestTree testBuiltinAvailabilityCompatibility = - testCase "Old and new versions of builtinsAvailableIn are compatible" $ - let builtinsIntroducedIn_old - :: Map.Map (PlutusLedgerLanguage, MajorProtocolVersion) (Set.Set DefaultFun) + testCase "Old and new versions of builtinsAvailableIn are compatible" $ + let builtinsIntroducedIn_old :: + Map.Map (PlutusLedgerLanguage, MajorProtocolVersion) (Set.Set DefaultFun) builtinsIntroducedIn_old = - Map.fromList - [ ((PlutusV1, alonzoPV), Set.fromList - [ AddInteger, SubtractInteger, MultiplyInteger, DivideInteger - , QuotientInteger, RemainderInteger, ModInteger, EqualsInteger - , LessThanInteger, LessThanEqualsInteger, AppendByteString - , ConsByteString, SliceByteString, LengthOfByteString - , IndexByteString, EqualsByteString, LessThanByteString - , LessThanEqualsByteString, Sha2_256, Sha3_256, Blake2b_256 - , VerifyEd25519Signature, AppendString, EqualsString, EncodeUtf8 - , DecodeUtf8, IfThenElse, ChooseUnit, Trace, FstPair, SndPair - , ChooseList, MkCons, HeadList, TailList, NullList, ChooseData - , ConstrData, MapData, ListData, IData, BData, UnConstrData - , UnMapData, UnListData, UnIData, UnBData, EqualsData, MkPairData - , MkNilData, MkNilPairData ]) - , ((PlutusV2, vasilPV), Set.fromList - [ SerialiseData ]) - , ((PlutusV2, valentinePV), Set.fromList - [ VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature ]) - , ((PlutusV2, plominPV), Set.fromList - [ IntegerToByteString, ByteStringToInteger ]) - , ((PlutusV3, changPV), Set.fromList - [ Bls12_381_G1_add, Bls12_381_G1_neg, Bls12_381_G1_scalarMul - , Bls12_381_G1_equal, Bls12_381_G1_hashToGroup - , Bls12_381_G1_compress, Bls12_381_G1_uncompress - , Bls12_381_G2_add, Bls12_381_G2_neg, Bls12_381_G2_scalarMul - , Bls12_381_G2_equal, Bls12_381_G2_hashToGroup - , Bls12_381_G2_compress, Bls12_381_G2_uncompress - , Bls12_381_millerLoop, Bls12_381_mulMlResult - , Bls12_381_finalVerify, Keccak_256, Blake2b_224 - , IntegerToByteString, ByteStringToInteger ]) - , ((PlutusV3, plominPV), Set.fromList - [ AndByteString, OrByteString, XorByteString - , ComplementByteString , ReadBit, WriteBits - , ReplicateByte , ShiftByteString, RotateByteString - , CountSetBits, FindFirstSetBit, Ripemd_160 ]) - ] - builtinsAvailableIn_old - :: PlutusLedgerLanguage - -> MajorProtocolVersion - -> Set.Set DefaultFun + Map.fromList + [ + ( (PlutusV1, alonzoPV) + , Set.fromList + [ AddInteger + , SubtractInteger + , MultiplyInteger + , DivideInteger + , QuotientInteger + , RemainderInteger + , ModInteger + , EqualsInteger + , LessThanInteger + , LessThanEqualsInteger + , AppendByteString + , ConsByteString + , SliceByteString + , LengthOfByteString + , IndexByteString + , EqualsByteString + , LessThanByteString + , LessThanEqualsByteString + , Sha2_256 + , Sha3_256 + , Blake2b_256 + , VerifyEd25519Signature + , AppendString + , EqualsString + , EncodeUtf8 + , DecodeUtf8 + , IfThenElse + , ChooseUnit + , Trace + , FstPair + , SndPair + , ChooseList + , MkCons + , HeadList + , TailList + , NullList + , ChooseData + , ConstrData + , MapData + , ListData + , IData + , BData + , UnConstrData + , UnMapData + , UnListData + , UnIData + , UnBData + , EqualsData + , MkPairData + , MkNilData + , MkNilPairData + ] + ) + , + ( (PlutusV2, vasilPV) + , Set.fromList + [SerialiseData] + ) + , + ( (PlutusV2, valentinePV) + , Set.fromList + [VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature] + ) + , + ( (PlutusV2, plominPV) + , Set.fromList + [IntegerToByteString, ByteStringToInteger] + ) + , + ( (PlutusV3, changPV) + , Set.fromList + [ Bls12_381_G1_add + , Bls12_381_G1_neg + , Bls12_381_G1_scalarMul + , Bls12_381_G1_equal + , Bls12_381_G1_hashToGroup + , Bls12_381_G1_compress + , Bls12_381_G1_uncompress + , Bls12_381_G2_add + , Bls12_381_G2_neg + , Bls12_381_G2_scalarMul + , Bls12_381_G2_equal + , Bls12_381_G2_hashToGroup + , Bls12_381_G2_compress + , Bls12_381_G2_uncompress + , Bls12_381_millerLoop + , Bls12_381_mulMlResult + , Bls12_381_finalVerify + , Keccak_256 + , Blake2b_224 + , IntegerToByteString + , ByteStringToInteger + ] + ) + , + ( (PlutusV3, plominPV) + , Set.fromList + [ AndByteString + , OrByteString + , XorByteString + , ComplementByteString + , ReadBit + , WriteBits + , ReplicateByte + , ShiftByteString + , RotateByteString + , CountSetBits + , FindFirstSetBit + , Ripemd_160 + ] + ) + ] + builtinsAvailableIn_old :: + PlutusLedgerLanguage -> + MajorProtocolVersion -> + Set.Set DefaultFun builtinsAvailableIn_old thisLv thisPv = - fold $ + fold $ Map.filterWithKey (const . alreadyIntroduced) builtinsIntroducedIn_old - where - alreadyIntroduced :: (PlutusLedgerLanguage, MajorProtocolVersion) -> Bool - alreadyIntroduced (introducedInLv,introducedInPv) = + where + alreadyIntroduced :: (PlutusLedgerLanguage, MajorProtocolVersion) -> Bool + alreadyIntroduced (introducedInLv, introducedInPv) = -- both should be satisfied - introducedInLv <= thisLv && introducedInPv <= thisPv - in sequence_ [ assertBool ("Old and new versions of builtinsAvailableIn differ for " - ++ show ll ++ " @PV" ++ show pv) - $ builtinsAvailableIn ll pv == builtinsAvailableIn_old ll pv - | pv <- [shelleyPV .. plominPV] - , ll <- Set.toList (ledgerLanguagesAvailableIn pv) ] + introducedInLv <= thisLv && introducedInPv <= thisPv + in sequence_ + [ assertBool + ( "Old and new versions of builtinsAvailableIn differ for " + ++ show ll + ++ " @PV" + ++ show pv + ) + $ builtinsAvailableIn ll pv == builtinsAvailableIn_old ll pv + | pv <- [shelleyPV .. plominPV] + , ll <- Set.toList (ledgerLanguagesAvailableIn pv) + ] -- Test that the checks for extra bytes after ends of scripts behave properly. deriving newtype instance Arbitrary MajorProtocolVersion testRmdr :: TestTree -testRmdr = testGroup "extra bytes after end of script" +testRmdr = + testGroup + "extra bytes after end of script" [ testCase "remdr" $ do - assertBool "remdr1" $ isRight $ V1.deserialiseScript valentinePV $ errorScript <> "remdr1" - assertBool "remdr2" $ isRight $ V2.deserialiseScript valentinePV $ errorScript <> "remdr2" - assertBool "remdr1c" $ isRight $ V1.deserialiseScript changPV $ errorScript <> "remdr1" - assertBool "remdr2c" $ isRight $ V2.deserialiseScript changPV $ errorScript <> "remdr2" - assertEqual "remdr3" (RemainderError "remdr3") $ fromLeft (Prelude.error "Expected Reft, got Right") $ V3.deserialiseScript changPV $ errorScript <> "remdr3" - , testProperty "remdr1gen"$ \remdr -> isRight $ V1.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr - , testProperty "remdr2gen"$ \remdr -> isRight $ V2.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr - , testProperty "remdr1genc"$ \remdr -> isRight $ V1.deserialiseScript changPV $ errorScript <> BSS.pack remdr - , testProperty "remdr2genc"$ \remdr -> isRight $ V2.deserialiseScript changPV $ errorScript <> BSS.pack remdr + assertBool "remdr1" $ isRight $ V1.deserialiseScript valentinePV $ errorScript <> "remdr1" + assertBool "remdr2" $ isRight $ V2.deserialiseScript valentinePV $ errorScript <> "remdr2" + assertBool "remdr1c" $ isRight $ V1.deserialiseScript changPV $ errorScript <> "remdr1" + assertBool "remdr2c" $ isRight $ V2.deserialiseScript changPV $ errorScript <> "remdr2" + assertEqual "remdr3" (RemainderError "remdr3") $ fromLeft (Prelude.error "Expected Reft, got Right") $ V3.deserialiseScript changPV $ errorScript <> "remdr3" + , testProperty "remdr1gen" $ \remdr -> isRight $ V1.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr + , testProperty "remdr2gen" $ \remdr -> isRight $ V2.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr + , testProperty "remdr1genc" $ \remdr -> isRight $ V1.deserialiseScript changPV $ errorScript <> BSS.pack remdr + , testProperty "remdr2genc" $ \remdr -> isRight $ V2.deserialiseScript changPV $ errorScript <> BSS.pack remdr -- we cannot make the same property as above for remdr3gen because it may generate valid bytestring append extensions to the original script -- a more sophisticated one could work though ] diff --git a/plutus-ledger-api/test/Spec/Interval.hs b/plutus-ledger-api/test/Spec/Interval.hs index 7a28b0e9f93..baba35a4eb9 100644 --- a/plutus-ledger-api/test/Spec/Interval.hs +++ b/plutus-ledger-api/test/Spec/Interval.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Spec.Interval where @@ -17,16 +17,16 @@ import Hedgehog.Range qualified as Range import PlutusLedgerApi.V1.Interval qualified as Interval import PlutusPrelude (reoption) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (assertBool, testCase) +import Test.Tasty.Hedgehog (testProperty) -- TODO: maybe bias towards generating non-empty intervals? genExtended :: Bool -> Hedgehog.Gen a -> Hedgehog.Gen (Interval.Extended a) genExtended finite g = if finite - then Interval.Finite <$> g - else Gen.choice [ Interval.Finite <$> g, pure Interval.NegInf, pure Interval.PosInf ] + then Interval.Finite <$> g + else Gen.choice [Interval.Finite <$> g, pure Interval.NegInf, pure Interval.PosInf] genLowerBound :: Bool -> Bool -> Hedgehog.Gen a -> Hedgehog.Gen (Interval.LowerBound a) genLowerBound finite closedOnly g = do @@ -71,18 +71,28 @@ openIsEmpty = testCase "open interval isEmpty" $ assertBool "open" - (Interval.isEmpty - (Interval.Interval - (Interval.strictLowerBound 4) (Interval.strictUpperBound 5) :: Interval.Interval Integer)) + ( Interval.isEmpty + ( Interval.Interval + (Interval.strictLowerBound 4) + (Interval.strictUpperBound 5) :: + Interval.Interval Integer + ) + ) openOverlaps :: TestTree openOverlaps = testCase "open interval overlaps" $ - let a = Interval.Interval - (Interval.strictLowerBound 1) (Interval.strictUpperBound 5) :: Interval.Interval Integer - b = Interval.Interval - (Interval.strictLowerBound 4) (Interval.strictUpperBound 6) :: Interval.Interval Integer - in assertBool "overlaps" (not $ Interval.overlaps a b) + let a = + Interval.Interval + (Interval.strictLowerBound 1) + (Interval.strictUpperBound 5) :: + Interval.Interval Integer + b = + Interval.Interval + (Interval.strictLowerBound 4) + (Interval.strictUpperBound 6) :: + Interval.Interval Integer + in assertBool "overlaps" (not $ Interval.overlaps a b) -- Property tests @@ -90,7 +100,8 @@ intvlIsEmpty :: Property intvlIsEmpty = property $ do (i1, i2) <- forAll $ - (,) <$> Gen.integral (toInteger <$> Range.linearBounded @Int) + (,) + <$> Gen.integral (toInteger <$> Range.linearBounded @Int) <*> Gen.integral (toInteger <$> Range.linearBounded @Int) let (from, to) = (min i1 i2, max i1 i2) nonEmpty = Interval.interval from to @@ -100,8 +111,9 @@ intvlIsEmpty = property $ do intvlIntersection :: Property intvlIntersection = property $ do - ints <- forAll $ - traverse (const $ Gen.integral (toInteger <$> Range.linearBounded @Int)) [1..4 :: Integer] + ints <- + forAll $ + traverse (const $ Gen.integral (toInteger <$> Range.linearBounded @Int)) [1 .. 4 :: Integer] let [i1, i2, i3, i4] = sort ints outer = Interval.interval i1 i4 inner = Interval.interval i2 i3 @@ -119,7 +131,8 @@ intvlOverlaps :: Property intvlOverlaps = property $ do (i1, i2) <- forAll $ - (,) <$> Gen.integral (toInteger <$> Range.linearBounded @Int) + (,) + <$> Gen.integral (toInteger <$> Range.linearBounded @Int) <*> Gen.integral (toInteger <$> Range.linearBounded @Int) let (from, to) = (min i1 i2, max i1 i2) i = Interval.interval from to @@ -139,21 +152,23 @@ is implementing the semantically correct behaviour. lowerBoundToValue :: Enum a => Interval.LowerBound a -> Maybe a lowerBoundToValue (Interval.LowerBound (Interval.Finite b) inclusive) = Just $ if inclusive then b else succ b -lowerBoundToValue _ = Nothing +lowerBoundToValue _ = Nothing upperBoundToValue :: Enum a => Interval.UpperBound a -> Maybe a upperBoundToValue (Interval.UpperBound (Interval.Finite b) inclusive) = Just $ if inclusive then b else pred b -upperBoundToValue _ = Nothing +upperBoundToValue _ = Nothing intervalToSet :: (Ord a, Enum a) => Interval.Interval a -> Maybe (Set.Set a) intervalToSet (Interval.Interval lb ub) = Set.fromList <$> (enumFromTo <$> lowerBoundToValue lb <*> upperBoundToValue ub) setToInterval :: Set.Set a -> Interval.Interval a -setToInterval st | Set.null st = - Interval.Interval - (Interval.LowerBound Interval.PosInf True) (Interval.UpperBound Interval.NegInf True) +setToInterval st + | Set.null st = + Interval.Interval + (Interval.LowerBound Interval.PosInf True) + (Interval.UpperBound Interval.NegInf True) setToInterval st = Interval.Interval (Interval.LowerBound (Interval.Finite (Set.findMin st)) True) @@ -223,25 +238,29 @@ tests = , alwaysIsNotEmpty , openIsEmpty , openOverlaps - , testGroup "laws for integer intervals" - [ eqLaws genIntegerInterval - , partialOrderLaws genIntegerInterval Interval.contains - , boundedLatticeLaws genIntegerInterval - ] - , testGroup "laws for boolean intervals" - [ eqLaws genBooleanInterval - , partialOrderLaws genBooleanInterval Interval.contains - , boundedLatticeLaws genBooleanInterval - ] - , testGroup "properties" - [ testProperty "intersection" intvlIntersection - , testProperty "isEmpty" intvlIsEmpty - , testProperty "overlaps" intvlOverlaps - ] - , testGroup "set model" - [ testProperty "tripping" prop_intervalSetTripping - , testProperty "equals" prop_intervalSetEquals - , testProperty "contains" prop_intervalSetContains - , testProperty "intersection" prop_intervalSetIntersection - ] + , testGroup + "laws for integer intervals" + [ eqLaws genIntegerInterval + , partialOrderLaws genIntegerInterval Interval.contains + , boundedLatticeLaws genIntegerInterval + ] + , testGroup + "laws for boolean intervals" + [ eqLaws genBooleanInterval + , partialOrderLaws genBooleanInterval Interval.contains + , boundedLatticeLaws genBooleanInterval + ] + , testGroup + "properties" + [ testProperty "intersection" intvlIntersection + , testProperty "isEmpty" intvlIsEmpty + , testProperty "overlaps" intvlOverlaps + ] + , testGroup + "set model" + [ testProperty "tripping" prop_intervalSetTripping + , testProperty "equals" prop_intervalSetEquals + , testProperty "contains" prop_intervalSetContains + , testProperty "intersection" prop_intervalSetIntersection + ] ] diff --git a/plutus-ledger-api/test/Spec/ScriptDecodeError.hs b/plutus-ledger-api/test/Spec/ScriptDecodeError.hs index c8d1212f491..08369672c1d 100644 --- a/plutus-ledger-api/test/Spec/ScriptDecodeError.hs +++ b/plutus-ledger-api/test/Spec/ScriptDecodeError.hs @@ -34,10 +34,10 @@ prettyCBORDeserialiseError = @?= "Failed to deserialise a script: CBOR deserialisation failed \ \at the offset 12345 for the following reason: reached the end \ \of input while more data was expected." - where - err = - CBORDeserialiseError - DeserialiseFailureInfo{dfOffset = 12345, dfReason = EndOfInput} + where + err = + CBORDeserialiseError + DeserialiseFailureInfo {dfOffset = 12345, dfReason = EndOfInput} prettyRemainderError :: Assertion prettyRemainderError = @@ -52,23 +52,23 @@ prettyLedgerLanguageNotAvailableError = \This is not yet supported by the current major protocol version 7. \ \The major protocol version that introduces this \ \Plutus Ledger Language is 9." - where - err = - LedgerLanguageNotAvailableError - { sdeAffectedLang = PlutusV2 - , sdeIntroPv = changPV - , sdeThisPv = vasilPV - } + where + err = + LedgerLanguageNotAvailableError + { sdeAffectedLang = PlutusV2 + , sdeIntroPv = changPV + , sdeThisPv = vasilPV + } prettyPlutusCoreLanguageNotAvailableError :: Assertion prettyPlutusCoreLanguageNotAvailableError = show (pretty err) @?= "Your script has a Plutus Core version of 1.0.0. \ \This is not supported in PlutusV2 and major protocol version 7." - where - err = - PlutusCoreLanguageNotAvailableError - { sdeAffectedVersion = plcVersion100 - , sdeThisLang = PlutusV2 - , sdeThisPv = vasilPV - } + where + err = + PlutusCoreLanguageNotAvailableError + { sdeAffectedVersion = plcVersion100 + , sdeThisLang = PlutusV2 + , sdeThisPv = vasilPV + } diff --git a/plutus-ledger-api/test/Spec/V1/Data/Value.hs b/plutus-ledger-api/test/Spec/V1/Data/Value.hs index cb4b345a3fa..078009e94fd 100644 --- a/plutus-ledger-api/test/Spec/V1/Data/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Data/Value.hs @@ -1,6 +1,7 @@ module Spec.V1.Data.Value where import PlutusLedgerApi.Test.V1.Data.Value as Value + -- TODO: import a new PlutusLedgerApi.Data.V1 module instead import PlutusLedgerApi.V1.Data.Value import PlutusTx.Numeric qualified as Numeric @@ -29,17 +30,17 @@ scaleTestsBy factor = withMaxSuccess (100 * factor) . mapSize (* factor) -- at random. mapMany :: (a -> Gen a) -> [a] -> Gen [a] mapMany f = traverse $ \x -> do - b <- arbitrary - if b then f x else pure x + b <- arbitrary + if b then f x else pure x -- | Apply a function to an arbitrary non-zero number of elements of the given list. The elements -- are chosen at random. mapSome :: Eq a => (a -> Gen a) -> [a] -> Gen [a] mapSome f xs = do - xs' <- mapMany f xs - i <- choose (0, length xs - 1) - let xi = xs !! i - ix i (\x -> if x == xi then f x else pure x) xs' + xs' <- mapMany f xs + i <- choose (0, length xs - 1) + let xi = xs !! i + ix i (\x -> if x == xi then f x else pure x) xs' -- | Generate an 'Integer' that is not equal to the given one. updateInteger :: Integer -> Gen Integer @@ -49,40 +50,45 @@ updateInteger i = arbitrary `suchThat` (/= i) -- one, being sorted as well. freshenTokenNames :: [(TokenName, Integer)] -> Gen [(TokenName, Integer)] freshenTokenNames tokens = - uniqueNames TokenName (map snd tokens) `suchThat` \tokens' -> - sort (filter ((/= 0) . snd) tokens) /= sort (filter ((/= 0) . snd) tokens') - -onLists - :: Value - -> ([(CurrencySymbol, [(TokenName, Integer)])] -> - Gen [(CurrencySymbol, [(TokenName, Integer)])]) - -> (Value -> Property) - -> Property + uniqueNames TokenName (map snd tokens) `suchThat` \tokens' -> + sort (filter ((/= 0) . snd) tokens) /= sort (filter ((/= 0) . snd) tokens') + +onLists :: + Value -> + ( [(CurrencySymbol, [(TokenName, Integer)])] -> + Gen [(CurrencySymbol, [(TokenName, Integer)])] + ) -> + (Value -> Property) -> + Property onLists value f = forAll (fmap listsToValue . f $ valueToLists value) -- | Test various laws for operations over 'Value'. test_laws :: TestTree -test_laws = testProperty "laws" . scaleTestsBy 5 $ \value1 -> conjoin +test_laws = testProperty "laws" . scaleTestsBy 5 $ \value1 -> + conjoin [ value1 <> value1 <=> Numeric.scale 2 value1 , value1 <> Numeric.negate value1 <=> mempty , if isZero value1 - then conjoin + then + conjoin [ value1 <=> mempty , forAll arbitrary $ \value2 -> value1 <> value2 <=> value2 ] - else conjoin + else + conjoin [ value1 mempty , forAll arbitrary $ \value2 -> if isZero value2 - then value1 <> value2 <=> value1 - else conjoin - [ value1 <> value2 value1 - , value1 <> value2 value2 - , value1 <> value2 <=> value2 <> value1 - , forAll arbitrary $ \value3 -> - not (isZero value3) ==> - (value1 <> value2) <> value3 <=> value1 <> (value2 <> value3) - ] + then value1 <> value2 <=> value1 + else + conjoin + [ value1 <> value2 value1 + , value1 <> value2 value2 + , value1 <> value2 <=> value2 <> value1 + , forAll arbitrary $ \value3 -> + not (isZero value3) ==> + (value1 <> value2) <> value3 <=> value1 <> (value2 <> value3) + ] ] ] @@ -90,38 +96,45 @@ test_laws = testProperty "laws" . scaleTestsBy 5 $ \value1 -> conjoin -- 'Value'. test_updateSomeTokenValues :: TestTree test_updateSomeTokenValues = testProperty "updateSomeTokenValues" . scaleTestsBy 15 $ \prevalue -> - let lists = filter (not . null . snd) $ valueToLists prevalue - value = listsToValue lists - in not (null lists) ==> - onLists value (mapSome . traverse . mapSome $ traverse updateInteger) - (\value' -> value value') + let lists = filter (not . null . snd) $ valueToLists prevalue + value = listsToValue lists + in not (null lists) ==> + onLists + value + (mapSome . traverse . mapSome $ traverse updateInteger) + (\value' -> value value') -- | Test that changing the values of some of the 'TokenName's creates a different 'Value'. test_updateSomeTokenNames :: TestTree test_updateSomeTokenNames = testProperty "updateSomeTokenNames" . scaleTestsBy 15 $ \prevalue -> - let lists = filter (not . null . snd) . map (fmap . filter $ (/= 0) . snd) $ - valueToLists prevalue - value = listsToValue lists - in not (null lists) ==> - onLists value (mapSome $ traverse freshenTokenNames) - (\value' -> value value') + let lists = + filter (not . null . snd) . map (fmap . filter $ (/= 0) . snd) $ + valueToLists prevalue + value = listsToValue lists + in not (null lists) ==> + onLists + value + (mapSome $ traverse freshenTokenNames) + (\value' -> value value') -- | Test that shuffling 'CurrencySymbol's or 'TokenName's creates a 'Value' that is equal to the -- original one. test_shuffle :: TestTree test_shuffle = testProperty "shuffle" . scaleTestsBy 10 $ \value1 -> - conjoin - [ onLists value1 shuffle $ \value1' -> value1 <=> value1' - , onLists value1 (mapMany $ traverse shuffle) $ \value1' -> value1 <=> value1' - ] + conjoin + [ onLists value1 shuffle $ \value1' -> value1 <=> value1' + , onLists value1 (mapMany $ traverse shuffle) $ \value1' -> value1 <=> value1' + ] test_split :: TestTree test_split = testProperty "split" . scaleTestsBy 7 $ \value -> - let (valueL, valueR) = split value - in Numeric.negate valueL <> valueR <=> value + let (valueL, valueR) = split value + in Numeric.negate valueL <> valueR <=> value test_Value :: TestTree -test_Value = testGroup "Value" +test_Value = + testGroup + "Value" [ test_laws , test_updateSomeTokenValues , test_updateSomeTokenNames diff --git a/plutus-ledger-api/test/Spec/V1/Value.hs b/plutus-ledger-api/test/Spec/V1/Value.hs index d3a997cd273..47cea08eeee 100644 --- a/plutus-ledger-api/test/Spec/V1/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Value.hs @@ -31,17 +31,17 @@ scaleTestsBy factor = withMaxSuccess (100 * factor) . mapSize (* factor) -- at random. mapMany :: (a -> Gen a) -> [a] -> Gen [a] mapMany f = traverse $ \x -> do - b <- arbitrary - if b then f x else pure x + b <- arbitrary + if b then f x else pure x -- | Apply a function to an arbitrary non-zero number of elements of the given list. The elements -- are chosen at random. mapSome :: Eq a => (a -> Gen a) -> [a] -> Gen [a] mapSome f xs = do - xs' <- mapMany f xs - i <- choose (0, length xs - 1) - let xi = xs !! i - ix i (\x -> if x == xi then f x else pure x) xs' + xs' <- mapMany f xs + i <- choose (0, length xs - 1) + let xi = xs !! i + ix i (\x -> if x == xi then f x else pure x) xs' -- | Generate an 'Integer' that is not equal to the given one. updateInteger :: Integer -> Gen Integer @@ -51,40 +51,45 @@ updateInteger i = arbitrary `suchThat` (/= i) -- one, being sorted as well. freshenTokenNames :: [(TokenName, Integer)] -> Gen [(TokenName, Integer)] freshenTokenNames tokens = - uniqueNames (TokenName . toBuiltin . PLC.unK) (map snd tokens) `suchThat` \tokens' -> - sort (filter ((/= 0) . snd) tokens) /= sort (filter ((/= 0) . snd) tokens') - -onLists - :: Value - -> ([(CurrencySymbol, [(TokenName, Integer)])] -> - Gen [(CurrencySymbol, [(TokenName, Integer)])]) - -> (Value -> Property) - -> Property + uniqueNames (TokenName . toBuiltin . PLC.unK) (map snd tokens) `suchThat` \tokens' -> + sort (filter ((/= 0) . snd) tokens) /= sort (filter ((/= 0) . snd) tokens') + +onLists :: + Value -> + ( [(CurrencySymbol, [(TokenName, Integer)])] -> + Gen [(CurrencySymbol, [(TokenName, Integer)])] + ) -> + (Value -> Property) -> + Property onLists value f = forAll (fmap listsToValue . f $ valueToLists value) -- | Test various laws for operations over 'Value'. test_laws :: TestTree -test_laws = testProperty "laws" . scaleTestsBy 5 $ \value1 -> conjoin +test_laws = testProperty "laws" . scaleTestsBy 5 $ \value1 -> + conjoin [ value1 <> value1 <=> Numeric.scale 2 value1 , value1 <> Numeric.negate value1 <=> mempty , if isZero value1 - then conjoin + then + conjoin [ value1 <=> mempty , forAll arbitrary $ \value2 -> value1 <> value2 <=> value2 ] - else conjoin + else + conjoin [ value1 mempty , forAll arbitrary $ \value2 -> if isZero value2 - then value1 <> value2 <=> value1 - else conjoin - [ value1 <> value2 value1 - , value1 <> value2 value2 - , value1 <> value2 <=> value2 <> value1 - , forAll arbitrary $ \value3 -> - not (isZero value3) ==> - (value1 <> value2) <> value3 <=> value1 <> (value2 <> value3) - ] + then value1 <> value2 <=> value1 + else + conjoin + [ value1 <> value2 value1 + , value1 <> value2 value2 + , value1 <> value2 <=> value2 <> value1 + , forAll arbitrary $ \value3 -> + not (isZero value3) ==> + (value1 <> value2) <> value3 <=> value1 <> (value2 <> value3) + ] ] ] @@ -92,51 +97,58 @@ test_laws = testProperty "laws" . scaleTestsBy 5 $ \value1 -> conjoin -- 'Value'. test_updateSomeTokenValues :: TestTree test_updateSomeTokenValues = testProperty "updateSomeTokenValues" . scaleTestsBy 15 $ \prevalue -> - let lists = filter (not . null . snd) $ valueToLists prevalue - value = listsToValue lists - in not (null lists) ==> - onLists value (mapSome . traverse . mapSome $ traverse updateInteger) - (\value' -> value value') + let lists = filter (not . null . snd) $ valueToLists prevalue + value = listsToValue lists + in not (null lists) ==> + onLists + value + (mapSome . traverse . mapSome $ traverse updateInteger) + (\value' -> value value') -- | Test that changing the values of some of the 'TokenName's creates a different 'Value'. test_updateSomeTokenNames :: TestTree test_updateSomeTokenNames = testProperty "updateSomeTokenNames" . scaleTestsBy 15 $ \prevalue -> - let lists = filter (not . null . snd) . map (fmap . filter $ (/= 0) . snd) $ - valueToLists prevalue - value = listsToValue lists - in not (null lists) ==> - onLists value (mapSome $ traverse freshenTokenNames) - (\value' -> value value') + let lists = + filter (not . null . snd) . map (fmap . filter $ (/= 0) . snd) $ + valueToLists prevalue + value = listsToValue lists + in not (null lists) ==> + onLists + value + (mapSome $ traverse freshenTokenNames) + (\value' -> value value') -- | Test that shuffling 'CurrencySymbol's or 'TokenName's creates a 'Value' that is equal to the -- original one. test_shuffle :: TestTree test_shuffle = testProperty "shuffle" . scaleTestsBy 10 $ \value1 -> - conjoin - [ onLists value1 shuffle $ \value1' -> value1 <=> value1' - , onLists value1 (mapMany $ traverse shuffle) $ \value1' -> value1 <=> value1' - ] + conjoin + [ onLists value1 shuffle $ \value1' -> value1 <=> value1' + , onLists value1 (mapMany $ traverse shuffle) $ \value1' -> value1 <=> value1' + ] test_split :: TestTree test_split = testProperty "split" . scaleTestsBy 7 $ \value -> - let (valueL, valueR) = split value - in Numeric.negate valueL <> valueR <=> value + let (valueL, valueR) = split value + in Numeric.negate valueL <> valueR <=> value -- | Test that builtin and non-builtin values are encoded identically in Data. test_toData :: TestTree test_toData = testProperty "toData" . scaleTestsBy 10 $ \v -> - PLC.valueData v === toData (valueFromBuiltin v) + PLC.valueData v === toData (valueFromBuiltin v) -- | Test that builtin and non-builtin values are decoded identically from Data. test_fromData :: TestTree test_fromData = testProperty "fromData" . scaleTestsBy 10 $ \v -> - let d = PLC.valueData v - in case PLC.unValueData d of - BuiltinSuccess v' -> valueFromBuiltin v' === unsafeFromData d - _ -> property False + let d = PLC.valueData v + in case PLC.unValueData d of + BuiltinSuccess v' -> valueFromBuiltin v' === unsafeFromData d + _ -> property False test_Value :: TestTree -test_Value = testGroup "Value" +test_Value = + testGroup + "Value" [ test_laws , test_updateSomeTokenValues , test_updateSomeTokenNames diff --git a/plutus-ledger-api/test/Spec/Versions.hs b/plutus-ledger-api/test/Spec/Versions.hs index ae6460e2a9c..c33fca27ce9 100644 --- a/plutus-ledger-api/test/Spec/Versions.hs +++ b/plutus-ledger-api/test/Spec/Versions.hs @@ -27,7 +27,9 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck tests :: TestTree -tests = testGroup "versions" +tests = + testGroup + "versions" [ testLedgerLanguages , testLanguageVersions , testPermittedBuiltins @@ -36,22 +38,22 @@ tests = testGroup "versions" ] allPVs :: [MajorProtocolVersion] -allPVs = [ shelleyPV .. newestPV ] +allPVs = [shelleyPV .. newestPV] showPV :: MajorProtocolVersion -> String showPV (MajorProtocolVersion pv) = case pv of - 2 -> "Shelley (PV2)" - 3 -> "Allegra (PV3)" - 4 -> "Mary (PV4)" - 5 -> "Alonzo (PV5)" - 6 -> "(Lobster) (PV6)" - 7 -> "Vasil (PV7)" - 8 -> "Valentine (PV8)" - 9 -> "Chang (PV9)" + 2 -> "Shelley (PV2)" + 3 -> "Allegra (PV3)" + 4 -> "Mary (PV4)" + 5 -> "Alonzo (PV5)" + 6 -> "(Lobster) (PV6)" + 7 -> "Vasil (PV7)" + 8 -> "Valentine (PV8)" + 9 -> "Chang (PV9)" 10 -> "Plomin (PV10)" 11 -> "PV11" - _ -> " (PV" ++ show pv ++ ")" + _ -> " (PV" ++ show pv ++ ")" -- Some scripts for use in the version tests. errorScript :: SerialisedScript @@ -77,24 +79,26 @@ badCaseScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Case () (UPLC.Error ()) and return them as `Left` values. Any other errors will cause `error` to be invoked. -} -mkTestTerm - :: PlutusLedgerLanguage - -> MajorProtocolVersion - -> UPLC.Program DeBruijn DefaultUni DefaultFun () - -> Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) +mkTestTerm :: + PlutusLedgerLanguage -> + MajorProtocolVersion -> + UPLC.Program DeBruijn DefaultUni DefaultFun () -> + Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) mkTestTerm ll pv prog = - case deserialiseScript ll pv $ serialiseUPLC prog - of Right s -> - case mkTermToEvaluate ll pv s [] - of Right t -> Right t - Left (CodecError e) -> Left e - Left e -> Prelude.error $ show e - Left e -> Left e + case deserialiseScript ll pv $ serialiseUPLC prog of + Right s -> + case mkTermToEvaluate ll pv s [] of + Right t -> Right t + Left (CodecError e) -> Left e + Left e -> Prelude.error $ show e + Left e -> Left e -- Test that the different Plutus Core ledger languages are available in the -- expected protocol versions and not in others. testLedgerLanguages :: TestTree -testLedgerLanguages = testGroup "ledger languages" +testLedgerLanguages = + testGroup + "ledger languages" [ testProperty "PlutusV1 not before but after" $ prop_notBeforeButAfter V1.deserialiseScript alonzoPV , testProperty "PlutusV2 not before but after" $ prop_notBeforeButAfter V2.deserialiseScript vasilPV , testProperty "PlutusV3 not before but after" $ prop_notBeforeButAfter V3.deserialiseScript changPV @@ -102,20 +106,21 @@ testLedgerLanguages = testGroup "ledger languages" \pvA pvB -> pvA < pvB ==> ledgerLanguagesAvailableIn pvA `Set.isSubsetOf` ledgerLanguagesAvailableIn pvB ] where - prop_notBeforeButAfter - :: (MajorProtocolVersion -> SerialisedScript -> Either ScriptDecodeError b) - -> MajorProtocolVersion -> MajorProtocolVersion -> Bool + prop_notBeforeButAfter :: + (MajorProtocolVersion -> SerialisedScript -> Either ScriptDecodeError b) -> + MajorProtocolVersion -> + MajorProtocolVersion -> + Bool prop_notBeforeButAfter phase1Func expectedPv genPv = - -- run phase 1 on an example script - let resPhase1 = phase1Func genPv errorScript - in if genPv < expectedPv - -- generated an old protocol version - then - case resPhase1 of - Left LedgerLanguageNotAvailableError{} -> True - _ -> False - -- generated an eq or gt the expected protocol version - else isRight resPhase1 + -- run phase 1 on an example script + let resPhase1 = phase1Func genPv errorScript + in if genPv < expectedPv + -- generated an old protocol version + then case resPhase1 of + Left LedgerLanguageNotAvailableError {} -> True + _ -> False + -- generated an eq or gt the expected protocol version + else isRight resPhase1 -- Test that the different Plutus Core language versions are available in the -- expected LL/PV combinations. @@ -124,46 +129,57 @@ testLanguageVersions = testGroup "Plutus Core language versions" $ let expectGood plcv prog ll pv = testCase ("Ok in " ++ showPV pv) $ - assertBool (plcv ++ " not allowed in " ++ show ll ++" @" ++ showPV pv) $ - isRight $ mkTestTerm ll pv prog + assertBool (plcv ++ " not allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isRight $ + mkTestTerm ll pv prog expectBad plcv prog ll pv = testCase ("Not in " ++ showPV pv) $ - assertBool (plcv ++ " should not be allowed in " ++ show ll ++" @" ++ showPV pv) $ - isLeft $ mkTestTerm ll pv prog + assertBool (plcv ++ " should not be allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isLeft $ + mkTestTerm ll pv prog testOkFrom plcv ll firstGood prog = - let expectedGood = [ firstGood .. newestPV ] - in testGroup (show ll) $ - fmap (expectBad plcv prog ll) (allPVs \\ expectedGood) ++ - fmap (expectGood plcv prog ll) expectedGood - in [ testGroup "v1.0.0 availability" - [ testOkFrom "v100" PlutusV1 alonzoPV v100script - , testOkFrom "v100" PlutusV2 vasilPV v100script - , testOkFrom "v100" PlutusV3 changPV v100script - ] - , testGroup "v1.1.0 availability" - [ testOkFrom "v110" PlutusV1 newestPV v110script - , testOkFrom "v110" PlutusV2 newestPV v110script - , testOkFrom "v110" PlutusV3 changPV v110script - ] - -- Check that case and constr are not allowed in 1.1.0 in any LL/PV combination - , testCase "case is not available in v1.0.0 ever" $ - sequence_ [ assertBool ("case unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ - isLeft $ mkTestTerm ll pv badCaseScript - | ll <- enumerate, pv <- allPVs ] - - , testCase "constr is not available in v1.0.0 ever" $ - sequence_ [ assertBool ("constr unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ - isLeft $ mkTestTerm ll pv badConstrScript - | ll <- enumerate, pv <- allPVs ] - ] + let expectedGood = [firstGood .. newestPV] + in testGroup (show ll) $ + fmap (expectBad plcv prog ll) (allPVs \\ expectedGood) + ++ fmap (expectGood plcv prog ll) expectedGood + in [ testGroup + "v1.0.0 availability" + [ testOkFrom "v100" PlutusV1 alonzoPV v100script + , testOkFrom "v100" PlutusV2 vasilPV v100script + , testOkFrom "v100" PlutusV3 changPV v100script + ] + , testGroup + "v1.1.0 availability" + [ testOkFrom "v110" PlutusV1 newestPV v110script + , testOkFrom "v110" PlutusV2 newestPV v110script + , testOkFrom "v110" PlutusV3 changPV v110script + ] + , -- Check that case and constr are not allowed in 1.1.0 in any LL/PV combination + testCase "case is not available in v1.0.0 ever" $ + sequence_ + [ assertBool ("case unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ + isLeft $ + mkTestTerm ll pv badCaseScript + | ll <- enumerate + , pv <- allPVs + ] + , testCase "constr is not available in v1.0.0 ever" $ + sequence_ + [ assertBool ("constr unexpectedly allowed in " ++ show ll ++ " @PV" ++ show pv) $ + isLeft $ + mkTestTerm ll pv badConstrScript + | ll <- enumerate + , pv <- allPVs + ] + ] -- Testing deserialisation checks for builtins -{- | Make small scripts containing each builtin and check that the expected - builtins are successfully deserialised in each PV/LL combination (and - unexpected builtins cause an error during deserialisation. These MUST BE - EXTENDED when new builtins are deployed. --} +-- | Make small scripts containing each builtin and check that the expected +-- builtins are successfully deserialised in each PV/LL combination (and +-- unexpected builtins cause an error during deserialisation. These MUST BE +-- EXTENDED when new builtins are deployed. + -- Should we test plcVersion110 as well? mkScriptForBuiltin :: DefaultFun -> (String, SerialisedScript) mkScriptForBuiltin fun = @@ -194,18 +210,22 @@ builtins6 :: [(String, SerialisedScript)] builtins6 = mkScriptsForBuiltins batch6 allBuiltins :: [(String, SerialisedScript)] -allBuiltins = builtins1 ++ builtins2 - ++ builtins3 ++ builtins4a - ++ builtins4b ++ builtins5 - ++ builtins6 - -{-| Test that the builtins that we expect to be allowed in each LL/PV - combination can be successfully deserialised and that the rest cannot. This - is mostly testing that `builtinsAvailableIn` does what it's supposed to. - This should be updated when new builtins, ledger languages, or protocol - versions are added, but we expect that after Anon all builtins will be - allowed in all ledger languages. --} +allBuiltins = + builtins1 + ++ builtins2 + ++ builtins3 + ++ builtins4a + ++ builtins4b + ++ builtins5 + ++ builtins6 + +-- | Test that the builtins that we expect to be allowed in each LL/PV +-- combination can be successfully deserialised and that the rest cannot. This +-- is mostly testing that `builtinsAvailableIn` does what it's supposed to. +-- This should be updated when new builtins, ledger languages, or protocol +-- versions are added, but we expect that after Anon all builtins will be +-- allowed in all ledger languages. + {- FIXME: Ideally we'd test that for PV11 scripts, all of the newer builtins have the same cost in each Plutus ledger language. That would involve having appropriate sets of cost model parameters to feed into the parameter update @@ -216,54 +236,59 @@ testPermittedBuiltins = let testBuiltins ll deserialise pv expectedGood = let expectGood scripts = for_ scripts $ \(name, script) -> - assertBool (name ++ " should be allowed in " ++ show ll ++" @" ++ showPV pv) $ - isRight $ deserialise pv script + assertBool (name ++ " should be allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isRight $ + deserialise pv script expectBad scripts = for_ scripts $ \(name, script) -> - assertBool (name ++ " should not be allowed in " ++ show ll ++" @" ++ showPV pv) $ - isLeft $ deserialise pv script - in testCase (showPV pv) $ do - expectGood expectedGood - expectBad (allBuiltins \\ expectedGood) - in testGroup "Builtins allowed" - [ let mkTest = testBuiltins PlutusV1 V1.deserialiseScript - in testGroup "PlutusV1" - [ mkTest shelleyPV [] - , mkTest allegraPV [] - , mkTest maryPV [] - , mkTest alonzoPV builtins1 - , mkTest vasilPV builtins1 - , mkTest valentinePV builtins1 - , mkTest changPV builtins1 - , mkTest plominPV builtins1 - , mkTest newestPV allBuiltins - ] - , let mkTest = testBuiltins PlutusV2 V2.deserialiseScript - in testGroup "PlutusV2" - [ mkTest shelleyPV [] - , mkTest allegraPV [] - , mkTest maryPV [] - , mkTest alonzoPV [] - , mkTest vasilPV $ builtins1 ++ builtins2 - , mkTest valentinePV $ builtins1 ++ builtins2 ++ builtins3 - , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 - , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4b - , mkTest newestPV allBuiltins - ] - , let mkTest = testBuiltins PlutusV3 V3.deserialiseScript - in testGroup "PlutusV3" - [ mkTest shelleyPV [] - , mkTest allegraPV [] - , mkTest maryPV [] - , mkTest alonzoPV [] - , mkTest vasilPV [] - , mkTest valentinePV [] - , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b - , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b ++ builtins5 - , mkTest newestPV allBuiltins - ] - ] - + assertBool (name ++ " should not be allowed in " ++ show ll ++ " @" ++ showPV pv) $ + isLeft $ + deserialise pv script + in testCase (showPV pv) $ do + expectGood expectedGood + expectBad (allBuiltins \\ expectedGood) + in testGroup + "Builtins allowed" + [ let mkTest = testBuiltins PlutusV1 V1.deserialiseScript + in testGroup + "PlutusV1" + [ mkTest shelleyPV [] + , mkTest allegraPV [] + , mkTest maryPV [] + , mkTest alonzoPV builtins1 + , mkTest vasilPV builtins1 + , mkTest valentinePV builtins1 + , mkTest changPV builtins1 + , mkTest plominPV builtins1 + , mkTest newestPV allBuiltins + ] + , let mkTest = testBuiltins PlutusV2 V2.deserialiseScript + in testGroup + "PlutusV2" + [ mkTest shelleyPV [] + , mkTest allegraPV [] + , mkTest maryPV [] + , mkTest alonzoPV [] + , mkTest vasilPV $ builtins1 ++ builtins2 + , mkTest valentinePV $ builtins1 ++ builtins2 ++ builtins3 + , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 + , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4b + , mkTest newestPV allBuiltins + ] + , let mkTest = testBuiltins PlutusV3 V3.deserialiseScript + in testGroup + "PlutusV3" + [ mkTest shelleyPV [] + , mkTest allegraPV [] + , mkTest maryPV [] + , mkTest alonzoPV [] + , mkTest vasilPV [] + , mkTest valentinePV [] + , mkTest changPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b + , mkTest plominPV $ builtins1 ++ builtins2 ++ builtins3 ++ builtins4a ++ builtins4b ++ builtins5 + , mkTest newestPV allBuiltins + ] + ] {- It's important that the results returned by `builtinsAvailableIn` don't change. The implementation changed when we enabled all builtins in all ledger @@ -278,79 +303,167 @@ testPermittedBuiltins = {- DON'T CHANGE THIS: it tests only up to PV10 and should never need to be extended. -} testBuiltinAvailabilityCompatibility :: TestTree testBuiltinAvailabilityCompatibility = - testCase "Old and new versions of builtinsAvailableIn are compatible" $ - let builtinsIntroducedIn_old - :: Map.Map (PlutusLedgerLanguage, MajorProtocolVersion) (Set.Set DefaultFun) + testCase "Old and new versions of builtinsAvailableIn are compatible" $ + let builtinsIntroducedIn_old :: + Map.Map (PlutusLedgerLanguage, MajorProtocolVersion) (Set.Set DefaultFun) builtinsIntroducedIn_old = - Map.fromList - [ ((PlutusV1, alonzoPV), Set.fromList - [ AddInteger, SubtractInteger, MultiplyInteger, DivideInteger - , QuotientInteger, RemainderInteger, ModInteger, EqualsInteger - , LessThanInteger, LessThanEqualsInteger, AppendByteString - , ConsByteString, SliceByteString, LengthOfByteString - , IndexByteString, EqualsByteString, LessThanByteString - , LessThanEqualsByteString, Sha2_256, Sha3_256, Blake2b_256 - , VerifyEd25519Signature, AppendString, EqualsString, EncodeUtf8 - , DecodeUtf8, IfThenElse, ChooseUnit, Trace, FstPair, SndPair - , ChooseList, MkCons, HeadList, TailList, NullList, ChooseData - , ConstrData, MapData, ListData, IData, BData, UnConstrData - , UnMapData, UnListData, UnIData, UnBData, EqualsData, MkPairData - , MkNilData, MkNilPairData ]) - , ((PlutusV2, vasilPV), Set.fromList - [ SerialiseData ]) - , ((PlutusV2, valentinePV), Set.fromList - [ VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature ]) - , ((PlutusV2, plominPV), Set.fromList - [ IntegerToByteString, ByteStringToInteger ]) - , ((PlutusV3, changPV), Set.fromList - [ Bls12_381_G1_add, Bls12_381_G1_neg, Bls12_381_G1_scalarMul - , Bls12_381_G1_equal, Bls12_381_G1_hashToGroup - , Bls12_381_G1_compress, Bls12_381_G1_uncompress - , Bls12_381_G2_add, Bls12_381_G2_neg, Bls12_381_G2_scalarMul - , Bls12_381_G2_equal, Bls12_381_G2_hashToGroup - , Bls12_381_G2_compress, Bls12_381_G2_uncompress - , Bls12_381_millerLoop, Bls12_381_mulMlResult - , Bls12_381_finalVerify, Keccak_256, Blake2b_224 - , IntegerToByteString, ByteStringToInteger ]) - , ((PlutusV3, plominPV), Set.fromList - [ AndByteString, OrByteString, XorByteString - , ComplementByteString , ReadBit, WriteBits - , ReplicateByte , ShiftByteString, RotateByteString - , CountSetBits, FindFirstSetBit, Ripemd_160 ]) - ] - builtinsAvailableIn_old - :: PlutusLedgerLanguage - -> MajorProtocolVersion - -> Set.Set DefaultFun + Map.fromList + [ + ( (PlutusV1, alonzoPV) + , Set.fromList + [ AddInteger + , SubtractInteger + , MultiplyInteger + , DivideInteger + , QuotientInteger + , RemainderInteger + , ModInteger + , EqualsInteger + , LessThanInteger + , LessThanEqualsInteger + , AppendByteString + , ConsByteString + , SliceByteString + , LengthOfByteString + , IndexByteString + , EqualsByteString + , LessThanByteString + , LessThanEqualsByteString + , Sha2_256 + , Sha3_256 + , Blake2b_256 + , VerifyEd25519Signature + , AppendString + , EqualsString + , EncodeUtf8 + , DecodeUtf8 + , IfThenElse + , ChooseUnit + , Trace + , FstPair + , SndPair + , ChooseList + , MkCons + , HeadList + , TailList + , NullList + , ChooseData + , ConstrData + , MapData + , ListData + , IData + , BData + , UnConstrData + , UnMapData + , UnListData + , UnIData + , UnBData + , EqualsData + , MkPairData + , MkNilData + , MkNilPairData + ] + ) + , + ( (PlutusV2, vasilPV) + , Set.fromList + [SerialiseData] + ) + , + ( (PlutusV2, valentinePV) + , Set.fromList + [VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature] + ) + , + ( (PlutusV2, plominPV) + , Set.fromList + [IntegerToByteString, ByteStringToInteger] + ) + , + ( (PlutusV3, changPV) + , Set.fromList + [ Bls12_381_G1_add + , Bls12_381_G1_neg + , Bls12_381_G1_scalarMul + , Bls12_381_G1_equal + , Bls12_381_G1_hashToGroup + , Bls12_381_G1_compress + , Bls12_381_G1_uncompress + , Bls12_381_G2_add + , Bls12_381_G2_neg + , Bls12_381_G2_scalarMul + , Bls12_381_G2_equal + , Bls12_381_G2_hashToGroup + , Bls12_381_G2_compress + , Bls12_381_G2_uncompress + , Bls12_381_millerLoop + , Bls12_381_mulMlResult + , Bls12_381_finalVerify + , Keccak_256 + , Blake2b_224 + , IntegerToByteString + , ByteStringToInteger + ] + ) + , + ( (PlutusV3, plominPV) + , Set.fromList + [ AndByteString + , OrByteString + , XorByteString + , ComplementByteString + , ReadBit + , WriteBits + , ReplicateByte + , ShiftByteString + , RotateByteString + , CountSetBits + , FindFirstSetBit + , Ripemd_160 + ] + ) + ] + builtinsAvailableIn_old :: + PlutusLedgerLanguage -> + MajorProtocolVersion -> + Set.Set DefaultFun builtinsAvailableIn_old thisLv thisPv = - fold $ + fold $ Map.filterWithKey (const . alreadyIntroduced) builtinsIntroducedIn_old - where - alreadyIntroduced :: (PlutusLedgerLanguage, MajorProtocolVersion) -> Bool - alreadyIntroduced (introducedInLv,introducedInPv) = + where + alreadyIntroduced :: (PlutusLedgerLanguage, MajorProtocolVersion) -> Bool + alreadyIntroduced (introducedInLv, introducedInPv) = -- both should be satisfied - introducedInLv <= thisLv && introducedInPv <= thisPv - in sequence_ [ assertBool ("Old and new versions of builtinsAvailableIn differ for " - ++ show ll ++ " @PV" ++ show pv) - $ builtinsAvailableIn ll pv == builtinsAvailableIn_old ll pv - | pv <- [shelleyPV .. plominPV] - , ll <- Set.toList (ledgerLanguagesAvailableIn pv) ] + introducedInLv <= thisLv && introducedInPv <= thisPv + in sequence_ + [ assertBool + ( "Old and new versions of builtinsAvailableIn differ for " + ++ show ll + ++ " @PV" + ++ show pv + ) + $ builtinsAvailableIn ll pv == builtinsAvailableIn_old ll pv + | pv <- [shelleyPV .. plominPV] + , ll <- Set.toList (ledgerLanguagesAvailableIn pv) + ] -- Test that the checks for extra bytes after ends of scripts behave properly. deriving newtype instance Arbitrary MajorProtocolVersion testRmdr :: TestTree -testRmdr = testGroup "extra bytes after end of script" +testRmdr = + testGroup + "extra bytes after end of script" [ testCase "remdr" $ do - assertBool "remdr1" $ isRight $ V1.deserialiseScript valentinePV $ errorScript <> "remdr1" - assertBool "remdr2" $ isRight $ V2.deserialiseScript valentinePV $ errorScript <> "remdr2" - assertBool "remdr1c" $ isRight $ V1.deserialiseScript changPV $ errorScript <> "remdr1" - assertBool "remdr2c" $ isRight $ V2.deserialiseScript changPV $ errorScript <> "remdr2" - assertEqual "remdr3" (RemainderError "remdr3") $ fromLeft (Prelude.error "Expected Reft, got Right") $ V3.deserialiseScript changPV $ errorScript <> "remdr3" - , testProperty "remdr1gen"$ \remdr -> isRight $ V1.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr - , testProperty "remdr2gen"$ \remdr -> isRight $ V2.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr - , testProperty "remdr1genc"$ \remdr -> isRight $ V1.deserialiseScript changPV $ errorScript <> BSS.pack remdr - , testProperty "remdr2genc"$ \remdr -> isRight $ V2.deserialiseScript changPV $ errorScript <> BSS.pack remdr + assertBool "remdr1" $ isRight $ V1.deserialiseScript valentinePV $ errorScript <> "remdr1" + assertBool "remdr2" $ isRight $ V2.deserialiseScript valentinePV $ errorScript <> "remdr2" + assertBool "remdr1c" $ isRight $ V1.deserialiseScript changPV $ errorScript <> "remdr1" + assertBool "remdr2c" $ isRight $ V2.deserialiseScript changPV $ errorScript <> "remdr2" + assertEqual "remdr3" (RemainderError "remdr3") $ fromLeft (Prelude.error "Expected Reft, got Right") $ V3.deserialiseScript changPV $ errorScript <> "remdr3" + , testProperty "remdr1gen" $ \remdr -> isRight $ V1.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr + , testProperty "remdr2gen" $ \remdr -> isRight $ V2.deserialiseScript valentinePV $ errorScript <> BSS.pack remdr + , testProperty "remdr1genc" $ \remdr -> isRight $ V1.deserialiseScript changPV $ errorScript <> BSS.pack remdr + , testProperty "remdr2genc" $ \remdr -> isRight $ V2.deserialiseScript changPV $ errorScript <> BSS.pack remdr -- we cannot make the same property as above for remdr3gen because it may generate valid bytestring append extensions to the original script -- a more sophisticated one could work though ] diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs index 10eeb3c1ec1..8c1412df558 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs @@ -1,12 +1,13 @@ {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -module PlutusLedgerApi.Test.Common.EvaluationContext - ( MCostModel - , MCekMachineCosts - , MBuiltinCostModel - , toMCostModel - , extractCostModelParamsLedgerOrder - ) where +{-# LANGUAGE TypeFamilies #-} + +module PlutusLedgerApi.Test.Common.EvaluationContext ( + MCostModel, + MCekMachineCosts, + MBuiltinCostModel, + toMCostModel, + extractCostModelParamsLedgerOrder, +) where import PlutusCore.Evaluation.Machine.BuiltinCostModel import PlutusCore.Evaluation.Machine.CostModelInterface @@ -30,32 +31,33 @@ type MBuiltinCostModel = BuiltinCostModelBase MCostingFun -- | A helper function to lift to a "full" `MCostModel`, by mapping *all* of its fields to `Just`. -- The fields can be later on cleared, by assigning them to `Nothing`. -toMCostModel :: CostModel CekMachineCosts BuiltinCostModel - -> MCostModel +toMCostModel :: + CostModel CekMachineCosts BuiltinCostModel -> + MCostModel toMCostModel cm = - cm - & machineCostModel - %~ bmap (Just . runIdentity) - & builtinCostModel - %~ bmap (MCostingFun . Just) - -{- | A variant of `extractCostModelParams` to make a mapping of params not in alphabetical order, -but in the `ParamName` order, i.e. the order expected by the ledger. - -Here, overconstrained to `MCostModel`, but it could also work with `CostModel mcosts bcosts`. --} -extractCostModelParamsLedgerOrder :: (Common.IsParamName p, Ord p) - => MCostModel - -> Maybe (Map.Map p Int64) + cm + & machineCostModel + %~ bmap (Just . runIdentity) + & builtinCostModel + %~ bmap (MCostingFun . Just) + +-- | A variant of `extractCostModelParams` to make a mapping of params not in alphabetical order, +-- but in the `ParamName` order, i.e. the order expected by the ledger. +-- +-- Here, overconstrained to `MCostModel`, but it could also work with `CostModel mcosts bcosts`. +extractCostModelParamsLedgerOrder :: + (Common.IsParamName p, Ord p) => + MCostModel -> + Maybe (Map.Map p Int64) extractCostModelParamsLedgerOrder = - extractInAlphaOrder - >=> toLedgerOrder - where - extractInAlphaOrder = extractCostModelParams - toLedgerOrder = mapKeysM readParamName + extractInAlphaOrder + >=> toLedgerOrder + where + extractInAlphaOrder = extractCostModelParams + toLedgerOrder = mapKeysM readParamName - mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> Map.Map k1 a -> m (Map.Map k2 a) - mapKeysM = viaListM . mapM . firstM + mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> Map.Map k1 a -> m (Map.Map k2 a) + mapKeysM = viaListM . mapM . firstM - viaListM op = fmap Map.fromList . op . Map.toList - firstM f (k,v) = (,v) <$> f k + viaListM op = fmap Map.fromList . op . Map.toList + firstM f (k, v) = (,v) <$> f k diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/EvaluationEvent.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/EvaluationEvent.hs index 0e76aff39e9..e3a260e03a9 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/EvaluationEvent.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/EvaluationEvent.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module PlutusLedgerApi.Test.EvaluationEvent - ( ScriptEvaluationEvents (..) - , ScriptEvaluationEvent (..) - , ScriptEvaluationData (..) - , ScriptEvaluationResult (..) - , UnexpectedEvaluationResult (..) - , TestFailure (..) - , renderTestFailure - , renderTestFailures - , checkEvaluationEvent - ) where +{-# LANGUAGE RecordWildCards #-} + +module PlutusLedgerApi.Test.EvaluationEvent ( + ScriptEvaluationEvents (..), + ScriptEvaluationEvent (..), + ScriptEvaluationData (..), + ScriptEvaluationResult (..), + UnexpectedEvaluationResult (..), + TestFailure (..), + renderTestFailure, + renderTestFailures, + checkEvaluationEvent, +) where import PlutusCore.Data qualified as PLC import PlutusCore.Pretty @@ -39,20 +39,19 @@ data ScriptEvaluationResult = ScriptEvaluationSuccess | ScriptEvaluationFailure instance Pretty ScriptEvaluationResult where pretty = viaShow -{- | All the data needed to evaluate a script using the ledger API, except for the cost model - parameters, as these are tracked separately. --} +-- | All the data needed to evaluate a script using the ledger API, except for the cost model +-- parameters, as these are tracked separately. data ScriptEvaluationData = ScriptEvaluationData { dataProtocolVersion :: MajorProtocolVersion - , dataBudget :: ExBudget - , dataScript :: SerialisedScript - , dataInputs :: [PLC.Data] + , dataBudget :: ExBudget + , dataScript :: SerialisedScript + , dataInputs :: [PLC.Data] } deriving stock (Show, Generic) deriving anyclass (Serialise) instance Pretty ScriptEvaluationData where - pretty ScriptEvaluationData{..} = + pretty ScriptEvaluationData {..} = vsep [ "major protocol version:" <+> pretty dataProtocolVersion , "budget: " <+> pretty dataBudget @@ -60,9 +59,8 @@ instance Pretty ScriptEvaluationData where , "data: " <+> nest 2 (vsep $ pretty <$> dataInputs) ] -{- | Information about an on-chain script evaluation event, specifically the information needed - to evaluate the script, and the expected result. --} +-- | Information about an on-chain script evaluation event, specifically the information needed +-- to evaluate the script, and the expected result. data ScriptEvaluationEvent = PlutusEvent PlutusLedgerLanguage ScriptEvaluationData ScriptEvaluationResult deriving stock (Show, Generic) @@ -78,18 +76,17 @@ instance Pretty ScriptEvaluationEvent where , pretty res ] -{- | This type contains a list of on-chain script evaluation events. All PlutusV1 - evaluations (if any) share the same cost parameters. Same with PlutusV2. - - Sharing the cost parameters lets us avoid creating a new `EvaluationContext` for - each `ScriptEvaluationEvent`. --} +-- | This type contains a list of on-chain script evaluation events. All PlutusV1 +-- evaluations (if any) share the same cost parameters. Same with PlutusV2. +-- +-- Sharing the cost parameters lets us avoid creating a new `EvaluationContext` for +-- each `ScriptEvaluationEvent`. data ScriptEvaluationEvents = ScriptEvaluationEvents { eventsCostParamsV1 :: Maybe [Int64] -- ^ Cost parameters shared by all PlutusV1 evaluation events in `eventsEvents`, if any. , eventsCostParamsV2 :: Maybe [Int64] -- ^ Cost parameters shared by all PlutusV2 evaluation events in `eventsEvents`, if any. - , eventsEvents :: NonEmpty ScriptEvaluationEvent + , eventsEvents :: NonEmpty ScriptEvaluationEvent } deriving stock (Generic) deriving anyclass (Serialise) @@ -98,14 +95,14 @@ data ScriptEvaluationEvents = ScriptEvaluationEvents data UnexpectedEvaluationResult = UnexpectedEvaluationSuccess ScriptEvaluationEvent + -- | Cost parameters [Int64] - -- ^ Cost parameters + -- | Actual budget consumed ExBudget - -- ^ Actual budget consumed | UnexpectedEvaluationFailure ScriptEvaluationEvent + -- | Cost parameters [Int64] - -- ^ Cost parameters EvaluationError | DecodeError ScriptDecodeError deriving stock (Show) @@ -157,14 +154,14 @@ renderTestFailures testFailures = ++ unwords (map renderTestFailure (toList testFailures)) -- | Re-evaluate an on-chain script evaluation event. -checkEvaluationEvent - :: EvaluationContext - -> [Int64] - -- ^ Cost parameters - -> ScriptEvaluationEvent - -> Maybe UnexpectedEvaluationResult +checkEvaluationEvent :: + EvaluationContext -> + -- | Cost parameters + [Int64] -> + ScriptEvaluationEvent -> + Maybe UnexpectedEvaluationResult checkEvaluationEvent ctx params ev = case ev of - PlutusEvent PlutusV1 ScriptEvaluationData{..} expected -> + PlutusEvent PlutusV1 ScriptEvaluationData {..} expected -> case deserialiseScript PlutusV1 dataProtocolVersion dataScript of Right script -> let (_, actual) = @@ -177,7 +174,7 @@ checkEvaluationEvent ctx params ev = case ev of dataInputs in verify expected actual Left err -> Just (DecodeError err) - PlutusEvent PlutusV2 ScriptEvaluationData{..} expected -> + PlutusEvent PlutusV2 ScriptEvaluationData {..} expected -> case deserialiseScript PlutusV2 dataProtocolVersion dataScript of Right script -> let (_, actual) = @@ -190,13 +187,13 @@ checkEvaluationEvent ctx params ev = case ev of dataInputs in verify expected actual Left err -> Just (DecodeError err) - PlutusEvent PlutusV3 ScriptEvaluationData{..} expected -> + PlutusEvent PlutusV3 ScriptEvaluationData {..} expected -> case deserialiseScript PlutusV3 dataProtocolVersion dataScript of Right script -> do dataInput <- case dataInputs of [input] -> Just input - _ -> Nothing + _ -> Nothing let (_, actual) = V3.evaluateScriptRestricting dataProtocolVersion diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs index de12bcba2b7..085a087dd02 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs @@ -1,5 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE TypeApplications #-} + -- | This module contains example values to be used for testing. These should NOT be used in non-test code! module PlutusLedgerApi.Test.Examples where @@ -21,35 +22,37 @@ It seems better therefore to avoid depending on Plutus Tx in any "core" projects -- | Creates a script which has N arguments, and always succeeds. alwaysSucceedingNAryFunction :: Natural -> SerialisedScript alwaysSucceedingNAryFunction n = serialiseUPLC $ UPLC.Program () PLC.plcVersion100 (body n) - where - -- No more arguments! The body can be anything that doesn't fail, so we return `\x . x` - body i | i == 0 = UPLC.LamAbs() (UPLC.DeBruijn 0) $ UPLC.Var () (UPLC.DeBruijn 1) - -- We're using de Bruijn indices, so we can use the same binder each time! - body i = UPLC.LamAbs () (UPLC.DeBruijn 0) $ body (i-1) + where + -- No more arguments! The body can be anything that doesn't fail, so we return `\x . x` + body i | i == 0 = UPLC.LamAbs () (UPLC.DeBruijn 0) $ UPLC.Var () (UPLC.DeBruijn 1) + -- We're using de Bruijn indices, so we can use the same binder each time! + body i = UPLC.LamAbs () (UPLC.DeBruijn 0) $ body (i - 1) -- | Creates a script which has N arguments, and always fails. alwaysFailingNAryFunction :: Natural -> SerialisedScript alwaysFailingNAryFunction n = serialiseUPLC $ UPLC.Program () PLC.plcVersion100 (body n) - where - -- No more arguments! The body should be error. - body i | i == 0 = UPLC.Error () - -- We're using de Bruijn indices, so we can use the same binder each time! - body i = UPLC.LamAbs () (UPLC.DeBruijn 0) $ body (i-1) + where + -- No more arguments! The body should be error. + body i | i == 0 = UPLC.Error () + -- We're using de Bruijn indices, so we can use the same binder each time! + body i = UPLC.LamAbs () (UPLC.DeBruijn 0) $ body (i - 1) summingFunction :: SerialisedScript summingFunction = serialiseUPLC $ UPLC.Program () PLC.plcVersion100 body - where - body = UPLC.Apply () (UPLC.Apply () (UPLC.Builtin () PLC.AddInteger) (PLC.mkConstant @Integer () 1)) (PLC.mkConstant @Integer () 2) + where + body = UPLC.Apply () (UPLC.Apply () (UPLC.Builtin () PLC.AddInteger) (PLC.mkConstant @Integer () 1)) (PLC.mkConstant @Integer () 2) -- | Wrap a script with lambda/app so that, for instance, it has a different hash but the same behavior. saltFunction :: Integer -> SerialisedScript -> SerialisedScript saltFunction salt b0 = serialiseUPLC $ UPLC.Program () version body - where - UPLC.Program () version b1 = uncheckedDeserialiseUPLC b0 + where + UPLC.Program () version b1 = uncheckedDeserialiseUPLC b0 - body = UPLC.Apply () - (UPLC.LamAbs () (UPLC.DeBruijn 0) b1) - (UPLC.Constant () $ Some $ PLC.ValueOf PLC.DefaultUniInteger salt) + body = + UPLC.Apply + () + (UPLC.LamAbs () (UPLC.DeBruijn 0) b1) + (UPLC.Constant () $ Some $ PLC.ValueOf PLC.DefaultUniInteger salt) integerToByteStringFunction :: SerialisedScript integerToByteStringFunction = serialiseUPLC $ UPLC.Program () PLC.plcVersion110 body diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs index ff360870d9f..16e4da7c97e 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs @@ -12,19 +12,19 @@ import PlutusLedgerApi.V1.Scripts import PlutusTx.Code (CompiledCode) import UntypedPlutusCore qualified as UPLC -uplcToScriptForEvaluation - :: PlutusLedgerLanguage - -> MajorProtocolVersion - -> UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () - -> Either ScriptDecodeError ScriptForEvaluation +uplcToScriptForEvaluation :: + PlutusLedgerLanguage -> + MajorProtocolVersion -> + UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () -> + Either ScriptDecodeError ScriptForEvaluation uplcToScriptForEvaluation ll pv = deserialiseScript ll pv . serialiseUPLC -compiledCodeToScriptForEvaluation - :: PlutusLedgerLanguage - -> MajorProtocolVersion - -> CompiledCode a - -> Either ScriptDecodeError ScriptForEvaluation +compiledCodeToScriptForEvaluation :: + PlutusLedgerLanguage -> + MajorProtocolVersion -> + CompiledCode a -> + Either ScriptDecodeError ScriptForEvaluation compiledCodeToScriptForEvaluation ll pv = deserialiseScript ll pv . serialiseCompiledCode diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/EvaluationContext.hs index f2cc2ad9d4c..2ec52ed08ed 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/EvaluationContext.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module PlutusLedgerApi.Test.V1.Data.EvaluationContext - ( costModelParamsForTesting - , mCostModel - , clearMachineCostModel - , clearBuiltinCostModel - ) where + +module PlutusLedgerApi.Test.V1.Data.EvaluationContext ( + costModelParamsForTesting, + mCostModel, + clearMachineCostModel, + clearBuiltinCostModel, +) where import PlutusCore.Evaluation.Machine.MachineParameters import PlutusLedgerApi.Data.V1 qualified as V1 @@ -21,30 +22,31 @@ import Data.Maybe -- | Example values of costs for @PlutusV1@, in expected ledger order. -- Suitable to be used in testing. costModelParamsForTesting :: [(V1.ParamName, Int64)] -costModelParamsForTesting = Map.toList $ fromJust $ - Common.extractCostModelParamsLedgerOrder mCostModel +costModelParamsForTesting = + Map.toList $ + fromJust $ + Common.extractCostModelParamsLedgerOrder mCostModel -- | The PlutusV1 "cost model" is constructed by the v2 "cost model", by clearing v2 introductions. mCostModel :: MCostModel -mCostModel = V2.mCostModel - & machineCostModel - %~ V2.clearMachineCostModel -- no changes for machine costs, so this is id - & builtinCostModel - %~ V2.clearBuiltinCostModel - -{- | Assign to `mempty` those CEK constructs that @PlutusV1@ introduces (indirectly by introducing -a ledger language version with those CEK constructs). - -This can be used to generate a (machine) cost model of the previous plutus version, -by omitting the generation of the costs concerning the missing @PlutusV1@ CEK constructs. --} -clearMachineCostModel :: (m ~ MCekMachineCosts) => m -> m +mCostModel = + V2.mCostModel + & machineCostModel + %~ V2.clearMachineCostModel -- no changes for machine costs, so this is id + & builtinCostModel + %~ V2.clearBuiltinCostModel + +-- | Assign to `mempty` those CEK constructs that @PlutusV1@ introduces (indirectly by introducing +-- a ledger language version with those CEK constructs). +-- +-- This can be used to generate a (machine) cost model of the previous plutus version, +-- by omitting the generation of the costs concerning the missing @PlutusV1@ CEK constructs. +clearMachineCostModel :: m ~ MCekMachineCosts => m -> m clearMachineCostModel = id -- no PlutusV0 so nothing to clear -{- | Assign to `mempty` those builtins that the @PlutusV1@ introduces. - -This can be used to generate a (builtin) cost model of the previous version -by omitting the generation of the costs concerning the missing @PlutusV1@ builtins. --} -clearBuiltinCostModel :: (m ~ MBuiltinCostModel) => m -> m +-- | Assign to `mempty` those builtins that the @PlutusV1@ introduces. +-- +-- This can be used to generate a (builtin) cost model of the previous version +-- by omitting the generation of the costs concerning the missing @PlutusV1@ builtins. +clearBuiltinCostModel :: m ~ MBuiltinCostModel => m -> m clearBuiltinCostModel = id -- no PlutusV0 so nothing to clear diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs index 665985c7067..35a3116baaf 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusLedgerApi.Test.V1.Data.Value where @@ -8,6 +7,7 @@ module PlutusLedgerApi.Test.V1.Data.Value where -- TODO: import a new PlutusLedgerApi.Data.V1 module instead import PlutusLedgerApi.V1.Data.Value import PlutusTx.Builtins hiding (error) + -- import PlutusTx.Data.AssocMap qualified as AssocMap import PlutusTx.List qualified as ListTx @@ -44,55 +44,56 @@ toCellCandidatesNumber i = max 6 . floor @Double $ fromIntegral i ** 1.5 -- different 'Value's would be virtually zero. genShortHex :: Int -> Gen BuiltinByteString genShortHex i = - toBuiltin . Base16.encode . BS8.pack . show <$> elements [0 .. toCellCandidatesNumber i] + toBuiltin . Base16.encode . BS8.pack . show <$> elements [0 .. toCellCandidatesNumber i] -- | Annotate each element of the give list with a @name@, given a function turning -- 'BuiltinByteString' into names. uniqueNames :: Eq name => (BuiltinByteString -> name) -> [b] -> Gen [(name, b)] uniqueNames wrap ys = do - let len = length ys - -- We always generate unique 'CurrencySymbol's within a single 'Value' and 'TokenName' within a - -- single 'CurrencySymbol', because functions over 'Value' don't handle duplicated names anyway. - -- Note that we can generate the same 'TokenName' within different 'CurrencySymbol's within the - -- same 'Value'. - xs <- uniqueVectorOf len $ wrap <$> genShortHex len - pure $ zip xs ys + let len = length ys + -- We always generate unique 'CurrencySymbol's within a single 'Value' and 'TokenName' within a + -- single 'CurrencySymbol', because functions over 'Value' don't handle duplicated names anyway. + -- Note that we can generate the same 'TokenName' within different 'CurrencySymbol's within the + -- same 'Value'. + xs <- uniqueVectorOf len $ wrap <$> genShortHex len + pure $ zip xs ys -- | The value of a 'TokenName' in a 'Value'. newtype FaceValue = FaceValue - { unFaceValue :: Integer - } + { unFaceValue :: Integer + } instance Arbitrary FaceValue where - -- We want to generate zeroes often, because there's a lot of corner cases associated with them - -- and all non-zero numbers are handled pretty much the same anyway, so there isn't much point - -- in diversifying them as much as possible. - arbitrary = frequency - [ (2, pure $ FaceValue 0) - , (1, FaceValue . fromIntegral <$> arbitrary @Int) - ] + -- We want to generate zeroes often, because there's a lot of corner cases associated with them + -- and all non-zero numbers are handled pretty much the same anyway, so there isn't much point + -- in diversifying them as much as possible. + arbitrary = + frequency + [ (2, pure $ FaceValue 0) + , (1, FaceValue . fromIntegral <$> arbitrary @Int) + ] -- | A wrapper for satisfying an @Arbitrary a@ constraint without implementing an 'Arbitrary' -- instance for @a@. newtype NoArbitrary a = NoArbitrary - { unNoArbitrary :: a - } + { unNoArbitrary :: a + } -- | 'arbitrary' throws, 'shrink' neither throws nor shrinks. instance Arbitrary (NoArbitrary a) where - arbitrary = error "No such 'Arbitrary' instance" - shrink _ = [] + arbitrary = error "No such 'Arbitrary' instance" + shrink _ = [] instance Arbitrary Value where - arbitrary = do - -- Generate values for all of the 'TokenName's in the final 'Value' and split them into a - -- list of lists. - faceValues <- multiSplit0 0.2 . map unFaceValue =<< arbitrary - -- Generate 'TokenName's and 'CurrencySymbol's. - currencies <- uniqueNames CurrencySymbol =<< traverse (uniqueNames TokenName) faceValues - pure $ listsToValue currencies - - shrink - = map listsToValue - . coerce (shrink @[(NoArbitrary CurrencySymbol, [(NoArbitrary TokenName, Integer)])]) - . valueToLists + arbitrary = do + -- Generate values for all of the 'TokenName's in the final 'Value' and split them into a + -- list of lists. + faceValues <- multiSplit0 0.2 . map unFaceValue =<< arbitrary + -- Generate 'TokenName's and 'CurrencySymbol's. + currencies <- uniqueNames CurrencySymbol =<< traverse (uniqueNames TokenName) faceValues + pure $ listsToValue currencies + + shrink = + map listsToValue + . coerce (shrink @[(NoArbitrary CurrencySymbol, [(NoArbitrary TokenName, Integer)])]) + . valueToLists diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/EvaluationContext.hs index aff810ed950..38b2d7acd7c 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/EvaluationContext.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module PlutusLedgerApi.Test.V1.EvaluationContext - ( costModelParamsForTesting - , mCostModel - , clearMachineCostModel - , clearBuiltinCostModel - ) where + +module PlutusLedgerApi.Test.V1.EvaluationContext ( + costModelParamsForTesting, + mCostModel, + clearMachineCostModel, + clearBuiltinCostModel, +) where import PlutusCore.Evaluation.Machine.MachineParameters import PlutusLedgerApi.Test.Common.EvaluationContext as Common @@ -21,30 +22,31 @@ import Data.Maybe -- | Example values of costs for @PlutusV1@, in expected ledger order. -- Suitable to be used in testing. costModelParamsForTesting :: [(V1.ParamName, Int64)] -costModelParamsForTesting = Map.toList $ fromJust $ - Common.extractCostModelParamsLedgerOrder mCostModel +costModelParamsForTesting = + Map.toList $ + fromJust $ + Common.extractCostModelParamsLedgerOrder mCostModel -- | The PlutusV1 "cost model" is constructed by the v2 "cost model", by clearing v2 introductions. mCostModel :: MCostModel -mCostModel = V2.mCostModel - & machineCostModel - %~ V2.clearMachineCostModel -- no changes for machine costs, so this is id - & builtinCostModel - %~ V2.clearBuiltinCostModel - -{- | Assign to `mempty` those CEK constructs that @PlutusV1@ introduces (indirectly by introducing -a ledger language version with those CEK constructs). - -This can be used to generate a (machine) cost model of the previous plutus version, -by omitting the generation of the costs concerning the missing @PlutusV1@ CEK constructs. --} -clearMachineCostModel :: (m ~ MCekMachineCosts) => m -> m +mCostModel = + V2.mCostModel + & machineCostModel + %~ V2.clearMachineCostModel -- no changes for machine costs, so this is id + & builtinCostModel + %~ V2.clearBuiltinCostModel + +-- | Assign to `mempty` those CEK constructs that @PlutusV1@ introduces (indirectly by introducing +-- a ledger language version with those CEK constructs). +-- +-- This can be used to generate a (machine) cost model of the previous plutus version, +-- by omitting the generation of the costs concerning the missing @PlutusV1@ CEK constructs. +clearMachineCostModel :: m ~ MCekMachineCosts => m -> m clearMachineCostModel = id -- no PlutusV0 so nothing to clear -{- | Assign to `mempty` those builtins that the @PlutusV1@ introduces. - -This can be used to generate a (builtin) cost model of the previous version -by omitting the generation of the costs concerning the missing @PlutusV1@ builtins. --} -clearBuiltinCostModel :: (m ~ MBuiltinCostModel) => m -> m +-- | Assign to `mempty` those builtins that the @PlutusV1@ introduces. +-- +-- This can be used to generate a (builtin) cost model of the previous version +-- by omitting the generation of the costs concerning the missing @PlutusV1@ builtins. +clearBuiltinCostModel :: m ~ MBuiltinCostModel => m -> m clearBuiltinCostModel = id -- no PlutusV0 so nothing to clear diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs index fe1c354cdcc..16ee0a1afb8 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} module PlutusLedgerApi.Test.V1.Value where @@ -27,32 +26,34 @@ valueToLists = ListTx.map (fmap AssocMap.toList) . AssocMap.toList . getValue -- | The value of a 'TokenName' in a 'Value'. newtype FaceValue = FaceValue - { unFaceValue :: Integer - } + { unFaceValue :: Integer + } instance Arbitrary FaceValue where - -- We want to generate zeroes often, because there's a lot of corner cases associated with them - -- and all non-zero numbers are handled pretty much the same anyway, so there isn't much point - -- in diversifying them as much as possible. - arbitrary = frequency - [ (2, pure $ FaceValue 0) - , (1, FaceValue . fromIntegral <$> arbitrary @Int) - ] + -- We want to generate zeroes often, because there's a lot of corner cases associated with them + -- and all non-zero numbers are handled pretty much the same anyway, so there isn't much point + -- in diversifying them as much as possible. + arbitrary = + frequency + [ (2, pure $ FaceValue 0) + , (1, FaceValue . fromIntegral <$> arbitrary @Int) + ] instance Arbitrary Value where - arbitrary = do - -- Generate values for all of the 'TokenName's in the final 'Value' and split them into a - -- list of lists. - faceValues <- multiSplit0 0.2 . map unFaceValue =<< arbitrary - -- Generate 'TokenName's and 'CurrencySymbol's. - currencies <- uniqueNames (CurrencySymbol . toBuiltin . PLC.unK) =<< - traverse (uniqueNames (TokenName . toBuiltin . PLC.unK)) faceValues - pure $ listsToValue currencies + arbitrary = do + -- Generate values for all of the 'TokenName's in the final 'Value' and split them into a + -- list of lists. + faceValues <- multiSplit0 0.2 . map unFaceValue =<< arbitrary + -- Generate 'TokenName's and 'CurrencySymbol's. + currencies <- + uniqueNames (CurrencySymbol . toBuiltin . PLC.unK) + =<< traverse (uniqueNames (TokenName . toBuiltin . PLC.unK)) faceValues + pure $ listsToValue currencies - shrink - = map listsToValue - . coerce (shrink @[(NoArbitrary CurrencySymbol, [(NoArbitrary TokenName, Integer)])]) - . valueToLists + shrink = + map listsToValue + . coerce (shrink @[(NoArbitrary CurrencySymbol, [(NoArbitrary TokenName, Integer)])]) + . valueToLists valueFromBuiltin :: PLC.Value -> Value valueFromBuiltin = @@ -60,5 +61,5 @@ valueFromBuiltin = . fmap (bimap (CurrencySymbol . toBuiltin . PLC.unK) inner) . Map.toList . PLC.unpack - where - inner = fmap (bimap (TokenName . toBuiltin . PLC.unK) PLC.unQuantity) . Map.toList + where + inner = fmap (bimap (TokenName . toBuiltin . PLC.unK) PLC.unQuantity) . Map.toList diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/Data/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/Data/EvaluationContext.hs index 8a2df236164..41141929644 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/Data/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/Data/EvaluationContext.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module PlutusLedgerApi.Test.V2.Data.EvaluationContext - ( costModelParamsForTesting - , mCostModel - , clearMachineCostModel - , clearBuiltinCostModel - ) where + +module PlutusLedgerApi.Test.V2.Data.EvaluationContext ( + costModelParamsForTesting, + mCostModel, + clearMachineCostModel, + clearBuiltinCostModel, +) where import PlutusCore.Evaluation.Machine.BuiltinCostModel import PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -23,36 +24,38 @@ import Data.Maybe -- | Example values of costs for @PlutusV2@, in expected ledger order. -- Suitable to be used in testing. costModelParamsForTesting :: [(V2.ParamName, Int64)] -costModelParamsForTesting = Map.toList $ fromJust $ - Common.extractCostModelParamsLedgerOrder mCostModel +costModelParamsForTesting = + Map.toList $ + fromJust $ + Common.extractCostModelParamsLedgerOrder mCostModel -- | The PlutusV2 "cost model" is constructed by the v3 "cost model", by clearing v3 introductions. mCostModel :: MCostModel -mCostModel = toMCostModel defaultCekCostModelForTestingB - & machineCostModel - %~ V3.clearMachineCostModel - & builtinCostModel - %~ V3.clearBuiltinCostModel - -{- | Assign to `mempty` those CEK constructs that @PlutusV2@ introduces (indirectly by introducing -a ledger language version with those CEK constructs). - -This can be used to generate a (machine) cost model of the previous plutus version, -by omitting the generation of the costs concerning the missing @PlutusV2@ CEK constructs. --} -clearMachineCostModel :: (m ~ MCekMachineCosts) => m -> m +mCostModel = + toMCostModel defaultCekCostModelForTestingB + & machineCostModel + %~ V3.clearMachineCostModel + & builtinCostModel + %~ V3.clearBuiltinCostModel + +-- | Assign to `mempty` those CEK constructs that @PlutusV2@ introduces (indirectly by introducing +-- a ledger language version with those CEK constructs). +-- +-- This can be used to generate a (machine) cost model of the previous plutus version, +-- by omitting the generation of the costs concerning the missing @PlutusV2@ CEK constructs. +clearMachineCostModel :: m ~ MCekMachineCosts => m -> m clearMachineCostModel = id -- nothing changed, so nothing to clear -{- | Assign to `mempty` those builtins that the @PlutusV2@ introduces. - -This can be used to generate a (builtin) cost model of the previous version -by omitting the generation of the costs concerning the missing @PlutusV2@ builtins. --} -clearBuiltinCostModel :: (m ~ MBuiltinCostModel) => m -> m -clearBuiltinCostModel r = r - { paramSerialiseData = mempty - , paramVerifyEcdsaSecp256k1Signature = mempty - , paramVerifySchnorrSecp256k1Signature = mempty - , paramIntegerToByteString = mempty - , paramByteStringToInteger = mempty - } +-- | Assign to `mempty` those builtins that the @PlutusV2@ introduces. +-- +-- This can be used to generate a (builtin) cost model of the previous version +-- by omitting the generation of the costs concerning the missing @PlutusV2@ builtins. +clearBuiltinCostModel :: m ~ MBuiltinCostModel => m -> m +clearBuiltinCostModel r = + r + { paramSerialiseData = mempty + , paramVerifyEcdsaSecp256k1Signature = mempty + , paramVerifySchnorrSecp256k1Signature = mempty + , paramIntegerToByteString = mempty + , paramByteStringToInteger = mempty + } diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs index 932486ee8d3..e77dd9e8cf0 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module PlutusLedgerApi.Test.V2.EvaluationContext - ( costModelParamsForTesting - , mCostModel - , clearMachineCostModel - , clearBuiltinCostModel - ) where + +module PlutusLedgerApi.Test.V2.EvaluationContext ( + costModelParamsForTesting, + mCostModel, + clearMachineCostModel, + clearBuiltinCostModel, +) where import PlutusCore.Evaluation.Machine.BuiltinCostModel import PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -23,36 +24,38 @@ import Data.Maybe -- | Example values of costs for @PlutusV2@, in expected ledger order. -- Suitable to be used in testing. costModelParamsForTesting :: [(V2.ParamName, Int64)] -costModelParamsForTesting = Map.toList $ fromJust $ - Common.extractCostModelParamsLedgerOrder mCostModel +costModelParamsForTesting = + Map.toList $ + fromJust $ + Common.extractCostModelParamsLedgerOrder mCostModel -- | The PlutusV2 "cost model" is constructed by the v3 "cost model", by clearing v3 introductions. mCostModel :: MCostModel -mCostModel = toMCostModel defaultCekCostModelForTestingB - & machineCostModel - %~ V3.clearMachineCostModel - & builtinCostModel - %~ V3.clearBuiltinCostModel - -{- | Assign to `mempty` those CEK constructs that @PlutusV2@ introduces (indirectly by introducing -a ledger language version with those CEK constructs). - -This can be used to generate a (machine) cost model of the previous plutus version, -by omitting the generation of the costs concerning the missing @PlutusV2@ CEK constructs. --} -clearMachineCostModel :: (m ~ MCekMachineCosts) => m -> m +mCostModel = + toMCostModel defaultCekCostModelForTestingB + & machineCostModel + %~ V3.clearMachineCostModel + & builtinCostModel + %~ V3.clearBuiltinCostModel + +-- | Assign to `mempty` those CEK constructs that @PlutusV2@ introduces (indirectly by introducing +-- a ledger language version with those CEK constructs). +-- +-- This can be used to generate a (machine) cost model of the previous plutus version, +-- by omitting the generation of the costs concerning the missing @PlutusV2@ CEK constructs. +clearMachineCostModel :: m ~ MCekMachineCosts => m -> m clearMachineCostModel = id -- nothing changed, so nothing to clear -{- | Assign to `mempty` those builtins that the @PlutusV2@ introduces. - -This can be used to generate a (builtin) cost model of the previous version -by omitting the generation of the costs concerning the missing @PlutusV2@ builtins. --} -clearBuiltinCostModel :: (m ~ MBuiltinCostModel) => m -> m -clearBuiltinCostModel r = r - { paramSerialiseData = mempty - , paramVerifyEcdsaSecp256k1Signature = mempty - , paramVerifySchnorrSecp256k1Signature = mempty - , paramIntegerToByteString = mempty - , paramByteStringToInteger = mempty - } +-- | Assign to `mempty` those builtins that the @PlutusV2@ introduces. +-- +-- This can be used to generate a (builtin) cost model of the previous version +-- by omitting the generation of the costs concerning the missing @PlutusV2@ builtins. +clearBuiltinCostModel :: m ~ MBuiltinCostModel => m -> m +clearBuiltinCostModel r = + r + { paramSerialiseData = mempty + , paramVerifyEcdsaSecp256k1Signature = mempty + , paramVerifySchnorrSecp256k1Signature = mempty + , paramIntegerToByteString = mempty + , paramByteStringToInteger = mempty + } diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs index 1786e3ffd4c..e449260165c 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module PlutusLedgerApi.Test.V3.Data.EvaluationContext - ( costModelParamsForTesting - , mCostModel - , clearMachineCostModel - , clearBuiltinCostModel - ) where + +module PlutusLedgerApi.Test.V3.Data.EvaluationContext ( + costModelParamsForTesting, + mCostModel, + clearMachineCostModel, + clearBuiltinCostModel, +) where import PlutusCore.Evaluation.Machine.BuiltinCostModel import PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -23,77 +24,79 @@ import GHC.Stack (HasCallStack) -- | Example values of costs for @PlutusV3@, in expected ledger order. -- Suitable to be used in testing. costModelParamsForTesting :: HasCallStack => [(V3.ParamName, Int64)] -costModelParamsForTesting = Map.toList $ fromJust $ - Common.extractCostModelParamsLedgerOrder mCostModel +costModelParamsForTesting = + Map.toList $ + fromJust $ + Common.extractCostModelParamsLedgerOrder mCostModel -- | The PlutusV3 "cost model" is constructed by the v4 "cost model", by clearing v4 introductions. mCostModel :: MCostModel mCostModel = - -- nothing to clear because v4 does not exist (yet). - toMCostModel defaultCekCostModelForTesting & builtinCostModel %~ clearBuiltinCostModel' - -{- | Assign to `mempty` those CEK constructs that @PlutusV3@ introduces (indirectly by introducing -a ledger language version with those CEK constructs). + -- nothing to clear because v4 does not exist (yet). + toMCostModel defaultCekCostModelForTesting & builtinCostModel %~ clearBuiltinCostModel' -This can be used to generate a (machine) cost model of the previous plutus version, -by omitting the generation of the costs concerning the missing @PlutusV3@ CEK constructs. --} -clearMachineCostModel :: (m ~ MCekMachineCosts) => m -> m -clearMachineCostModel r = r - { cekConstrCost = mempty - , cekCaseCost = mempty +-- | Assign to `mempty` those CEK constructs that @PlutusV3@ introduces (indirectly by introducing +-- a ledger language version with those CEK constructs). +-- +-- This can be used to generate a (machine) cost model of the previous plutus version, +-- by omitting the generation of the costs concerning the missing @PlutusV3@ CEK constructs. +clearMachineCostModel :: m ~ MCekMachineCosts => m -> m +clearMachineCostModel r = + r + { cekConstrCost = mempty + , cekCaseCost = mempty } -{- | Assign to `mempty` those builtins that the @PlutusV3@ introduces. - -This can be used to generate a (builtin) cost model of the previous version -by omitting the generation of the costs concerning the missing @PlutusV3@ builtins. --} -clearBuiltinCostModel :: (m ~ MBuiltinCostModel) => m -> m -clearBuiltinCostModel r = r - { paramBls12_381_G1_add = mempty - , paramBls12_381_G1_neg = mempty - , paramBls12_381_G1_scalarMul = mempty - , paramBls12_381_G1_equal = mempty - , paramBls12_381_G1_hashToGroup = mempty - , paramBls12_381_G1_compress = mempty - , paramBls12_381_G1_uncompress = mempty - , paramBls12_381_G2_add = mempty - , paramBls12_381_G2_neg = mempty - , paramBls12_381_G2_scalarMul = mempty - , paramBls12_381_G2_equal = mempty - , paramBls12_381_G2_hashToGroup = mempty - , paramBls12_381_G2_compress = mempty - , paramBls12_381_G2_uncompress = mempty - , paramBls12_381_millerLoop = mempty - , paramBls12_381_mulMlResult = mempty - , paramBls12_381_finalVerify = mempty - , paramKeccak_256 = mempty - , paramBlake2b_224 = mempty - , paramIntegerToByteString = mempty - , paramByteStringToInteger = mempty - , paramAndByteString = mempty - , paramOrByteString = mempty - , paramXorByteString = mempty - , paramComplementByteString = mempty - , paramReadBit = mempty - , paramWriteBits = mempty - , paramReplicateByte = mempty - , paramShiftByteString = mempty - , paramRotateByteString = mempty - , paramCountSetBits = mempty - , paramFindFirstSetBit = mempty - , paramRipemd_160 = mempty - , paramExpModInteger = mempty - , paramLengthOfArray = mempty - , paramListToArray = mempty - , paramIndexArray = mempty - , paramBls12_381_G1_multiScalarMul = mempty - , paramBls12_381_G2_multiScalarMul = mempty - } - +-- | Assign to `mempty` those builtins that the @PlutusV3@ introduces. +-- +-- This can be used to generate a (builtin) cost model of the previous version +-- by omitting the generation of the costs concerning the missing @PlutusV3@ builtins. +clearBuiltinCostModel :: m ~ MBuiltinCostModel => m -> m +clearBuiltinCostModel r = + r + { paramBls12_381_G1_add = mempty + , paramBls12_381_G1_neg = mempty + , paramBls12_381_G1_scalarMul = mempty + , paramBls12_381_G1_equal = mempty + , paramBls12_381_G1_hashToGroup = mempty + , paramBls12_381_G1_compress = mempty + , paramBls12_381_G1_uncompress = mempty + , paramBls12_381_G2_add = mempty + , paramBls12_381_G2_neg = mempty + , paramBls12_381_G2_scalarMul = mempty + , paramBls12_381_G2_equal = mempty + , paramBls12_381_G2_hashToGroup = mempty + , paramBls12_381_G2_compress = mempty + , paramBls12_381_G2_uncompress = mempty + , paramBls12_381_millerLoop = mempty + , paramBls12_381_mulMlResult = mempty + , paramBls12_381_finalVerify = mempty + , paramKeccak_256 = mempty + , paramBlake2b_224 = mempty + , paramIntegerToByteString = mempty + , paramByteStringToInteger = mempty + , paramAndByteString = mempty + , paramOrByteString = mempty + , paramXorByteString = mempty + , paramComplementByteString = mempty + , paramReadBit = mempty + , paramWriteBits = mempty + , paramReplicateByte = mempty + , paramShiftByteString = mempty + , paramRotateByteString = mempty + , paramCountSetBits = mempty + , paramFindFirstSetBit = mempty + , paramRipemd_160 = mempty + , paramExpModInteger = mempty + , paramLengthOfArray = mempty + , paramListToArray = mempty + , paramIndexArray = mempty + , paramBls12_381_G1_multiScalarMul = mempty + , paramBls12_381_G2_multiScalarMul = mempty + } -- *** FIXME(https://github.com/IntersectMBO/plutus-private/issues/1610)!!! *** + -- This is temporary to get the tests to pass -- [Later: now we can get away without this because we're planning to deploy all builtins in all versions]. clearBuiltinCostModel' :: diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs index 520c088b2d3..363ea03350d 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module PlutusLedgerApi.Test.V3.EvaluationContext - ( costModelParamsForTesting - , mCostModel - , clearMachineCostModel - , clearBuiltinCostModel - ) where + +module PlutusLedgerApi.Test.V3.EvaluationContext ( + costModelParamsForTesting, + mCostModel, + clearMachineCostModel, + clearBuiltinCostModel, +) where import PlutusCore.Evaluation.Machine.BuiltinCostModel import PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -15,92 +16,93 @@ import PlutusLedgerApi.V3 qualified as V3 import PlutusPrelude import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts - import Data.Int (Int64) import Data.Map qualified as Map import Data.Maybe import GHC.Stack (HasCallStack) - -- ** FIXME **. These tests no longer make much sense because now we're assuming + -- that all builtins will be available in all PlutusVN, so the cost models will -- be very similar (but not yet identical). -- | Example values of costs for @PlutusV3@, in expected ledger order. -- Suitable to be used in testing. costModelParamsForTesting :: HasCallStack => [(V3.ParamName, Int64)] -costModelParamsForTesting = Map.toList $ fromJust $ - Common.extractCostModelParamsLedgerOrder mCostModel +costModelParamsForTesting = + Map.toList $ + fromJust $ + Common.extractCostModelParamsLedgerOrder mCostModel -- | The PlutusV3 "cost model" is constructed by the v4 "cost model", by clearing v4 introductions. mCostModel :: MCostModel mCostModel = - -- nothing to clear because v4 does not exist (yet). - toMCostModel defaultCekCostModelForTesting & builtinCostModel %~ clearBuiltinCostModel' - -{- | Assign to `mempty` those CEK constructs that @PlutusV3@ introduces (indirectly by introducing -a ledger language version with those CEK constructs). + -- nothing to clear because v4 does not exist (yet). + toMCostModel defaultCekCostModelForTesting & builtinCostModel %~ clearBuiltinCostModel' -This can be used to generate a (machine) cost model of the previous plutus version, -by omitting the generation of the costs concerning the missing @PlutusV3@ CEK constructs. --} -clearMachineCostModel :: (m ~ MCekMachineCosts) => m -> m -clearMachineCostModel r = r - { cekConstrCost = mempty - , cekCaseCost = mempty +-- | Assign to `mempty` those CEK constructs that @PlutusV3@ introduces (indirectly by introducing +-- a ledger language version with those CEK constructs). +-- +-- This can be used to generate a (machine) cost model of the previous plutus version, +-- by omitting the generation of the costs concerning the missing @PlutusV3@ CEK constructs. +clearMachineCostModel :: m ~ MCekMachineCosts => m -> m +clearMachineCostModel r = + r + { cekConstrCost = mempty + , cekCaseCost = mempty } -{- | Assign to `mempty` those builtins that the @PlutusV3@ introduces. - -This can be used to generate a (builtin) cost model of the previous version -by omitting the generation of the costs concerning the missing @PlutusV3@ builtins. --} -clearBuiltinCostModel :: (m ~ MBuiltinCostModel) => m -> m -clearBuiltinCostModel r = r - { paramBls12_381_G1_add = mempty - , paramBls12_381_G1_neg = mempty - , paramBls12_381_G1_scalarMul = mempty - , paramBls12_381_G1_equal = mempty - , paramBls12_381_G1_hashToGroup = mempty - , paramBls12_381_G1_compress = mempty - , paramBls12_381_G1_uncompress = mempty - , paramBls12_381_G2_add = mempty - , paramBls12_381_G2_neg = mempty - , paramBls12_381_G2_scalarMul = mempty - , paramBls12_381_G2_equal = mempty - , paramBls12_381_G2_hashToGroup = mempty - , paramBls12_381_G2_compress = mempty - , paramBls12_381_G2_uncompress = mempty - , paramBls12_381_millerLoop = mempty - , paramBls12_381_mulMlResult = mempty - , paramBls12_381_finalVerify = mempty - , paramKeccak_256 = mempty - , paramBlake2b_224 = mempty - , paramIntegerToByteString = mempty - , paramByteStringToInteger = mempty - , paramAndByteString = mempty - , paramOrByteString = mempty - , paramXorByteString = mempty - , paramComplementByteString = mempty - , paramReadBit = mempty - , paramWriteBits = mempty - , paramReplicateByte = mempty - , paramShiftByteString = mempty - , paramRotateByteString = mempty - , paramCountSetBits = mempty - , paramFindFirstSetBit = mempty - , paramRipemd_160 = mempty - , paramExpModInteger = mempty - , paramDropList = mempty - , paramLengthOfArray = mempty - , paramListToArray = mempty - , paramIndexArray = mempty - , paramBls12_381_G1_multiScalarMul = mempty - , paramBls12_381_G2_multiScalarMul = mempty - } - +-- | Assign to `mempty` those builtins that the @PlutusV3@ introduces. +-- +-- This can be used to generate a (builtin) cost model of the previous version +-- by omitting the generation of the costs concerning the missing @PlutusV3@ builtins. +clearBuiltinCostModel :: m ~ MBuiltinCostModel => m -> m +clearBuiltinCostModel r = + r + { paramBls12_381_G1_add = mempty + , paramBls12_381_G1_neg = mempty + , paramBls12_381_G1_scalarMul = mempty + , paramBls12_381_G1_equal = mempty + , paramBls12_381_G1_hashToGroup = mempty + , paramBls12_381_G1_compress = mempty + , paramBls12_381_G1_uncompress = mempty + , paramBls12_381_G2_add = mempty + , paramBls12_381_G2_neg = mempty + , paramBls12_381_G2_scalarMul = mempty + , paramBls12_381_G2_equal = mempty + , paramBls12_381_G2_hashToGroup = mempty + , paramBls12_381_G2_compress = mempty + , paramBls12_381_G2_uncompress = mempty + , paramBls12_381_millerLoop = mempty + , paramBls12_381_mulMlResult = mempty + , paramBls12_381_finalVerify = mempty + , paramKeccak_256 = mempty + , paramBlake2b_224 = mempty + , paramIntegerToByteString = mempty + , paramByteStringToInteger = mempty + , paramAndByteString = mempty + , paramOrByteString = mempty + , paramXorByteString = mempty + , paramComplementByteString = mempty + , paramReadBit = mempty + , paramWriteBits = mempty + , paramReplicateByte = mempty + , paramShiftByteString = mempty + , paramRotateByteString = mempty + , paramCountSetBits = mempty + , paramFindFirstSetBit = mempty + , paramRipemd_160 = mempty + , paramExpModInteger = mempty + , paramDropList = mempty + , paramLengthOfArray = mempty + , paramListToArray = mempty + , paramIndexArray = mempty + , paramBls12_381_G1_multiScalarMul = mempty + , paramBls12_381_G2_multiScalarMul = mempty + } -- *** FIXME(https://github.com/IntersectMBO/plutus-private/issues/1610)!!! *** + -- This is temporary to get the tests to pass -- [Later: now we can get away without this because we're planning to deploy all builtins in all versions]. clearBuiltinCostModel' :: diff --git a/plutus-metatheory/src/Certifier.hs b/plutus-metatheory/src/Certifier.hs index af73eb4b6d8..a37710bf1fb 100644 --- a/plutus-metatheory/src/Certifier.hs +++ b/plutus-metatheory/src/Certifier.hs @@ -1,12 +1,12 @@ {-# OPTIONS_GHC -Wall #-} module Certifier ( - runCertifier - , mkCertifier - , prettyCertifierError - , prettyCertifierSuccess - , CertifierError (..) - ) where + runCertifier, + mkCertifier, + prettyCertifierError, + prettyCertifierSuccess, + CertifierError (..), +) where import Control.Monad.Except (ExceptT (..), runExceptT, throwError) import Control.Monad.IO.Class (liftIO) @@ -40,10 +40,11 @@ newtype CertifierSuccess = CertifierSuccess CertDir prettyCertifierError :: CertifierError -> String prettyCertifierError (InvalidCertificate certDir) = - "\n\nInvalid certificate: " <> certDir <> - "\nThe compilation was not successfully certified. \ - \Please open a bug report at https://www.github.com/IntersectMBO/plutus \ - \and attach the faulty certificate.\n" + "\n\nInvalid certificate: " + <> certDir + <> "\nThe compilation was not successfully certified. \ + \Please open a bug report at https://www.github.com/IntersectMBO/plutus \ + \and attach the faulty certificate.\n" prettyCertifierError InvalidCompilerOutput = "\n\nInvalid compiler output: \ \\nThe certifier was not able to process the trace produced by the compiler. \ @@ -51,14 +52,17 @@ prettyCertifierError InvalidCompilerOutput = \containing a minimal program that when compiled reproduces the issue.\n" prettyCertifierError (ValidationError name) = "\n\nInvalid certificate name: \ - \\nThe certificate name " <> name <> " is invalid. \ - \Please use only alphanumeric characters, underscores and dashes. \ - \The first character must be a letter.\n" + \\nThe certificate name " + <> name + <> " is invalid. \ + \Please use only alphanumeric characters, underscores and dashes. \ + \The first character must be a letter.\n" prettyCertifierSuccess :: CertifierSuccess -> String prettyCertifierSuccess (CertifierSuccess certDir) = - "\n\nCertificate successfully created: " <> certDir <> - "\nThe compilation was successfully certified.\n" + "\n\nCertificate successfully created: " + <> certDir + <> "\nThe compilation was successfully certified.\n" type Certifier = ExceptT CertifierError IO @@ -66,12 +70,12 @@ runCertifier :: Certifier a -> IO (Either CertifierError a) runCertifier = runExceptT -- | Run the Agda certifier on the simplification trace, if requested -mkCertifier - :: SimplifierTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a - -- ^ The trace produced by the simplification process - -> CertName - -- ^ The name of the certificate to be produced - -> Certifier CertifierSuccess +mkCertifier :: + -- | The trace produced by the simplification process + SimplifierTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a -> + -- | The name of the certificate to be produced + CertName -> + Certifier CertifierSuccess mkCertifier simplTrace certName = do certName' <- validCertName certName let rawAgdaTrace = mkFfiSimplifierTrace simplTrace @@ -92,26 +96,26 @@ validCertName name@(fstC : rest) = then pure (toUpper fstC : rest) else throwError $ ValidationError name where - isValidChar c = c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_-" + isValidChar c = c `elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "_-" type EquivClass = Int data TermWithId = TermWithId { termId :: Int - , term :: UTerm + , term :: UTerm } data Ast = Ast - { equivClass :: EquivClass + { equivClass :: EquivClass , astTermWithId :: TermWithId } getTermId :: Ast -> Int -getTermId Ast {astTermWithId = TermWithId {termId} } = termId +getTermId Ast {astTermWithId = TermWithId {termId}} = termId data Certificate = Certificate - { certName :: String - , certTrace :: [(SimplifierStage, (Ast, Ast))] + { certName :: String + , certTrace :: [(SimplifierStage, (Ast, Ast))] , certReprAsts :: [Ast] } @@ -129,24 +133,24 @@ mkCertificate certName rawTrace = , certReprAsts } where - addIds - :: [(SimplifierStage, (UTerm, UTerm))] - -> [(SimplifierStage, (TermWithId, TermWithId))] + addIds :: + [(SimplifierStage, (UTerm, UTerm))] -> + [(SimplifierStage, (TermWithId, TermWithId))] addIds = go 0 where - go - :: Int - -> [(SimplifierStage, (UTerm, UTerm))] - -> [(SimplifierStage, (TermWithId, TermWithId))] + go :: + Int -> + [(SimplifierStage, (UTerm, UTerm))] -> + [(SimplifierStage, (TermWithId, TermWithId))] go _ [] = [] go id' ((stage, (before, after)) : rest) = let beforeWithId = TermWithId id' before afterWithId = TermWithId (id' + 1) after in (stage, (beforeWithId, afterWithId)) : go (id' + 2) rest - extractTermWithIds - :: [(SimplifierStage, (TermWithId, TermWithId))] - -> [TermWithId] + extractTermWithIds :: + [(SimplifierStage, (TermWithId, TermWithId))] -> + [TermWithId] extractTermWithIds = concatMap (\(_, (before, after)) -> [before, after]) findEquivClasses :: [TermWithId] -> [NonEmpty Ast] @@ -168,22 +172,22 @@ mkCertificate certName rawTrace = \ This is an issue in the certifier, please open a bug report at\ \ https://github.com/IntersectMBO/plutus/issues" - mkAstTrace - :: [Ast] - -> [(SimplifierStage, (TermWithId, TermWithId))] - -> [(SimplifierStage, (Ast, Ast))] + mkAstTrace :: + [Ast] -> + [(SimplifierStage, (TermWithId, TermWithId))] -> + [(SimplifierStage, (Ast, Ast))] mkAstTrace _ [] = [] mkAstTrace allAsts ((stage, (rawBefore, rawAfter)) : rest) = let processedBefore = - fromMaybe (error errorMessage) - $ find (\ast -> getTermId ast == termId rawBefore) allAsts + fromMaybe (error errorMessage) $ + find (\ast -> getTermId ast == termId rawBefore) allAsts processedAfter = - fromMaybe (error errorMessage) - $ find (\ast -> getTermId ast == termId rawAfter) allAsts + fromMaybe (error errorMessage) $ + find (\ast -> getTermId ast == termId rawAfter) allAsts in (stage, (processedBefore, processedAfter)) : mkAstTrace allAsts rest mkAstModuleName :: Ast -> String -mkAstModuleName Ast { equivClass } = +mkAstModuleName Ast {equivClass} = "Ast" <> show equivClass mkAgdaAstFile :: Ast -> (FilePath, String) @@ -199,27 +203,33 @@ mkAgdaAstFile ast = mkAstModule :: String -> String -> String -> String mkAstModule agdaIdStr agdaAstTy agdaAstDef = - "module " <> agdaIdStr <> " where\ - \\n\ - \\nopen import VerifiedCompilation\ - \\nopen import VerifiedCompilation.Certificate\ - \\nopen import Untyped\ - \\nopen import RawU\ - \\nopen import Builtin\ - \\nopen import Data.Unit\ - \\nopen import Data.Nat\ - \\nopen import Data.Integer\ - \\nopen import Utils\ - \\nimport Agda.Builtin.Bool\ - \\nimport Relation.Nullary\ - \\nimport VerifiedCompilation.UntypedTranslation\ - \\nopen import Agda.Builtin.Maybe\ - \\nopen import Data.Empty using (⊥)\ - \\nopen import Data.Bool.Base using (Bool; false; true)\ - \\nopen import Agda.Builtin.Equality using (_≡_; refl)\ - \\n\ - \\n" <> agdaAstTy <> "\n\ - \\n" <> agdaAstDef <> "\n" + "module " + <> agdaIdStr + <> " where\ + \\n\ + \\nopen import VerifiedCompilation\ + \\nopen import VerifiedCompilation.Certificate\ + \\nopen import Untyped\ + \\nopen import RawU\ + \\nopen import Builtin\ + \\nopen import Data.Unit\ + \\nopen import Data.Nat\ + \\nopen import Data.Integer\ + \\nopen import Utils\ + \\nimport Agda.Builtin.Bool\ + \\nimport Relation.Nullary\ + \\nimport VerifiedCompilation.UntypedTranslation\ + \\nopen import Agda.Builtin.Maybe\ + \\nopen import Data.Empty using (⊥)\ + \\nopen import Data.Bool.Base using (Bool; false; true)\ + \\nopen import Agda.Builtin.Equality using (_≡_; refl)\ + \\n\ + \\n" + <> agdaAstTy + <> "\n\ + \\n" + <> agdaAstDef + <> "\n" mkAgdaOpenImport :: String -> String mkAgdaOpenImport agdaModuleName = @@ -231,85 +241,96 @@ instance AgdaUnparse AgdaVar where agdaUnparse (AgdaVar var) = var mkCertificateFile :: Certificate -> (FilePath, String) -mkCertificateFile Certificate { certName, certTrace, certReprAsts } = +mkCertificateFile Certificate {certName, certTrace, certReprAsts} = let imports = fmap (mkAgdaOpenImport . mkAstModuleName) certReprAsts agdaTrace = - agdaUnparse - $ (\(st, (ast1, ast2)) -> - (st - , (AgdaVar $ "ast" <> (show . equivClass) ast1 - , AgdaVar $ "ast" <> (show . equivClass) ast2 + agdaUnparse $ + ( \(st, (ast1, ast2)) -> + ( st + , + ( AgdaVar $ "ast" <> (show . equivClass) ast1 + , AgdaVar $ "ast" <> (show . equivClass) ast2 + ) ) - ) ) - <$> certTrace + <$> certTrace certFile = certName <> ".agda" in (certFile, mkCertificateModule certName agdaTrace imports) mkCertificateModule :: String -> String -> [String] -> String mkCertificateModule certModule agdaTrace imports = - "module " <> certModule <> " where\ - \\n\ - \\nopen import VerifiedCompilation\ - \\nopen import VerifiedCompilation.Certificate\ - \\nopen import Untyped\ - \\nopen import RawU\ - \\nopen import Builtin\ - \\nopen import Data.Unit\ - \\nopen import Data.Nat\ - \\nopen import Data.Integer\ - \\nopen import Utils\ - \\nimport Agda.Builtin.Bool\ - \\nimport Relation.Nullary\ - \\nimport VerifiedCompilation.UntypedTranslation\ - \\nopen import Agda.Builtin.Maybe\ - \\nopen import Data.Empty using (⊥)\ - \\nopen import Data.Bool.Base using (Bool; false; true)\ - \\nopen import Agda.Builtin.Equality using (_≡_; refl)\ - \\n" <> unlines imports <> "\n" <> - "\n\ - \\nasts : List (SimplifierTag × Untyped × Untyped)\ - \\nasts = " <> agdaTrace <> - "\n\ - \\ncertificate : passed? (runCertifier asts) ≡ true\ - \\ncertificate = refl\ - \\n" + "module " + <> certModule + <> " where\ + \\n\ + \\nopen import VerifiedCompilation\ + \\nopen import VerifiedCompilation.Certificate\ + \\nopen import Untyped\ + \\nopen import RawU\ + \\nopen import Builtin\ + \\nopen import Data.Unit\ + \\nopen import Data.Nat\ + \\nopen import Data.Integer\ + \\nopen import Utils\ + \\nimport Agda.Builtin.Bool\ + \\nimport Relation.Nullary\ + \\nimport VerifiedCompilation.UntypedTranslation\ + \\nopen import Agda.Builtin.Maybe\ + \\nopen import Data.Empty using (⊥)\ + \\nopen import Data.Bool.Base using (Bool; false; true)\ + \\nopen import Agda.Builtin.Equality using (_≡_; refl)\ + \\n" + <> unlines imports + <> "\n" + <> "\n\ + \\nasts : List (SimplifierTag × Untyped × Untyped)\ + \\nasts = " + <> agdaTrace + <> "\n\ + \\ncertificate : passed? (runCertifier asts) ≡ true\ + \\ncertificate = refl\ + \\n" data AgdaCertificateProject = AgdaCertificateProject { mainModule :: (FilePath, String) , astModules :: [(FilePath, String)] , projectDir :: FilePath - , agdalib :: (FilePath, String) + , agdalib :: (FilePath, String) } mkAgdaLib :: String -> (FilePath, String) mkAgdaLib name = let contents = - "name: " <> name <> - "\ndepend:\ - \\n standard-library-2.1.1\ - \\n plutus-metatheory\ - \\ninclude: src" + "name: " + <> name + <> "\ndepend:\ + \\n standard-library-2.1.1\ + \\n plutus-metatheory\ + \\ninclude: src" in (name <> ".agda-lib", contents) -mkAgdaCertificateProject - :: Certificate - -> AgdaCertificateProject +mkAgdaCertificateProject :: + Certificate -> + AgdaCertificateProject mkAgdaCertificateProject cert = let name = certName cert mainModule = mkCertificateFile cert astModules = fmap mkAgdaAstFile (certReprAsts cert) projectDir = name agdalib = mkAgdaLib name - in AgdaCertificateProject { mainModule, astModules, projectDir, agdalib } + in AgdaCertificateProject {mainModule, astModules, projectDir, agdalib} -writeCertificateProject - :: AgdaCertificateProject - -> Certifier CertDir +writeCertificateProject :: + AgdaCertificateProject -> + Certifier CertDir writeCertificateProject AgdaCertificateProject - { mainModule, astModules, projectDir, agdalib } - = liftIO $ do + { mainModule + , astModules + , projectDir + , agdalib + } = + liftIO $ do let (mainModulePath, mainModuleContents) = mainModule (agdalibPath, agdalibContents) = agdalib time <- systemNanoseconds <$> getSystemTime @@ -318,6 +339,9 @@ writeCertificateProject createDirectory (actualProjectDir "src") writeFile (actualProjectDir "src" mainModulePath) mainModuleContents writeFile (actualProjectDir agdalibPath) agdalibContents - mapM_ (\(path, contents) -> - writeFile (actualProjectDir "src" path) contents) astModules + mapM_ + ( \(path, contents) -> + writeFile (actualProjectDir "src" path) contents + ) + astModules pure actualProjectDir diff --git a/plutus-metatheory/src/FFI/AgdaUnparse.hs b/plutus-metatheory/src/FFI/AgdaUnparse.hs index 9e31e24acd8..7966655a50a 100644 --- a/plutus-metatheory/src/FFI/AgdaUnparse.hs +++ b/plutus-metatheory/src/FFI/AgdaUnparse.hs @@ -38,21 +38,25 @@ instance AgdaUnparse AgdaFFI.UTerm where AgdaFFI.UBuiltin fun -> "(UBuiltin " ++ agdaUnparse fun ++ ")" AgdaFFI.UDelay term -> "(UDelay " ++ agdaUnparse term ++ ")" AgdaFFI.UForce term -> "(UForce " ++ agdaUnparse term ++ ")" - AgdaFFI.UConstr i terms -> "(UConstr " ++ agdaUnparse (fromInteger i :: Natural) - ++ " " ++ agdaUnparse terms ++ ")" + AgdaFFI.UConstr i terms -> + "(UConstr " + ++ agdaUnparse (fromInteger i :: Natural) + ++ " " + ++ agdaUnparse terms + ++ ")" AgdaFFI.UCase term cases -> "(UCase " ++ agdaUnparse term ++ " " ++ agdaUnparse cases ++ ")" instance AgdaUnparse UPLC.DefaultFun where agdaUnparse = usToHyphen . lowerInitialChar . show instance AgdaUnparse SimplifierStage where - agdaUnparse FloatDelay = "floatDelayT" - agdaUnparse ForceDelay = "forceDelayT" + agdaUnparse FloatDelay = "floatDelayT" + agdaUnparse ForceDelay = "forceDelayT" agdaUnparse ForceCaseDelay = "forceCaseDelayT" - agdaUnparse CaseOfCase = "caseOfCaseT" - agdaUnparse CaseReduce = "caseReduceT" - agdaUnparse Inline = "inlineT" - agdaUnparse CSE = "cseT" + agdaUnparse CaseOfCase = "caseOfCaseT" + agdaUnparse CaseReduce = "caseReduceT" + agdaUnparse Inline = "inlineT" + agdaUnparse CSE = "cseT" instance AgdaUnparse Natural where agdaUnparse = show @@ -60,11 +64,11 @@ instance AgdaUnparse Natural where instance AgdaUnparse Integer where agdaUnparse x = case (x < 0) of - True -> "(ℤ.negsuc " ++ show (x - 1) ++ ")" - False -> "(ℤ.pos " ++ show x ++ ")" + True -> "(ℤ.negsuc " ++ show (x - 1) ++ ")" + False -> "(ℤ.pos " ++ show x ++ ")" instance AgdaUnparse Bool where - agdaUnparse True = "true" + agdaUnparse True = "true" agdaUnparse False = "false" instance AgdaUnparse Char where @@ -78,7 +82,7 @@ instance AgdaUnparse ByteString where instance AgdaUnparse () where agdaUnparse _ = "tt" -agdaUnfold :: (AgdaUnparse a , Foldable f) => f a -> String +agdaUnfold :: (AgdaUnparse a, Foldable f) => f a -> String agdaUnfold l = "(" ++ foldr (\x xs -> agdaUnparse x ++ " ∷ " ++ xs) "[]" l ++ ")" instance AgdaUnparse a => AgdaUnparse [a] where @@ -87,7 +91,7 @@ instance AgdaUnparse a => AgdaUnparse [a] where instance (AgdaUnparse a, AgdaUnparse b) => AgdaUnparse (a, b) where agdaUnparse (x, y) = "(" ++ agdaUnparse x ++ " , " ++ agdaUnparse y ++ ")" -instance (AgdaUnparse a) => AgdaUnparse (Vector a) where +instance AgdaUnparse a => AgdaUnparse (Vector a) where agdaUnparse v = "(mkArray (" ++ agdaUnfold v ++ "))" instance AgdaUnparse Data where @@ -136,8 +140,8 @@ instance AgdaUnparse (UPLC.DefaultUni (PLC.Esc a)) where instance AgdaUnparse (PLC.Some (PLC.ValueOf UPLC.DefaultUni)) where agdaUnparse (PLC.Some valOf) = - "(tagCon " ++ - case valOf of + "(tagCon " + ++ case valOf of PLC.ValueOf PLC.DefaultUniInteger val -> "integer " ++ agdaUnparse val PLC.ValueOf PLC.DefaultUniByteString val -> @@ -154,32 +158,29 @@ instance AgdaUnparse (PLC.Some (PLC.ValueOf UPLC.DefaultUni)) where "value " ++ agdaUnparse val PLC.ValueOf univ@(PLC.DefaultUniList elemType) val -> agdaUnparse univ - ++ " " - ++ - ( PLC.bring (Proxy @AgdaUnparse) elemType - $ agdaUnparse val - ) + ++ " " + ++ ( PLC.bring (Proxy @AgdaUnparse) elemType $ + agdaUnparse val + ) PLC.ValueOf univ@(PLC.DefaultUniPair type1 type2) val -> agdaUnparse univ - ++ " " - ++ - ( PLC.bring (Proxy @AgdaUnparse) type1 - $ PLC.bring (Proxy @AgdaUnparse) type2 - $ agdaUnparse val - ) + ++ " " + ++ ( PLC.bring (Proxy @AgdaUnparse) type1 $ + PLC.bring (Proxy @AgdaUnparse) type2 $ + agdaUnparse val + ) PLC.ValueOf PLC.DefaultUniBLS12_381_G1_Element val -> - "bls12-381-g1-element " ++ agdaUnparse val + "bls12-381-g1-element " ++ agdaUnparse val PLC.ValueOf PLC.DefaultUniBLS12_381_G2_Element val -> - "bls12-381-g2-element " ++ agdaUnparse val + "bls12-381-g2-element " ++ agdaUnparse val PLC.ValueOf PLC.DefaultUniBLS12_381_MlResult val -> "bls12-381-mlresult " ++ agdaUnparse val - PLC.ValueOf univ@(PLC.DefaultUniArray elemType) val -> + PLC.ValueOf univ@(PLC.DefaultUniArray elemType) val -> agdaUnparse univ - ++ " " - ++ - ( PLC.bring (Proxy @AgdaUnparse) elemType - $ agdaUnparse val - ) + ++ " " + ++ ( PLC.bring (Proxy @AgdaUnparse) elemType $ + agdaUnparse val + ) PLC.ValueOf (PLC.DefaultUniApply _ _) _ -> error "Application of an unknown type is not supported." - ++ ")" + ++ ")" diff --git a/plutus-metatheory/src/FFI/Opts.hs b/plutus-metatheory/src/FFI/Opts.hs index cbfa7197237..122b865933c 100644 --- a/plutus-metatheory/src/FFI/Opts.hs +++ b/plutus-metatheory/src/FFI/Opts.hs @@ -14,27 +14,34 @@ import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekMachineCosts import PlutusCore.Evaluation.Machine.SimpleBuiltinCostModel import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts) - -- the different budget modes of plc-agda -data BudgetMode a = Silent - | Counting a - | Tallying a - deriving Functor +data BudgetMode a + = Silent + | Counting a + | Tallying a + deriving (Functor) countingbudget :: Parser (BudgetMode ()) -countingbudget = flag' (Counting ()) - ( long "counting" - <> short 'c' - <> help "Run machine in counting mode and report results" ) +countingbudget = + flag' + (Counting ()) + ( long "counting" + <> short 'c' + <> help "Run machine in counting mode and report results" + ) tallyingbudget :: Parser (BudgetMode ()) -tallyingbudget = flag' (Tallying ()) - ( long "tallying" - <> short 't' - <> help "Run machine in tallying mode and report results" ) +tallyingbudget = + flag' + (Tallying ()) + ( long "tallying" + <> short 't' + <> help "Run machine in tallying mode and report results" + ) budgetmode :: Parser (BudgetMode ()) -budgetmode = asum +budgetmode = + asum [ countingbudget , tallyingbudget , pure Silent @@ -44,16 +51,19 @@ budgetmode = asum data EvalMode = U | TL | TCK | TCEK deriving stock (Show, Read) data EvalOptions a = EvalOpts Input Format EvalMode (BudgetMode a) - deriving Functor + deriving (Functor) evalMode :: Parser EvalMode -evalMode = option auto - ( long "mode" - <> short 'm' - <> metavar "MODE" - <> value TL - <> showDefault - <> help "Evaluation mode (U , TL, TCK, TCEK)" ) +evalMode = + option + auto + ( long "mode" + <> short 'm' + <> metavar "MODE" + <> value TL + <> showDefault + <> help "Evaluation mode (U , TL, TCK, TCEK)" + ) evalOpts :: Parser (EvalOptions ()) evalOpts = EvalOpts <$> input <*> inputformat <*> evalMode <*> budgetmode @@ -63,33 +73,43 @@ data TypecheckOptions = TCOpts Input Format typecheckOpts :: Parser TypecheckOptions typecheckOpts = TCOpts <$> input <*> inputformat -data Command a = Eval (EvalOptions a) - | Typecheck TypecheckOptions - deriving Functor +data Command a + = Eval (EvalOptions a) + | Typecheck TypecheckOptions + deriving (Functor) commands :: Parser (Command ()) -commands = hsubparser ( - command "evaluate" - (info (Eval <$> evalOpts) - (fullDesc <> progDesc "run a Plutus Core program")) - <> command "typecheck" - (info (Typecheck <$> typecheckOpts) - (fullDesc <> progDesc "typecheck a Plutus Core program"))) +commands = + hsubparser + ( command + "evaluate" + ( info + (Eval <$> evalOpts) + (fullDesc <> progDesc "run a Plutus Core program") + ) + <> command + "typecheck" + ( info + (Typecheck <$> typecheckOpts) + (fullDesc <> progDesc "typecheck a Plutus Core program") + ) + ) -- A CostModel has all the information to run the Agda machine -- with cost reporting -type CostModel = (CekMachineCosts , BuiltinCostMap) +type CostModel = (CekMachineCosts, BuiltinCostMap) addJSONParameters :: Command a -> Command CostModel addJSONParameters = fmap (const (defaultCekMachineCostsForTesting, defaultSimpleBuiltinCostModel)) execP :: IO (Command CostModel) -execP = addJSONParameters <$> execParser (info (commands <**> helper) - (fullDesc - <> progDesc "Plutus Core tool" - <> header "plc-agda - a Plutus Core implementation written in Agda")) - - - - - +execP = + addJSONParameters + <$> execParser + ( info + (commands <**> helper) + ( fullDesc + <> progDesc "Plutus Core tool" + <> header "plc-agda - a Plutus Core implementation written in Agda" + ) + ) diff --git a/plutus-metatheory/src/FFI/SimplifierTrace.hs b/plutus-metatheory/src/FFI/SimplifierTrace.hs index ef825c51af3..3705b716f0b 100644 --- a/plutus-metatheory/src/FFI/SimplifierTrace.hs +++ b/plutus-metatheory/src/FFI/SimplifierTrace.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wall #-} module FFI.SimplifierTrace ( - mkFfiSimplifierTrace, + mkFfiSimplifierTrace, ) where import FFI.Untyped qualified as FFI @@ -11,14 +11,14 @@ import PlutusPrelude import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Transform.Simplifier -mkFfiSimplifierTrace - :: SimplifierTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a - -> [(SimplifierStage, (FFI.UTerm, FFI.UTerm))] +mkFfiSimplifierTrace :: + SimplifierTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a -> + [(SimplifierStage, (FFI.UTerm, FFI.UTerm))] mkFfiSimplifierTrace (SimplifierTrace simplTrace) = reverse $ toFfiAst <$> simplTrace where toFfiAst Simplification {beforeAST, stage, afterAST} = case (UPLC.deBruijnTerm beforeAST, UPLC.deBruijnTerm afterAST) of - (Right before', Right after') -> + (Right before', Right after') -> (stage, (FFI.conv (void before'), FFI.conv (void after'))) (Left (err :: UPLC.FreeVariableError), _) -> error $ show err (_, Left (err :: UPLC.FreeVariableError)) -> error $ show err diff --git a/plutus-metatheory/src/FFI/Untyped.hs b/plutus-metatheory/src/FFI/Untyped.hs index f4f650d1191..96ad601fb3e 100644 --- a/plutus-metatheory/src/FFI/Untyped.hs +++ b/plutus-metatheory/src/FFI/Untyped.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -Wall #-} @@ -12,17 +12,18 @@ import GHC.Exts (IsList (..)) -- Untyped (Raw) syntax -data UTerm = UVar Integer - | ULambda UTerm - | UApp UTerm UTerm - | UCon (Some (ValueOf DefaultUni)) - | UError - | UBuiltin DefaultFun - | UDelay UTerm - | UForce UTerm - | UConstr Integer [UTerm] - | UCase UTerm [UTerm] - deriving (Eq, Show) +data UTerm + = UVar Integer + | ULambda UTerm + | UApp UTerm UTerm + | UCon (Some (ValueOf DefaultUni)) + | UError + | UBuiltin DefaultFun + | UDelay UTerm + | UForce UTerm + | UConstr Integer [UTerm] + | UCase UTerm [UTerm] + deriving (Eq, Show) unIndex :: Index -> Integer unIndex (Index n) = toInteger n @@ -31,36 +32,39 @@ convP :: Program NamedDeBruijn DefaultUni DefaultFun a -> UTerm convP (Program _ _ t) = conv t conv :: Term NamedDeBruijn DefaultUni DefaultFun a -> UTerm -conv (Var _ x) = UVar (unIndex (ndbnIndex x) - 1) -conv (LamAbs _ _ t) = ULambda (conv t) -conv (Apply _ t u) = UApp (conv t) (conv u) -conv (Builtin _ b) = UBuiltin b -conv (Constant _ c) = UCon c -conv (Error _) = UError -conv (Delay _ t) = UDelay (conv t) -conv (Force _ t) = UForce (conv t) +conv (Var _ x) = UVar (unIndex (ndbnIndex x) - 1) +conv (LamAbs _ _ t) = ULambda (conv t) +conv (Apply _ t u) = UApp (conv t) (conv u) +conv (Builtin _ b) = UBuiltin b +conv (Constant _ c) = UCon c +conv (Error _) = UError +conv (Delay _ t) = UDelay (conv t) +conv (Force _ t) = UForce (conv t) conv (Constr _ i es) = UConstr (toInteger i) (toList (fmap conv es)) conv (Case _ arg cs) = UCase (conv arg) (toList (fmap conv cs)) tmnames :: String tmnames = ['a' .. 'z'] -uconv :: Int -> UTerm -> Term NamedDeBruijn DefaultUni DefaultFun () -uconv i (UVar x) = Var - () - (NamedDeBruijn (T.pack [tmnames !! (i - 1 - fromInteger x)]) - -- PLC's debruijn starts counting from 1, while in the metatheory it starts from 0. - (Index (fromInteger x + 1))) -uconv i (ULambda t) = LamAbs - () - (NamedDeBruijn (T.pack [tmnames !! i]) deBruijnInitIndex) - (uconv (i+1) t) -uconv i (UApp t u) = Apply () (uconv i t) (uconv i u) -uconv _ (UCon c) = Constant () c -uconv _ UError = Error () -uconv _ (UBuiltin b) = Builtin () b -uconv i (UDelay t) = Delay () (uconv i t) -uconv i (UForce t) = Force () (uconv i t) +uconv :: Int -> UTerm -> Term NamedDeBruijn DefaultUni DefaultFun () +uconv i (UVar x) = + Var + () + ( NamedDeBruijn + (T.pack [tmnames !! (i - 1 - fromInteger x)]) + -- PLC's debruijn starts counting from 1, while in the metatheory it starts from 0. + (Index (fromInteger x + 1)) + ) +uconv i (ULambda t) = + LamAbs + () + (NamedDeBruijn (T.pack [tmnames !! i]) deBruijnInitIndex) + (uconv (i + 1) t) +uconv i (UApp t u) = Apply () (uconv i t) (uconv i u) +uconv _ (UCon c) = Constant () c +uconv _ UError = Error () +uconv _ (UBuiltin b) = Builtin () b +uconv i (UDelay t) = Delay () (uconv i t) +uconv i (UForce t) = Force () (uconv i t) uconv i (UConstr j xs) = Constr () (fromInteger j) (fmap (uconv i) xs) -uconv i (UCase t xs) = Case () (uconv i t) (fromList (fmap (uconv i) xs)) - +uconv i (UCase t xs) = Case () (uconv i t) (fromList (fmap (uconv i) xs)) diff --git a/plutus-metatheory/src/Raw.hs b/plutus-metatheory/src/Raw.hs index 3fba88ec7fd..62677f9192c 100644 --- a/plutus-metatheory/src/Raw.hs +++ b/plutus-metatheory/src/Raw.hs @@ -1,10 +1,10 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall #-} -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1796) {-# OPTIONS_GHC -Wno-incomplete-patterns #-} @@ -18,49 +18,52 @@ import PlutusCore.DeBruijn import PlutusCore.Error (ParserErrorBundle) data KIND = Star | Sharp | Arrow KIND KIND - deriving Show - -data RType = RTyVar Integer - | RTyFun RType RType - | RTyPi KIND RType - | RTyLambda KIND RType - | RTyApp RType RType - | RTyCon RTyCon - | RTyMu RType RType - | RTySOP [[RType]] - deriving Show - -data AtomicTyCon = ATyConInt - | ATyConBS - | ATyConStr - | ATyConUnit - | ATyConBool - | ATyConData - | ATyConBLS12_381_G1_Element - | ATyConBLS12_381_G2_Element - | ATyConBLS12_381_MlResult - deriving Show - -data RTyCon = RTyConAtom AtomicTyCon - | RTyConList - | RTyConArray - | RTyConPair - deriving Show - - -data RTerm = RVar Integer - | RTLambda KIND RTerm - | RTApp RTerm RType - | RLambda RType RTerm - | RApp RTerm RTerm - | RCon (Some (ValueOf DefaultUni)) - | RError RType - | RBuiltin DefaultFun - | RWrap RType RType RTerm - | RUnWrap RTerm - | RConstr RType Integer [RTerm] - | RCase RType RTerm [RTerm] - deriving Show + deriving (Show) + +data RType + = RTyVar Integer + | RTyFun RType RType + | RTyPi KIND RType + | RTyLambda KIND RType + | RTyApp RType RType + | RTyCon RTyCon + | RTyMu RType RType + | RTySOP [[RType]] + deriving (Show) + +data AtomicTyCon + = ATyConInt + | ATyConBS + | ATyConStr + | ATyConUnit + | ATyConBool + | ATyConData + | ATyConBLS12_381_G1_Element + | ATyConBLS12_381_G2_Element + | ATyConBLS12_381_MlResult + deriving (Show) + +data RTyCon + = RTyConAtom AtomicTyCon + | RTyConList + | RTyConArray + | RTyConPair + deriving (Show) + +data RTerm + = RVar Integer + | RTLambda KIND RTerm + | RTApp RTerm RType + | RLambda RType RTerm + | RApp RTerm RTerm + | RCon (Some (ValueOf DefaultUni)) + | RError RType + | RBuiltin DefaultFun + | RWrap RType RType RTerm + | RUnWrap RTerm + | RConstr RType Integer [RTerm] + | RCase RType RTerm [RTerm] + deriving (Show) unIndex :: Index -> Integer unIndex (Index n) = toInteger n @@ -69,50 +72,51 @@ convP :: Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun a -> RTerm convP (Program _ _ t) = conv t convK :: Kind a -> KIND -convK (Type _) = Star +convK (Type _) = Star convK (KindArrow _ k k') = Arrow (convK k) (convK k') convT :: Type NamedTyDeBruijn DefaultUni a -> RType convT (TyVar _ (NamedTyDeBruijn x)) = RTyVar (unIndex (ndbnIndex x)) -convT (TyFun _ _A _B) = RTyFun (convT _A) (convT _B) -convT (TyForall _ _ _K _A) = RTyPi (convK _K) (convT _A) -convT (TyLam _ _ _K _A) = RTyLambda (convK _K) (convT _A) -convT (TyApp _ _A _B) = RTyApp (convT _A) (convT _B) +convT (TyFun _ _A _B) = RTyFun (convT _A) (convT _B) +convT (TyForall _ _ _K _A) = RTyPi (convK _K) (convT _A) +convT (TyLam _ _ _K _A) = RTyLambda (convK _K) (convT _A) +convT (TyApp _ _A _B) = RTyApp (convT _A) (convT _B) convT (TyBuiltin ann (SomeTypeIn (DefaultUniApply f x))) = - RTyApp (convT (TyBuiltin ann (SomeTypeIn f))) - (convT (TyBuiltin ann (SomeTypeIn x))) -convT (TyBuiltin _ someUni) = convTyCon someUni -convT (TyIFix _ a b) = RTyMu (convT a) (convT b) -convT (TySOP _ xss) = RTySOP (map (map convT) xss) + RTyApp + (convT (TyBuiltin ann (SomeTypeIn f))) + (convT (TyBuiltin ann (SomeTypeIn x))) +convT (TyBuiltin _ someUni) = convTyCon someUni +convT (TyIFix _ a b) = RTyMu (convT a) (convT b) +convT (TySOP _ xss) = RTySOP (map (map convT) xss) convTyCon :: SomeTypeIn DefaultUni -> RType -convTyCon (SomeTypeIn DefaultUniInteger) = RTyCon (RTyConAtom ATyConInt) -convTyCon (SomeTypeIn DefaultUniByteString) = RTyCon (RTyConAtom ATyConBS) -convTyCon (SomeTypeIn DefaultUniString) = RTyCon (RTyConAtom ATyConStr) -convTyCon (SomeTypeIn DefaultUniBool) = RTyCon (RTyConAtom ATyConBool) -convTyCon (SomeTypeIn DefaultUniUnit) = RTyCon (RTyConAtom ATyConUnit) -convTyCon (SomeTypeIn DefaultUniData) = RTyCon (RTyConAtom ATyConData) +convTyCon (SomeTypeIn DefaultUniInteger) = RTyCon (RTyConAtom ATyConInt) +convTyCon (SomeTypeIn DefaultUniByteString) = RTyCon (RTyConAtom ATyConBS) +convTyCon (SomeTypeIn DefaultUniString) = RTyCon (RTyConAtom ATyConStr) +convTyCon (SomeTypeIn DefaultUniBool) = RTyCon (RTyConAtom ATyConBool) +convTyCon (SomeTypeIn DefaultUniUnit) = RTyCon (RTyConAtom ATyConUnit) +convTyCon (SomeTypeIn DefaultUniData) = RTyCon (RTyConAtom ATyConData) convTyCon (SomeTypeIn DefaultUniBLS12_381_G1_Element) = RTyCon (RTyConAtom ATyConBLS12_381_G1_Element) convTyCon (SomeTypeIn DefaultUniBLS12_381_G2_Element) = RTyCon (RTyConAtom ATyConBLS12_381_G2_Element) -convTyCon (SomeTypeIn DefaultUniBLS12_381_MlResult) = RTyCon (RTyConAtom ATyConBLS12_381_MlResult) -convTyCon (SomeTypeIn DefaultUniProtoList) = RTyCon RTyConList -convTyCon (SomeTypeIn DefaultUniProtoArray) = RTyCon RTyConArray -convTyCon (SomeTypeIn DefaultUniProtoPair) = RTyCon RTyConPair -convTyCon (SomeTypeIn (DefaultUniApply _ _)) = error "unsupported builtin type application" +convTyCon (SomeTypeIn DefaultUniBLS12_381_MlResult) = RTyCon (RTyConAtom ATyConBLS12_381_MlResult) +convTyCon (SomeTypeIn DefaultUniProtoList) = RTyCon RTyConList +convTyCon (SomeTypeIn DefaultUniProtoArray) = RTyCon RTyConArray +convTyCon (SomeTypeIn DefaultUniProtoPair) = RTyCon RTyConPair +convTyCon (SomeTypeIn (DefaultUniApply _ _)) = error "unsupported builtin type application" conv :: Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun a -> RTerm -conv (Var _ x) = RVar (unIndex (ndbnIndex x)) -conv (TyAbs _ _ _K t) = RTLambda (convK _K) (conv t) -conv (TyInst _ t _A) = RTApp (conv t) (convT _A) -conv (LamAbs _ _ _A t) = RLambda (convT _A) (conv t) -conv (Apply _ t u) = RApp (conv t) (conv u) -conv (Builtin _ b) = RBuiltin b -conv (Constant _ c) = RCon c -conv (Unwrap _ t) = RUnWrap (conv t) +conv (Var _ x) = RVar (unIndex (ndbnIndex x)) +conv (TyAbs _ _ _K t) = RTLambda (convK _K) (conv t) +conv (TyInst _ t _A) = RTApp (conv t) (convT _A) +conv (LamAbs _ _ _A t) = RLambda (convT _A) (conv t) +conv (Apply _ t u) = RApp (conv t) (conv u) +conv (Builtin _ b) = RBuiltin b +conv (Constant _ c) = RCon c +conv (Unwrap _ t) = RUnWrap (conv t) conv (IWrap _ ty1 ty2 t) = RWrap (convT ty1) (convT ty2) (conv t) -conv (Error _ _A) = RError (convT _A) -conv (Constr _ _A i cs) = RConstr (convT _A) (toInteger i) (fmap conv cs) -conv (Case _ _A arg cs) = RCase (convT _A) (conv arg) (fmap conv cs) +conv (Error _ _A) = RError (convT _A) +conv (Constr _ _A i cs) = RConstr (convT _A) (toInteger i) (fmap conv cs) +conv (Case _ _A arg cs) = RCase (convT _A) (conv arg) (fmap conv cs) varTm :: Int -> NamedDeBruijn varTm i = NamedDeBruijn (T.pack [tmnames !! i]) deBruijnInitIndex @@ -122,69 +126,68 @@ varTy i = NamedDeBruijn (T.pack [tynames !! i]) deBruijnInitIndex unconvK :: KIND -> Kind () unconvK (Arrow k k') = KindArrow () (unconvK k) (unconvK k') -unconvK _ = Type () +unconvK _ = Type () -- this should take a level and render levels as names unconvT :: Int -> RType -> Type NamedTyDeBruijn DefaultUni () -unconvT i (RTyVar x) = +unconvT i (RTyVar x) = TyVar () (NamedTyDeBruijn (NamedDeBruijn (T.pack [tynames !! (i - fromIntegral x)]) (Index (fromInteger x)))) -unconvT i (RTyFun t u) = TyFun () (unconvT i t) (unconvT i u) -unconvT i (RTyPi k t) = - TyForall () (NamedTyDeBruijn (varTy i)) (unconvK k) (unconvT (i+1) t) -unconvT i (RTyLambda k t) = TyLam () (NamedTyDeBruijn (varTy i)) (unconvK k) (unconvT (i+1) t) - -unconvT i (RTyApp t u) = TyApp () (unconvT i t) (unconvT i u) -unconvT _ (RTyCon c) = TyBuiltin () (unconvTyCon c) -unconvT i (RTyMu t u) = TyIFix () (unconvT i t) (unconvT i u) -unconvT i (RTySOP xss) = TySOP () (map (map (unconvT i)) xss) +unconvT i (RTyFun t u) = TyFun () (unconvT i t) (unconvT i u) +unconvT i (RTyPi k t) = + TyForall () (NamedTyDeBruijn (varTy i)) (unconvK k) (unconvT (i + 1) t) +unconvT i (RTyLambda k t) = TyLam () (NamedTyDeBruijn (varTy i)) (unconvK k) (unconvT (i + 1) t) +unconvT i (RTyApp t u) = TyApp () (unconvT i t) (unconvT i u) +unconvT _ (RTyCon c) = TyBuiltin () (unconvTyCon c) +unconvT i (RTyMu t u) = TyIFix () (unconvT i t) (unconvT i u) +unconvT i (RTySOP xss) = TySOP () (map (map (unconvT i)) xss) unconvTyCon :: RTyCon -> SomeTypeIn DefaultUni -unconvTyCon (RTyConAtom ATyConInt) = SomeTypeIn DefaultUniInteger -unconvTyCon (RTyConAtom ATyConBS) = SomeTypeIn DefaultUniByteString -unconvTyCon (RTyConAtom ATyConStr) = SomeTypeIn DefaultUniString +unconvTyCon (RTyConAtom ATyConInt) = SomeTypeIn DefaultUniInteger +unconvTyCon (RTyConAtom ATyConBS) = SomeTypeIn DefaultUniByteString +unconvTyCon (RTyConAtom ATyConStr) = SomeTypeIn DefaultUniString unconvTyCon (RTyConAtom ATyConBool) = SomeTypeIn DefaultUniBool unconvTyCon (RTyConAtom ATyConUnit) = SomeTypeIn DefaultUniUnit unconvTyCon (RTyConAtom ATyConData) = SomeTypeIn DefaultUniData -unconvTyCon (RTyConAtom ATyConBLS12_381_G1_Element) - = SomeTypeIn DefaultUniBLS12_381_G1_Element -unconvTyCon (RTyConAtom ATyConBLS12_381_G2_Element) - = SomeTypeIn DefaultUniBLS12_381_G2_Element -unconvTyCon (RTyConAtom ATyConBLS12_381_MlResult) - = SomeTypeIn DefaultUniBLS12_381_MlResult -unconvTyCon RTyConList = SomeTypeIn DefaultUniProtoList -unconvTyCon RTyConArray = SomeTypeIn DefaultUniProtoArray -unconvTyCon RTyConPair = SomeTypeIn DefaultUniProtoPair - +unconvTyCon (RTyConAtom ATyConBLS12_381_G1_Element) = + SomeTypeIn DefaultUniBLS12_381_G1_Element +unconvTyCon (RTyConAtom ATyConBLS12_381_G2_Element) = + SomeTypeIn DefaultUniBLS12_381_G2_Element +unconvTyCon (RTyConAtom ATyConBLS12_381_MlResult) = + SomeTypeIn DefaultUniBLS12_381_MlResult +unconvTyCon RTyConList = SomeTypeIn DefaultUniProtoList +unconvTyCon RTyConArray = SomeTypeIn DefaultUniProtoArray +unconvTyCon RTyConPair = SomeTypeIn DefaultUniProtoPair tmnames, tynames :: String tmnames = ['a' .. 'z'] ---tynames = ['α','β','γ','δ','ε','ζ','θ','ι','κ','ν','ξ','ο','π','ρ','σ','τ','υ','ϕ','χ','ψ','ω'] +-- tynames = ['α','β','γ','δ','ε','ζ','θ','ι','κ','ν','ξ','ο','π','ρ','σ','τ','υ','ϕ','χ','ψ','ω'] tynames = ['A' .. 'Z'] unconv :: Int -> RTerm -> Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun () -unconv i (RVar x) = - Var () (NamedDeBruijn (T.pack [tmnames !! (i - fromInteger x )]) (Index (fromInteger x))) -unconv i (RTLambda k tm) = TyAbs () (NamedTyDeBruijn (varTy i)) (unconvK k) (unconv (i+1) tm) -unconv i (RTApp t ty) = TyInst () (unconv i t) (unconvT i ty) -unconv i (RLambda ty tm) = LamAbs () (varTm i) (unconvT (i+1) ty) (unconv (i+1) tm) -unconv i (RApp t u) = Apply () (unconv i t) (unconv i u) -unconv _ (RCon c) = Constant () c -unconv i (RError ty) = Error () (unconvT i ty) -unconv _ (RBuiltin b) = Builtin () b +unconv i (RVar x) = + Var () (NamedDeBruijn (T.pack [tmnames !! (i - fromInteger x)]) (Index (fromInteger x))) +unconv i (RTLambda k tm) = TyAbs () (NamedTyDeBruijn (varTy i)) (unconvK k) (unconv (i + 1) tm) +unconv i (RTApp t ty) = TyInst () (unconv i t) (unconvT i ty) +unconv i (RLambda ty tm) = LamAbs () (varTm i) (unconvT (i + 1) ty) (unconv (i + 1) tm) +unconv i (RApp t u) = Apply () (unconv i t) (unconv i u) +unconv _ (RCon c) = Constant () c +unconv i (RError ty) = Error () (unconvT i ty) +unconv _ (RBuiltin b) = Builtin () b unconv i (RWrap tyA tyB t) = IWrap () (unconvT i tyA) (unconvT i tyB) (unconv i t) -unconv i (RUnWrap t) = Unwrap () (unconv i t) +unconv i (RUnWrap t) = Unwrap () (unconv i t) unconv i (RConstr ty j cs) = Constr () (unconvT i ty) (fromInteger j) (fmap (unconv i) cs) unconv i (RCase ty arg cs) = Case () (unconvT i ty) (unconv i arg) (fmap (unconv i) cs) -- I have put this here as it needs to be a .hs file so that it can be -- imported in multiple places -data ERROR = TypeError T.Text - | ParseError ParserErrorBundle - | ScopeError ScopeError - | RuntimeError RuntimeError - | JsonError T.Text - deriving Show +data ERROR + = TypeError T.Text + | ParseError ParserErrorBundle + | ScopeError ScopeError + | RuntimeError RuntimeError + | JsonError T.Text + deriving (Show) -data ScopeError = DeBError|FreeVariableError FreeVariableError deriving Show -data RuntimeError = GasError | UserError | RuntimeTypeError deriving Show +data ScopeError = DeBError | FreeVariableError FreeVariableError deriving (Show) +data RuntimeError = GasError | UserError | RuntimeTypeError deriving (Show) diff --git a/plutus-metatheory/test/NEAT/Spec.hs b/plutus-metatheory/test/NEAT/Spec.hs index 234c336a5ab..0c3497d4f86 100644 --- a/plutus-metatheory/test/NEAT/Spec.hs +++ b/plutus-metatheory/test/NEAT/Spec.hs @@ -20,9 +20,18 @@ import Test.Tasty.HUnit import UntypedPlutusCore qualified as U import UntypedPlutusCore.Evaluation.Machine.Cek qualified as U -import MAlonzo.Code.Evaluator.Term (checkKindAgda, checkTypeAgda, inferKindAgda, inferTypeAgda, - normalizeTypeAgda, normalizeTypeTermAgda, runTCEKAgda, - runTCKAgda, runTLAgda, runUAgda) +import MAlonzo.Code.Evaluator.Term ( + checkKindAgda, + checkTypeAgda, + inferKindAgda, + inferTypeAgda, + normalizeTypeAgda, + normalizeTypeTermAgda, + runTCEKAgda, + runTCKAgda, + runTLAgda, + runUAgda, + ) import PlutusCore.DeBruijn import Raw hiding (TypeError, tynames) @@ -32,16 +41,20 @@ main :: IO () main = defaultMain allTests allTests :: TestTree -allTests = testGroup "NEAT" - [ localOption (GenDepth 12) $ - bigTest "type-level" - (Type ()) - (packAssertion prop_Type) - , localOption (GenDepth 18) $ - bigTest "term-level" - (TyBuiltinG TyUnitG) - (packAssertion prop_Term) - ] +allTests = + testGroup + "NEAT" + [ localOption (GenDepth 12) $ + bigTest + "type-level" + (Type ()) + (packAssertion prop_Type) + , localOption (GenDepth 18) $ + bigTest + "term-level" + (TyBuiltinG TyUnitG) + (packAssertion prop_Term) + ] -- one type-level test to rule them all prop_Type :: Kind () -> ClosedTypeG -> ExceptT TestFail Quote () @@ -54,11 +67,14 @@ prop_Type k tyG = do tyDB <- withExceptT FVErrorP $ deBruijnTy ty -- 1. check soundness of Agda kindchecker with respect to NEAT: - withExceptT (const $ Ctrex (CtrexKindCheckFail k tyG)) $ liftEither $ - checkKindAgda tyDB (convK k) + withExceptT (const $ Ctrex (CtrexKindCheckFail k tyG)) $ + liftEither $ + checkKindAgda tyDB (convK k) -- infer kind using Agda kind inferer: - k1a <- withExceptT (const $ Ctrex (CtrexKindCheckFail k tyG)) $ - liftEither $ inferKindAgda tyDB + k1a <- + withExceptT (const $ Ctrex (CtrexKindCheckFail k tyG)) $ + liftEither $ + inferKindAgda tyDB let k1 = unconvK k1a -- infer kind using production kind inferer: k2 <- withExceptT TypeError $ inferKind defKindCheckConfig ty @@ -67,14 +83,16 @@ prop_Type k tyG = do unless (k1 == k2) $ throwCtrex (CtrexKindMismatch k tyG k1 k2) - -- normalize type using Agda type normalizer: - ty' <- withExceptT (const $ Ctrex (CtrexTypeNormalizationFail k tyG)) $ - liftEither $ normalizeTypeAgda tyDB + ty' <- + withExceptT (const $ Ctrex (CtrexTypeNormalizationFail k tyG)) $ + liftEither $ + normalizeTypeAgda tyDB -- 3. check that the Agda type normalizer doesn't mange the kind: withExceptT (const $ Ctrex (CtrexKindPreservationFail k tyG)) $ - liftEither $ checkKindAgda ty' (convK k) + liftEither $ + checkKindAgda ty' (convK k) -- convert Agda normalized type back to named notation: ty1 <- withExceptT FVErrorP $ unDeBruijnTy ty' @@ -85,8 +103,6 @@ prop_Type k tyG = do unless (ty1 == ty2) $ throwCtrex (CtrexNormalizeConvertCommuteTypes k tyG ty1 ty2) - - -- one term-level test to rule them all prop_Term :: ClosedTypeG -> ClosedTermG -> ExceptT TestFail Quote () prop_Term tyG tmG = do @@ -100,26 +116,33 @@ prop_Term tyG tmG = do tmDB <- withExceptT FVErrorP $ deBruijnTerm tm -- 1. check the term in the type - withExceptT (const $ Ctrex (CtrexTypeCheckFail tyG tmG)) $ liftEither $ - checkTypeAgda tyDB tmDB + withExceptT (const $ Ctrex (CtrexTypeCheckFail tyG tmG)) $ + liftEither $ + checkTypeAgda tyDB tmDB -- 2. run production CK against metatheory CK - tmPlcCK <- withExceptT CkP $ liftEither $ - evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def tm `catchError` handleError ty - tmCK <- withExceptT (const $ Ctrex (CtrexTermEvaluationFail "0" tyG tmG)) $ - liftEither $ runTCKAgda tmDB + tmPlcCK <- + withExceptT CkP $ + liftEither $ + evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def tm `catchError` handleError ty + tmCK <- + withExceptT (const $ Ctrex (CtrexTermEvaluationFail "0" tyG tmG)) $ + liftEither $ + runTCKAgda tmDB tmCKN <- withExceptT FVErrorP $ unDeBruijnTerm tmCK unless (tmPlcCK == tmCKN) $ - throwCtrex (CtrexTermEvaluationMismatch tyG tmG [("prod CK",tmPlcCK),("meta CK",tmCKN)]) + throwCtrex (CtrexTermEvaluationMismatch tyG tmG [("prod CK", tmPlcCK), ("meta CK", tmCKN)]) -- 3. run all the metatheory evaluators against each other. Taking -- care to normalize the types in the output of runCKAgda. The other -- versions return terms with already normalized types. - let namedEvs = [("meta red",runTLAgda),("meta CK",runTCKAgda),("meta CEK",runTCEKAgda)] - let (ss,evs) = unzip namedEvs + let namedEvs = [("meta red", runTLAgda), ("meta CK", runTCKAgda), ("meta CEK", runTCEKAgda)] + let (ss, evs) = unzip namedEvs let tmEvsM = map ($ tmDB) evs - tmEvs <- withExceptT (const $ Ctrex (CtrexTermEvaluationFail "typed" tyG tmG)) $ - liftEither $ sequence tmEvsM + tmEvs <- + withExceptT (const $ Ctrex (CtrexTermEvaluationFail "typed" tyG tmG)) $ + liftEither $ + sequence tmEvsM tmEvsN <- withExceptT FVErrorP $ traverse unDeBruijnTerm tmEvs unless (length (nub tmEvsN) == 1) $ throwCtrex (CtrexTermEvaluationMismatch tyG tmG (zip ss tmEvsN)) @@ -131,23 +154,29 @@ prop_Term tyG tmG = do tmUDB <- withExceptT FVErrorP $ U.deBruijnTerm tmU -- reduce the untyped term tmUDB' <- case runUAgda tmUDB of - Left (RuntimeError UserError) -> pure $ U.Error () - _ -> withExceptT (\e -> Ctrex (CtrexTermEvaluationFail "untyped CEK" tyG tmG)) - $ liftEither $ runUAgda tmUDB + Left (RuntimeError UserError) -> pure $ U.Error () + _ -> + withExceptT (\e -> Ctrex (CtrexTermEvaluationFail "untyped CEK" tyG tmG)) $ + liftEither $ + runUAgda tmUDB -- turn it back into a named term tmU' <- withExceptT FVErrorP $ U.unDeBruijnTerm tmUDB' -- reduce the original de Bruijn typed term - tmDB'' <- withExceptT (\e -> Ctrex (CtrexTermEvaluationFail "typed CEK" tyG tmG)) $ - liftEither $ runTCEKAgda tmDB + tmDB'' <- + withExceptT (\e -> Ctrex (CtrexTermEvaluationFail "typed CEK" tyG tmG)) $ + liftEither $ + runTCEKAgda tmDB -- turn it back into a named term tm'' <- withExceptT FVErrorP $ unDeBruijnTerm tmDB'' -- erase it after the fact let tmU'' = eraseTerm tm'' unless (tmU' == tmU'') $ - throwCtrex (CtrexUntypedTermEvaluationMismatch tyG tmG [("erase;reduce" , tmU'),("reduce;erase" , tmU'')]) + throwCtrex (CtrexUntypedTermEvaluationMismatch tyG tmG [("erase;reduce", tmU'), ("reduce;erase", tmU'')]) -- 4. run prod untyped CEK against meta untyped CEK - tmU''' <- withExceptT UCekP $ liftEither $ - U.evaluateCekNoEmit defaultCekParametersForTesting tmU'' `catchError` handleUError + tmU''' <- + withExceptT UCekP $ + liftEither $ + U.evaluateCekNoEmit defaultCekParametersForTesting tmU'' `catchError` handleUError unless (tmU' == tmU''') $ - throwCtrex (CtrexUntypedTermEvaluationMismatch tyG tmG [("meta U" , tmU'),("prod U" , tmU'')]) + throwCtrex (CtrexUntypedTermEvaluationMismatch tyG tmG [("meta U", tmU'), ("prod U", tmU'')]) diff --git a/plutus-metatheory/test/certifier/Spec.hs b/plutus-metatheory/test/certifier/Spec.hs index edd0d5f82dd..8d8845e59ac 100644 --- a/plutus-metatheory/test/certifier/Spec.hs +++ b/plutus-metatheory/test/certifier/Spec.hs @@ -11,8 +11,9 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain $ - testGroup "Certification" - [ optimizerTests - , astTests - , forceDelayASTTests - ] + testGroup + "Certification" + [ optimizerTests + , astTests + , forceDelayASTTests + ] diff --git a/plutus-metatheory/test/certifier/Test/Certifier/AST.hs b/plutus-metatheory/test/certifier/Test/Certifier/AST.hs index cefdbd8433b..823f562bc5a 100644 --- a/plutus-metatheory/test/certifier/Test/Certifier/AST.hs +++ b/plutus-metatheory/test/certifier/Test/Certifier/AST.hs @@ -11,11 +11,11 @@ import Data.Text.Encoding qualified as Text import Test.Tasty import Test.Tasty.HUnit -mkMockTracePair - :: SimplifierStage - -> Term Name DefaultUni DefaultFun () - -> Term Name DefaultUni DefaultFun () - -> SimplifierTrace Name DefaultUni DefaultFun () +mkMockTracePair :: + SimplifierStage -> + Term Name DefaultUni DefaultFun () -> + Term Name DefaultUni DefaultFun () -> + SimplifierTrace Name DefaultUni DefaultFun () mkMockTracePair stage before' after' = SimplifierTrace { simplifierTrace = @@ -27,9 +27,9 @@ mkMockTracePair stage before' after' = ] } -runCertifierWithMockTrace - :: SimplifierTrace Name DefaultUni DefaultFun () - -> IO Bool +runCertifierWithMockTrace :: + SimplifierTrace Name DefaultUni DefaultFun () -> + IO Bool runCertifierWithMockTrace trace = do let rawAgdaTrace = mkFfiSimplifierTrace trace case runCertifierMain rawAgdaTrace of @@ -37,12 +37,12 @@ runCertifierWithMockTrace trace = do Nothing -> assertFailure "The certifier exited with an error." -testSuccess - :: String - -> SimplifierStage - -> Term Name PLC.DefaultUni PLC.DefaultFun () - -> Term Name PLC.DefaultUni PLC.DefaultFun () - -> TestTree +testSuccess :: + String -> + SimplifierStage -> + Term Name PLC.DefaultUni PLC.DefaultFun () -> + Term Name PLC.DefaultUni PLC.DefaultFun () -> + TestTree testSuccess testName st bf af = testCase testName $ do let trace = mkMockTracePair st bf af @@ -51,12 +51,12 @@ testSuccess testName st bf af = "The certifier was expected to succeed." result -testFailure - :: String - -> SimplifierStage - -> Term Name PLC.DefaultUni PLC.DefaultFun () - -> Term Name PLC.DefaultUni PLC.DefaultFun () - -> TestTree +testFailure :: + String -> + SimplifierStage -> + Term Name PLC.DefaultUni PLC.DefaultFun () -> + Term Name PLC.DefaultUni PLC.DefaultFun () -> + TestTree testFailure testName st bf af = testCase testName $ do let trace = mkMockTracePair st bf af @@ -66,24 +66,22 @@ testFailure testName st bf af = (not result) -- Helper functions for making lists of tests. -testSuccessItem - :: - (String, - SimplifierStage, - Term Name PLC.DefaultUni PLC.DefaultFun (), - Term Name PLC.DefaultUni PLC.DefaultFun () - ) - -> TestTree +testSuccessItem :: + ( String + , SimplifierStage + , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun () + ) -> + TestTree testSuccessItem (name, stage, before, after) = testSuccess name stage before after -testFailureItem - :: - (String, - SimplifierStage, - Term Name PLC.DefaultUni PLC.DefaultFun (), - Term Name PLC.DefaultUni PLC.DefaultFun () - ) - -> TestTree +testFailureItem :: + ( String + , SimplifierStage + , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun () + ) -> + TestTree testFailureItem (name, stage, before, after) = testFailure name stage before after testTrivialSuccess1 :: TestTree @@ -120,7 +118,8 @@ testByteStringEqFailure = astTests :: TestTree astTests = - testGroup "certifier ast tests" + testGroup + "certifier ast tests" [ testTrivialSuccess1 , testTrivialFailure1 , testByteStringEqSuccess diff --git a/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs b/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs index 0ae72e7808c..f30edb8f9f0 100644 --- a/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs +++ b/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs @@ -31,23 +31,30 @@ import Test.Certifier.AST (testFailureItem, testSuccessItem) -- Constructors positive: [0,2,3,4] simpleSuccessBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () simpleSuccessBefore = runQuote $ do - x <- freshName "x" - return (Force () - (Apply () - (LamAbs () x - (Delay () (mkConstant () (1 :: Integer))) - ) - (mkConstant () (2 :: Integer)) - ) - ) + x <- freshName "x" + return + ( Force + () + ( Apply + () + ( LamAbs + () + x + (Delay () (mkConstant () (1 :: Integer))) + ) + (mkConstant () (2 :: Integer)) + ) + ) simpleSuccessAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () simpleSuccessAfter = runQuote $ do - x <- freshName "x" - return (Apply () - (LamAbs () x (mkConstant () (1 :: Integer))) - (mkConstant () (2 :: Integer)) - ) + x <- freshName "x" + return + ( Apply + () + (LamAbs () x (mkConstant () (1 :: Integer))) + (mkConstant () (2 :: Integer)) + ) -- Nested application that reverts to Translation, -- and then more Force-Delay cleanup @@ -59,42 +66,61 @@ simpleSuccessAfter = runQuote $ do -- Constructors positive: [0,1,2,3,5] nestedBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () nestedBefore = runQuote $ do - x <- freshName "x" - y <- freshName "y" - return (Force () - (Delay () - (Apply () - (LamAbs () x - (Apply () - (LamAbs () y - (Force () (Delay () ( - (mkConstant () (2 :: Integer)) - ))) + x <- freshName "x" + y <- freshName "y" + return + ( Force + () + ( Delay + () + ( Apply + () + ( LamAbs + () + x + ( Apply + () + ( LamAbs + () + y + ( Force + () + ( Delay + () + ((mkConstant () (2 :: Integer))) ) - (mkConstant () (3 :: Integer)) ) ) - (mkConstant () (1 :: Integer)) + (mkConstant () (3 :: Integer)) ) ) - ) + (mkConstant () (1 :: Integer)) + ) + ) + ) nestedAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () nestedAfter = runQuote $ do - x <- freshName "x" - y <- freshName "y" - return (Apply () - (LamAbs () x - (Apply () - (LamAbs () y - (mkConstant () (2 :: Integer)) - ) - (mkConstant () (3 :: Integer)) - ) - ) - (mkConstant () (1 :: Integer)) + x <- freshName "x" + y <- freshName "y" + return + ( Apply + () + ( LamAbs + () + x + ( Apply + () + ( LamAbs + () + y + (mkConstant () (2 :: Integer)) ) - + (mkConstant () (3 :: Integer)) + ) + ) + (mkConstant () (1 :: Integer)) + ) -- Force traverses ifThenElse -- (force [ @@ -113,31 +139,38 @@ nestedAfter = runQuote $ do -- Constructors positive: [6] ifThenElseSuccessBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () ifThenElseSuccessBefore = - (Force () - (Apply () - (Apply () - (Apply () - (Force () (Builtin () PLC.IfThenElse)) - (mkConstant () (True :: Bool)) - ) - (Delay () (mkConstant () (1 :: Integer))) - ) - (Delay () (mkConstant () (2 :: Integer))) - ) - ) + ( Force + () + ( Apply + () + ( Apply + () + ( Apply + () + (Force () (Builtin () PLC.IfThenElse)) + (mkConstant () (True :: Bool)) + ) + (Delay () (mkConstant () (1 :: Integer))) + ) + (Delay () (mkConstant () (2 :: Integer))) + ) + ) ifThenElseSuccessAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () ifThenElseSuccessAfter = - (Apply () - (Apply () - (Apply () - (Force () (Builtin () PLC.IfThenElse)) - (mkConstant () (True :: Bool)) - ) - (mkConstant () (1 :: Integer)) - ) - (mkConstant () (2 :: Integer)) - ) + ( Apply + () + ( Apply + () + ( Apply + () + (Force () (Builtin () PLC.IfThenElse)) + (mkConstant () (True :: Bool)) + ) + (mkConstant () (1 :: Integer)) + ) + (mkConstant () (2 :: Integer)) + ) -- "Negative" tests -- Deliberately fail each constructor. @@ -154,11 +187,14 @@ simpleForceBreakAfter = (mkConstant () (1 :: Integer)) -- Constructors [0,1,4] -- Constructors violated: [1] simpleFailBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () -simpleFailBefore = (Force () - (Delay () - (Delay () (mkConstant () (1 :: Integer))) - ) - ) +simpleFailBefore = + ( Force + () + ( Delay + () + (Delay () (mkConstant () (1 :: Integer))) + ) + ) simpleFailAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () simpleFailAfter = (mkConstant () (1 :: Integer)) @@ -166,50 +202,61 @@ simpleFailAfter = (mkConstant () (1 :: Integer)) -- Traverse an application when you shouldn't -- no matching lambda -- Constructors violated: [2] simpleAppBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () -simpleAppBreakBefore = (Force () - (Apply () - (Delay () (mkConstant () (1 :: Integer))) - (mkConstant () (2 :: Integer)) - ) - ) +simpleAppBreakBefore = + ( Force + () + ( Apply + () + (Delay () (mkConstant () (1 :: Integer))) + (mkConstant () (2 :: Integer)) + ) + ) simpleAppBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () -simpleAppBreakAfter = (Apply () - (mkConstant () (1 :: Integer)) - (mkConstant () (2 :: Integer)) - ) +simpleAppBreakAfter = + ( Apply + () + (mkConstant () (1 :: Integer)) + (mkConstant () (2 :: Integer)) + ) -- Traverse an application when you shouldn't -- broken applied term -- Constructors violated: [2,0] appTermBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () appTermBreakBefore = runQuote $ do - x <- freshName "x" - return (Apply () - (LamAbs () x (mkConstant () (1 :: Integer))) - (Force () (mkConstant () (2 :: Integer))) - ) + x <- freshName "x" + return + ( Apply + () + (LamAbs () x (mkConstant () (1 :: Integer))) + (Force () (mkConstant () (2 :: Integer))) + ) appTermBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () appTermBreakAfter = runQuote $ do - x <- freshName "x" - return (Apply () - (LamAbs () x (mkConstant () (1 :: Integer))) - (mkConstant () (2 :: Integer)) - ) + x <- freshName "x" + return + ( Apply + () + (LamAbs () x (mkConstant () (1 :: Integer))) + (mkConstant () (2 :: Integer)) + ) -- Traverse a lambda when you shouldn't -- no applied term -- Constructors violated: [3] lambdaBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () lambdaBreakBefore = runQuote $ do - x <- freshName "x" - return (Force () - (LamAbs () x (Delay () (mkConstant () (1 :: Integer)))) - ) + x <- freshName "x" + return + ( Force + () + (LamAbs () x (Delay () (mkConstant () (1 :: Integer)))) + ) lambdaBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () lambdaBreakAfter = runQuote $ do - x <- freshName "x" - return (LamAbs () x (mkConstant () (1 :: Integer))) + x <- freshName "x" + return (LamAbs () x (mkConstant () (1 :: Integer))) -- Valid force-delay, but invalid sub-tree change. -- Constructors violated: [4] @@ -226,69 +273,110 @@ lastDelayBreakAfter = (mkConstant () (2 :: Integer)) -- Constructors violated: [5] lastAbsBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () lastAbsBreakBefore = runQuote $ do - x <- freshName "x" - return (Force () - (Delay () - (Apply () - (LamAbs () x (mkConstant () (1 :: Integer))) - (mkConstant () (3 :: Integer)) - ) - ) - ) + x <- freshName "x" + return + ( Force + () + ( Delay + () + ( Apply + () + (LamAbs () x (mkConstant () (1 :: Integer))) + (mkConstant () (3 :: Integer)) + ) + ) + ) lastAbsBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () lastAbsBreakAfter = runQuote $ do - x <- freshName "x" - return (Apply () - (LamAbs () x (mkConstant () (2 :: Integer))) - (mkConstant () (3 :: Integer)) - ) - + x <- freshName "x" + return + ( Apply + () + (LamAbs () x (mkConstant () (2 :: Integer))) + (mkConstant () (3 :: Integer)) + ) -successItems - :: [ - (String - , SimplifierStage - , Term Name PLC.DefaultUni PLC.DefaultFun () - , Term Name PLC.DefaultUni PLC.DefaultFun () - ) - ] +successItems :: + [ ( String + , SimplifierStage + , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun () + ) + ] successItems = - [ - ("Simple one lambda", ForceDelay - , simpleSuccessBefore, simpleSuccessAfter) - ,("Nested", ForceDelay - , nestedBefore, nestedAfter) - , ("ifThenElse", ForceDelay - , ifThenElseSuccessBefore, ifThenElseSuccessAfter) - ] -failItems - :: [ - (String - , SimplifierStage - , Term Name PLC.DefaultUni PLC.DefaultFun () - , Term Name PLC.DefaultUni PLC.DefaultFun ()) - ] + [ + ( "Simple one lambda" + , ForceDelay + , simpleSuccessBefore + , simpleSuccessAfter + ) + , + ( "Nested" + , ForceDelay + , nestedBefore + , nestedAfter + ) + , + ( "ifThenElse" + , ForceDelay + , ifThenElseSuccessBefore + , ifThenElseSuccessAfter + ) + ] +failItems :: + [ ( String + , SimplifierStage + , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun () + ) + ] failItems = - [ - ("Simple extra delay", ForceDelay - , simpleFailBefore, simpleFailAfter) - , ("Simple force break", ForceDelay - , simpleForceBreakBefore, simpleForceBreakAfter) - , ("Simple app break", ForceDelay - , simpleAppBreakBefore, simpleAppBreakAfter) - , ("App term break", ForceDelay - , appTermBreakBefore, appTermBreakAfter) - , ("Lambda break", ForceDelay - , lambdaBreakBefore, lambdaBreakAfter) - , ("Last delay break", ForceDelay - , lastDelayBreakBefore, lastDelayBreakAfter) - , ("Last abs break", ForceDelay - , lastAbsBreakBefore, lastAbsBreakAfter) - ] + [ + ( "Simple extra delay" + , ForceDelay + , simpleFailBefore + , simpleFailAfter + ) + , + ( "Simple force break" + , ForceDelay + , simpleForceBreakBefore + , simpleForceBreakAfter + ) + , + ( "Simple app break" + , ForceDelay + , simpleAppBreakBefore + , simpleAppBreakAfter + ) + , + ( "App term break" + , ForceDelay + , appTermBreakBefore + , appTermBreakAfter + ) + , + ( "Lambda break" + , ForceDelay + , lambdaBreakBefore + , lambdaBreakAfter + ) + , + ( "Last delay break" + , ForceDelay + , lastDelayBreakBefore + , lastDelayBreakAfter + ) + , + ( "Last abs break" + , ForceDelay + , lastAbsBreakBefore + , lastAbsBreakAfter + ) + ] forceDelayASTTests :: TestTree forceDelayASTTests = - testGroup "force-delay ast tests" - $ fmap testSuccessItem successItems - <> fmap testFailureItem failItems - + testGroup "force-delay ast tests" $ + fmap testSuccessItem successItems + <> fmap testFailureItem failItems diff --git a/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs b/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs index cfac1a5888e..6e1b6a36dd4 100644 --- a/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs +++ b/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs @@ -9,46 +9,47 @@ import Transform.Simplify.Lib (testCse, testSimplify) import Transform.Simplify.Spec (testCseInputs, testSimplifyInputs) import UntypedPlutusCore (DefaultFun, DefaultUni, Name, SimplifierTrace, Term) -type SimplifierFunc - = Term Name PLC.DefaultUni PLC.DefaultFun () - -> PLC.Quote - ( Term Name PLC.DefaultUni PLC.DefaultFun () - , SimplifierTrace Name PLC.DefaultUni PLC.DefaultFun () - ) +type SimplifierFunc = + Term Name PLC.DefaultUni PLC.DefaultFun () -> + PLC.Quote + ( Term Name PLC.DefaultUni PLC.DefaultFun () + , SimplifierTrace Name PLC.DefaultUni PLC.DefaultFun () + ) -mkUPLCTest - :: SimplifierFunc - -> String - -> Term Name DefaultUni DefaultFun () - -> TestTree -mkUPLCTest simplifierFunc name input = testCase name $ - let rawAgdaTrace = PLC.runQuote $ do - simplifierTrace <- snd <$> simplifierFunc input - return $ mkFfiSimplifierTrace simplifierTrace - in - case runCertifierMain rawAgdaTrace of - Just result -> - assertBool "The certifier returned false." result - Nothing -> - assertFailure "The certifier exited with an error." +mkUPLCTest :: + SimplifierFunc -> + String -> + Term Name DefaultUni DefaultFun () -> + TestTree +mkUPLCTest simplifierFunc name input = + testCase name $ + let rawAgdaTrace = PLC.runQuote $ do + simplifierTrace <- snd <$> simplifierFunc input + return $ mkFfiSimplifierTrace simplifierTrace + in case runCertifierMain rawAgdaTrace of + Just result -> + assertBool "The certifier returned false." result + Nothing -> + assertFailure "The certifier exited with an error." -mkUPLCSimplifierTest - :: String - -> Term Name DefaultUni DefaultFun () - -> TestTree +mkUPLCSimplifierTest :: + String -> + Term Name DefaultUni DefaultFun () -> + TestTree mkUPLCSimplifierTest = mkUPLCTest testSimplify -mkUPLCCseTest - :: String - -> Term Name DefaultUni DefaultFun () - -> TestTree +mkUPLCCseTest :: + String -> + Term Name DefaultUni DefaultFun () -> + TestTree mkUPLCCseTest = mkUPLCTest testCse optimizerTests :: TestTree optimizerTests = - testGroup "uplc optimizer tests" - [ testGroup "cse tests" - $ fmap (uncurry mkUPLCCseTest) testCseInputs - , testGroup "simplification tests" - $ fmap (uncurry mkUPLCSimplifierTest) testSimplifyInputs + testGroup + "uplc optimizer tests" + [ testGroup "cse tests" $ + fmap (uncurry mkUPLCCseTest) testCseInputs + , testGroup "simplification tests" $ + fmap (uncurry mkUPLCSimplifierTest) testSimplifyInputs ] diff --git a/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs b/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs index 750c25a53ab..cc191302be9 100644 --- a/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs +++ b/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} module Main (main) where @@ -28,7 +28,7 @@ parseParams = do [ OA.metavar "OUTPUT_FILE" , OA.help "Output file path" ] - pure Params{..} + pure Params {..} main :: IO () main = do @@ -71,5 +71,5 @@ For each boolean option, you can add a `no-` prefix to switch it off, such as `n genRow :: O.OptionKey -> O.PluginOption -> Text genRow k (O.PluginOption tr _ field desc _) = [fmt||`{k}`|{show tr}|{show (pretty defaultValue)}|{desc}||] - where - defaultValue = O.defaultPluginOptions ^. field + where + defaultValue = O.defaultPluginOptions ^. field diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs index bd6a8516c67..4579cf2b52a 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs @@ -1,7 +1,7 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} -- | Convenient functions for compiling binders. module PlutusTx.Compiler.Binders where @@ -31,105 +31,100 @@ first. variable *last* (so it is on the outside, so will be first when applying). -} -withVarScoped - :: (CompilingDefault uni fun m ann) - => GHC.Var - -> Ann - -> Maybe (PIRTerm uni fun) - -> (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) - -> m a +withVarScoped :: + CompilingDefault uni fun m ann => + GHC.Var -> + Ann -> + Maybe (PIRTerm uni fun) -> + (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) -> + m a withVarScoped v ann def k = do let ghcName = GHC.getName v var <- compileVarFresh ann v - local (\c -> c{ccScope = pushName ghcName var def (ccScope c)}) (k var) - -{-| Like `withVarScoped`, but takes a `PIRType`, and uses it for the type -of the compiled `GHC.Var`. --} -withVarTyScoped - :: (CompilingDefault uni fun m ann) - => GHC.Var - -> PIRType uni - -> (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) - -> m a + local (\c -> c {ccScope = pushName ghcName var def (ccScope c)}) (k var) + +-- | Like `withVarScoped`, but takes a `PIRType`, and uses it for the type +-- of the compiled `GHC.Var`. +withVarTyScoped :: + CompilingDefault uni fun m ann => + GHC.Var -> + PIRType uni -> + (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) -> + m a withVarTyScoped v t k = do let ghcName = GHC.getName v var <- compileVarWithTyFresh annMayInline v t - local (\c -> c{ccScope = pushName ghcName var Nothing (ccScope c)}) (k var) + local (\c -> c {ccScope = pushName ghcName var Nothing (ccScope c)}) (k var) -withVarsScoped - :: (CompilingDefault uni fun m ann) - => [(GHC.Var, Maybe (PIRTerm uni fun))] - -> ([PIR.VarDecl PIR.TyName PIR.Name uni Ann] -> m a) - -> m a +withVarsScoped :: + CompilingDefault uni fun m ann => + [(GHC.Var, Maybe (PIRTerm uni fun))] -> + ([PIR.VarDecl PIR.TyName PIR.Name uni Ann] -> m a) -> + m a withVarsScoped vs k = do vars <- for vs $ \(v, def) -> do let name = GHC.getName v var' <- compileVarFresh annMayInline v pure (name, var', def) - local (\c -> c{ccScope = pushNames vars (ccScope c)}) (k (fmap snd3 vars)) + local (\c -> c {ccScope = pushNames vars (ccScope c)}) (k (fmap snd3 vars)) -withTyVarScoped - :: (Compiling uni fun m ann) - => GHC.Var - -> (PIR.TyVarDecl PIR.TyName Ann -> m a) - -> m a +withTyVarScoped :: + Compiling uni fun m ann => + GHC.Var -> + (PIR.TyVarDecl PIR.TyName Ann -> m a) -> + m a withTyVarScoped v k = do let ghcName = GHC.getName v var <- compileTyVarFresh v - local (\c -> c{ccScope = pushTyName ghcName var (ccScope c)}) (k var) + local (\c -> c {ccScope = pushTyName ghcName var (ccScope c)}) (k var) -withTyVarsScoped - :: (Compiling uni fun m ann) - => [GHC.Var] - -> ([PIR.TyVarDecl PIR.TyName Ann] -> m a) - -> m a +withTyVarsScoped :: + Compiling uni fun m ann => + [GHC.Var] -> + ([PIR.TyVarDecl PIR.TyName Ann] -> m a) -> + m a withTyVarsScoped vs k = do vars <- for vs $ \v -> do let name = GHC.getName v var' <- compileTyVarFresh v pure (name, var') - local (\c -> c{ccScope = pushTyNames vars (ccScope c)}) (k (fmap snd vars)) - -{-| Builds a lambda, binding the given variable to a name that -will be in scope when running the second argument. --} -mkLamAbsScoped - :: (CompilingDefault uni fun m ann) - => Ann - -> GHC.Var - -> m (PIRTerm uni fun) - -> m (PIRTerm uni fun) + local (\c -> c {ccScope = pushTyNames vars (ccScope c)}) (k (fmap snd vars)) + +-- | Builds a lambda, binding the given variable to a name that +-- will be in scope when running the second argument. +mkLamAbsScoped :: + CompilingDefault uni fun m ann => + Ann -> + GHC.Var -> + m (PIRTerm uni fun) -> + m (PIRTerm uni fun) mkLamAbsScoped ann v body = withVarScoped v ann Nothing $ \(PIR.VarDecl _ n t) -> PIR.LamAbs ann n t <$> body -{-| Builds a type abstraction, binding the given variable to a name that -will be in scope when running the second argument. --} -mkTyAbsScoped :: (Compiling uni fun m ann) => GHC.Var -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) +-- | Builds a type abstraction, binding the given variable to a name that +-- will be in scope when running the second argument. +mkTyAbsScoped :: Compiling uni fun m ann => GHC.Var -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) mkTyAbsScoped v body = withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyAbs annMayInline t k <$> body -mkIterTyAbsScoped - :: (Compiling uni fun m ann) => [GHC.Var] -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) +mkIterTyAbsScoped :: + Compiling uni fun m ann => [GHC.Var] -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) mkIterTyAbsScoped vars body = foldr (\v acc -> mkTyAbsScoped v acc) body vars -{-| Builds a forall, binding the given variable to a name that -will be in scope when running the second argument. --} -mkTyForallScoped :: (Compiling uni fun m ann) => GHC.Var -> m (PIRType uni) -> m (PIRType uni) +-- | Builds a forall, binding the given variable to a name that +-- will be in scope when running the second argument. +mkTyForallScoped :: Compiling uni fun m ann => GHC.Var -> m (PIRType uni) -> m (PIRType uni) mkTyForallScoped v body = withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyForall annMayInline t k <$> body -mkIterTyForallScoped :: (Compiling uni fun m ann) => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) +mkIterTyForallScoped :: Compiling uni fun m ann => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) mkIterTyForallScoped vars body = foldr (\v acc -> mkTyForallScoped v acc) body vars -{-| Builds a type lambda, binding the given variable to a name that -will be in scope when running the second argument. --} -mkTyLamScoped :: (Compiling uni fun m ann) => GHC.Var -> m (PIRType uni) -> m (PIRType uni) +-- | Builds a type lambda, binding the given variable to a name that +-- will be in scope when running the second argument. +mkTyLamScoped :: Compiling uni fun m ann => GHC.Var -> m (PIRType uni) -> m (PIRType uni) mkTyLamScoped v body = withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyLam annMayInline t k <$> body -mkIterTyLamScoped :: (Compiling uni fun m ann) => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) +mkIterTyLamScoped :: Compiling uni fun m ann => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) mkIterTyLamScoped vars body = foldr (\v acc -> mkTyLamScoped v acc) body vars diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 77e3b8b590a..1ed939050a2 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -1,14 +1,14 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | Functions for compiling Plutus Core builtins. module PlutusTx.Compiler.Builtins ( @@ -302,7 +302,7 @@ builtinNames = , 'Builtins.scaleValue ] -defineBuiltinTerm :: (CompilingDefault uni fun m ann) => Ann -> TH.Name -> PIRTerm uni fun -> m () +defineBuiltinTerm :: CompilingDefault uni fun m ann => Ann -> TH.Name -> PIRTerm uni fun -> m () defineBuiltinTerm ann name term = do ghcId <- lookupGhcId name var <- compileVarFresh ann ghcId @@ -313,8 +313,8 @@ defineBuiltinTerm ann name term = do PIR.defineTerm (LexName $ GHC.getName ghcId) def mempty -- | Add definitions for all the builtin types to the environment. -defineBuiltinType - :: forall uni fun m ann. (Compiling uni fun m ann) => TH.Name -> PIRType uni -> m () +defineBuiltinType :: + forall uni fun m ann. Compiling uni fun m ann => TH.Name -> PIRType uni -> m () defineBuiltinType name ty = do tc <- lookupGhcTyCon name var <- compileTcTyVarFresh tc @@ -322,7 +322,7 @@ defineBuiltinType name ty = do -- these are all aliases for now PIR.recordAlias (LexName $ GHC.getName tc) -defineBoolType :: forall uni fun m ann. (CompilingDefault uni fun m ann) => m () +defineBoolType :: forall uni fun m ann. CompilingDefault uni fun m ann => m () defineBoolType = do datatypeStyle <- asks $ coDatatypeStyle . ccOpts @@ -338,19 +338,22 @@ defineBoolType = do caseMatcher :: PIR.ManualMatcher uni fun Ann caseMatcher _tyArgs scrut resTy branches = case datatypeStyle of - style | style == PIR.ScottEncoding || style == PIR.SumsOfProducts -> - -- For IfThenElse, true branch comes first hence we reverse brenches - PIR.mkIterApp - (PIR.tyInst annMayInline - (PIR.builtin annMayInline PLC.IfThenElse) - resTy) - ((annMayInline, ) <$> (scrut : reverse branches)) + style + | style == PIR.ScottEncoding || style == PIR.SumsOfProducts -> + -- For IfThenElse, true branch comes first hence we reverse brenches + PIR.mkIterApp + ( PIR.tyInst + annMayInline + (PIR.builtin annMayInline PLC.IfThenElse) + resTy + ) + ((annMayInline,) <$> (scrut : reverse branches)) _BuiltinCasing -> PIR.kase annMayInline resTy scrut branches PIR.defineManualDatatype (LexName $ GHC.getName boolTyCon) - (PIR.ManualDatatype + ( PIR.ManualDatatype [PIR.mkConstant annAlwaysInline False, PIR.mkConstant annAlwaysInline True] caseMatcher [] @@ -358,7 +361,7 @@ defineBoolType = do (Set.fromList [builtinBoolName]) -- | Add definitions for all the builtin terms to the environment. -defineBuiltinTerms :: (CompilingDefault uni fun m ann) => m () +defineBuiltinTerms :: CompilingDefault uni fun m ann => m () defineBuiltinTerms = do datatypeStyle <- asks $ coDatatypeStyle . ccOpts -- Error @@ -401,29 +404,35 @@ defineBuiltinTerms = do f <- freshName "f" let pairTy = - PLC.TyApp () - (PLC.TyApp () - (PLC.mkTyBuiltin @_ @(,) ()) - (PLC.TyVar () a)) + PLC.TyApp + () + ( PLC.TyApp + () + (PLC.mkTyBuiltin @_ @(,) ()) + (PLC.TyVar () a) + ) (PLC.TyVar () b) contTy = PLC.TyFun () (PLC.TyVar () a) $ - PLC.TyFun () (PLC.TyVar () b) (PLC.TyVar () r) + PLC.TyFun () (PLC.TyVar () b) (PLC.TyVar () r) instFstOrSnd x = PIR.tyInst () (PIR.tyInst () (PIR.builtin () x) (PLC.TyVar () a)) (PLC.TyVar () b) pure $ PIR.tyAbs () a (PLC.Type ()) $ - PIR.tyAbs () b (PLC.Type ()) $ - PIR.tyAbs () r (PLC.Type ()) $ - PIR.lamAbs () p pairTy $ - PIR.lamAbs () f contTy $ - PIR.apply () - (PIR.apply () - (PIR.var () f) - (PIR.apply () (instFstOrSnd PLC.FstPair) (PIR.var () p))) - (PIR.apply () (instFstOrSnd PLC.SndPair) (PIR.var () p)) + PIR.tyAbs () b (PLC.Type ()) $ + PIR.tyAbs () r (PLC.Type ()) $ + PIR.lamAbs () p pairTy $ + PIR.lamAbs () f contTy $ + PIR.apply + () + ( PIR.apply + () + (PIR.var () f) + (PIR.apply () (instFstOrSnd PLC.FstPair) (PIR.var () p)) + ) + (PIR.apply () (instFstOrSnd PLC.SndPair) (PIR.var () p)) _BuiltinCasing -> -- > /\a b r -> -- > \(p : pair a b) (f : a -> b -> r) -> @@ -436,22 +445,25 @@ defineBuiltinTerms = do f <- freshName "f" let pairTy = - PLC.TyApp () - (PLC.TyApp () - (PLC.mkTyBuiltin @_ @(,) ()) - (PLC.TyVar () a)) + PLC.TyApp + () + ( PLC.TyApp + () + (PLC.mkTyBuiltin @_ @(,) ()) + (PLC.TyVar () a) + ) (PLC.TyVar () b) contTy = PLC.TyFun () (PLC.TyVar () a) $ - PLC.TyFun () (PLC.TyVar () b) (PLC.TyVar () r) + PLC.TyFun () (PLC.TyVar () b) (PLC.TyVar () r) pure $ PIR.tyAbs () a (PLC.Type ()) $ - PIR.tyAbs () b (PLC.Type ()) $ - PIR.tyAbs () r (PLC.Type ()) $ - PIR.lamAbs () p pairTy $ - PIR.lamAbs () f contTy $ - PIR.kase () (PLC.TyVar () r) (PIR.Var () p) [PIR.Var () f] + PIR.tyAbs () b (PLC.Type ()) $ + PIR.tyAbs () r (PLC.Type ()) $ + PIR.lamAbs () p pairTy $ + PIR.lamAbs () f contTy $ + PIR.kase () (PLC.TyVar () r) (PIR.Var () p) [PIR.Var () f] defineBuiltinTerm annMayInline 'Builtins.caseList' $ case datatypeStyle of style | style == PIR.ScottEncoding || style == PIR.SumsOfProducts -> @@ -515,57 +527,58 @@ defineBuiltinTerms = do z <- freshName "z" f <- freshName "f" let listA = PLC.TyApp () (PLC.mkTyBuiltin @_ @[] ()) $ PLC.TyVar () a - return - $ PIR.tyAbs () a (PLC.Type ()) - $ PIR.tyAbs () r (PLC.Type ()) - $ PIR.lamAbs () z (PLC.TyVar () r) - $ PIR.lamAbs () f (PLC.TyFun () (PLC.TyVar () a) . PLC.TyFun () listA $ PLC.TyVar () r) - $ PIR.lamAbs () xs listA - $ PIR.kase - () - (PLC.TyVar () r) - (PIR.var () xs) - [PIR.var () f, PIR.var () z] - + return $ + PIR.tyAbs () a (PLC.Type ()) $ + PIR.tyAbs () r (PLC.Type ()) $ + PIR.lamAbs () z (PLC.TyVar () r) $ + PIR.lamAbs () f (PLC.TyFun () (PLC.TyVar () a) . PLC.TyFun () listA $ PLC.TyVar () r) $ + PIR.lamAbs () xs listA $ + PIR.kase + () + (PLC.TyVar () r) + (PIR.var () xs) + [PIR.var () f, PIR.var () z] -- See Note [Builtin terms and values] for_ enumerate $ \fun -> let defineBuiltinInl impl = defineBuiltinTerm annMayInline impl $ mkBuiltin fun in case fun of PLC.IfThenElse -> case datatypeStyle of - PIR.ScottEncoding -> defineBuiltinInl 'Builtins.ifThenElse - PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.ifThenElse - PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.ifThenElse $ - fmap (const annMayInline) . runQuote $ do - a <- freshTyName "a" - b <- freshName "b" - x <- freshName "x" - y <- freshName "y" - return - . PIR.tyAbs () a (PLC.Type ()) - . PIR.lamAbs () b (PLC.mkTyBuiltin @_ @Bool ()) - . PIR.lamAbs () x (PLC.TyVar () a) - . PIR.lamAbs () y (PLC.TyVar () a) - $ PIR.kase () - (PLC.TyVar () a) - (PIR.Var () b) - [PIR.Var () y, PIR.Var () x] + PIR.ScottEncoding -> defineBuiltinInl 'Builtins.ifThenElse + PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.ifThenElse + PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.ifThenElse $ + fmap (const annMayInline) . runQuote $ do + a <- freshTyName "a" + b <- freshName "b" + x <- freshName "x" + y <- freshName "y" + return + . PIR.tyAbs () a (PLC.Type ()) + . PIR.lamAbs () b (PLC.mkTyBuiltin @_ @Bool ()) + . PIR.lamAbs () x (PLC.TyVar () a) + . PIR.lamAbs () y (PLC.TyVar () a) + $ PIR.kase + () + (PLC.TyVar () a) + (PIR.Var () b) + [PIR.Var () y, PIR.Var () x] PLC.ChooseUnit -> case datatypeStyle of - PIR.ScottEncoding -> defineBuiltinInl 'Builtins.chooseUnit - PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.chooseUnit - PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.chooseUnit $ - fmap (const annMayInline) . runQuote $ do - r <- freshTyName "r" - unit <- freshName "unit" - x <- freshName "x" - return $ - PIR.tyAbs () r (PLC.Type ()) $ - PIR.lamAbs () unit (PLC.mkTyBuiltin @_ @() ()) $ - PIR.lamAbs () x (PLC.TyVar () r) $ - PIR.kase () + PIR.ScottEncoding -> defineBuiltinInl 'Builtins.chooseUnit + PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.chooseUnit + PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.chooseUnit $ + fmap (const annMayInline) . runQuote $ do + r <- freshTyName "r" + unit <- freshName "unit" + x <- freshName "x" + return $ + PIR.tyAbs () r (PLC.Type ()) $ + PIR.lamAbs () unit (PLC.mkTyBuiltin @_ @() ()) $ + PIR.lamAbs () x (PLC.TyVar () r) $ + PIR.kase + () (PLC.TyVar () r) (PIR.Var () unit) - [ PIR.var () x ] + [PIR.var () x] -- Bytestrings PLC.AppendByteString -> defineBuiltinInl 'Builtins.appendByteString PLC.ConsByteString -> defineBuiltinInl 'Builtins.consByteString @@ -605,62 +618,68 @@ defineBuiltinTerms = do PLC.Trace -> defineBuiltinInl 'Builtins.trace -- Pairs PLC.FstPair -> case datatypeStyle of - PIR.ScottEncoding -> defineBuiltinInl 'Builtins.fst - PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.fst - PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.fst $ - fmap (const annMayInline) . runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - x <- freshName "x" - l <- freshName "l" - r <- freshName "r" - let - pairTy = - PLC.TyApp () - (PLC.TyApp () - (PLC.mkTyBuiltin @_ @(,) ()) - (PLC.TyVar () a) - ) - (PLC.TyVar () b) - return $ - PIR.tyAbs () a (PLC.Type ()) $ - PIR.tyAbs () b (PLC.Type ()) $ - PIR.lamAbs () x pairTy $ - PIR.kase () + PIR.ScottEncoding -> defineBuiltinInl 'Builtins.fst + PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.fst + PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.fst $ + fmap (const annMayInline) . runQuote $ do + a <- freshTyName "a" + b <- freshTyName "b" + x <- freshName "x" + l <- freshName "l" + r <- freshName "r" + let + pairTy = + PLC.TyApp + () + ( PLC.TyApp + () + (PLC.mkTyBuiltin @_ @(,) ()) + (PLC.TyVar () a) + ) + (PLC.TyVar () b) + return $ + PIR.tyAbs () a (PLC.Type ()) $ + PIR.tyAbs () b (PLC.Type ()) $ + PIR.lamAbs () x pairTy $ + PIR.kase + () (PLC.TyVar () a) (PIR.Var () x) [ PIR.lamAbs () l (PLC.TyVar () a) $ - PIR.lamAbs () r (PLC.TyVar () b) $ - PIR.var () l + PIR.lamAbs () r (PLC.TyVar () b) $ + PIR.var () l ] PLC.SndPair -> case datatypeStyle of - PIR.ScottEncoding -> defineBuiltinInl 'Builtins.snd - PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.snd - PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.snd $ - fmap (const annMayInline) . runQuote $ do - a <- freshTyName "a" - b <- freshTyName "b" - x <- freshName "x" - l <- freshName "l" - r <- freshName "r" - let - pairTy = - PLC.TyApp () - (PLC.TyApp () - (PLC.mkTyBuiltin @_ @(,) ()) - (PLC.TyVar () a) - ) - (PLC.TyVar () b) - return $ - PIR.tyAbs () a (PLC.Type ()) $ - PIR.tyAbs () b (PLC.Type ()) $ - PIR.lamAbs () x pairTy $ - PIR.kase () + PIR.ScottEncoding -> defineBuiltinInl 'Builtins.snd + PIR.SumsOfProducts -> defineBuiltinInl 'Builtins.snd + PIR.BuiltinCasing -> defineBuiltinTerm annMayInline 'Builtins.snd $ + fmap (const annMayInline) . runQuote $ do + a <- freshTyName "a" + b <- freshTyName "b" + x <- freshName "x" + l <- freshName "l" + r <- freshName "r" + let + pairTy = + PLC.TyApp + () + ( PLC.TyApp + () + (PLC.mkTyBuiltin @_ @(,) ()) + (PLC.TyVar () a) + ) + (PLC.TyVar () b) + return $ + PIR.tyAbs () a (PLC.Type ()) $ + PIR.tyAbs () b (PLC.Type ()) $ + PIR.lamAbs () x pairTy $ + PIR.kase + () (PLC.TyVar () b) (PIR.Var () x) [ PIR.lamAbs () l (PLC.TyVar () a) $ - PIR.lamAbs () r (PLC.TyVar () b) $ - PIR.var () r + PIR.lamAbs () r (PLC.TyVar () b) $ + PIR.var () r ] PLC.MkPairData -> defineBuiltinInl 'Builtins.mkPairData -- List @@ -736,7 +755,7 @@ defineBuiltinTerms = do PLC.UnValueData -> defineBuiltinInl 'Builtins.unsafeDataAsValue PLC.ScaleValue -> defineBuiltinInl 'Builtins.scaleValue -defineBuiltinTypes :: (CompilingDefault uni fun m ann) => m () +defineBuiltinTypes :: CompilingDefault uni fun m ann => m () defineBuiltinTypes = do defineBuiltinType ''Builtins.BuiltinByteString . ($> annMayInline) $ PLC.toTypeAst $ @@ -763,7 +782,7 @@ defineBuiltinTypes = do defineBuiltinType ''Builtins.BuiltinValue . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Value -- | Lookup a builtin term by its TH name. These are assumed to be present, so fails if it cannot find it. -lookupBuiltinTerm :: (Compiling uni fun m ann) => TH.Name -> m (PIRTerm uni fun) +lookupBuiltinTerm :: Compiling uni fun m ann => TH.Name -> m (PIRTerm uni fun) lookupBuiltinTerm name = do ghcName <- lookupGhcName name maybeTerm <- PIR.lookupTerm (LexName ghcName) @@ -772,7 +791,7 @@ lookupBuiltinTerm name = do Nothing -> throwSd CompilationError $ "Missing builtin definition:" GHC.<+> (GHC.text $ show name) -- | Lookup a builtin type by its TH name. These are assumed to be present, so fails if it is cannot find it. -lookupBuiltinType :: (Compiling uni fun m ann) => TH.Name -> m (PIRType uni) +lookupBuiltinType :: Compiling uni fun m ann => TH.Name -> m (PIRType uni) lookupBuiltinType name = do ghcName <- lookupGhcName name maybeType <- PIR.lookupType annMayInline (LexName ghcName) @@ -781,14 +800,14 @@ lookupBuiltinType name = do Nothing -> throwSd CompilationError $ "Missing builtin definition:" GHC.<+> (GHC.text $ show name) -- | The function 'error :: forall a . a'. -errorFunc :: (Compiling uni fun m ann) => m (PIRTerm uni fun) +errorFunc :: Compiling uni fun m ann => m (PIRTerm uni fun) errorFunc = do n <- safeFreshTyName "e" pure $ PIR.TyAbs annMayInline n (PIR.Type annMayInline) (PIR.Error annMayInline (PIR.TyVar annMayInline n)) -- | The delayed error function 'error :: forall a . () -> a'. -delayedErrorFunc :: (CompilingDefault uni fun m ann) => m (PIRTerm uni fun) +delayedErrorFunc :: CompilingDefault uni fun m ann => m (PIRTerm uni fun) delayedErrorFunc = do n <- safeFreshTyName "a" t <- liftQuote (freshName "thunk") diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs index 591cf25dc68..9daf34951cc 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs @@ -1,13 +1,13 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusTx.Compiler.Error ( CompileError, @@ -30,23 +30,22 @@ import Control.Monad.Except import Data.Text qualified as T import Prettyprinter qualified as PP -{-| An error with some (nested) context. The integer argument to 'WithContextC' represents -the priority of the context when displaying it. Lower numbers are more prioritised. --} +-- | An error with some (nested) context. The integer argument to 'WithContextC' represents +-- the priority of the context when displaying it. Lower numbers are more prioritised. data WithContext c e = NoContext e | WithContextC Int c (WithContext c e) - deriving stock Functor + deriving stock (Functor) type CompileError uni fun ann = WithContext T.Text (Error uni fun ann) -withContext :: (MonadError (WithContext c e) m) => Int -> c -> m a -> m a +withContext :: MonadError (WithContext c e) m => Int -> c -> m a -> m a withContext p c act = catchError act $ \err -> throwError (WithContextC p c err) -withContextM :: (MonadError (WithContext c e) m) => Int -> m c -> m a -> m a +withContextM :: MonadError (WithContext c e) m => Int -> m c -> m a -> m a withContextM p mc act = do c <- mc catchError act $ \err -> throwError (WithContextC p c err) -throwPlain :: (MonadError (WithContext c e) m) => e -> m a +throwPlain :: MonadError (WithContext c e) m => e -> m a throwPlain = throwError . NoContext pruneContext :: Int -> WithContext c e -> WithContext c e @@ -77,8 +76,8 @@ instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) => PP.Pretty (Error uni pretty = PLC.prettyPlcClassicSimple instance - (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) - => PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun a) + (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) => + PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun a) where prettyBy config = \case PLCError e -> PP.vsep ["Error from the PLC compiler:", PLC.prettyBy config e] diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index a6888eb820e..fee62197038 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -1,16 +1,16 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Functions for compiling GHC Core expressions into Plutus Core terms. @@ -141,10 +141,10 @@ character is "un-consed" from its tail, for example: Then we re-do the cons after un-doing the original rewrite rule. -} -compileLiteral - :: (CompilingDefault uni fun m ann) - => GHC.Literal - -> m (PIRTerm uni fun) +compileLiteral :: + CompilingDefault uni fun m ann => + GHC.Literal -> + m (PIRTerm uni fun) compileLiteral = \case -- Just accept any kind of number literal, we'll complain about types we don't support elsewhere (GHC.LitNumber _ i) -> pure $ PIR.embedTerm $ PLC.mkConstant annMayInline i @@ -152,13 +152,12 @@ compileLiteral = \case GHC.LitChar _ -> throwPlain $ UnsupportedError "Literal char" GHC.LitFloat _ -> throwPlain $ UnsupportedError "Literal float" GHC.LitDouble _ -> throwPlain $ UnsupportedError "Literal double" - GHC.LitLabel{} -> throwPlain $ UnsupportedError "Literal label" + GHC.LitLabel {} -> throwPlain $ UnsupportedError "Literal label" GHC.LitNullAddr -> throwPlain $ UnsupportedError "Literal null" - GHC.LitRubbish{} -> throwPlain $ UnsupportedError "Literal rubbish" + GHC.LitRubbish {} -> throwPlain $ UnsupportedError "Literal rubbish" -{-| Get the bytestring content of a string expression, if possible. -Follows (Haskell) variable references! --} +-- | Get the bytestring content of a string expression, if possible. +-- Follows (Haskell) variable references! tryStringLiteralAsBytes :: GHC.CoreExpr -> Maybe BS.ByteString tryStringLiteralAsBytes coreExpr = case coreExpr of GHC.Lit (GHC.LitString bytes) -> @@ -209,16 +208,15 @@ tryStringLiteralAsBytes coreExpr = case coreExpr of tryStringLiteralAsBytes unfolding _ -> Nothing -{-| Given a GHC Core expression representing a string literal -extracts a ByteString from it. --} -stringLiteralAsBytes - :: (Compiling uni fun m ann) - => GHC.Name - -- ^ is used for error reporting. - -> GHC.CoreExpr - -- ^ The expression to extract the ByteString from. - -> m BS.ByteString +-- | Given a GHC Core expression representing a string literal +-- extracts a ByteString from it. +stringLiteralAsBytes :: + Compiling uni fun m ann => + -- | is used for error reporting. + GHC.Name -> + -- | The expression to extract the ByteString from. + GHC.CoreExpr -> + m BS.ByteString stringLiteralAsBytes name coreExpr = case tryStringLiteralAsBytes coreExpr of Just bytes -> pure bytes @@ -229,10 +227,9 @@ stringLiteralAsBytes name coreExpr = GHC.<+> "with inscrutable content: " GHC.<+> GHC.ppr coreExpr -{-| Given a GHC Core expression representing a string literal -extracts UTF-8 encoded ByteString from it and decodes it as Text --} -stringLiteralAsText :: (Compiling uni fun m ann) => GHC.Name -> GHC.CoreExpr -> m T.Text +-- | Given a GHC Core expression representing a string literal +-- extracts UTF-8 encoded ByteString from it and decodes it as Text +stringLiteralAsText :: Compiling uni fun m ann => GHC.Name -> GHC.CoreExpr -> m T.Text stringLiteralAsText name coreExpr = do bytes <- stringLiteralAsBytes name coreExpr case TE.decodeUtf8' bytes of @@ -242,14 +239,13 @@ stringLiteralAsText name coreExpr = do "Invalid UTF-8 in string literal:" GHC.<+> GHC.text (displayException err) -{-| Tries to recover original bytes from a UTF-8 encoded bytestring literal. - -This isn't a full UTF-8 decoder: it only decodes the subset of UTF-8 that -is expected to be found in bytestring literals: 0x00 - 0xFF - -If 'ByteString' contains a codepoint that is not in this range, the function will throw an error. --} -utf8CodePointsAsBytes :: (Compiling uni fun m ann) => BS.ByteString -> m BS.ByteString +-- | Tries to recover original bytes from a UTF-8 encoded bytestring literal. +-- +-- This isn't a full UTF-8 decoder: it only decodes the subset of UTF-8 that +-- is expected to be found in bytestring literals: 0x00 - 0xFF +-- +-- If 'ByteString' contains a codepoint that is not in this range, the function will throw an error. +utf8CodePointsAsBytes :: Compiling uni fun m ann => BS.ByteString -> m BS.ByteString utf8CodePointsAsBytes bs = case tryUtf8CodePointsAsBytes bs of Just bytes -> pure bytes @@ -259,30 +255,29 @@ utf8CodePointsAsBytes bs = tryUtf8CodePointsAsBytes :: BS.ByteString -> Maybe BS.ByteString tryUtf8CodePointsAsBytes = fmap BS.pack . gracefullyDecodeUtf8Bytes . BS.unpack - where - {- - Why not use 'Data.Text.Encoding'? - 1. Some bytes never appear in UTF-8 encoded text (0xC0, 0xC1, 0xF5-0xFF). - 2. GHC Core could contain such bytes in bytestring literals, - e.g. "\0\1" is stored as "\192\128\SOH". - 3. The UTF-8 parser from 'Data.Text.Encoding' chokes on these bytes: - ghci> TE.decodeUtf8 "\192\128\SOH" - *** Exception: Cannot decode byte '\xc0': Data.Text.Encoding: Invalid UTF-8 stream - 4. In the custom parsing logic below we can handle these bytes: - -} - gracefullyDecodeUtf8Bytes :: [Word8] -> Maybe [Word8] - gracefullyDecodeUtf8Bytes = \case - [] -> Just [] - 192 : 128 : rest -> (0x00 :) <$> gracefullyDecodeUtf8Bytes rest - 194 : b : rest | b > 127 && b < 192 -> (b :) <$> gracefullyDecodeUtf8Bytes rest - 195 : b : rest | b > 127 && b < 192 -> ((b + 64) :) <$> gracefullyDecodeUtf8Bytes rest - b : rest | b > 0 && b < 128 -> (b :) <$> gracefullyDecodeUtf8Bytes rest - _ -> Nothing - -{-| Strip off irrelevant things when we're trying to match a particular pattern in the code. Mostly ticks. -We only need to do this as part of a complex pattern match: if we're just compiling the expression -in question we will strip this off anyway. --} + where + {- + Why not use 'Data.Text.Encoding'? + 1. Some bytes never appear in UTF-8 encoded text (0xC0, 0xC1, 0xF5-0xFF). + 2. GHC Core could contain such bytes in bytestring literals, + e.g. "\0\1" is stored as "\192\128\SOH". + 3. The UTF-8 parser from 'Data.Text.Encoding' chokes on these bytes: + ghci> TE.decodeUtf8 "\192\128\SOH" + *** Exception: Cannot decode byte '\xc0': Data.Text.Encoding: Invalid UTF-8 stream + 4. In the custom parsing logic below we can handle these bytes: + -} + gracefullyDecodeUtf8Bytes :: [Word8] -> Maybe [Word8] + gracefullyDecodeUtf8Bytes = \case + [] -> Just [] + 192 : 128 : rest -> (0x00 :) <$> gracefullyDecodeUtf8Bytes rest + 194 : b : rest | b > 127 && b < 192 -> (b :) <$> gracefullyDecodeUtf8Bytes rest + 195 : b : rest | b > 127 && b < 192 -> ((b + 64) :) <$> gracefullyDecodeUtf8Bytes rest + b : rest | b > 0 && b < 128 -> (b :) <$> gracefullyDecodeUtf8Bytes rest + _ -> Nothing + +-- | Strip off irrelevant things when we're trying to match a particular pattern in the code. Mostly ticks. +-- We only need to do this as part of a complex pattern match: if we're just compiling the expression +-- in question we will strip this off anyway. strip :: GHC.CoreExpr -> GHC.CoreExpr strip = \case GHC.Var n `GHC.App` GHC.Type _ `GHC.App` expr | GHC.getName n == GHC.noinlineIdName -> strip expr @@ -290,7 +285,7 @@ strip = \case expr -> expr -- | Convert a reference to a data constructor, i.e. a call to it. -compileDataConRef :: (CompilingDefault uni fun m ann) => GHC.DataCon -> m (PIRTerm uni fun) +compileDataConRef :: CompilingDefault uni fun m ann => GHC.DataCon -> m (PIRTerm uni fun) compileDataConRef dc = do dcs <- getDataCons tc constrs <- getConstructors tc @@ -303,19 +298,19 @@ compileDataConRef dc = do CompilationError "Data constructor not in the type constructor's list of constructors" pure $ constrs !! index - where - tc = GHC.dataConTyCon dc + where + tc = GHC.dataConTyCon dc -- | Make alternatives with non-delayed and delayed bodies for a given 'CoreAlt'. -compileAlt - :: (CompilingDefault uni fun m ann) - => GHC.CoreAlt - -- ^ The 'CoreAlt' representing the branch itself. - -> [GHC.Type] - -- ^ The instantiated type arguments for the data constructor. - -> PIRTerm uni fun - -> m (PIRTerm uni fun, PIRTerm uni fun) - -- ^ Non-delayed and delayed +compileAlt :: + CompilingDefault uni fun m ann => + -- | The 'CoreAlt' representing the branch itself. + GHC.CoreAlt -> + -- | The instantiated type arguments for the data constructor. + [GHC.Type] -> + PIRTerm uni fun -> + -- | Non-delayed and delayed + m (PIRTerm uni fun, PIRTerm uni fun) compileAlt (GHC.Alt alt vars body) instArgTys defaultBody = traceCompilation 3 ("Creating alternative:" GHC.<+> GHC.ppr alt) $ case alt of GHC.LitAlt _ -> throwPlain $ UnsupportedError "Literal case" @@ -333,14 +328,14 @@ compileAlt (GHC.Alt alt vars body) instArgTys defaultBody = nonDelayed <- wrapDefaultAlt compiledBody delayed <- delay compiledBody >>= wrapDefaultAlt return (nonDelayed, delayed) - where - wrapDefaultAlt :: (CompilingDefault uni fun m ann) => PIRTerm uni fun -> m (PIRTerm uni fun) - wrapDefaultAlt body' = do - -- need to consume the args - argTypes <- mapM compileTypeNorm instArgTys - argNames <- - forM [0 .. (length argTypes - 1)] (\i -> safeFreshName $ "default_arg" <> (T.pack $ show i)) - pure $ PIR.mkIterLamAbs (zipWith (PIR.VarDecl annMayInline) argNames argTypes) body' + where + wrapDefaultAlt :: CompilingDefault uni fun m ann => PIRTerm uni fun -> m (PIRTerm uni fun) + wrapDefaultAlt body' = do + -- need to consume the args + argTypes <- mapM compileTypeNorm instArgTys + argNames <- + forM [0 .. (length argTypes - 1)] (\i -> safeFreshName $ "default_arg" <> (T.pack $ show i)) + pure $ PIR.mkIterLamAbs (zipWith (PIR.VarDecl annMayInline) argNames argTypes) body' -- See Note [GHC runtime errors] isErrorId :: GHC.Id -> Bool @@ -364,9 +359,8 @@ isProbablyIntegerEq (GHC.getName -> n) True isProbablyIntegerEq _ = False -{-| Check for literal ranges like [1..9] and [1, 5..101]. This will also -return `True` if there's an explicit use of `enumFromTo` or similar. --} +-- | Check for literal ranges like [1..9] and [1, 5..101]. This will also +-- return `True` if there's an explicit use of `enumFromTo` or similar. isProbablyBoundedRange :: GHC.Id -> Bool isProbablyBoundedRange (GHC.getName -> n) | Just m <- GHC.nameModule_maybe n @@ -377,16 +371,15 @@ isProbablyBoundedRange (GHC.getName -> n) ) ) || "enumDeltaToInteger" `isPrefixOf` methodName - where - -- \^ These are introduced by inlining for Integer ranges in - -- GHC.Enum. This also happens for Char, Word, and Int, but those types - -- aren't supported in Plutus Core. - methodName = GHC.occNameString (GHC.nameOccName n) + where + -- \^ These are introduced by inlining for Integer ranges in + -- GHC.Enum. This also happens for Char, Word, and Int, but those types + -- aren't supported in Plutus Core. + methodName = GHC.occNameString (GHC.nameOccName n) isProbablyBoundedRange _ = False -{-| Check for literal ranges like [1..] and [1, 5..]. This will also return -`True` if there's an explicit use of `enumFrom` or similar. --} +-- | Check for literal ranges like [1..] and [1, 5..]. This will also return +-- `True` if there's an explicit use of `enumFrom` or similar. isProbablyUnboundedRange :: GHC.Id -> Bool isProbablyUnboundedRange (GHC.getName -> n) | Just m <- GHC.nameModule_maybe n @@ -397,8 +390,8 @@ isProbablyUnboundedRange (GHC.getName -> n) ) ) || "enumDeltaInteger" `isPrefixOf` methodName -- Introduced by inlining - where - methodName = GHC.occNameString (GHC.nameOccName n) + where + methodName = GHC.occNameString (GHC.nameOccName n) isProbablyUnboundedRange _ = False {- Note [GHC runtime errors] @@ -613,11 +606,11 @@ for any variables that were freshly created by the simplifier. That's easy to fi ourselves before we start. -} -hoistExpr - :: (CompilingDefault uni fun m ann) - => GHC.Var - -> GHC.CoreExpr - -> m (PIRTerm uni fun) +hoistExpr :: + CompilingDefault uni fun m ann => + GHC.Var -> + GHC.CoreExpr -> + m (PIRTerm uni fun) hoistExpr var t = do wrapUnsafeDataAsConstrName <- lookupGhcName 'PlutusTx.AsData.Internal.wrapUnsafeDataAsConstr @@ -641,10 +634,10 @@ hoistExpr var t = do maybeDef <- PIR.lookupTerm lexName let varSpan = getVarSourceSpan var addSpan = case varSpan of - Nothing -> id + Nothing -> id Just src -> fmap . fmap . addSrcSpan $ src ^. srcSpanIso varSpanMsg = case varSpan of - Nothing -> "" + Nothing -> "" Just src -> ", located at" GHC.<+> GHC.ppr src case maybeDef of Just term -> pure term @@ -665,14 +658,14 @@ hoistExpr var t = do pure $ PIR.mkVar var' -- 'GHC.Var' in argument is only for extracting srcspan and accurate name. -maybeProfileRhs - :: (CompilingDefault uni fun m ann) - => GHC.Var - -> PLCVar uni - -> PIRTerm uni fun - -> m (PIRTerm uni fun) +maybeProfileRhs :: + CompilingDefault uni fun m ann => + GHC.Var -> + PLCVar uni -> + PIRTerm uni fun -> + m (PIRTerm uni fun) maybeProfileRhs ghcVar var t = do - CompileContext{ccOpts = compileOpts} <- ask + CompileContext {ccOpts = compileOpts} <- ask let nameStr = GHC.occNameString $ GHC.occName $ GHC.varName $ ghcVar displayName = T.pack $ @@ -680,11 +673,11 @@ maybeProfileRhs ghcVar var t = do -- When module is not compiled and GHC is using cached build from previous build, it will -- lack source span. There's nothing much we can do about this here since this is GHC -- behavior. Issue #7203 - Nothing -> nameStr + Nothing -> nameStr Just src -> nameStr <> " (" <> show (src ^. srcSpanIso) <> ")" ty = PLC._varDeclType var - isFunctionOrAbstraction = case ty of PLC.TyFun{} -> True; PLC.TyForall{} -> True; _ -> False + isFunctionOrAbstraction = case ty of PLC.TyFun {} -> True; PLC.TyForall {} -> True; _ -> False -- Trace only if profiling is on *and* the thing being defined is a function if coProfile compileOpts == All && isFunctionOrAbstraction then do @@ -692,24 +685,24 @@ maybeProfileRhs ghcVar var t = do pure $ entryExitTracingInside thunk displayName t ty else pure t -mkTrace - :: (uni `PLC.HasTermLevel` T.Text) - => PLC.Type PLC.TyName uni Ann - -> T.Text - -> PIRTerm uni PLC.DefaultFun - -> PIRTerm uni PLC.DefaultFun +mkTrace :: + uni `PLC.HasTermLevel` T.Text => + PLC.Type PLC.TyName uni Ann -> + T.Text -> + PIRTerm uni PLC.DefaultFun -> + PIRTerm uni PLC.DefaultFun mkTrace ty str v = PLC.mkIterApp (PIR.TyInst annMayInline (PIR.Builtin annMayInline PLC.Trace) ty) ((annMayInline,) <$> [PLC.mkConstant annMayInline str, v]) -- `mkLazyTrace ty str v` builds the term `force (trace str (delay v))` if `v` has type `ty` -mkLazyTrace - :: (CompilingDefault uni fun m ann) - => PLC.Type PLC.TyName uni Ann - -> T.Text - -> PIRTerm uni PLC.DefaultFun - -> m (PIRTerm uni fun) +mkLazyTrace :: + CompilingDefault uni fun m ann => + PLC.Type PLC.TyName uni Ann -> + T.Text -> + PIRTerm uni PLC.DefaultFun -> + m (PIRTerm uni fun) mkLazyTrace ty str v = do delayedBody <- delay v delayedType <- delayType ty @@ -755,37 +748,36 @@ f :: Identity (a -> a) f = Identity (\x -> x) -} -{-| Add entry/exit tracing inside a term's leading arguments, both term and type arguments. -@(/\a -> \b -> body)@ into @/\a -> \b -> entryExitTracing body@. --} -entryExitTracingInside - :: PIR.Name - -> T.Text - -> PIRTerm PLC.DefaultUni PLC.DefaultFun - -> PLCType PLC.DefaultUni - -> PIRTerm PLC.DefaultUni PLC.DefaultFun +-- | Add entry/exit tracing inside a term's leading arguments, both term and type arguments. +-- @(/\a -> \b -> body)@ into @/\a -> \b -> entryExitTracing body@. +entryExitTracingInside :: + PIR.Name -> + T.Text -> + PIRTerm PLC.DefaultUni PLC.DefaultFun -> + PLCType PLC.DefaultUni -> + PIRTerm PLC.DefaultUni PLC.DefaultFun entryExitTracingInside lamName displayName = go mempty - where - go - :: Map.Map PLC.TyName (PLCType PLC.DefaultUni) - -> PIRTerm PLC.DefaultUni PLC.DefaultFun - -> PLCType PLC.DefaultUni - -> PIRTerm PLC.DefaultUni PLC.DefaultFun - go subst (LamAbs ann n t body) (PLC.TyFun _ _dom cod) = - -- when t = \x -> body, => \x -> entryExitTracingInside body - LamAbs ann n t $ go subst body cod - go subst (TyAbs ann tn1 k body) (PLC.TyForall _ tn2 _k ty) = - -- when t = /\x -> body, => /\x -> entryExitTracingInside body - -- See Note [Profiling polymorphic functions] - let subst' = Map.insert tn2 (PLC.TyVar annMayInline tn1) subst - in TyAbs ann tn1 k $ go subst' body ty - -- See Note [Term/type argument mismatches] - -- Even if there still look like there are arguments on the term or the type level, because we've hit - -- a mismatch we go ahead and insert our profiling traces here. - go subst e ty = - -- See Note [Profiling polymorphic functions] - let ty' = PLC.typeSubstTyNames (\tn -> Map.lookup tn subst) ty - in entryExitTracing lamName displayName e ty' + where + go :: + Map.Map PLC.TyName (PLCType PLC.DefaultUni) -> + PIRTerm PLC.DefaultUni PLC.DefaultFun -> + PLCType PLC.DefaultUni -> + PIRTerm PLC.DefaultUni PLC.DefaultFun + go subst (LamAbs ann n t body) (PLC.TyFun _ _dom cod) = + -- when t = \x -> body, => \x -> entryExitTracingInside body + LamAbs ann n t $ go subst body cod + go subst (TyAbs ann tn1 k body) (PLC.TyForall _ tn2 _k ty) = + -- when t = /\x -> body, => /\x -> entryExitTracingInside body + -- See Note [Profiling polymorphic functions] + let subst' = Map.insert tn2 (PLC.TyVar annMayInline tn1) subst + in TyAbs ann tn1 k $ go subst' body ty + -- See Note [Term/type argument mismatches] + -- Even if there still look like there are arguments on the term or the type level, because we've hit + -- a mismatch we go ahead and insert our profiling traces here. + go subst e ty = + -- See Note [Profiling polymorphic functions] + let ty' = PLC.typeSubstTyNames (\tn -> Map.lookup tn subst) ty + in entryExitTracing lamName displayName e ty' {- Note [Profiling Markers] The @profile-all@ will insert trarces when entering and exciting functions. These @@ -800,12 +792,12 @@ entryExitTracingInside lamName displayName = go mempty -} -- | Add tracing before entering and after exiting a term. -entryExitTracing - :: PLC.Name - -> T.Text - -> PIRTerm PLC.DefaultUni PLC.DefaultFun - -> PLC.Type PLC.TyName PLC.DefaultUni Ann - -> PIRTerm PLC.DefaultUni PLC.DefaultFun +entryExitTracing :: + PLC.Name -> + T.Text -> + PIRTerm PLC.DefaultUni PLC.DefaultFun -> + PLC.Type PLC.TyName PLC.DefaultUni Ann -> + PIRTerm PLC.DefaultUni PLC.DefaultFun entryExitTracing lamName displayName e ty = let defaultUnitTy = PLC.TyBuiltin annMayInline (PLC.SomeTypeIn PLC.DefaultUniUnit) defaultUnit = PIR.Constant annMayInline (PLC.someValueOf PLC.DefaultUniUnit ()) @@ -862,11 +854,11 @@ entryExitTracing lamName displayName e ty = an unfolding. -} -compileHaskellList - :: forall uni fun m ann - . (CompilingDefault uni fun m ann) - => GHC.CoreExpr - -> m [PIRTerm uni fun] +compileHaskellList :: + forall uni fun m ann. + CompilingDefault uni fun m ann => + GHC.CoreExpr -> + m [PIRTerm uni fun] compileHaskellList = buildList . strip where err = @@ -884,16 +876,17 @@ compileHaskellList = buildList . strip let consume :: GHC.CoreExpr -> m [GHC.CoreExpr] consume (GHC.App (GHC.App (GHC.Var con') e) rest) - | con' == con = (e:) <$> consume rest + | con' == con = (e :) <$> consume rest | otherwise = err consume (GHC.Var nil') | nil' == nil = pure [] | otherwise = err consume _ = err - in consume li >>= traverse compileExpr + in + consume li >>= traverse compileExpr buildList _ = err -compileExpr :: (CompilingDefault uni fun m ann) => GHC.CoreExpr -> m (PIRTerm uni fun) +compileExpr :: CompilingDefault uni fun m ann => GHC.CoreExpr -> m (PIRTerm uni fun) compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- See Note [Scopes] CompileContext @@ -933,18 +926,18 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- case integer GHC.App (GHC.App (GHC.App (GHC.Var var) (GHC.Type resTy)) scrut) li | GHC.getName var == caseIntegerName && coDatatypeStyle opts == PIR.BuiltinCasing -> do - resTy' <- compileTypeNorm resTy - scrut' <- compileExpr scrut - branches <- compileHaskellList li - pure $ PIR.kase annAlwaysInline resTy' scrut' branches + resTy' <- compileTypeNorm resTy + scrut' <- compileExpr scrut + branches <- compileHaskellList li + pure $ PIR.kase annAlwaysInline resTy' scrut' branches | GHC.getName var == caseIntegerName -> - -- This is when we don't have bultin casing. We have to use something - -- else. Currently, it will use PlutusTx.List.!!, but this will be quite a bit - -- less efficient since it will also build the list and than index on the built - -- list. Ideally, It is possible to have some custom PIR here that will generate - -- chain of if-statements so that can skip the list construction work if we want - -- to optimize more here. - compileExpr $ GHC.App (GHC.App (GHC.App (GHC.Var listIndexId) (GHC.Type resTy)) li) scrut + -- This is when we don't have bultin casing. We have to use something + -- else. Currently, it will use PlutusTx.List.!!, but this will be quite a bit + -- less efficient since it will also build the list and than index on the built + -- list. Ideally, It is possible to have some custom PIR here that will generate + -- chain of if-statements so that can skip the list construction work if we want + -- to optimize more here. + compileExpr $ GHC.App (GHC.App (GHC.App (GHC.Var listIndexId) (GHC.Type resTy)) li) scrut {- Note [Lazy boolean operators] (||) and (&&) have a special treatment: we want them lazy in the second argument, as this is the behavior in Haskell and other PLs. @@ -970,7 +963,7 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- we use it directly. -- This only supports `inline f`, not `inline (f x1 ... xn)`. Just (_var, Just def) | null args -> pure def - _ -> compileExpr e' + _ -> compileExpr e' Just unfolding -- `f` is recursive. We do not inline recursive bindings. | any (== f) (universeBi unfolding) -> compileExpr e' @@ -1155,7 +1148,7 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- selectors that do have them let sel_names = fmap GHC.getName (GHC.classAllSelIds cls) val_index <- case elemIndex (GHC.getName n) sel_names of - Just i -> pure i + Just i -> pure i Nothing -> throwSd CompilationError $ "Id not in class method list:" GHC.<+> GHC.ppr n let rhs = GHC.mkDictSelRhs cls val_index @@ -1187,7 +1180,7 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- `annIsAsDataMatcher` annotation to the whole application. -- See Note [Compiling AsData Matchers and Their Invocations] if annIsAsDataMatcher (PIR.termAnn l') - then fmap (\ann -> ann{annIsAsDataMatcher = True}) + then fmap (\ann -> ann {annIsAsDataMatcher = True}) else id ) ( -- Ignore applications to types of 'RuntimeRep' kind, see Note [Runtime reps] @@ -1204,12 +1197,12 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- `annIsAsDataMatcher` annotation to the whole application. -- See Note [Compiling AsData Matchers and Their Invocations] if isAsDataMatcher - then fmap (\ann -> ann{annIsAsDataMatcher = True}) + then fmap (\ann -> ann {annIsAsDataMatcher = True}) else id ) ( -- If the head of the application is an `AsData` matcher, set `safeToInline` -- to True and continue. - (if isAsDataMatcher then local (\c -> c{ccSafeToInline = True}) else id) + (if isAsDataMatcher then local (\c -> c {ccSafeToInline = True}) else id) (PIR.Apply annMayInline <$> pure l' <*> compileExpr arg) ) -- if we're biding a type variable it's a type abstraction @@ -1226,7 +1219,7 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- the binding is in scope for the body, but not for the arg rhs' <- compileExpr rhs ty <- case rhs of - GHC.Lit (GHC.LitNumber{}) + GHC.Lit (GHC.LitNumber {}) | GHC.eqType (GHC.varType b) GHC.byteArrayPrimTy -> -- Handle the following case: -- @@ -1269,7 +1262,7 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- See Note [What source locations to cover] GHC.Tick tick body | Just src <- getSourceSpan maybeModBreaks tick -> traceCompilation 1 ("Compiling expr at:" GHC.<+> GHC.ppr src) $ do - CompileContext{ccOpts = coverageOpts} <- ask + CompileContext {ccOpts = coverageOpts} <- ask -- See Note [Coverage annotations] let anns = Set.toList $ activeCoverageTypes coverageOpts compiledBody <- fmap (addSrcSpan $ src ^. srcSpanIso) <$> compileExpr body @@ -1282,18 +1275,18 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do GHC.Type _ -> throwPlain $ UnsupportedError "Types as standalone expressions" GHC.Coercion _ -> throwPlain $ UnsupportedError "Coercions as expressions" -compileCase - :: (CompilingDefault uni fun m ann) - => (GHC.Var -> GHC.CoreExpr -> Bool) - -- ^ Whether the variable is dead in the expr - -> Bool - -- ^ Whether we should try to rewrite unnecessary constructor applications - -> BuiltinsInfo uni fun - -> GHC.CoreExpr - -> GHC.Var - -> GHC.Type - -> [GHC.CoreAlt] - -> m (PIRTerm uni fun) +compileCase :: + CompilingDefault uni fun m ann => + -- | Whether the variable is dead in the expr + (GHC.Var -> GHC.CoreExpr -> Bool) -> + -- | Whether we should try to rewrite unnecessary constructor applications + Bool -> + BuiltinsInfo uni fun -> + GHC.CoreExpr -> + GHC.Var -> + GHC.Type -> + [GHC.CoreAlt] -> + m (PIRTerm uni fun) compileCase isDead rewriteConApps binfo scrutinee binder t alts = do wrapTailName <- lookupGhcName 'PlutusTx.AsData.Internal.wrapTail let @@ -1301,7 +1294,7 @@ compileCase isDead rewriteConApps binfo scrutinee binder t alts = do isWrapTailApp = case GHC.collectArgs (strip scrutinee) of (strip -> GHC.Var f, _args) -> GHC.getName f == wrapTailName - _ -> False + _ -> False binderAnn | hasAlwaysInlinePragma binder = annAlwaysInline | isWrapTailApp = annSafeToInline @@ -1449,13 +1442,13 @@ in each case, but since we operate on them in the same way, there's no problem. -- | Do your best to try to extract a source span from a tick getSourceSpan :: Maybe GHC.ModBreaks -> _ -> Maybe GHC.RealSrcSpan -getSourceSpan _ GHC.SourceNote{GHC.sourceSpan = src} = Just src -getSourceSpan _ GHC.ProfNote{GHC.profNoteCC = cc} = +getSourceSpan _ GHC.SourceNote {GHC.sourceSpan = src} = Just src +getSourceSpan _ GHC.ProfNote {GHC.profNoteCC = cc} = case cc of GHC.NormalCC _ _ _ (GHC.RealSrcSpan sp _) -> Just sp - GHC.AllCafsCC _ (GHC.RealSrcSpan sp _) -> Just sp - _ -> Nothing -getSourceSpan mmb GHC.HpcTick{GHC.tickId = tid} = do + GHC.AllCafsCC _ (GHC.RealSrcSpan sp _) -> Just sp + _ -> Nothing +getSourceSpan mmb GHC.HpcTick {GHC.tickId = tid} = do mb <- mmb let arr = GHC.modBreaks_locs mb range = Array.bounds arr @@ -1468,20 +1461,20 @@ getVarSourceSpan = GHC.srcSpanToRealSrcSpan . GHC.nameSrcSpan . GHC.varName srcSpanIso :: Iso' GHC.RealSrcSpan SrcSpan srcSpanIso = iso fromGHC toGHC - where - fromGHC sp = - SrcSpan - { srcSpanFile = GHC.unpackFS (GHC.srcSpanFile sp) - , srcSpanSLine = GHC.srcSpanStartLine sp - , srcSpanSCol = GHC.srcSpanStartCol sp - , srcSpanELine = GHC.srcSpanEndLine sp - , srcSpanECol = GHC.srcSpanEndCol sp - } - toGHC sp = - GHC.mkRealSrcSpan - (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanSLine sp) (srcSpanSCol sp)) - (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanELine sp) (srcSpanECol sp)) - fileNameFs = GHC.fsLit . srcSpanFile + where + fromGHC sp = + SrcSpan + { srcSpanFile = GHC.unpackFS (GHC.srcSpanFile sp) + , srcSpanSLine = GHC.srcSpanStartLine sp + , srcSpanSCol = GHC.srcSpanStartCol sp + , srcSpanELine = GHC.srcSpanEndLine sp + , srcSpanECol = GHC.srcSpanEndCol sp + } + toGHC sp = + GHC.mkRealSrcSpan + (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanSLine sp) (srcSpanSCol sp)) + (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanELine sp) (srcSpanECol sp)) + fileNameFs = GHC.fsLit . srcSpanFile -- | Obviously this function computes a GHC.RealSrcSpan from a CovLoc toCovLoc :: GHC.RealSrcSpan -> CovLoc @@ -1498,19 +1491,19 @@ toCovLoc sp = -- See Note [Coverage order] -- | Annotate a term for coverage -coverageCompile - :: (CompilingDefault uni fun m ann) - => GHC.CoreExpr - -- ^ The original expression - -> GHC.Type - -- ^ The type of the expression - -> GHC.RealSrcSpan - -- ^ The source location of this expression - -> PIRTerm uni fun - -- ^ The current term (this is what we add coverage tracking to) - -> CoverageType - -- ^ The type of coverage to do next - -> m (PIRTerm uni fun) +coverageCompile :: + CompilingDefault uni fun m ann => + -- | The original expression + GHC.CoreExpr -> + -- | The type of the expression + GHC.Type -> + -- | The source location of this expression + GHC.RealSrcSpan -> + -- | The current term (this is what we add coverage tracking to) + PIRTerm uni fun -> + -- | The type of coverage to do next + CoverageType -> + m (PIRTerm uni fun) coverageCompile originalExpr exprType src compiledTerm covT = case covT of -- Add a location coverage annotation to tell us "we've executed this piece of code" @@ -1554,25 +1547,24 @@ coverageCompile originalExpr exprType src compiledTerm covT = , PLC.mkConstant annMayInline (T.pack . show $ fc) , compiledTerm ] - where - findHeadSymbol :: GHC.CoreExpr -> Maybe GHC.Id - findHeadSymbol (GHC.Var n) = Just n - findHeadSymbol (GHC.App t _) = findHeadSymbol t - findHeadSymbol (GHC.Lam _ t) = findHeadSymbol t - findHeadSymbol (GHC.Tick _ t) = findHeadSymbol t - findHeadSymbol (GHC.Let _ t) = findHeadSymbol t - findHeadSymbol (GHC.Cast t _) = findHeadSymbol t - findHeadSymbol _ = Nothing + where + findHeadSymbol :: GHC.CoreExpr -> Maybe GHC.Id + findHeadSymbol (GHC.Var n) = Just n + findHeadSymbol (GHC.App t _) = findHeadSymbol t + findHeadSymbol (GHC.Lam _ t) = findHeadSymbol t + findHeadSymbol (GHC.Tick _ t) = findHeadSymbol t + findHeadSymbol (GHC.Let _ t) = findHeadSymbol t + findHeadSymbol (GHC.Cast t _) = findHeadSymbol t + findHeadSymbol _ = Nothing hasAlwaysInlinePragma :: GHC.Var -> Bool hasAlwaysInlinePragma = GHC.isInlinePragma . GHC.idInlinePragma -{-| We cannot compile the unfolding of `GHC.Num.Integer.integerNegate`, which is -important because GHC inserts calls to it when it sees negations, even negations -of literals (unless NegativeLiterals is on, which it usually isn't). So we directly -define a PIR term for it: @integerNegate = \x -> 0 - x@. --} -defineIntegerNegate :: (CompilingDefault PLC.DefaultUni fun m ann) => m () +-- | We cannot compile the unfolding of `GHC.Num.Integer.integerNegate`, which is +-- important because GHC inserts calls to it when it sees negations, even negations +-- of literals (unless NegativeLiterals is on, which it usually isn't). So we directly +-- define a PIR term for it: @integerNegate = \x -> 0 - x@. +defineIntegerNegate :: CompilingDefault PLC.DefaultUni fun m ann => m () defineIntegerNegate = do ghcId <- lookupGhcId 'GHC.Num.Integer.integerNegate -- Always inline `integerNegate`. @@ -1595,7 +1587,7 @@ defineIntegerNegate = do def = PIR.Def var (body, PIR.Strict) PIR.defineTerm (LexName GHC.integerNegateName) def mempty -defineFix :: (CompilingDefault PLC.DefaultUni fun m ann) => m () +defineFix :: CompilingDefault PLC.DefaultUni fun m ann => m () defineFix = do inlineFix <- asks (coInlineFix . ccOpts) ghcId <- lookupGhcId 'PlutusTx.Function.fix @@ -1604,7 +1596,7 @@ defineFix = do let def = PIR.Def var (rhs, PIR.Strict) PIR.defineTerm (LexName (GHC.getName ghcId)) def mempty -lookupIntegerNegate :: (Compiling uni fun m ann) => m (PIRTerm uni fun) +lookupIntegerNegate :: Compiling uni fun m ann => m (PIRTerm uni fun) lookupIntegerNegate = do ghcName <- lookupGhcName 'GHC.Num.Integer.integerNegate PIR.lookupTerm (LexName ghcName) >>= \case @@ -1613,10 +1605,10 @@ lookupIntegerNegate = do throwPlain $ CompilationError "Cannot find the definition of integerNegate. Please file a bug report." -compileExprWithDefs - :: (CompilingDefault uni fun m ann) - => GHC.CoreExpr - -> m (PIRTerm uni fun) +compileExprWithDefs :: + CompilingDefault uni fun m ann => + GHC.CoreExpr -> + m (PIRTerm uni fun) compileExprWithDefs e = do -- Order matters here. Generlly, Once that define types should go before anything that defines -- terms. Otherwise, type definitions might get ignored if they appear in types of term definitions. diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs-boot b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs-boot index 3e750c896a1..c0fc11278dd 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs-boot +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs-boot @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module PlutusTx.Compiler.Expr (compileExpr, compileExprWithDefs, compileDataConRef) where @@ -9,11 +9,9 @@ import PlutusTx.PIRTypes import GHC.Plugins qualified as GHC compileDataConRef :: CompilingDefault uni fun m ann => GHC.DataCon -> m (PIRTerm uni fun) - -compileExpr - :: CompilingDefault uni fun m ann - => GHC.CoreExpr -> m (PIRTerm uni fun) - -compileExprWithDefs - :: CompilingDefault uni fun m ann - => GHC.CoreExpr -> m (PIRTerm uni fun) +compileExpr :: + CompilingDefault uni fun m ann => + GHC.CoreExpr -> m (PIRTerm uni fun) +compileExprWithDefs :: + CompilingDefault uni fun m ann => + GHC.CoreExpr -> m (PIRTerm uni fun) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs index 96177f7436a..037ec369600 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs @@ -1,7 +1,7 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | Functions for compiling GHC kinds into PlutusCore kinds. module PlutusTx.Compiler.Kind (compileKind) where @@ -15,7 +15,7 @@ import GHC.Plugins qualified as GHC import PlutusCore qualified as PLC -compileKind :: (Compiling uni fun m ann) => GHC.Kind -> m (PLC.Kind ()) +compileKind :: Compiling uni fun m ann => GHC.Kind -> m (PLC.Kind ()) compileKind k = traceCompilation 2 ("Compiling kind:" GHC.<+> GHC.ppr k) $ case k of -- this is a bit weird because GHC uses 'Type' to represent kinds, so '* -> *' is a 'TyFun' (GHC.isLiftedTypeKind -> True) -> pure $ PLC.Type () diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs index 80a7c103627..20e5eea7fa3 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs @@ -1,7 +1,7 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} -- | Simulating laziness. module PlutusTx.Compiler.Laziness where @@ -25,43 +25,43 @@ with the standard library because it makes the generated terms simpler without t a simplifier pass. Also, PLC isn't lazy, so combinators work less well. -} -delay :: (Compiling uni fun m ann) => PIRTerm uni fun -> m (PIRTerm uni fun) +delay :: Compiling uni fun m ann => PIRTerm uni fun -> m (PIRTerm uni fun) delay body = PIR.TyAbs annMayInline <$> liftQuote (freshTyName "dead") <*> pure (PIR.Type annMayInline) <*> pure body -delayType :: (Compiling uni fun m ann) => PIRType uni -> m (PIRType uni) +delayType :: Compiling uni fun m ann => PIRType uni -> m (PIRType uni) delayType orig = PIR.TyForall annMayInline <$> liftQuote (freshTyName "dead") <*> pure (PIR.Type annMayInline) <*> pure orig -delayVar :: (Compiling uni fun m ann) => PIRVar uni -> m (PIRVar uni) +delayVar :: Compiling uni fun m ann => PIRVar uni -> m (PIRVar uni) delayVar (PIR.VarDecl ann n ty) = do ty' <- delayType ty pure $ PIR.VarDecl ann n ty' -force - :: (CompilingDefault uni fun m ann) - => PIRTerm uni fun -> m (PIRTerm uni fun) +force :: + CompilingDefault uni fun m ann => + PIRTerm uni fun -> m (PIRTerm uni fun) force thunk = do a <- liftQuote (freshTyName "dead") let fakeTy = PIR.TyForall annMayInline a (PIR.Type annMayInline) (PIR.TyVar annMayInline a) pure $ PIR.TyInst annMayInline thunk fakeTy -maybeDelay :: (Compiling uni fun m ann) => Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) +maybeDelay :: Compiling uni fun m ann => Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) maybeDelay yes t = if yes then delay t else pure t -maybeDelayVar :: (Compiling uni fun m ann) => Bool -> PIRVar uni -> m (PIRVar uni) +maybeDelayVar :: Compiling uni fun m ann => Bool -> PIRVar uni -> m (PIRVar uni) maybeDelayVar yes v = if yes then delayVar v else pure v -maybeDelayType :: (Compiling uni fun m ann) => Bool -> PIRType uni -> m (PIRType uni) +maybeDelayType :: Compiling uni fun m ann => Bool -> PIRType uni -> m (PIRType uni) maybeDelayType yes t = if yes then delayType t else pure t -maybeForce - :: (CompilingDefault uni fun m ann) - => Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) +maybeForce :: + CompilingDefault uni fun m ann => + Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) maybeForce yes t = if yes then force t else pure t diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs index 6be98999120..18e79aceffc 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} -- | Functions for compiling GHC names into Plutus Core names. module PlutusTx.Compiler.Names where @@ -28,44 +28,42 @@ import Data.Text qualified as T lookupName :: Scope uni fun -> GHC.Name -> Maybe (PLCVar uni, Maybe (PIRTerm uni fun)) lookupName (Scope ns _) n = Map.lookup n ns -{-| -Reverses the OccName tidying that GHC does, see 'tidyOccEnv' -and accompanying Notes. - -This is bad, because it makes it much harder to read since the -disambiguating numbers are gone. However, these appear to be -non-deterministic (possibly depending on the order in which -modules are processed?), so we can't rely on them. - -Essentially, we just strip off trailing digits. -This might remove "real" digits added by the user, but -there's not much we can do about that. - -Note that this only affects the *textual* name, not the underlying -unique, so it has no effect on the behaviour of the program, merely -on how it is printed. --} +-- | +-- Reverses the OccName tidying that GHC does, see 'tidyOccEnv' +-- and accompanying Notes. +-- +-- This is bad, because it makes it much harder to read since the +-- disambiguating numbers are gone. However, these appear to be +-- non-deterministic (possibly depending on the order in which +-- modules are processed?), so we can't rely on them. +-- +-- Essentially, we just strip off trailing digits. +-- This might remove "real" digits added by the user, but +-- there's not much we can do about that. +-- +-- Note that this only affects the *textual* name, not the underlying +-- unique, so it has no effect on the behaviour of the program, merely +-- on how it is printed. getUntidiedOccString :: GHC.Name -> String getUntidiedOccString n = dropWhileEnd isDigit (GHC.getOccString n) -compileNameFresh :: (MonadQuote m) => GHC.Name -> m PLC.Name +compileNameFresh :: MonadQuote m => GHC.Name -> m PLC.Name compileNameFresh n = safeFreshName $ T.pack $ getUntidiedOccString n -compileVarFresh :: (CompilingDefault uni fun m ann) => Ann -> GHC.Var -> m (PLCVar uni) +compileVarFresh :: CompilingDefault uni fun m ann => Ann -> GHC.Var -> m (PLCVar uni) compileVarFresh ann v = do t' <- compileTypeNorm $ GHC.varType v n' <- compileNameFresh $ GHC.getName v pure $ PLC.VarDecl ann n' t' -{-| Like `compileVarFresh`, but takes a `PIRType` instead of obtaining the -PIR type from the given `GHC.Var`. --} -compileVarWithTyFresh - :: (CompilingDefault uni fun m ann) - => Ann - -> GHC.Var - -> PIRType uni - -> m (PLCVar uni) +-- | Like `compileVarFresh`, but takes a `PIRType` instead of obtaining the +-- PIR type from the given `GHC.Var`. +compileVarWithTyFresh :: + CompilingDefault uni fun m ann => + Ann -> + GHC.Var -> + PIRType uni -> + m (PLCVar uni) compileVarWithTyFresh ann v t = do n' <- compileNameFresh $ GHC.getName v pure $ PLC.VarDecl ann n' t @@ -73,16 +71,16 @@ compileVarWithTyFresh ann v t = do lookupTyName :: Scope uni fun -> GHC.Name -> Maybe PLCTyVar lookupTyName (Scope _ tyns) n = Map.lookup n tyns -compileTyNameFresh :: (MonadQuote m) => GHC.Name -> m PLC.TyName +compileTyNameFresh :: MonadQuote m => GHC.Name -> m PLC.TyName compileTyNameFresh n = safeFreshTyName $ T.pack $ getUntidiedOccString n -compileTyVarFresh :: (Compiling uni fun m ann) => GHC.TyVar -> m PLCTyVar +compileTyVarFresh :: Compiling uni fun m ann => GHC.TyVar -> m PLCTyVar compileTyVarFresh v = do k' <- compileKind $ GHC.tyVarKind v t' <- compileTyNameFresh $ GHC.getName v pure $ PLC.TyVarDecl annMayInline t' (k' $> annMayInline) -compileTcTyVarFresh :: (Compiling uni fun m ann) => GHC.TyCon -> m PLCTyVar +compileTcTyVarFresh :: Compiling uni fun m ann => GHC.TyCon -> m PLCTyVar compileTcTyVarFresh tc = do k' <- compileKind $ GHC.tyConKind tc t' <- compileTyNameFresh $ GHC.getName tc diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs index 55c07314fa0..b9501e3bc7a 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module PlutusTx.Compiler.Trace where @@ -16,35 +16,34 @@ import Data.Text (Text) import Debug.Trace import GHC.Plugins qualified as GHC -{-| A combination of `withContextM` and `traceCompilationStep`. - -`withContextM` emits a stack trace when the compilation fails, and can be -turned on via `-fcontext-level=`. - -`traceCompilationStep` dumps the full compilation trace, and can be -turned on via `-fdump-compilation-trace`. --} -traceCompilation - :: ( MonadReader (CompileContext uni fun) m - , MonadState CompileState m - , MonadError (WithContext Text e) m - ) - => Int - -- ^ Context level - -> GHC.SDoc - -- ^ The thing (expr, type, kind, etc.) being compiled - -> m a - -- ^ The compilation action - -> m a +-- | A combination of `withContextM` and `traceCompilationStep`. +-- +-- `withContextM` emits a stack trace when the compilation fails, and can be +-- turned on via `-fcontext-level=`. +-- +-- `traceCompilationStep` dumps the full compilation trace, and can be +-- turned on via `-fdump-compilation-trace`. +traceCompilation :: + ( MonadReader (CompileContext uni fun) m + , MonadState CompileState m + , MonadError (WithContext Text e) m + ) => + -- | Context level + Int -> + -- | The thing (expr, type, kind, etc.) being compiled + GHC.SDoc -> + -- | The compilation action + m a -> + m a traceCompilation p sd = withContextM p (sdToTxt sd) . traceCompilationStep sd -traceCompilationStep - :: (MonadReader (CompileContext uni fun) m, MonadState CompileState m) - => GHC.SDoc - -- ^ The thing (expr, type, kind, etc.) being compiled - -> m a - -- ^ The compilation action - -> m a +traceCompilationStep :: + (MonadReader (CompileContext uni fun) m, MonadState CompileState m) => + -- | The thing (expr, type, kind, etc.) being compiled + GHC.SDoc -> + -- | The compilation action + m a -> + m a traceCompilationStep sd compile = ifM (notM (asks ccDebugTraceOn)) compile $ do CompileState nextStep prevSteps <- get put $ CompileState (nextStep + 1) (nextStep : prevSteps) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs index e98089361f6..af023c597c3 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -{-| Functions for compiling GHC types into PlutusCore types, as well as compiling constructors, -matchers, and pattern match alternatives. --} +-- | Functions for compiling GHC types into PlutusCore types, as well as compiling constructors, +-- matchers, and pattern match alternatives. module PlutusTx.Compiler.Type ( compileTypeNorm, compileType, @@ -63,24 +62,23 @@ TODO: use topNormaliseType to be more efficient and handle newtypes as well. Pro is dealing with recursive newtypes. -} -{-| Compile a type, first of all normalizing it to remove type family redexes. - -Generally, we need to call this whenever we are compiling a "new" type from the program. -If we are compiling a part of a type we are already processing then it has likely been -normalized and we can just use 'compileType' --} -compileTypeNorm :: (CompilingDefault uni fun m ann) => GHC.Type -> m (PIRType uni) +-- | Compile a type, first of all normalizing it to remove type family redexes. +-- +-- Generally, we need to call this whenever we are compiling a "new" type from the program. +-- If we are compiling a part of a type we are already processing then it has likely been +-- normalized and we can just use 'compileType' +compileTypeNorm :: CompilingDefault uni fun m ann => GHC.Type -> m (PIRType uni) compileTypeNorm ty = do - CompileContext{ccFamInstEnvs = envs} <- ask + CompileContext {ccFamInstEnvs = envs} <- ask -- See Note [Type families and normalizing types] let (GHC.Reduction _ ty') = GHC.normaliseType envs GHC.Representational ty compileType ty' -- | Compile a type. -compileType :: (CompilingDefault uni fun m ann) => GHC.Type -> m (PIRType uni) +compileType :: CompilingDefault uni fun m ann => GHC.Type -> m (PIRType uni) compileType t = traceCompilation 2 ("Compiling type:" GHC.<+> GHC.ppr t) $ do -- See Note [Scopes] - CompileContext{ccScope = scope} <- ask + CompileContext {ccScope = scope} <- ask case t of -- in scope type name (GHC.getTyVar_maybe -> Just v) -> case lookupTyName scope (GHC.getName v) of @@ -122,11 +120,11 @@ we just have to ban recursive newtypes, and we do this by blackholing the name w definition, and dying if we see it again. -} -compileTyCon - :: forall uni fun m ann - . (CompilingDefault uni fun m ann) - => GHC.TyCon - -> m (PIRType uni) +compileTyCon :: + forall uni fun m ann. + CompilingDefault uni fun m ann => + GHC.TyCon -> + m (PIRType uni) compileTyCon tc | tc == GHC.intTyCon = throwPlain $ UnsupportedError "Int: use Integer instead" | tc == GHC.intPrimTyCon = @@ -250,22 +248,22 @@ sortConstructors tc cs = let sorted = sortBy (\dc1 dc2 -> compare (GHC.getOccName dc1) (GHC.getOccName dc2)) cs in if tc == GHC.listTyCon then reverse sorted else sorted -getDataCons :: (Compiling uni fun m ann) => GHC.TyCon -> m [GHC.DataCon] +getDataCons :: Compiling uni fun m ann => GHC.TyCon -> m [GHC.DataCon] getDataCons tc' = sortConstructors tc' <$> extractDcs tc' - where - extractDcs tc - | GHC.isAlgTyCon tc || GHC.isTupleTyCon tc = case GHC.algTyConRhs tc of - GHC.AbstractTyCon -> + where + extractDcs tc + | GHC.isAlgTyCon tc || GHC.isTupleTyCon tc = case GHC.algTyConRhs tc of + GHC.AbstractTyCon -> + throwSd UnsupportedError $ + "Abstract type:" GHC.<+> GHC.ppr tc + GHC.DataTyCon {GHC.data_cons = dcs} -> pure dcs + GHC.TupleTyCon {GHC.data_con = dc} -> pure [dc] + GHC.SumTyCon {GHC.data_cons = dcs} -> pure dcs + GHC.NewTyCon {GHC.data_con = dc} -> pure [dc] + | GHC.isFamilyTyCon tc = throwSd UnsupportedError $ - "Abstract type:" GHC.<+> GHC.ppr tc - GHC.DataTyCon{GHC.data_cons = dcs} -> pure dcs - GHC.TupleTyCon{GHC.data_con = dc} -> pure [dc] - GHC.SumTyCon{GHC.data_cons = dcs} -> pure dcs - GHC.NewTyCon{GHC.data_con = dc} -> pure [dc] - | GHC.isFamilyTyCon tc = - throwSd UnsupportedError $ - "Irreducible type family application:" GHC.<+> GHC.ppr tc - | otherwise = throwSd UnsupportedError $ "Type constructor:" GHC.<+> GHC.ppr tc + "Irreducible type family application:" GHC.<+> GHC.ppr tc + | otherwise = throwSd UnsupportedError $ "Type constructor:" GHC.<+> GHC.ppr tc {- Note [On data constructor workers and wrappers] By default GHC has 'unbox-small-strict-fields' flag enabled. @@ -279,10 +277,9 @@ That fixes the type mismatch problem when the GHC unpacks the field but we infer the type of the original code without that information. -} -{-| Makes the type of the constructor corresponding to the given 'DataCon', with the -type variables free. --} -mkConstructorType :: (CompilingDefault uni fun m ann) => GHC.DataCon -> m (PIRType uni) +-- | Makes the type of the constructor corresponding to the given 'DataCon', with the +-- type variables free. +mkConstructorType :: CompilingDefault uni fun m ann => GHC.DataCon -> m (PIRType uni) mkConstructorType dc = -- see Note [On data constructor workers and wrappers] let argTys = GHC.scaledThing <$> GHC.dataConRepArgTys dc @@ -300,7 +297,7 @@ ghcStrictnessNote = GHC.<+> "'-fno-unbox-strict-fields', or '-fno-unbox-small-strict-fields'." -- | Get the constructors of the given 'TyCon' as PLC terms. -getConstructors :: (CompilingDefault uni fun m ann) => GHC.TyCon -> m [PIRTerm uni fun] +getConstructors :: CompilingDefault uni fun m ann => GHC.TyCon -> m [PIRTerm uni fun] getConstructors tc = do -- make sure the constructors have been created _ <- compileTyCon tc @@ -312,7 +309,7 @@ getConstructors tc = do "Cannot construct a value of type:" GHC.<+> GHC.ppr tc GHC.$+$ ghcStrictnessNote -- | Get the matcher of the given 'TyCon' as a PLC term -getMatch :: (CompilingDefault uni fun m ann) => GHC.TyCon -> m (PIR.ManualMatcher uni fun Ann) +getMatch :: CompilingDefault uni fun m ann => GHC.TyCon -> m (PIR.ManualMatcher uni fun Ann) getMatch tc = do -- ensure the tycon has been compiled, which will create the matcher _ <- compileTyCon tc @@ -323,16 +320,17 @@ getMatch tc = do throwSd UnsupportedError $ "Cannot case on a value on type:" GHC.<+> GHC.ppr tc GHC.$+$ ghcStrictnessNote -{-| Get the matcher of the given 'Type' (which must be equal to a type constructor application) -as a PLC term instantiated for the type constructor argument types. --} -getMatchInstantiated - :: (CompilingDefault uni fun m ann) - => GHC.Type - -> m (PIR.Term PIR.TyName PIR.Name uni fun Ann -> - PIR.Type PIR.TyName uni Ann -> - [PIR.Term PIR.TyName PIR.Name uni fun Ann] -> - PIR.Term PIR.TyName PIR.Name uni fun Ann) +-- | Get the matcher of the given 'Type' (which must be equal to a type constructor application) +-- as a PLC term instantiated for the type constructor argument types. +getMatchInstantiated :: + CompilingDefault uni fun m ann => + GHC.Type -> + m + ( PIR.Term PIR.TyName PIR.Name uni fun Ann -> + PIR.Type PIR.TyName uni Ann -> + [PIR.Term PIR.TyName PIR.Name uni fun Ann] -> + PIR.Term PIR.TyName PIR.Name uni fun Ann + ) getMatchInstantiated t = traceCompilation 3 ("Creating instantiated matcher for type:" GHC.<+> GHC.ppr t) $ case t of (GHC.splitTyConApp_maybe -> Just (tc, args)) -> do @@ -345,10 +343,9 @@ getMatchInstantiated t = throwSd CompilationError $ "Cannot case on a value of a type which is not a datatype:" GHC.<+> GHC.ppr t -{-| Drops prefix of 'RuntimeRep' type variables (similar to 'dropRuntimeRepArgs'). -Useful for e.g. dropping 'LiftedRep type variables arguments of unboxed tuple type applications: - - dropRuntimeRepVars [ k0, k1, a, b ] == [a, b] --} +-- | Drops prefix of 'RuntimeRep' type variables (similar to 'dropRuntimeRepArgs'). +-- Useful for e.g. dropping 'LiftedRep type variables arguments of unboxed tuple type applications: +-- +-- dropRuntimeRepVars [ k0, k1, a, b ] == [a, b] dropRuntimeRepVars :: [GHC.TyVar] -> [GHC.TyVar] dropRuntimeRepVars = dropWhile (GHC.isRuntimeRepTy . GHC.varType) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs-boot b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs-boot index ea4423ccd3c..9699e2c4852 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs-boot +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs-boot @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} module PlutusTx.Compiler.Type where @@ -10,5 +10,4 @@ import GHC.Plugins qualified as GHC compileTypeNorm :: CompilingDefault uni fun m ann => GHC.Type -> m (PIRType uni) compileType :: CompilingDefault uni fun m ann => GHC.Type -> m (PIRType uni) - -getMatchInstantiated :: (CompilingDefault uni fun m ann) => GHC.Type -> m (PIRTerm uni fun -> PIRType uni -> [PIRTerm uni fun] -> PIRTerm uni fun) +getMatchInstantiated :: CompilingDefault uni fun m ann => GHC.Type -> m (PIRTerm uni fun -> PIRType uni -> [PIRTerm uni fun] -> PIRTerm uni fun) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs index 9411e714dc1..1dae119af18 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs @@ -1,11 +1,11 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module PlutusTx.Compiler.Types ( module PlutusTx.Compiler.Types, @@ -47,38 +47,36 @@ type NameInfo = Map.Map TH.Name GHC.TyThing -- | Compilation options. data CompileOptions = CompileOptions - { coProfile :: ProfileOpts - , coCoverage :: CoverageOpts + { coProfile :: ProfileOpts + , coCoverage :: CoverageOpts , coDatatypeStyle :: PIR.DatatypeStyle - , coRemoveTrace :: Bool - , coInlineFix :: Bool + , coRemoveTrace :: Bool + , coInlineFix :: Bool } data CompileContext uni fun = CompileContext - { ccOpts :: CompileOptions - , ccFlags :: GHC.DynFlags - , ccFamInstEnvs :: GHC.FamInstEnvs - , ccNameInfo :: NameInfo - , ccScope :: Scope uni fun - , ccBlackholed :: Set.Set GHC.Name - , ccCurDef :: Maybe LexName - , ccModBreaks :: Maybe GHC.ModBreaks - , ccBuiltinsInfo :: PIR.BuiltinsInfo uni fun + { ccOpts :: CompileOptions + , ccFlags :: GHC.DynFlags + , ccFamInstEnvs :: GHC.FamInstEnvs + , ccNameInfo :: NameInfo + , ccScope :: Scope uni fun + , ccBlackholed :: Set.Set GHC.Name + , ccCurDef :: Maybe LexName + , ccModBreaks :: Maybe GHC.ModBreaks + , ccBuiltinsInfo :: PIR.BuiltinsInfo uni fun , ccBuiltinCostModel :: PLC.CostingPart uni fun - , ccDebugTraceOn :: Bool - , ccRewriteRules :: PIR.RewriteRules uni fun - , ccSafeToInline :: Bool + , ccDebugTraceOn :: Bool + , ccRewriteRules :: PIR.RewriteRules uni fun + , ccSafeToInline :: Bool } data CompileState = CompileState - { csNextStep :: Int - {- ^ The ID of the next step to be taken by the PlutusTx compiler. - This is used when generating debug traces. - -} + { csNextStep :: Int + -- ^ The ID of the next step to be taken by the PlutusTx compiler. + -- This is used when generating debug traces. , csPreviousSteps :: [Int] - {- ^ The IDs of the previous steps taken by the PlutusTx compiler leading up to - the current point. This is used when generating debug traces. - -} + -- ^ The IDs of the previous steps taken by the PlutusTx compiler leading up to + -- the current point. This is used when generating debug traces. } -- | Verbosity level of the Plutus Tx compiler. @@ -100,30 +98,26 @@ data ProfileOpts instance Pretty ProfileOpts where pretty = viaShow -{-| Coverage options -See Note [Coverage annotations] --} +-- | Coverage options +-- See Note [Coverage annotations] data CoverageOpts = CoverageOpts {unCoverageOpts :: Set CoverageType} -- | Get the coverage types we are using activeCoverageTypes :: CompileOptions -> Set CoverageType activeCoverageTypes = unCoverageOpts . coCoverage -{-| Option `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-all #-\}` enables all these -See Note [Adding more coverage annotations]. -See Note [Coverage order] --} +-- | Option `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-all #-\}` enables all these +-- See Note [Adding more coverage annotations]. +-- See Note [Coverage order] data CoverageType - = {-| Check that all source locations that we can identify in GHC Core have been covered. - For this to work at all we need `{\-# OPTIONS_GHC -g #-\}` - turn on with `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-location #-\}` - -} + = -- | Check that all source locations that we can identify in GHC Core have been covered. + -- For this to work at all we need `{\-# OPTIONS_GHC -g #-\}` + -- turn on with `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-location #-\}` LocationCoverage - | {-| Check that every boolean valued expression that isn't `True` or `False` for which - we know the source location have been covered. For this to work at all we need - `{\-# OPTIONS_GHC -g #-\}` turn on with - `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-boolean #-\}` - -} + | -- | Check that every boolean valued expression that isn't `True` or `False` for which + -- we know the source location have been covered. For this to work at all we need + -- `{\-# OPTIONS_GHC -g #-\}` turn on with + -- `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-boolean #-\}` BooleanCoverage deriving stock (Ord, Eq, Show, Enum, Bounded) @@ -137,13 +131,12 @@ data CoverageType and you've read the code of `coverageCompile` carefully. -} -{-| A wrapper around 'GHC.Name' with a stable 'Ord' instance. Use this where the ordering -will affect the output of the compiler, i.e. when sorting or so on. It's fine to use -'GHC.Name' if we're just putting them in a 'Set.Set', for example. - -The 'Eq' instance we derive - it's also not stable across builds, but I believe this is only -a problem if you compare things from different builds, which we don't do. --} +-- | A wrapper around 'GHC.Name' with a stable 'Ord' instance. Use this where the ordering +-- will affect the output of the compiler, i.e. when sorting or so on. It's fine to use +-- 'GHC.Name' if we're just putting them in a 'Set.Set', for example. +-- +-- The 'Eq' instance we derive - it's also not stable across builds, but I believe this is only +-- a problem if you compare things from different builds, which we don't do. newtype LexName = LexName GHC.Name deriving stock (Eq) @@ -158,7 +151,7 @@ instance Ord LexName where -- non-deterministic! But we care even more about not mixing up things -- that are different than we do about determinism. EQ -> compare n1 n2 - o -> o + o -> o {- Note [Stable name comparisons] GHC defines `stableNameCmp` which does a good job of being a stable name @@ -190,12 +183,12 @@ stableNameCmp n1 n2 = <> -- See Note [Stable name comparisons] maybeCmp stableModuleCmp (GHC.nameModule_maybe n1) (GHC.nameModule_maybe n2) - where - maybeCmp :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering - maybeCmp cmp (Just l) (Just r) = l `cmp` r - maybeCmp _ Nothing (Just _) = LT - maybeCmp _ (Just _) Nothing = GT - maybeCmp _ Nothing Nothing = EQ + where + maybeCmp :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering + maybeCmp cmp (Just l) (Just r) = l `cmp` r + maybeCmp _ Nothing (Just _) = LT + maybeCmp _ (Just _) Nothing = GT + maybeCmp _ Nothing Nothing = EQ -- | Our own version of 'GHC.stableModuleCmp'. stableModuleCmp :: GHC.Module -> GHC.Module -> Ordering @@ -225,12 +218,12 @@ type CompilingDefault uni fun m ann = , Compiling uni fun m ann ) -blackhole :: (MonadReader (CompileContext uni fun) m) => GHC.Name -> m a -> m a -blackhole name = local (\cc -> cc{ccBlackholed = Set.insert name (ccBlackholed cc)}) +blackhole :: MonadReader (CompileContext uni fun) m => GHC.Name -> m a -> m a +blackhole name = local (\cc -> cc {ccBlackholed = Set.insert name (ccBlackholed cc)}) -blackholed :: (MonadReader (CompileContext uni fun) m) => GHC.Name -> m Bool +blackholed :: MonadReader (CompileContext uni fun) m => GHC.Name -> m Bool blackholed name = do - CompileContext{ccBlackholed = bh} <- ask + CompileContext {ccBlackholed = bh} <- ask pure $ Set.member name bh {- Note [Scopes] @@ -250,12 +243,12 @@ data Scope uni fun initialScope :: Scope uni fun initialScope = Scope Map.empty Map.empty -withCurDef :: (Compiling uni fun m ann) => LexName -> m a -> m a -withCurDef name = local (\cc -> cc{ccCurDef = Just name}) +withCurDef :: Compiling uni fun m ann => LexName -> m a -> m a +withCurDef name = local (\cc -> cc {ccCurDef = Just name}) -modifyCurDeps :: (Compiling uni fun m ann) => (Set.Set LexName -> Set.Set LexName) -> m () +modifyCurDeps :: Compiling uni fun m ann => (Set.Set LexName -> Set.Set LexName) -> m () modifyCurDeps f = do cur <- asks ccCurDef case cur of Nothing -> pure () - Just n -> modifyDeps n f + Just n -> modifyDeps n f diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs index 27d2b5d6c23..9f503cde3bc 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module PlutusTx.Compiler.Utils where @@ -22,49 +22,46 @@ import Language.Haskell.TH.Syntax qualified as TH import Data.Map qualified as Map import Data.Text qualified as T -{-| Get the 'GHC.TyCon' for a given 'TH.Name' stored in the builtin name info, -failing if it is missing. --} -lookupGhcTyCon :: (Compiling uni fun m ann) => TH.Name -> m GHC.TyCon +-- | Get the 'GHC.TyCon' for a given 'TH.Name' stored in the builtin name info, +-- failing if it is missing. +lookupGhcTyCon :: Compiling uni fun m ann => TH.Name -> m GHC.TyCon lookupGhcTyCon thName = do - CompileContext{ccNameInfo} <- ask + CompileContext {ccNameInfo} <- ask case Map.lookup thName ccNameInfo of Just (GHC.ATyCon tc) -> pure tc _ -> throwPlain $ CompilationError $ "TyCon not found: " <> T.pack (show thName) -{-| Get the 'GHC.Name' for a given 'TH.Name' stored in the builtin name info, -failing if it is missing. --} -lookupGhcName :: (Compiling uni fun m ann) => TH.Name -> m GHC.Name +-- | Get the 'GHC.Name' for a given 'TH.Name' stored in the builtin name info, +-- failing if it is missing. +lookupGhcName :: Compiling uni fun m ann => TH.Name -> m GHC.Name lookupGhcName thName = do - CompileContext{ccNameInfo} <- ask + CompileContext {ccNameInfo} <- ask case Map.lookup thName ccNameInfo of Just thing -> pure (GHC.getName thing) - Nothing -> throwPlain $ CompilationError $ "Name not found: " <> T.pack (show thName) + Nothing -> throwPlain $ CompilationError $ "Name not found: " <> T.pack (show thName) -{-| Get the 'GHC.Id' for a given 'TH.Name' stored in the builtin name info, -failing if it is missing. --} -lookupGhcId :: (Compiling uni fun m ann) => TH.Name -> m GHC.Id +-- | Get the 'GHC.Id' for a given 'TH.Name' stored in the builtin name info, +-- failing if it is missing. +lookupGhcId :: Compiling uni fun m ann => TH.Name -> m GHC.Id lookupGhcId thName = do - CompileContext{ccNameInfo} <- ask + CompileContext {ccNameInfo} <- ask case Map.lookup thName ccNameInfo of Just (GHC.AnId ghcId) -> pure ghcId _ -> throwPlain $ CompilationError $ "Id not found: " <> T.pack (show thName) -sdToStr :: (MonadReader (CompileContext uni fun) m) => GHC.SDoc -> m String +sdToStr :: MonadReader (CompileContext uni fun) m => GHC.SDoc -> m String sdToStr sd = do - CompileContext{ccFlags = flags} <- ask + CompileContext {ccFlags = flags} <- ask pure $ GHC.showSDocForUser flags GHC.emptyUnitState GHC.alwaysQualify sd -sdToTxt :: (MonadReader (CompileContext uni fun) m) => GHC.SDoc -> m T.Text +sdToTxt :: MonadReader (CompileContext uni fun) m => GHC.SDoc -> m T.Text sdToTxt = fmap T.pack . sdToStr -throwSd - :: (MonadError (CompileError uni fun ann) m, MonadReader (CompileContext uni fun) m) - => (T.Text -> Error uni fun ann) - -> GHC.SDoc - -> m a +throwSd :: + (MonadError (CompileError uni fun ann) m, MonadReader (CompileContext uni fun) m) => + (T.Text -> Error uni fun ann) -> + GHC.SDoc -> + m a throwSd constr = (throwPlain . constr) <=< sdToTxt tyConsOfExpr :: GHC.CoreExpr -> GHC.UniqSet GHC.TyCon @@ -92,8 +89,8 @@ tyConsOfBind :: GHC.Bind GHC.CoreBndr -> GHC.UniqSet GHC.TyCon tyConsOfBind = \case GHC.NonRec bndr rhs -> binderTyCons bndr rhs GHC.Rec bndrs -> foldMap (uncurry binderTyCons) bndrs - where - binderTyCons bndr rhs = tyConsOfBndr bndr <> tyConsOfExpr rhs + where + binderTyCons bndr rhs = tyConsOfBndr bndr <> tyConsOfExpr rhs tyConsOfAlt :: GHC.CoreAlt -> GHC.UniqSet GHC.TyCon tyConsOfAlt (GHC.Alt _ vars e) = foldMap tyConsOfBndr vars <> tyConsOfExpr e diff --git a/plutus-tx-plugin/src/PlutusTx/Options.hs b/plutus-tx-plugin/src/PlutusTx/Options.hs index fa2237998a8..033b28661c3 100644 --- a/plutus-tx-plugin/src/PlutusTx/Options.hs +++ b/plutus-tx-plugin/src/PlutusTx/Options.hs @@ -1,12 +1,12 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module PlutusTx.Options where @@ -40,42 +40,42 @@ import Text.Read (readMaybe) import Type.Reflection data PluginOptions = PluginOptions - { _posPlcTargetVersion :: PLC.Version - , _posDoTypecheck :: Bool - , _posDeferErrors :: Bool - , _posConservativeOpts :: Bool - , _posContextLevel :: Int - , _posDumpPir :: Bool - , _posDumpPlc :: Bool - , _posDumpUPlc :: Bool - , _posOptimize :: Bool - , _posPedantic :: Bool - , _posVerbosity :: Verbosity - , _posDatatypes :: PIR.DatatypeCompilationOpts - , _posMaxSimplifierIterationsPir :: Int - , _posMaxSimplifierIterationsUPlc :: Int - , _posMaxCseIterations :: Int - , _posDoSimplifierUnwrapCancel :: Bool - , _posDoSimplifierBeta :: Bool - , _posDoSimplifierInline :: Bool - , _posDoSimplifierEvaluateBuiltins :: Bool - , _posDoSimplifierStrictifyBindings :: Bool + { _posPlcTargetVersion :: PLC.Version + , _posDoTypecheck :: Bool + , _posDeferErrors :: Bool + , _posConservativeOpts :: Bool + , _posContextLevel :: Int + , _posDumpPir :: Bool + , _posDumpPlc :: Bool + , _posDumpUPlc :: Bool + , _posOptimize :: Bool + , _posPedantic :: Bool + , _posVerbosity :: Verbosity + , _posDatatypes :: PIR.DatatypeCompilationOpts + , _posMaxSimplifierIterationsPir :: Int + , _posMaxSimplifierIterationsUPlc :: Int + , _posMaxCseIterations :: Int + , _posDoSimplifierUnwrapCancel :: Bool + , _posDoSimplifierBeta :: Bool + , _posDoSimplifierInline :: Bool + , _posDoSimplifierEvaluateBuiltins :: Bool + , _posDoSimplifierStrictifyBindings :: Bool , _posDoSimplifierRemoveDeadBindings :: Bool - , _posProfile :: ProfileOpts - , _posCoverageAll :: Bool - , _posCoverageLocation :: Bool - , _posCoverageBoolean :: Bool - , _posRelaxedFloatin :: Bool - , _posCaseOfCaseConservative :: Bool - , _posInlineCallsiteGrowth :: Int - , _posInlineConstants :: Bool - , _posInlineFix :: Bool - , _posPreserveLogging :: Bool + , _posProfile :: ProfileOpts + , _posCoverageAll :: Bool + , _posCoverageLocation :: Bool + , _posCoverageBoolean :: Bool + , _posRelaxedFloatin :: Bool + , _posCaseOfCaseConservative :: Bool + , _posInlineCallsiteGrowth :: Int + , _posInlineConstants :: Bool + , _posInlineFix :: Bool + , _posPreserveLogging :: Bool -- ^ Whether to try and retain the logging behaviour of the program. , -- Setting to `True` defines `trace` as `\_ a -> a` instead of the builtin version. -- Which effectively ignores the trace text. - _posRemoveTrace :: Bool - , _posDumpCompilationTrace :: Bool + _posRemoveTrace :: Bool + , _posDumpCompilationTrace :: Bool } makeLenses ''PluginOptions @@ -89,22 +89,20 @@ data Implication a = forall b. Implication (a -> Bool) (Lens' PluginOptions b) b -- | A plugin option definition for a `PluginOptions` field of type @a@. data PluginOption = forall a. - (Pretty a) => + Pretty a => PluginOption - { poTypeRep :: TypeRep a + { poTypeRep :: TypeRep a -- ^ `TypeRep` used for pretty printing the option. - , poFun :: Maybe OptionValue -> Validation ParseError (a -> a) + , poFun :: Maybe OptionValue -> Validation ParseError (a -> a) -- ^ Consumes an optional value, and either updates the field or reports an error. - , poLens :: Lens' PluginOptions a - {- ^ Lens focusing on the field. This is for modifying the field, as well as - getting the field value from `defaultPluginOptions` for pretty printing. - -} - , poDescription :: Text + , poLens :: Lens' PluginOptions a + -- ^ Lens focusing on the field. This is for modifying the field, as well as + -- getting the field value from `defaultPluginOptions` for pretty printing. + , poDescription :: Text -- ^ A description of the option. , poImplications :: [Implication a] - {- ^ Implications of this option being set to a particular value. - An option should not imply itself. - -} + -- ^ Implications of this option being set to a particular value. + -- An option should not imply itself. } data ParseError @@ -143,7 +141,7 @@ renderParseError = \case UnrecognisedOption k suggs -> "Unrecognised option: " <> Text.pack (show k) <> "." <> case suggs of [] -> "" - _ -> "\nDid you mean one of:\n" <> Text.intercalate "\n" suggs + _ -> "\nDid you mean one of:\n" <> Text.intercalate "\n" suggs -- | Definition of plugin options. pluginOptions :: Map OptionKey PluginOption @@ -318,12 +316,12 @@ setTrue = flag (const True) plcParserOption :: PLC.Parser a -> OptionKey -> Maybe OptionValue -> Validation ParseError (a -> a) plcParserOption p k = \case Just t -> case PLC.runQuoteT $ PLC.parse p "none" t of - Right v -> Success $ const v + Right v -> Success $ const v -- TODO: use the error Left (_e :: PLC.ParserErrorBundle) -> Failure $ CannotParseValue k t (someTypeRep (Proxy @Int)) Nothing -> Failure $ MissingValue k -readOption :: (Read a) => OptionKey -> Maybe OptionValue -> Validation ParseError (a -> a) +readOption :: Read a => OptionKey -> Maybe OptionValue -> Validation ParseError (a -> a) readOption k = \case Just v | Just i <- readMaybe (Text.unpack v) -> Success $ const i @@ -331,12 +329,12 @@ readOption k = \case Nothing -> Failure $ MissingValue k -- | Obtain an option value of type @a@ from an `Int`. -fromReadOption - :: (Read a) - => OptionKey - -> (a -> Validation ParseError b) - -> Maybe OptionValue - -> Validation ParseError (b -> b) +fromReadOption :: + Read a => + OptionKey -> + (a -> Validation ParseError b) -> + Maybe OptionValue -> + Validation ParseError (b -> b) fromReadOption k f = \case Just v | Just i <- readMaybe (Text.unpack v) -> const <$> f i @@ -381,10 +379,10 @@ defaultPluginOptions = , _posDumpCompilationTrace = False } -processOne - :: OptionKey - -> Maybe OptionValue - -> Validation ParseError (PluginOptions -> PluginOptions) +processOne :: + OptionKey -> + Maybe OptionValue -> + Validation ParseError (PluginOptions -> PluginOptions) processOne key val | Just (PluginOption _ f field _ impls) <- Map.lookup key pluginOptions = fmap (applyImplications field impls) . over field <$> f val @@ -408,9 +406,9 @@ applyImplications field = ) id -processAll - :: [(OptionKey, Maybe OptionValue)] - -> Validation ParseErrors [PluginOptions -> PluginOptions] +processAll :: + [(OptionKey, Maybe OptionValue)] -> + Validation ParseErrors [PluginOptions -> PluginOptions] processAll = traverse $ first (ParseErrors . pure) . uncurry processOne toKeyValue :: GHC.CommandLineOption -> (OptionKey, Maybe OptionValue) @@ -420,8 +418,7 @@ toKeyValue opt = case List.elemIndex '=' opt of let (lhs, rhs) = splitAt idx opt in (Text.pack lhs, Just (Text.pack (drop 1 rhs))) -{-| Parses the arguments that were given to ghc at commandline as - "-fplugin-opt PlutusTx.Plugin:opt" or "-fplugin-opt PlutusTx.Plugin:opt=val" --} +-- | Parses the arguments that were given to ghc at commandline as +-- "-fplugin-opt PlutusTx.Plugin:opt" or "-fplugin-opt PlutusTx.Plugin:opt=val" parsePluginOptions :: [GHC.CommandLineOption] -> Validation ParseErrors PluginOptions parsePluginOptions = fmap (foldl' (flip ($)) defaultPluginOptions) . processAll . fmap toKeyValue diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index 6464ef65e06..66458a9b3d0 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -- For some reason this module is very slow to compile otherwise {-# OPTIONS_GHC -O0 #-} @@ -87,10 +87,10 @@ import System.IO (openBinaryTempFile) import System.IO.Unsafe (unsafePerformIO) data PluginCtx = PluginCtx - { pcOpts :: PluginOptions - , pcFamEnvs :: GHC.FamInstEnvs - , pcMarkerName :: GHC.Name - , pcModuleName :: GHC.ModuleName + { pcOpts :: PluginOptions + , pcFamEnvs :: GHC.FamInstEnvs + , pcMarkerName :: GHC.Name + , pcModuleName :: GHC.ModuleName , pcModuleModBreaks :: Maybe GHC.ModBreaks } @@ -127,21 +127,21 @@ plugin = { GHC.pluginRecompile = GHC.flagRecompile , GHC.installCoreToDos = install } - where - install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo] - install args rest = do - -- create simplifier pass to be placed at the front - simplPass <- mkSimplPass <$> GHC.getDynFlags - -- instantiate our plugin pass - pluginPass <- - mkPluginPass <$> case parsePluginOptions args of - Success opts -> pure opts - Failure errs -> liftIO $ throwIO errs - -- return the pipeline - pure $ - simplPass - : pluginPass - : rest + where + install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo] + install args rest = do + -- create simplifier pass to be placed at the front + simplPass <- mkSimplPass <$> GHC.getDynFlags + -- instantiate our plugin pass + pluginPass <- + mkPluginPass <$> case parsePluginOptions args of + Success opts -> pure opts + Failure errs -> liftIO $ throwIO errs + -- return the pipeline + pure $ + simplPass + : pluginPass + : rest {- Note [GHC.sm_pre_inline] We run a GHC simplifier pass before the plugin, in which we turn on `sm_pre_inline`, which @@ -197,28 +197,28 @@ mkSimplPass dflags = , GHC.so_hpt_rules = GHC.emptyRuleBase , GHC.so_top_env_cfg = GHC.TopEnvConfig 0 0 } - where - simplMode = - GHC.SimplMode - { GHC.sm_names = ["Ensure unfoldings are present"] - , GHC.sm_phase = GHC.InitialPhase - , GHC.sm_uf_opts = GHC.defaultUnfoldingOpts - , GHC.sm_rules = False - , GHC.sm_cast_swizzle = True - , -- See Note [GHC.sm_pre_inline] - GHC.sm_pre_inline = True - , -- You might think you would need this, but apparently not - GHC.sm_inline = False - , GHC.sm_case_case = False - , GHC.sm_eta_expand = False - , GHC.sm_float_enable = GHC.FloatDisabled - , GHC.sm_do_eta_reduction = False - , GHC.sm_arity_opts = GHC.ArityOpts False False - , GHC.sm_rule_opts = GHC.RuleOpts (GHC.targetPlatform dflags) False True False - , GHC.sm_case_folding = False - , GHC.sm_case_merge = False - , GHC.sm_co_opt_opts = GHC.OptCoercionOpts False - } + where + simplMode = + GHC.SimplMode + { GHC.sm_names = ["Ensure unfoldings are present"] + , GHC.sm_phase = GHC.InitialPhase + , GHC.sm_uf_opts = GHC.defaultUnfoldingOpts + , GHC.sm_rules = False + , GHC.sm_cast_swizzle = True + , -- See Note [GHC.sm_pre_inline] + GHC.sm_pre_inline = True + , -- You might think you would need this, but apparently not + GHC.sm_inline = False + , GHC.sm_case_case = False + , GHC.sm_eta_expand = False + , GHC.sm_float_enable = GHC.FloatDisabled + , GHC.sm_do_eta_reduction = False + , GHC.sm_arity_opts = GHC.ArityOpts False False + , GHC.sm_rule_opts = GHC.RuleOpts (GHC.targetPlatform dflags) False True False + , GHC.sm_case_folding = False + , GHC.sm_case_merge = False + , GHC.sm_co_opt_opts = GHC.OptCoercionOpts False + } {- Note [Marker resolution] We use TH's 'foo exact syntax for resolving the 'plc marker's ghc name, as explained in: @@ -239,10 +239,9 @@ This dynamic approach comes with its own downsides however, because the user may have imported "plc" qualified or aliased it, which will fail to resolve. -} -{-| Our plugin works at haskell-module level granularity; the plugin -looks at the module's top-level bindings for plc markers and compiles their right-hand-side core -expressions. --} +-- | Our plugin works at haskell-module level granularity; the plugin +-- looks at the module's top-level bindings for plc markers and compiles their right-hand-side core +-- expressions. mkPluginPass :: PluginOptions -> GHC.CoreToDo mkPluginPass opts = GHC.CoreDoPluginPass "Core to PLC" $ \guts -> do -- Family env code borrowed from SimplCore @@ -265,15 +264,14 @@ mkPluginPass opts = GHC.CoreDoPluginPass "Core to PLC" $ \guts -> do in -- start looking for plc calls from the top-level binds GHC.bindsOnlyPass (runPluginM pctx . traverse compileBind) guts -{-| The monad where the plugin runs in for each module. -It is a core->core compiler monad, called PluginM, augmented with pure errors. --} +-- | The monad where the plugin runs in for each module. +-- It is a core->core compiler monad, called PluginM, augmented with pure errors. type PluginM uni fun = ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) GHC.CoreM) -- | Runs the plugin monad in a given context; throws a Ghc.Exception when compilation fails. -runPluginM - :: (PLC.PrettyUni uni, PP.Pretty fun) - => PluginCtx -> PluginM uni fun a -> GHC.CoreM a +runPluginM :: + (PLC.PrettyUni uni, PP.Pretty fun) => + PluginCtx -> PluginM uni fun a -> GHC.CoreM a runPluginM pctx act = do res <- runExceptT $ runReaderT act pctx case res of @@ -353,13 +351,12 @@ compileMarkedExprs expr = do e@(GHC.Var _) -> pure e e@(GHC.Type _) -> pure e -{-| Behaves the same as 'compileMarkedExpr', unless a compilation error occurs ; -if a compilation error happens and the 'defer-errors' option is turned on, -the compilation error is suppressed and the original hs expression is replaced with a -haskell runtime-error expression. --} -compileMarkedExprOrDefer - :: String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr +-- | Behaves the same as 'compileMarkedExpr', unless a compilation error occurs ; +-- if a compilation error happens and the 'defer-errors' option is turned on, +-- the compilation error is suppressed and the original hs expression is replaced with a +-- haskell runtime-error expression. +compileMarkedExprOrDefer :: + String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr compileMarkedExprOrDefer locStr codeTy origE = do opts <- asks pcOpts let compileAct = compileMarkedExpr locStr codeTy origE @@ -369,12 +366,11 @@ compileMarkedExprOrDefer locStr codeTy origE = do then compileAct `catchError` emitRuntimeError codeTy else compileAct -{-| Given an expected Haskell type 'a', it generates Haskell code which throws a GHC runtime error -\"as\" 'CompiledCode a'. --} -emitRuntimeError - :: (PLC.PrettyUni uni, PP.Pretty fun) - => GHC.Type -> CompileError uni fun Ann -> PluginM uni fun GHC.CoreExpr +-- | Given an expected Haskell type 'a', it generates Haskell code which throws a GHC runtime error +-- \"as\" 'CompiledCode a'. +emitRuntimeError :: + (PLC.PrettyUni uni, PP.Pretty fun) => + GHC.Type -> CompileError uni fun Ann -> PluginM uni fun GHC.CoreExpr emitRuntimeError codeTy e = do opts <- asks pcOpts let shown = show $ PP.pretty (pruneContext (_posContextLevel opts) e) @@ -382,12 +378,11 @@ emitRuntimeError codeTy e = do tc <- lift . lift $ GHC.lookupTyCon tcName pure $ GHC.mkImpossibleExpr (GHC.mkTyConApp tc [codeTy]) shown -{-| Compile the core expression that is surrounded by a 'plc' marker, -and return a core expression which evaluates to the compiled plc AST as a serialized bytestring, -to be injected back to the Haskell program. --} -compileMarkedExpr - :: String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr +-- | Compile the core expression that is surrounded by a 'plc' marker, +-- and return a core expression which evaluates to the compiled plc AST as a serialized bytestring, +-- to be injected back to the Haskell program. +compileMarkedExpr :: + String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr compileMarkedExpr locStr codeTy origE = do flags <- GHC.getDynFlags famEnvs <- asks pcFamEnvs @@ -472,32 +467,32 @@ compileMarkedExpr locStr codeTy origE = do `GHC.App` bsPir `GHC.App` covIdxFlat -{-| The GHC.Core to PIR to PLC compiler pipeline. Returns both the PIR and PLC output. -It invokes the whole compiler chain: Core expr -> PIR expr -> PLC expr -> UPLC expr. --} -runCompiler - :: forall uni fun m - . ( uni ~ PLC.DefaultUni - , fun ~ PLC.DefaultFun - , MonadReader (CompileContext uni fun) m - , MonadState CompileState m - , MonadWriter CoverageIndex m - , MonadQuote m - , MonadError (CompileError uni fun Ann) m - , MonadIO m - ) - => String - -> PluginOptions - -> GHC.CoreExpr - -> m (PIRProgram uni fun, UPLCProgram uni fun) +-- | The GHC.Core to PIR to PLC compiler pipeline. Returns both the PIR and PLC output. +-- It invokes the whole compiler chain: Core expr -> PIR expr -> PLC expr -> UPLC expr. +runCompiler :: + forall uni fun m. + ( uni ~ PLC.DefaultUni + , fun ~ PLC.DefaultFun + , MonadReader (CompileContext uni fun) m + , MonadState CompileState m + , MonadWriter CoverageIndex m + , MonadQuote m + , MonadError (CompileError uni fun Ann) m + , MonadIO m + ) => + String -> + PluginOptions -> + GHC.CoreExpr -> + m (PIRProgram uni fun, UPLCProgram uni fun) runCompiler moduleName opts expr = do GHC.DynFlags {GHC.extensions = extensions} <- asks ccFlags let enabledExtensions = mapMaybe - (\case + ( \case GHC.On a -> Just a - GHC.Off _ -> Nothing) + GHC.Off _ -> Nothing + ) extensions extensionBlacklist = [ GADTs @@ -507,9 +502,10 @@ runCompiler moduleName opts expr = do filter (`elem` extensionBlacklist) enabledExtensions when (not $ null unsupportedExtensions) $ - throwPlain $ UnsupportedError $ - "Following extensions are not supported: " - <> Text.intercalate ", " (Text.pack . show <$> unsupportedExtensions) + throwPlain $ + UnsupportedError $ + "Following extensions are not supported: " + <> Text.intercalate ", " (Text.pack . show <$> unsupportedExtensions) -- Plc configuration plcTcConfig <- @@ -621,52 +617,53 @@ runCompiler moduleName opts expr = do modifyError (NoContext . PIRError) $ PIR.compileToReadable pirP when (opts ^. posDumpPir) . liftIO $ - dumpFlat (void spirP) "simplified PIR program" (moduleName ++ "_simplified.pir-flat") + dumpFlat (void spirP) "simplified PIR program" (moduleName ++ "_simplified.pir-flat") -- (Simplified) Pir -> Plc translation. - plcP <- flip runReaderT pirCtx $ - modifyError (NoContext . PIRError) $ - PIR.compileReadableToPlc spirP + plcP <- + flip runReaderT pirCtx $ + modifyError (NoContext . PIRError) $ + PIR.compileReadableToPlc spirP when (opts ^. posDumpPlc) . liftIO $ - dumpFlat (void plcP) "typed PLC program" (moduleName ++ ".tplc-flat") + dumpFlat (void plcP) "typed PLC program" (moduleName ++ ".tplc-flat") -- We do this after dumping the programs so that if we fail typechecking we still get the dump. when (opts ^. posDoTypecheck) . void $ - liftExcept $ - modifyError PLC.TypeErrorE $ - PLC.inferTypeOfProgram plcTcConfig (plcP $> annMayInline) + liftExcept $ + modifyError PLC.TypeErrorE $ + PLC.inferTypeOfProgram plcTcConfig (plcP $> annMayInline) (uplcP, _) <- flip runReaderT plcOpts $ PLC.compileProgramWithTrace plcP dbP <- liftExcept $ modifyError PLC.FreeVariableErrorE $ traverseOf UPLC.progTerm UPLC.deBruijnTerm uplcP when (opts ^. posDumpUPlc) . liftIO $ - dumpFlat - (UPLC.UnrestrictedProgram $ void dbP) - "untyped PLC program" - (moduleName ++ ".uplc-flat") + dumpFlat + (UPLC.UnrestrictedProgram $ void dbP) + "untyped PLC program" + (moduleName ++ ".uplc-flat") -- Discard the Provenance information at this point, just keep the SrcSpans -- TODO: keep it and do something useful with it pure (fmap getSrcSpans spirP, fmap getSrcSpans dbP) - where - -- ugly trick to take out the concrete plc.error and in case of error, map it / rethrow it - -- using our 'CompileError' - liftExcept :: ExceptT (PLC.Error PLC.DefaultUni PLC.DefaultFun Ann) m b -> m b - liftExcept = modifyError (NoContext . PLCError) + where + -- ugly trick to take out the concrete plc.error and in case of error, map it / rethrow it + -- using our 'CompileError' + liftExcept :: ExceptT (PLC.Error PLC.DefaultUni PLC.DefaultFun Ann) m b -> m b + liftExcept = modifyError (NoContext . PLCError) - dumpFlat :: (Flat t) => t -> String -> String -> IO () - dumpFlat t desc fileName = do - (tPath, tHandle) <- openBinaryTempFile "." fileName - putStrLn $ "!!! dumping " ++ desc ++ " to " ++ show tPath - BS.hPut tHandle $ flat t + dumpFlat :: Flat t => t -> String -> String -> IO () + dumpFlat t desc fileName = do + (tPath, tHandle) <- openBinaryTempFile "." fileName + putStrLn $ "!!! dumping " ++ desc ++ " to " ++ show tPath + BS.hPut tHandle $ flat t - getSrcSpans :: PIR.Provenance Ann -> SrcSpans - getSrcSpans = SrcSpans . Set.unions . fmap (unSrcSpans . annSrcSpans) . toList + getSrcSpans :: PIR.Provenance Ann -> SrcSpans + getSrcSpans = SrcSpans . Set.unions . fmap (unSrcSpans . annSrcSpans) . toList -- | Get the 'GHC.Name' corresponding to the given 'TH.Name', or throw an error if we can't get it. thNameToGhcNameOrFail :: TH.Name -> PluginM uni fun GHC.Name thNameToGhcNameOrFail name = do maybeName <- lift . lift $ GHC.thNameToGhcName name case maybeName of - Just n -> pure n + Just n -> pure n Nothing -> throwError . NoContext $ CoreNameLookupError name -- | Create a GHC Core expression that will evaluate to the given ByteString at runtime. @@ -710,9 +707,8 @@ stripTicks = \case mkCompiledCode :: forall a. BS.ByteString -> BS.ByteString -> BS.ByteString -> CompiledCode a mkCompiledCode plcBS pirBS ci = SerializedCode plcBS (Just pirBS) (fold . unflat $ ci) -{-| Make a 'NameInfo' mapping the given set of TH names to their -'GHC.TyThing's for later reference. --} +-- | Make a 'NameInfo' mapping the given set of TH names to their +-- 'GHC.TyThing's for later reference. makePrimitiveNameInfo :: [TH.Name] -> PluginM uni fun NameInfo makePrimitiveNameInfo names = do infos <- for names $ \name -> do diff --git a/plutus-tx-plugin/test/AsData/Budget/Spec.hs b/plutus-tx-plugin/test/AsData/Budget/Spec.hs index 2776659fbd5..725aa5409b3 100644 --- a/plutus-tx-plugin/test/AsData/Budget/Spec.hs +++ b/plutus-tx-plugin/test/AsData/Budget/Spec.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module AsData.Budget.Spec where @@ -14,8 +14,8 @@ import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.Code import PlutusTx.IsData qualified as PlutusTx import PlutusTx.Lift (liftCodeDef) -import PlutusTx.Test (goldenBundle) import PlutusTx.TH (compile) +import PlutusTx.Test (goldenBundle) tests :: TestNested tests = @@ -41,7 +41,7 @@ onlyUseFirstField = $$( compile [|| \d -> case PlutusTx.unsafeFromBuiltinData d of - Ints{int1 = x} -> x + Ints {int1 = x} -> x ||] ) @@ -50,7 +50,7 @@ onlyUseFirstFieldManual = $$( compile [|| \d -> case PlutusTx.unsafeFromBuiltinData d of - IntsManual{int1Manual = x} -> x + IntsManual {int1Manual = x} -> x ||] ) diff --git a/plutus-tx-plugin/test/AsData/Budget/Types.hs b/plutus-tx-plugin/test/AsData/Budget/Types.hs index f8a255e65dd..7ab0b15d442 100644 --- a/plutus-tx-plugin/test/AsData/Budget/Types.hs +++ b/plutus-tx-plugin/test/AsData/Budget/Types.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module AsData.Budget.Types where @@ -33,7 +33,7 @@ newtype IntsManual = IntsManualDataCon PlutusTx.BuiltinData deriving newtype (PlutusTx.Eq, PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) pattern IntsManual :: Integer -> Integer -> Integer -> Integer -> IntsManual -pattern IntsManual{int1Manual, int2Manual, int3Manual, int4Manual} <- +pattern IntsManual {int1Manual, int2Manual, int3Manual, int4Manual} <- IntsManualDataCon ( wrapUnsafeDataAsConstr -> BI.snd -> @@ -95,17 +95,17 @@ pattern ThatDManual arg <- TheseDManual_ (BI.mkConstr 1 (BI.mkCons (PlutusTx.toBuiltinData arg) (BI.mkNilData BI.unitval))) -unpack1 :: (PlutusTx.UnsafeFromData a) => BI.BuiltinList BI.BuiltinData -> a +unpack1 :: PlutusTx.UnsafeFromData a => BI.BuiltinList BI.BuiltinData -> a unpack1 = PlutusTx.unsafeFromBuiltinData . BI.head -pattern TheseDManual - :: ( PlutusTx.ToData a - , PlutusTx.UnsafeFromData a - , PlutusTx.ToData b - , PlutusTx.UnsafeFromData b - ) - => a -> b -> TheseDManual a b +pattern TheseDManual :: + ( PlutusTx.ToData a + , PlutusTx.UnsafeFromData a + , PlutusTx.ToData b + , PlutusTx.UnsafeFromData b + ) => + a -> b -> TheseDManual a b pattern TheseDManual arg1 arg2 <- TheseDManual_ (BI.unsafeDataAsConstr -> B.pairToPair -> ((PlutusTx.==) 2 -> True, unpack2 -> (arg1, arg2))) @@ -123,9 +123,9 @@ pattern TheseDManual arg1 arg2 <- ) ) -unpack2 - :: (PlutusTx.UnsafeFromData a, PlutusTx.UnsafeFromData b) - => BI.BuiltinList BI.BuiltinData -> (a, b) +unpack2 :: + (PlutusTx.UnsafeFromData a, PlutusTx.UnsafeFromData b) => + BI.BuiltinList BI.BuiltinData -> (a, b) unpack2 args = let x = PlutusTx.unsafeFromBuiltinData $ BI.head args rest = BI.tail args diff --git a/plutus-tx-plugin/test/AssocMap/Golden.hs b/plutus-tx-plugin/test/AssocMap/Golden.hs index 3e39acf7ea1..ed5682415a7 100644 --- a/plutus-tx-plugin/test/AssocMap/Golden.hs +++ b/plutus-tx-plugin/test/AssocMap/Golden.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -- CSE is very unstable and produces different output, likely depending on the version of either -- @unordered-containers@ or @hashable@. {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module AssocMap.Golden where @@ -28,16 +28,16 @@ import PlutusTx.TH (compile) import PlutusTx.These (these) -- | Test the performance and interaction between 'insert', 'delete' and 'lookup'. -map1 - :: CompiledCode - ( Integer - -> ( Maybe Integer - , Maybe Integer - , Maybe Integer - , Maybe Integer - , Maybe Integer - ) - ) +map1 :: + CompiledCode + ( Integer -> + ( Maybe Integer + , Maybe Integer + , Maybe Integer + , Maybe Integer + , Maybe Integer + ) + ) map1 = $$( compile [|| @@ -58,10 +58,9 @@ map1 = ||] ) -{-| Test that 'unionWith' is implemented correctly. Due to the nature of 'Map k v', -some type errors are only caught when running the PlutusTx compiler on code which uses -'unionWith'. --} +-- | Test that 'unionWith' is implemented correctly. Due to the nature of 'Map k v', +-- some type errors are only caught when running the PlutusTx compiler on code which uses +-- 'unionWith'. map2 :: CompiledCode (Integer -> [(Integer, Integer)]) map2 = $$( compile @@ -88,9 +87,8 @@ map2 = ||] ) -{-| Similar to map2, but uses 'union' instead of 'unionWith'. Evaluating 'map3' and 'map2' -should yield the same result. --} +-- | Similar to map2, but uses 'union' instead of 'unionWith'. Evaluating 'map3' and 'map2' +-- should yield the same result. map3 :: CompiledCode (Integer -> [(Integer, Integer)]) map3 = $$( compile diff --git a/plutus-tx-plugin/test/AssocMap/Properties1.hs b/plutus-tx-plugin/test/AssocMap/Properties1.hs index b8f425cea06..7fdee802c2e 100644 --- a/plutus-tx-plugin/test/AssocMap/Properties1.hs +++ b/plutus-tx-plugin/test/AssocMap/Properties1.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -- CSE is very unstable and produces different output, likely depending on the version of either @@ -28,8 +28,8 @@ import PlutusTx.IsData () import PlutusTx.Lift (liftCodeDef) import PlutusTx.List qualified as PlutusTx import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import PlutusTx.TH (compile) +import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import AssocMap.Semantics @@ -45,13 +45,13 @@ memberProgram = $$(compile [||AssocMap.member||]) dataMemberProgram :: CompiledCode (Integer -> Data.AssocMap.Map Integer Integer -> Bool) dataMemberProgram = $$(compile [||Data.AssocMap.member||]) -insertProgram - :: CompiledCode - ( Integer - -> Integer - -> AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +insertProgram :: + CompiledCode + ( Integer -> + Integer -> + AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) insertProgram = $$( compile [|| @@ -60,13 +60,13 @@ insertProgram = ||] ) -dataInsertProgram - :: CompiledCode - ( Integer - -> Integer - -> Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +dataInsertProgram :: + CompiledCode + ( Integer -> + Integer -> + Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) dataInsertProgram = $$( compile [|| @@ -75,12 +75,12 @@ dataInsertProgram = ||] ) -deleteProgram - :: CompiledCode - ( Integer - -> AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +deleteProgram :: + CompiledCode + ( Integer -> + AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) deleteProgram = $$( compile [|| @@ -89,12 +89,12 @@ deleteProgram = ||] ) -dataDeleteProgram - :: CompiledCode - ( Integer - -> Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +dataDeleteProgram :: + CompiledCode + ( Integer -> + Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) dataDeleteProgram = $$( compile [|| @@ -103,30 +103,30 @@ dataDeleteProgram = ||] ) -allProgram - :: CompiledCode - ( Integer - -> AssocMap.Map Integer Integer - -> Bool - ) +allProgram :: + CompiledCode + ( Integer -> + AssocMap.Map Integer Integer -> + Bool + ) allProgram = $$(compile [||\num m -> AssocMap.all (\x -> x PlutusTx.< num) m||]) -dataAllProgram - :: CompiledCode - ( Integer - -> Data.AssocMap.Map Integer Integer - -> Bool - ) +dataAllProgram :: + CompiledCode + ( Integer -> + Data.AssocMap.Map Integer Integer -> + Bool + ) dataAllProgram = $$(compile [||\num m -> Data.AssocMap.all (\x -> x PlutusTx.< num) m||]) -dataAnyProgram - :: CompiledCode - ( Integer - -> Data.AssocMap.Map Integer Integer - -> Bool - ) +dataAnyProgram :: + CompiledCode + ( Integer -> + Data.AssocMap.Map Integer Integer -> + Bool + ) dataAnyProgram = $$(compile [||\num m -> Data.AssocMap.any (\x -> x PlutusTx.< num) m||]) diff --git a/plutus-tx-plugin/test/AssocMap/Properties2.hs b/plutus-tx-plugin/test/AssocMap/Properties2.hs index 698ddbd798d..8e230f0cc62 100644 --- a/plutus-tx-plugin/test/AssocMap/Properties2.hs +++ b/plutus-tx-plugin/test/AssocMap/Properties2.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -- CSE is very unstable and produces different output, likely depending on the version of either @@ -29,49 +29,49 @@ import PlutusTx.IsData () import PlutusTx.Lift (liftCodeDef) import PlutusTx.List qualified as PlutusTx import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import PlutusTx.TH (compile) +import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import AssocMap.Semantics -keysProgram - :: CompiledCode - ( AssocMap.Map Integer Integer - -> [Integer] - ) +keysProgram :: + CompiledCode + ( AssocMap.Map Integer Integer -> + [Integer] + ) keysProgram = $$(compile [||AssocMap.keys||]) -dataKeysProgram - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> [Integer] - ) +dataKeysProgram :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + [Integer] + ) dataKeysProgram = $$(compile [||Data.List.toSOP . Data.AssocMap.keys||]) -elemsProgram - :: CompiledCode - ( AssocMap.Map Integer Integer - -> [Integer] - ) +elemsProgram :: + CompiledCode + ( AssocMap.Map Integer Integer -> + [Integer] + ) elemsProgram = $$(compile [||AssocMap.elems||]) -dataElemsProgram - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> [Integer] - ) +dataElemsProgram :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + [Integer] + ) dataElemsProgram = $$(compile [||Data.List.toSOP . Data.AssocMap.elems||]) -filterProgram - :: CompiledCode - ( Integer - -> AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +filterProgram :: + CompiledCode + ( Integer -> + AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) filterProgram = $$( compile [|| @@ -82,12 +82,12 @@ filterProgram = ||] ) -dataFilterProgram - :: CompiledCode - ( Integer - -> Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +dataFilterProgram :: + CompiledCode + ( Integer -> + Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) dataFilterProgram = $$( compile [|| @@ -98,11 +98,11 @@ dataFilterProgram = ||] ) -mapWithKeyProgram - :: CompiledCode - ( AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +mapWithKeyProgram :: + CompiledCode + ( AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) mapWithKeyProgram = $$( compile [|| @@ -113,11 +113,11 @@ mapWithKeyProgram = ||] ) -dataMapWithKeyProgram - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +dataMapWithKeyProgram :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) dataMapWithKeyProgram = $$( compile [|| @@ -128,12 +128,12 @@ dataMapWithKeyProgram = ||] ) -mapMaybeProgram - :: CompiledCode - ( Integer - -> AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +mapMaybeProgram :: + CompiledCode + ( Integer -> + AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) mapMaybeProgram = $$( compile [|| @@ -146,12 +146,12 @@ mapMaybeProgram = ||] ) -dataMapMaybeProgram - :: CompiledCode - ( Integer - -> Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +dataMapMaybeProgram :: + CompiledCode + ( Integer -> + Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) dataMapMaybeProgram = $$( compile [|| @@ -164,11 +164,11 @@ dataMapMaybeProgram = ||] ) -mapMaybeWithKeyProgram - :: CompiledCode - ( AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +mapMaybeWithKeyProgram :: + CompiledCode + ( AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) mapMaybeWithKeyProgram = $$( compile [|| @@ -181,11 +181,11 @@ mapMaybeWithKeyProgram = ||] ) -dataMapMaybeWithKeyProgram - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +dataMapMaybeWithKeyProgram :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) dataMapMaybeWithKeyProgram = $$( compile [|| @@ -198,11 +198,11 @@ dataMapMaybeWithKeyProgram = ||] ) -dataNoDuplicateKeysProgram - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> Bool - ) +dataNoDuplicateKeysProgram :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + Bool + ) dataNoDuplicateKeysProgram = $$(compile [||Data.AssocMap.noDuplicateKeys||]) diff --git a/plutus-tx-plugin/test/AssocMap/Properties3.hs b/plutus-tx-plugin/test/AssocMap/Properties3.hs index 6dff4504357..c8028a396d0 100644 --- a/plutus-tx-plugin/test/AssocMap/Properties3.hs +++ b/plutus-tx-plugin/test/AssocMap/Properties3.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -- CSE is very unstable and produces different output, likely depending on the version of either @@ -30,19 +30,19 @@ import PlutusTx.IsData qualified as P import PlutusTx.Lift (liftCodeDef) import PlutusTx.List qualified as PlutusTx import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test.Run.Code (evalResult, evaluateCompiledCode, evaluationResultMatchesHaskell) import PlutusTx.TH (compile) +import PlutusTx.Test.Run.Code (evalResult, evaluateCompiledCode, evaluationResultMatchesHaskell) import PlutusTx.These (These (..)) import AssocMap.Semantics -unionProgram - :: CompiledCode - ( AssocMap.Map Integer Integer - -> AssocMap.Map Integer Integer - -> [(Integer, These Integer Integer)] - ) +unionProgram :: + CompiledCode + ( AssocMap.Map Integer Integer -> + AssocMap.Map Integer Integer -> + [(Integer, These Integer Integer)] + ) unionProgram = $$( compile [|| @@ -51,12 +51,12 @@ unionProgram = ||] ) -dataUnionProgram - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> Data.AssocMap.Map Integer Integer - -> [(Integer, These Integer Integer)] - ) +dataUnionProgram :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + Data.AssocMap.Map Integer Integer -> + [(Integer, These Integer Integer)] + ) dataUnionProgram = $$( compile [|| @@ -65,12 +65,12 @@ dataUnionProgram = ||] ) -unionWithProgram - :: CompiledCode - ( AssocMap.Map Integer Integer - -> AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +unionWithProgram :: + CompiledCode + ( AssocMap.Map Integer Integer -> + AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) unionWithProgram = $$( compile [|| @@ -79,12 +79,12 @@ unionWithProgram = ||] ) -dataUnionWithProgram - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +dataUnionWithProgram :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) dataUnionWithProgram = $$( compile [|| @@ -93,25 +93,25 @@ dataUnionWithProgram = ||] ) -encodedDataAssocMap - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> PlutusTx.BuiltinData - ) +encodedDataAssocMap :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + PlutusTx.BuiltinData + ) encodedDataAssocMap = $$(compile [||P.toBuiltinData||]) -encodedAssocMap - :: CompiledCode - ( AssocMap.Map Integer Integer - -> PlutusTx.BuiltinData - ) +encodedAssocMap :: + CompiledCode + ( AssocMap.Map Integer Integer -> + PlutusTx.BuiltinData + ) encodedAssocMap = $$(compile [||P.toBuiltinData||]) -mDecodedDataAssocMap - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> PlutusTx.Maybe [(Integer, Integer)] - ) +mDecodedDataAssocMap :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + PlutusTx.Maybe [(Integer, Integer)] + ) mDecodedDataAssocMap = $$( compile [|| @@ -119,11 +119,11 @@ mDecodedDataAssocMap = ||] ) -mDecodedAssocMap - :: CompiledCode - ( AssocMap.Map Integer Integer - -> PlutusTx.Maybe [(Integer, Integer)] - ) +mDecodedAssocMap :: + CompiledCode + ( AssocMap.Map Integer Integer -> + PlutusTx.Maybe [(Integer, Integer)] + ) mDecodedAssocMap = $$( compile [|| @@ -133,11 +133,11 @@ mDecodedAssocMap = ||] ) -decodedDataAssocMap - :: CompiledCode - ( Data.AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +decodedDataAssocMap :: + CompiledCode + ( Data.AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) decodedDataAssocMap = $$( compile [|| @@ -148,11 +148,11 @@ decodedDataAssocMap = ||] ) -decodedAssocMap - :: CompiledCode - ( AssocMap.Map Integer Integer - -> [(Integer, Integer)] - ) +decodedAssocMap :: + CompiledCode + ( AssocMap.Map Integer Integer -> + [(Integer, Integer)] + ) decodedAssocMap = $$( compile [|| diff --git a/plutus-tx-plugin/test/AssocMap/Semantics.hs b/plutus-tx-plugin/test/AssocMap/Semantics.hs index 03c80d9ac45..84dce5b1b05 100644 --- a/plutus-tx-plugin/test/AssocMap/Semantics.hs +++ b/plutus-tx-plugin/test/AssocMap/Semantics.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -- CSE is very unstable and produces different output, likely depending on the version of either @@ -32,27 +32,26 @@ import PlutusTx.IsData qualified as P import PlutusTx.Lift (makeLift) import PlutusTx.These (These (..)) -{-| The semantics of PlutusTx maps and their operations. -The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') -are checked against the semantics to ensure correctness. --} +-- | The semantics of PlutusTx maps and their operations. +-- The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') +-- are checked against the semantics to ensure correctness. newtype AssocMapS k v = AssocMapS [(k, v)] deriving stock (Show, Eq) semanticsToAssocMap :: AssocMapS k v -> AssocMap.Map k v semanticsToAssocMap = AssocMap.unsafeFromList . toListS -semanticsToDataAssocMap - :: (P.ToData k, P.ToData v) - => AssocMapS k v -> Data.AssocMap.Map k v +semanticsToDataAssocMap :: + (P.ToData k, P.ToData v) => + AssocMapS k v -> Data.AssocMap.Map k v semanticsToDataAssocMap = Data.AssocMap.unsafeFromSOPList . toListS assocMapToSemantics :: AssocMap.Map k v -> AssocMapS k v assocMapToSemantics = unsafeFromListS . AssocMap.toList -dataAssocMapToSemantics - :: (P.UnsafeFromData k, P.UnsafeFromData v) - => Data.AssocMap.Map k v -> AssocMapS k v +dataAssocMapToSemantics :: + (P.UnsafeFromData k, P.UnsafeFromData v) => + Data.AssocMap.Map k v -> AssocMapS k v dataAssocMapToSemantics = unsafeFromListS . Data.AssocMap.toSOPList nullS :: AssocMapS k v -> Bool @@ -67,7 +66,7 @@ toListS (AssocMapS l) = l unsafeFromListS :: [(k, v)] -> AssocMapS k v unsafeFromListS = AssocMapS -safeFromListS :: (Ord k) => [(k, v)] -> AssocMapS k v +safeFromListS :: Ord k => [(k, v)] -> AssocMapS k v safeFromListS = AssocMapS . Map.toList . Map.fromList lookupS :: Integer -> AssocMapS Integer Integer -> Maybe Integer @@ -103,48 +102,47 @@ noDuplicateKeysS (AssocMapS l) = mapS :: (a -> b) -> AssocMapS k a -> AssocMapS k b mapS f (AssocMapS l) = AssocMapS $ map (\(k, v) -> (k, f v)) l -filterS - :: (Integer -> Bool) - -> AssocMapS Integer Integer - -> AssocMapS Integer Integer +filterS :: + (Integer -> Bool) -> + AssocMapS Integer Integer -> + AssocMapS Integer Integer filterS p (AssocMapS l) = AssocMapS $ filter (p . snd) l -mapWithKeyS - :: (Integer -> Integer -> Integer) - -> AssocMapS Integer Integer - -> AssocMapS Integer Integer +mapWithKeyS :: + (Integer -> Integer -> Integer) -> + AssocMapS Integer Integer -> + AssocMapS Integer Integer mapWithKeyS f (AssocMapS l) = AssocMapS . Map.toList . Map.mapWithKey f . Map.fromList $ l -mapMaybeS - :: (Integer -> Maybe Integer) - -> AssocMapS Integer Integer - -> AssocMapS Integer Integer +mapMaybeS :: + (Integer -> Maybe Integer) -> + AssocMapS Integer Integer -> + AssocMapS Integer Integer mapMaybeS f (AssocMapS l) = AssocMapS . Map.toList . Map.mapMaybe f . Map.fromList $ l -mapMaybeWithKeyS - :: (Integer -> Integer -> Maybe Integer) - -> AssocMapS Integer Integer - -> AssocMapS Integer Integer +mapMaybeWithKeyS :: + (Integer -> Integer -> Maybe Integer) -> + AssocMapS Integer Integer -> + AssocMapS Integer Integer mapMaybeWithKeyS f (AssocMapS l) = AssocMapS . Map.toList . Map.mapMaybeWithKey f . Map.fromList $ l makeLift ''AssocMapS -{-| The semantics of 'union' is based on the 'AssocMap' implementation. -The code is duplicated here to avoid any issues if the 'AssocMap' implementation changes. --} -unionS - :: AssocMapS Integer Integer - -> AssocMapS Integer Integer - -> AssocMapS Integer (Haskell.These Integer Integer) +-- | The semantics of 'union' is based on the 'AssocMap' implementation. +-- The code is duplicated here to avoid any issues if the 'AssocMap' implementation changes. +unionS :: + AssocMapS Integer Integer -> + AssocMapS Integer Integer -> + AssocMapS Integer (Haskell.These Integer Integer) unionS (AssocMapS ls) (AssocMapS rs) = let f a b' = case b' of Nothing -> Haskell.This a - Just b -> Haskell.These a b + Just b -> Haskell.These a b ls' = fmap (\(c, i) -> (c, f i (lookupS c (AssocMapS rs)))) ls @@ -161,11 +159,11 @@ haskellToPlutusThese = \case Haskell.That b -> That b Haskell.These a b -> These a b -unionWithS - :: (Integer -> Integer -> Integer) - -> AssocMapS Integer Integer - -> AssocMapS Integer Integer - -> AssocMapS Integer Integer +unionWithS :: + (Integer -> Integer -> Integer) -> + AssocMapS Integer Integer -> + AssocMapS Integer Integer -> + AssocMapS Integer Integer unionWithS merge (AssocMapS ls) (AssocMapS rs) = AssocMapS . Map.toList @@ -174,33 +172,32 @@ unionWithS merge (AssocMapS ls) (AssocMapS rs) = genAssocMapS :: Gen (AssocMapS Integer Integer) genAssocMapS = AssocMapS . Map.toList <$> Gen.map rangeLength genPair - where - genPair :: Gen (Integer, Integer) - genPair = do - (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem genUnsafeAssocMapS :: Gen (AssocMapS Integer Integer) genUnsafeAssocMapS = do AssocMapS <$> Gen.list rangeLength genPair - where - genPair :: Gen (Integer, Integer) - genPair = do - (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem - -{-| The 'Equivalence' class is used to define an equivalence relation -between `AssocMapS` and the 'PlutusTx' implementations. --} + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +-- | The 'Equivalence' class is used to define an equivalence relation +-- between `AssocMapS` and the 'PlutusTx' implementations. class Equivalence l where - (~~) - :: ( MonadTest m - , Show k - , Show v - , Ord k - , Ord v - , P.UnsafeFromData k - , P.UnsafeFromData v - ) - => AssocMapS k v -> l k v -> m () + (~~) :: + ( MonadTest m + , Show k + , Show v + , Ord k + , Ord v + , P.UnsafeFromData k + , P.UnsafeFromData v + ) => + AssocMapS k v -> l k v -> m () -- | An `AssocMap.Map` is equivalent to an `AssocMapS` if they have the same elements. instance Equivalence AssocMap.Map where diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index dfa931a2b74..cd2be85fa65 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -- CSE is very unstable and produces different output, likely depending on the version of either -- @unordered-containers@ or @hashable@. {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module AssocMap.Spec where diff --git a/plutus-tx-plugin/test/AstSize/Main.hs b/plutus-tx-plugin/test/AstSize/Main.hs index 973709b64f5..6efedc1e202 100644 --- a/plutus-tx-plugin/test/AstSize/Main.hs +++ b/plutus-tx-plugin/test/AstSize/Main.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} @@ -12,12 +12,12 @@ import PlutusTx.Code (CompiledCode, countAstNodes) import PlutusTx.IsData.Class (fromBuiltinData, toBuiltinData, unsafeFromBuiltinData) import PlutusTx.Prelude qualified as Plutus import PlutusTx.Ratio qualified as PlutusRatio -import PlutusTx.Test import PlutusTx.TH (compile) -import Prelude +import PlutusTx.Test import Test.Tasty (TestName, TestTree, defaultMain, testGroup) import Test.Tasty.Extras (runTestNested, testNested) import Test.Tasty.Providers (IsTest (run, testOptions), singleTest, testFailed, testPassed) +import Prelude main :: IO () main = @@ -183,19 +183,19 @@ genScale = $$(compile [||\s v -> PlutusRatio.fromInteger s Plutus.* v||]) -------------------------------------------------------------------------------- -- Helper functions for the size comparison tests ------------------------------ -fitsUnder - :: forall (a :: Type) - . (Typeable a) - => TestName - -> (TestName, CompiledCode a) - -> (TestName, CompiledCode a) - -> TestTree +fitsUnder :: + forall (a :: Type). + Typeable a => + TestName -> + (TestName, CompiledCode a) -> + (TestName, CompiledCode a) -> + TestTree fitsUnder name test target = singleTest name $ AstSizeComparisonTest test target data AstSizeComparisonTest (a :: Type) = AstSizeComparisonTest (TestName, CompiledCode a) (TestName, CompiledCode a) -instance (Typeable a) => IsTest (AstSizeComparisonTest a) where +instance Typeable a => IsTest (AstSizeComparisonTest a) where run _ (AstSizeComparisonTest (mName, mCode) (tName, tCode)) _ = do let tEstimate = countAstNodes tCode let mEstimate = countAstNodes mCode diff --git a/plutus-tx-plugin/test/Blueprint/Tests.hs b/plutus-tx-plugin/test/Blueprint/Tests.hs index ca395428dee..b21a09e7c18 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests.hs @@ -1,17 +1,28 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Blueprint.Tests where import Prelude -import Blueprint.Tests.Lib (Bytes, Datum, DatumPayload, Param2a, Param2b, Params, Redeemer, - Redeemer2, goldenJson, serialisedScript, validatorScript1, - validatorScript2) +import Blueprint.Tests.Lib ( + Bytes, + Datum, + DatumPayload, + Param2a, + Param2b, + Params, + Redeemer, + Redeemer2, + goldenJson, + serialisedScript, + validatorScript1, + validatorScript2, + ) import Blueprint.Tests.Lib.AsData.Blueprint (Datum2) import Control.Monad.Reader.Class (asks) import Data.ByteString.Base16 qualified as Base16 @@ -27,8 +38,11 @@ import PlutusTx.Blueprint.PlutusVersion (PlutusVersion (..)) import PlutusTx.Blueprint.Preamble (Preamble (..)) import PlutusTx.Blueprint.Purpose qualified as Purpose import PlutusTx.Blueprint.TH (deriveArgumentBlueprint, deriveParameterBlueprint) -import PlutusTx.Blueprint.Validator (CompiledValidator (..), ValidatorBlueprint (..), - compiledValidator) +import PlutusTx.Blueprint.Validator ( + CompiledValidator (..), + ValidatorBlueprint (..), + compiledValidator, + ) import PlutusTx.Blueprint.Write (writeBlueprint) import PlutusTx.Builtins (BuiltinByteString, BuiltinData, BuiltinString) import System.FilePath (joinPath) @@ -100,16 +114,16 @@ contractBlueprint = ] } -testAllRequredDefinitions - :: UnrollAll - [ Params - , Param2a - , Param2b - , Redeemer - , Redeemer2 - , Datum - , Datum2 - ] +testAllRequredDefinitions :: + UnrollAll + [ Params + , Param2a + , Param2b + , Redeemer + , Redeemer2 + , Datum + , Datum2 + ] :~: [ Params , Bool , () @@ -134,8 +148,8 @@ testCompiledValidator = do compiledScriptInHex <- Text.readFile exampleScriptPath let fromHex = Base16.decode . Text.encodeUtf8 . Text.strip toHex = Text.decodeUtf8 . Base16.encode - MkCompiledValidator{..} <- + MkCompiledValidator {..} <- case compiledValidator PlutusV2 <$> fromHex compiledScriptInHex of Left err -> fail $ "Error when hex-decoding: " <> err - Right x -> pure x + Right x -> pure x toHex compiledValidatorHash @?= "ffbd2f1be8910706804dcb12a1ca72a5573374e9a6c7b93a4e8858a4" diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs index 73087822b6b..6f8a1197971 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} module Blueprint.Tests.Lib ( module Blueprint.Tests.Lib, @@ -33,23 +33,32 @@ import GHC.Generics (Generic) import PlutusCore.Flat qualified as Flat import PlutusTx.AsData (asData) import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) -import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), Unrolled, definitionIdFromTypeK, - definitionRef) +import PlutusTx.Blueprint.Definition ( + HasBlueprintDefinition (..), + Unrolled, + definitionIdFromTypeK, + definitionRef, + ) import PlutusTx.Blueprint.Schema (Schema (..), emptyBytesSchema) -import PlutusTx.Blueprint.Schema.Annotation (SchemaComment (..), SchemaDescription (..), - SchemaInfo (..), SchemaTitle (..), emptySchemaInfo) +import PlutusTx.Blueprint.Schema.Annotation ( + SchemaComment (..), + SchemaDescription (..), + SchemaInfo (..), + SchemaTitle (..), + emptySchemaInfo, + ) import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed) import PlutusTx.Builtins.Internal (BuiltinByteString, BuiltinData, BuiltinString, emptyByteString) import PlutusTx.Code qualified as PlutusTx import PlutusTx.IsData (FromData, ToData (..), UnsafeFromData (..)) import PlutusTx.Lift (liftCodeDef, makeLift) import PlutusTx.TH qualified as PlutusTx -import Prelude import System.FilePath (()) import Test.Tasty (TestName) import Test.Tasty.Extras (TestNested, embed) import Test.Tasty.Golden (goldenVsFile) import UntypedPlutusCore qualified as UPLC +import Prelude ---------------------------------------------------------------------------------------------------- -- Validator 1 for testing blueprints -------------------------------------------------------------- @@ -57,11 +66,11 @@ import UntypedPlutusCore qualified as UPLC {-# ANN type Params (SchemaTitle "Acme Parameter") #-} {-# ANN type Params (SchemaDescription "A parameter that does something awesome") #-} data Params = MkParams - { myUnit :: () - , myBool :: Bool - , myInteger :: Integer - , myListOfInts :: [Integer] - , myBuiltinData :: BuiltinData + { myUnit :: () + , myBool :: Bool + , myInteger :: Integer + , myListOfInts :: [Integer] + , myBuiltinData :: BuiltinData , myBuiltinByteString :: BuiltinByteString } deriving stock (Generic) @@ -70,8 +79,8 @@ data Params = MkParams $(makeLift ''Params) $(makeIsDataSchemaIndexed ''Params [('MkParams, 0)]) -unrolledParams - :: Unrolled Params +unrolledParams :: + Unrolled Params :~: [ Params , Bool , () @@ -85,12 +94,12 @@ unrolledParams = Refl newtype Bytes (phantom :: Type) = MkAcmeBytes BuiltinByteString deriving newtype (ToData, FromData, UnsafeFromData) -instance (HasBlueprintDefinition phantom) => HasBlueprintDefinition (Bytes phantom) where +instance HasBlueprintDefinition phantom => HasBlueprintDefinition (Bytes phantom) where type Unroll (Bytes phantom) = '[Bytes phantom] definitionId = definitionIdFromTypeK @(Type -> Type) @Bytes <> definitionId @phantom instance HasBlueprintSchema (Bytes phantom) ts where - schema = SchemaBytes emptySchemaInfo{title = Just "SchemaBytes"} emptyBytesSchema + schema = SchemaBytes emptySchemaInfo {title = Just "SchemaBytes"} emptyBytesSchema {-# ANN MkDatumPayload (SchemaComment "MkDatumPayload") #-} diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs index bd12c85306d..f12c646ee19 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -{-| This module contains data type declarations to use in blueprints **only** - -The problem with using the 'AsData' types in blueprints is that such types are opaque and -do not reveal their schema when deriving a 'HasBlueprintSchema' instance for a blueprint. - -To work around this problem we generate a separate data type declaration for each 'AsData' type -and use these in blueprints. - -Do not use these types in real validators, instead use the 'AsData' declarations. --} +-- | This module contains data type declarations to use in blueprints **only** +-- +-- The problem with using the 'AsData' types in blueprints is that such types are opaque and +-- do not reveal their schema when deriving a 'HasBlueprintSchema' instance for a blueprint. +-- +-- To work around this problem we generate a separate data type declaration for each 'AsData' type +-- and use these in blueprints. +-- +-- Do not use these types in real validators, instead use the 'AsData' declarations. module Blueprint.Tests.Lib.AsData.Blueprint where import Blueprint.Tests.Lib.AsData.Decls (datum2) diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs index 8254b3faea2..9773ec33198 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs @@ -1,13 +1,12 @@ {-# LANGUAGE TemplateHaskellQuotes #-} -{-| This module contains TH data type declarations from which 'AsData' declarations are derived. - -These declarations are used for two purposes: -1. To generate an 'AsData' type declaration to be used in real validators. -2. To generate a regular data type declaration to be used in a blueprint. - -Because of the GHC stage restriction, we have to keep these TH declarations in a separate module. --} +-- | This module contains TH data type declarations from which 'AsData' declarations are derived. +-- +-- These declarations are used for two purposes: +-- 1. To generate an 'AsData' type declaration to be used in real validators. +-- 2. To generate a regular data type declaration to be used in a blueprint. +-- +-- Because of the GHC stage restriction, we have to keep these TH declarations in a separate module. module Blueprint.Tests.Lib.AsData.Decls where import GHC.Generics (Generic) diff --git a/plutus-tx-plugin/test/Budget/Spec.hs b/plutus-tx-plugin/test/Budget/Spec.hs index e7a608f11b2..0c51bda9f8d 100644 --- a/plutus-tx-plugin/test/Budget/Spec.hs +++ b/plutus-tx-plugin/test/Budget/Spec.hs @@ -1,14 +1,14 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Budget.Spec where @@ -29,8 +29,8 @@ import PlutusTx.Lift (liftCodeDef, makeLift) import PlutusTx.List qualified as List import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.Show qualified as PlutusTx -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test AsData.asData [d| @@ -340,7 +340,7 @@ compiledGte0 = -- | A version of @all@ that doesn't inline due to being recursive. recursiveAll :: forall a. (a -> Bool) -> [a] -> Bool -recursiveAll _ [] = True +recursiveAll _ [] = True recursiveAll f (x : xs) = if f x then recursiveAll f xs else False {-# INLINEABLE recursiveAll #-} @@ -482,9 +482,9 @@ sumAtIndices d = 'list [|s1 PlutusTx.+ s4 PlutusTx.+ s5|] ) - where - list :: List Integer - list = IsData.unsafeFromBuiltinData d + where + list :: List Integer + list = IsData.unsafeFromBuiltinData d compiledSumAtIndices :: CompiledCode (PlutusTx.BuiltinData -> Integer) compiledSumAtIndices = $$(compile [||sumAtIndices||]) @@ -560,10 +560,9 @@ compiledShow = ||] ) -{-| In this example, the float-in pass cannot reduce the cost unless it allows -unconditionally floating into type abstractions. Both branches are -turned into type abstractions (because the `a + a` branch is not a value). --} +-- | In this example, the float-in pass cannot reduce the cost unless it allows +-- unconditionally floating into type abstractions. Both branches are +-- turned into type abstractions (because the `a + a` branch is not a value). compiledIfThenElse1 :: CompiledCode Integer compiledIfThenElse1 = $$( compile @@ -575,10 +574,9 @@ compiledIfThenElse1 = ||] ) -{-| In this example, the float-in pass cannot reduce the cost unless it allows -unconditionally floating into lambda abstractions. Both branches are -lambda abstractions. --} +-- | In this example, the float-in pass cannot reduce the cost unless it allows +-- unconditionally floating into lambda abstractions. Both branches are +-- lambda abstractions. compiledIfThenElse2 :: CompiledCode Integer compiledIfThenElse2 = $$( compile diff --git a/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs b/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs index 7bf9403282c..d31ae0d76fb 100644 --- a/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs +++ b/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module BuiltinList.Budget.Spec where @@ -12,8 +12,8 @@ import PlutusTx.Prelude hiding (mapMaybe) import PlutusTx.BuiltinList qualified as L import PlutusTx.Code (CompiledCode, unsafeApplyCode) import PlutusTx.Lift (liftCodeDef) -import PlutusTx.Test (goldenBundle) import PlutusTx.TH (compile) +import PlutusTx.Test (goldenBundle) import System.FilePath (()) import Test.Tasty.Extras (TestNested, testNested, testNestedGhc) diff --git a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs index f33d163d15a..ca364e7e781 100644 --- a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs +++ b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} module ByteStringLiterals.Spec (tests) where @@ -15,10 +15,17 @@ import Data.String (fromString) import Data.Text.Encoding qualified as TE import PlutusCore (DefaultUni (..), Some (..), ValueOf (..), someValue) import PlutusTx (CompiledCode, getPlcNoAnn) -import PlutusTx.Builtins (BuiltinByteString, BuiltinByteStringHex, BuiltinByteStringUtf8, - fromBuiltin) -import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString, stringToBuiltinByteStringHex, - stringToBuiltinByteStringUtf8) +import PlutusTx.Builtins ( + BuiltinByteString, + BuiltinByteStringHex, + BuiltinByteStringUtf8, + fromBuiltin, + ) +import PlutusTx.Builtins.HasOpaque ( + stringToBuiltinByteString, + stringToBuiltinByteStringHex, + stringToBuiltinByteStringUtf8, + ) import PlutusTx.TH (compile) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -51,55 +58,11 @@ test_CompileBuiltinByteStringLiteral_raw :: TestTree test_CompileBuiltinByteStringLiteral_raw = testCase "Raw bytes" do term compiledLiteral @?= expectedUplc - where - compiledLiteral :: CompiledCode BuiltinByteString = - -- 00..FF FF..00 - $$( compile - [|| - "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F\ - \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F\ - \\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F\ - \\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F\ - \\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F\ - \\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F\ - \\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F\ - \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F\ - \\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\ - \\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\ - \\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\ - \\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\ - \\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\ - \\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\ - \\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\ - \\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF\ - \\xFF\xFE\xFD\xFC\xFB\xFA\xF9\xF8\xF7\xF6\xF5\xF4\xF3\xF2\xF1\xF0\ - \\xEF\xEE\xED\xEC\xEB\xEA\xE9\xE8\xE7\xE6\xE5\xE4\xE3\xE2\xE1\xE0\ - \\xDF\xDE\xDD\xDC\xDB\xDA\xD9\xD8\xD7\xD6\xD5\xD4\xD3\xD2\xD1\xD0\ - \\xCF\xCE\xCD\xCC\xCB\xCA\xC9\xC8\xC7\xC6\xC5\xC4\xC3\xC2\xC1\xC0\ - \\xBF\xBE\xBD\xBC\xBB\xBA\xB9\xB8\xB7\xB6\xB5\xB4\xB3\xB2\xB1\xB0\ - \\xAF\xAE\xAD\xAC\xAB\xAA\xA9\xA8\xA7\xA6\xA5\xA4\xA3\xA2\xA1\xA0\ - \\x9F\x9E\x9D\x9C\x9B\x9A\x99\x98\x97\x96\x95\x94\x93\x92\x91\x90\ - \\x8F\x8E\x8D\x8C\x8B\x8A\x89\x88\x87\x86\x85\x84\x83\x82\x81\x80\ - \\x7F\x7E\x7D\x7C\x7B\x7A\x79\x78\x77\x76\x75\x74\x73\x72\x71\x70\ - \\x6F\x6E\x6D\x6C\x6B\x6A\x69\x68\x67\x66\x65\x64\x63\x62\x61\x60\ - \\x5F\x5E\x5D\x5C\x5B\x5A\x59\x58\x57\x56\x55\x54\x53\x52\x51\x50\ - \\x4F\x4E\x4D\x4C\x4B\x4A\x49\x48\x47\x46\x45\x44\x43\x42\x41\x40\ - \\x3F\x3E\x3D\x3C\x3B\x3A\x39\x38\x37\x36\x35\x34\x33\x32\x31\x30\ - \\x2F\x2E\x2D\x2C\x2B\x2A\x29\x28\x27\x26\x25\x24\x23\x22\x21\x20\ - \\x1F\x1E\x1D\x1C\x1B\x1A\x19\x18\x17\x16\x15\x14\x13\x12\x11\x10\ - \\x0F\x0E\x0D\x0C\x0B\x0A\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00" - ||] - ) - -test_CompileBuiltinByteStringLiteral_stringToBuiltinByteString :: TestTree -test_CompileBuiltinByteStringLiteral_stringToBuiltinByteString = - testCase "stringToBuiltinByteString" do - term compiledLiteral @?= expectedUplc - where - compiledLiteral :: CompiledCode BuiltinByteString = - $$( compile - [|| - stringToBuiltinByteString + where + compiledLiteral :: CompiledCode BuiltinByteString = + -- 00..FF FF..00 + $$( compile + [|| "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F\ \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F\ \\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F\ @@ -132,8 +95,52 @@ test_CompileBuiltinByteStringLiteral_stringToBuiltinByteString = \\x2F\x2E\x2D\x2C\x2B\x2A\x29\x28\x27\x26\x25\x24\x23\x22\x21\x20\ \\x1F\x1E\x1D\x1C\x1B\x1A\x19\x18\x17\x16\x15\x14\x13\x12\x11\x10\ \\x0F\x0E\x0D\x0C\x0B\x0A\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00" - ||] - ) + ||] + ) + +test_CompileBuiltinByteStringLiteral_stringToBuiltinByteString :: TestTree +test_CompileBuiltinByteStringLiteral_stringToBuiltinByteString = + testCase "stringToBuiltinByteString" do + term compiledLiteral @?= expectedUplc + where + compiledLiteral :: CompiledCode BuiltinByteString = + $$( compile + [|| + stringToBuiltinByteString + "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F\ + \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F\ + \\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F\ + \\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F\ + \\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F\ + \\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F\ + \\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F\ + \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F\ + \\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\ + \\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\ + \\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\ + \\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\ + \\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\ + \\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\ + \\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\ + \\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF\ + \\xFF\xFE\xFD\xFC\xFB\xFA\xF9\xF8\xF7\xF6\xF5\xF4\xF3\xF2\xF1\xF0\ + \\xEF\xEE\xED\xEC\xEB\xEA\xE9\xE8\xE7\xE6\xE5\xE4\xE3\xE2\xE1\xE0\ + \\xDF\xDE\xDD\xDC\xDB\xDA\xD9\xD8\xD7\xD6\xD5\xD4\xD3\xD2\xD1\xD0\ + \\xCF\xCE\xCD\xCC\xCB\xCA\xC9\xC8\xC7\xC6\xC5\xC4\xC3\xC2\xC1\xC0\ + \\xBF\xBE\xBD\xBC\xBB\xBA\xB9\xB8\xB7\xB6\xB5\xB4\xB3\xB2\xB1\xB0\ + \\xAF\xAE\xAD\xAC\xAB\xAA\xA9\xA8\xA7\xA6\xA5\xA4\xA3\xA2\xA1\xA0\ + \\x9F\x9E\x9D\x9C\x9B\x9A\x99\x98\x97\x96\x95\x94\x93\x92\x91\x90\ + \\x8F\x8E\x8D\x8C\x8B\x8A\x89\x88\x87\x86\x85\x84\x83\x82\x81\x80\ + \\x7F\x7E\x7D\x7C\x7B\x7A\x79\x78\x77\x76\x75\x74\x73\x72\x71\x70\ + \\x6F\x6E\x6D\x6C\x6B\x6A\x69\x68\x67\x66\x65\x64\x63\x62\x61\x60\ + \\x5F\x5E\x5D\x5C\x5B\x5A\x59\x58\x57\x56\x55\x54\x53\x52\x51\x50\ + \\x4F\x4E\x4D\x4C\x4B\x4A\x49\x48\x47\x46\x45\x44\x43\x42\x41\x40\ + \\x3F\x3E\x3D\x3C\x3B\x3A\x39\x38\x37\x36\x35\x34\x33\x32\x31\x30\ + \\x2F\x2E\x2D\x2C\x2B\x2A\x29\x28\x27\x26\x25\x24\x23\x22\x21\x20\ + \\x1F\x1E\x1D\x1C\x1B\x1A\x19\x18\x17\x16\x15\x14\x13\x12\x11\x10\ + \\x0F\x0E\x0D\x0C\x0B\x0A\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00" + ||] + ) test_CompileBuiltinByteStringLiteral_utf8 :: TestTree test_CompileBuiltinByteStringLiteral_utf8 = @@ -151,60 +158,10 @@ test_CompileBuiltinByteStringLiteral_hex :: TestTree test_CompileBuiltinByteStringLiteral_hex = testCase "BuiltinByteStringHex (local)" do term compiledLiteral @?= expectedUplc - where - compiledLiteral :: CompiledCode BuiltinByteStringHex = - $$( compile - [|| - "000102030405060708090a0b0c0d0e0f\ - \101112131415161718191a1b1c1d1e1f\ - \202122232425262728292a2b2c2d2e2f\ - \303132333435363738393a3b3c3d3e3f\ - \404142434445464748494a4b4c4d4e4f\ - \505152535455565758595a5b5c5d5e5f\ - \606162636465666768696a6b6c6d6e6f\ - \707172737475767778797a7b7c7d7e7f\ - \808182838485868788898a8b8c8d8e8f\ - \909192939495969798999a9b9c9d9e9f\ - \a0a1a2a3a4a5a6a7a8a9aaabacadaeaf\ - \b0b1b2b3b4b5b6b7b8b9babbbcbdbebf\ - \c0c1c2c3c4c5c6c7c8c9cacbcccdcecf\ - \d0d1d2d3d4d5d6d7d8d9dadbdcdddedf\ - \e0e1e2e3e4e5e6e7e8e9eaebecedeeef\ - \f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff\ - \fffefdfcfbfaf9f8f7f6f5f4f3f2f1f0\ - \efeeedecebeae9e8e7e6e5e4e3e2e1e0\ - \dfdedddcdbdad9d8d7d6d5d4d3d2d1d0\ - \cfcecdcccbcac9c8c7c6c5c4c3c2c1c0\ - \bfbebdbcbbbab9b8b7b6b5b4b3b2b1b0\ - \afaeadacabaaa9a8a7a6a5a4a3a2a1a0\ - \9f9e9d9c9b9a99989796959493929190\ - \8f8e8d8c8b8a89888786858483828180\ - \7f7e7d7c7b7a79787776757473727170\ - \6f6e6d6c6b6a69686766656463626160\ - \5f5e5d5c5b5a59585756555453525150\ - \4f4e4d4c4b4a49484746454443424140\ - \3f3e3d3c3b3a39383736353433323130\ - \2f2e2d2c2b2a29282726252423222120\ - \1f1e1d1c1b1a19181716151413121110\ - \0f0e0d0c0b0a09080706050403020100" - ||] - ) - -test_CompileBuiltinByteStringLiteral_hex_imported :: TestTree -test_CompileBuiltinByteStringLiteral_hex_imported = - testCase "BuiltinByteStringHex (imported)" $ - term $$(compile [||Lib.hex||]) - @?= Constant () (Some (ValueOf DefaultUniByteString "\240\209")) - -test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex :: TestTree -test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex = - testCase "stringToBuiltinByteStringHex" do - term compiledLiteral @?= expectedUplc - where - compiledLiteral :: CompiledCode BuiltinByteString = - $$( compile - [|| - stringToBuiltinByteStringHex + where + compiledLiteral :: CompiledCode BuiltinByteStringHex = + $$( compile + [|| "000102030405060708090a0b0c0d0e0f\ \101112131415161718191a1b1c1d1e1f\ \202122232425262728292a2b2c2d2e2f\ @@ -237,8 +194,58 @@ test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex = \2f2e2d2c2b2a29282726252423222120\ \1f1e1d1c1b1a19181716151413121110\ \0f0e0d0c0b0a09080706050403020100" - ||] - ) + ||] + ) + +test_CompileBuiltinByteStringLiteral_hex_imported :: TestTree +test_CompileBuiltinByteStringLiteral_hex_imported = + testCase "BuiltinByteStringHex (imported)" $ + term $$(compile [||Lib.hex||]) + @?= Constant () (Some (ValueOf DefaultUniByteString "\240\209")) + +test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex :: TestTree +test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex = + testCase "stringToBuiltinByteStringHex" do + term compiledLiteral @?= expectedUplc + where + compiledLiteral :: CompiledCode BuiltinByteString = + $$( compile + [|| + stringToBuiltinByteStringHex + "000102030405060708090a0b0c0d0e0f\ + \101112131415161718191a1b1c1d1e1f\ + \202122232425262728292a2b2c2d2e2f\ + \303132333435363738393a3b3c3d3e3f\ + \404142434445464748494a4b4c4d4e4f\ + \505152535455565758595a5b5c5d5e5f\ + \606162636465666768696a6b6c6d6e6f\ + \707172737475767778797a7b7c7d7e7f\ + \808182838485868788898a8b8c8d8e8f\ + \909192939495969798999a9b9c9d9e9f\ + \a0a1a2a3a4a5a6a7a8a9aaabacadaeaf\ + \b0b1b2b3b4b5b6b7b8b9babbbcbdbebf\ + \c0c1c2c3c4c5c6c7c8c9cacbcccdcecf\ + \d0d1d2d3d4d5d6d7d8d9dadbdcdddedf\ + \e0e1e2e3e4e5e6e7e8e9eaebecedeeef\ + \f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff\ + \fffefdfcfbfaf9f8f7f6f5f4f3f2f1f0\ + \efeeedecebeae9e8e7e6e5e4e3e2e1e0\ + \dfdedddcdbdad9d8d7d6d5d4d3d2d1d0\ + \cfcecdcccbcac9c8c7c6c5c4c3c2c1c0\ + \bfbebdbcbbbab9b8b7b6b5b4b3b2b1b0\ + \afaeadacabaaa9a8a7a6a5a4a3a2a1a0\ + \9f9e9d9c9b9a99989796959493929190\ + \8f8e8d8c8b8a89888786858483828180\ + \7f7e7d7c7b7a79787776757473727170\ + \6f6e6d6c6b6a69686766656463626160\ + \5f5e5d5c5b5a59585756555453525150\ + \4f4e4d4c4b4a49484746454443424140\ + \3f3e3d3c3b3a39383736353433323130\ + \2f2e2d2c2b2a29282726252423222120\ + \1f1e1d1c1b1a19181716151413121110\ + \0f0e0d0c0b0a09080706050403020100" + ||] + ) term :: CompiledCode a -> Term NamedDeBruijn DefaultUni DefaultFun () term = _progTerm . getPlcNoAnn diff --git a/plutus-tx-plugin/test/CallTrace/Lib.hs b/plutus-tx-plugin/test/CallTrace/Lib.hs index 430cab9223f..291f1e8bc30 100644 --- a/plutus-tx-plugin/test/CallTrace/Lib.hs +++ b/plutus-tx-plugin/test/CallTrace/Lib.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module CallTrace.Lib where @@ -20,11 +20,11 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.Internal qualified as UPLC import PlutusTx.Test (prettyBudget, prettyCodeSize) -goldenEvalCekTraceWithEmitter - :: UPLC.EmitterMode UPLC.DefaultUni UPLC.DefaultFun - -> TestName - -> CompiledCode a - -> TestNested +goldenEvalCekTraceWithEmitter :: + UPLC.EmitterMode UPLC.DefaultUni UPLC.DefaultFun -> + TestName -> + CompiledCode a -> + TestNested goldenEvalCekTraceWithEmitter emitter name compiledCode = nestedGoldenVsDocM name ".eval" $ ppCatch $ do uplc <- toUPlc compiledCode @@ -39,7 +39,7 @@ goldenEvalCekTraceWithEmitter emitter name compiledCode = traceMsg = case logOut of [] -> ["No Trace Produced"] - x -> ["Trace:", vsep $ pretty <$> x] + x -> ["Trace:", vsep $ pretty <$> x] pure $ render @Text $ case evalRes of Left evalErr -> diff --git a/plutus-tx-plugin/test/CallTrace/OtherModule.hs b/plutus-tx-plugin/test/CallTrace/OtherModule.hs index 1e553b1aeec..b1df3b0e5ed 100644 --- a/plutus-tx-plugin/test/CallTrace/OtherModule.hs +++ b/plutus-tx-plugin/test/CallTrace/OtherModule.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module CallTrace.OtherModule where import PlutusTx.Prelude errorWhenTrue :: Bool -> BuiltinString -errorWhenTrue True = error () +errorWhenTrue True = error () errorWhenTrue False = "hi" wraps :: Bool -> BuiltinString @@ -20,4 +20,4 @@ instance MyClassInOtherModule Integer where myClassFuncInOtherModule _ = error () instance MyClassInOtherModule () where - myClassFuncInOtherModule () = error () + myClassFuncInOtherModule () = error () diff --git a/plutus-tx-plugin/test/CallTrace/Spec.hs b/plutus-tx-plugin/test/CallTrace/Spec.hs index 816de39af92..93d758196f7 100644 --- a/plutus-tx-plugin/test/CallTrace/Spec.hs +++ b/plutus-tx-plugin/test/CallTrace/Spec.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:profile-all #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# HLINT ignore "Eta reduce" #-} {-# HLINT ignore "Redundant if" #-} @@ -72,7 +72,7 @@ nestedLinear, nestedLinear2, nestedLinear3, nestedLinear4 :: Bool -> BuiltinStri nestedLinear x = nestedLinear2 x nestedLinear2 x = nestedLinear3 x nestedLinear3 x = nestedLinear4 x -nestedLinear4 True = error () +nestedLinear4 True = error () nestedLinear4 False = error () func :: Integer -> BuiltinString diff --git a/plutus-tx-plugin/test/Inline/Spec.hs b/plutus-tx-plugin/test/Inline/Spec.hs index 58fe910d7e6..beebb089133 100644 --- a/plutus-tx-plugin/test/Inline/Spec.hs +++ b/plutus-tx-plugin/test/Inline/Spec.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Inline.Spec where @@ -14,8 +14,8 @@ import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.Code import PlutusTx.Lift (liftCodeDef) import PlutusTx.Optimize.Inline (inline) -import PlutusTx.Test (goldenBundle, goldenPirReadable, goldenUPlcReadable) import PlutusTx.TH (compile) +import PlutusTx.Test (goldenBundle, goldenPirReadable, goldenUPlcReadable) tests :: TestNested tests = @@ -34,12 +34,12 @@ tests = , goldenPirReadable "always-inline-local" compiledAlwaysInlineLocal , goldenUPlcReadable "always-inline-local" compiledAlwaysInlineLocal ] - where - applyOneTwoThree f = - f - `unsafeApplyCode` liftCodeDef 1 - `unsafeApplyCode` liftCodeDef 2 - `unsafeApplyCode` liftCodeDef 3 + where + applyOneTwoThree f = + f + `unsafeApplyCode` liftCodeDef 1 + `unsafeApplyCode` liftCodeDef 2 + `unsafeApplyCode` liftCodeDef 3 double :: Integer -> Integer double x = x `PlutusTx.addInteger` x @@ -109,16 +109,15 @@ recursive = ||] ) -{-| This test case verifies that `inline` can inline local bindings -(like `square`). - -The third usage of `square` is inlined in PIR, but not in UPLC, since -in UPLC the inlining is reversed by CSE. --} +-- | This test case verifies that `inline` can inline local bindings +-- (like `square`). +-- +-- The third usage of `square` is inlined in PIR, but not in UPLC, since +-- in UPLC the inlining is reversed by CSE. inlineLocalOnce :: Integer -> Integer inlineLocalOnce x = square `PlutusTx.addInteger` square `PlutusTx.addInteger` inline square - where - !square = x `PlutusTx.multiplyInteger` x + where + !square = x `PlutusTx.multiplyInteger` x {-# INLINEABLE inlineLocalOnce #-} -- Use INLINE pragma on local variable `square` to make it always inlined. @@ -126,9 +125,9 @@ inlineLocalOnce x = square `PlutusTx.addInteger` square `PlutusTx.addInteger` in -- reversed by CSE in UPLC. alwaysInlineLocal :: Integer -> Integer alwaysInlineLocal x = square `PlutusTx.addInteger` square `PlutusTx.addInteger` square - where - !square = x `PlutusTx.multiplyInteger` x - {-# INLINE square #-} + where + !square = x `PlutusTx.multiplyInteger` x + {-# INLINE square #-} {-# INLINEABLE alwaysInlineLocal #-} compiledInlineLocalOnce :: CompiledCode (Integer -> Integer) diff --git a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs index b2a780f7b4c..ccb8084cc52 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE NoStrict #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| This module tests that integer literals are handled correctly when @Strict@ is off -and @NegativeLiterals@ is on. These two extensions affect the Core we get. When -@NegativeLiterals@ is on, we can get @IN@ for negative integers. - -See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. --} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoStrict #-} + +-- | This module tests that integer literals are handled correctly when @Strict@ is off +-- and @NegativeLiterals@ is on. These two extensions affect the Core we get. When +-- @NegativeLiterals@ is on, we can get @IN@ for negative integers. +-- +-- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. module IntegerLiterals.NoStrict.NegativeLiterals.Spec where import PlutusTx.Code import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test import Test.Tasty.Extras diff --git a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs index a5218009b12..7a900025b57 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoNegativeLiterals #-} -{-# LANGUAGE NoStrict #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoStrict #-} -{-| This module tests that integer literals are handled correctly when both @Strict@ -and @NegativeLiterals@ are off. These two extensions affect the Core we get. - -See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. --} +-- | This module tests that integer literals are handled correctly when both @Strict@ +-- and @NegativeLiterals@ are off. These two extensions affect the Core we get. +-- +-- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. module IntegerLiterals.NoStrict.NoNegativeLiterals.Spec where import PlutusTx.Code import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test import Test.Tasty.Extras diff --git a/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs index fa310482ce8..5f3cf118983 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} -{-| This module tests that integer literals are handled correctly when both -@Strict@ and @NegativeLiterals@ are on. These two extensions affect the Core -we get. When @NegativeLiterals@ is on, we can get @IN@ for negative integers. - -See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. --} +-- | This module tests that integer literals are handled correctly when both +-- @Strict@ and @NegativeLiterals@ are on. These two extensions affect the Core +-- we get. When @NegativeLiterals@ is on, we can get @IN@ for negative integers. +-- +-- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. module IntegerLiterals.Strict.NegativeLiterals.Spec where import PlutusTx.Code import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test import Test.Tasty.Extras diff --git a/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs index 296fd11eb70..c0c8650dca8 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoNegativeLiterals #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-| This module tests that integer literals are handled correctly when @Strict@ is on -and @NegativeLiterals@ is off. These two extensions affect the Core we get. - -See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. --} +-- | This module tests that integer literals are handled correctly when @Strict@ is on +-- and @NegativeLiterals@ is off. These two extensions affect the Core we get. +-- +-- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. module IntegerLiterals.Strict.NoNegativeLiterals.Spec where import PlutusTx.Code import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test import Test.Tasty.Extras diff --git a/plutus-tx-plugin/test/IsData/Spec.hs b/plutus-tx-plugin/test/IsData/Spec.hs index a57927f4310..f1ddf397ad2 100644 --- a/plutus-tx-plugin/test/IsData/Spec.hs +++ b/plutus-tx-plugin/test/IsData/Spec.hs @@ -1,24 +1,24 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module IsData.Spec where @@ -68,8 +68,8 @@ deconstructData = plc (Proxy @"deconstructData4") (\(d :: Builtins.BuiltinData) unsafeDeconstructData :: CompiledCode (Builtins.BuiltinData -> Maybe (Integer, Integer)) unsafeDeconstructData = plc (Proxy @"deconstructData4") (\(d :: Builtins.BuiltinData) -> IsData.unsafeFromBuiltinData d) -isDataRoundtrip - :: (IsData.FromData a, IsData.UnsafeFromData a, IsData.ToData a, P.Eq a) => a -> Bool +isDataRoundtrip :: + (IsData.FromData a, IsData.UnsafeFromData a, IsData.ToData a, P.Eq a) => a -> Bool isDataRoundtrip a = let d = IsData.toBuiltinData a safeRoundtrip = case IsData.fromBuiltinData d of @@ -134,10 +134,11 @@ tests = , assertResult "tupleInterop" ( unsafeApplyCodeN - ( plc (Proxy @"tupleInterop") + ( plc + (Proxy @"tupleInterop") ( \(d :: P.BuiltinData) -> case IsData.fromBuiltinData d of - Just t -> t P.== (1 :: Integer, 2 :: Integer) + Just t -> t P.== (1 :: Integer, 2 :: Integer) Nothing -> False ) ) @@ -146,9 +147,10 @@ tests = , assertResult "unsafeTupleInterop" ( unsafeApplyCodeN - ( plc (Proxy @"unsafeTupleInterop") - (\(d :: P.BuiltinData) -> - IsData.unsafeFromBuiltinData d P.== (1 :: Integer, 2 :: Integer) + ( plc + (Proxy @"unsafeTupleInterop") + ( \(d :: P.BuiltinData) -> + IsData.unsafeFromBuiltinData d P.== (1 :: Integer, 2 :: Integer) ) ) (plc (Proxy @"unsafeTupleInteropArg") (P.toBuiltinData (1 :: Integer, 2 :: Integer))) @@ -157,11 +159,12 @@ tests = , assertResult "unitInterop" ( unsafeApplyCodeN - ( plc (Proxy @"unitInterop") - (\(d :: P.BuiltinData) -> - case IsData.fromBuiltinData d of - Just t -> t P.== () - Nothing -> False + ( plc + (Proxy @"unitInterop") + ( \(d :: P.BuiltinData) -> + case IsData.fromBuiltinData d of + Just t -> t P.== () + Nothing -> False ) ) (plc (Proxy @"unitInteropArg") (P.toBuiltinData ())) @@ -170,13 +173,18 @@ tests = , assertResult "poly" (plc (Proxy @"poly") (isDataRoundtrip (Poly1 (1 :: Integer) (2 :: Integer)))) , assertResult "record" (plc (Proxy @"record") (isDataRoundtrip (MyMonoRecord 1 2))) , assertResult "recordAsList" (plc (Proxy @"record") (isDataRoundtrip (MyMonoRecordAsList 1 2))) - , assertResult "recordAsList is List" - (plc (Proxy @"record") ( - P.toBuiltinData (MyMonoRecordAsList 1 2) - P.== (BI.mkList $ - BI.mkCons (P.toBuiltinData @Integer 1) $ - BI.mkCons (P.toBuiltinData @Integer 2) $ - BI.mkNilData BI.unitval))) + , assertResult + "recordAsList is List" + ( plc + (Proxy @"record") + ( P.toBuiltinData (MyMonoRecordAsList 1 2) + P.== ( BI.mkList $ + BI.mkCons (P.toBuiltinData @Integer 1) $ + BI.mkCons (P.toBuiltinData @Integer 2) $ + BI.mkNilData BI.unitval + ) + ) + ) , assertResult "list" (plc (Proxy @"list") (isDataRoundtrip ([1] :: [Integer]))) , assertResult "nested" (plc (Proxy @"nested") (isDataRoundtrip (NestedRecord (Just (1, 2))))) , assertResult @@ -185,7 +193,8 @@ tests = , goldenPirReadable "deconstructData" deconstructData , goldenPirReadable "unsafeDeconstructData" unsafeDeconstructData , goldenPirReadable "matchAsData" matchAsData - , goldenUEval "matchAsDataE" + , goldenUEval + "matchAsDataE" [ unsafeApplyCodeN matchAsData (plc (Proxy @"test") (P.unsafeFromBuiltinData $ P.toBuiltinData $ SecondC 3)) @@ -194,7 +203,8 @@ tests = , goldenPirReadable "dataToData" dataToData , goldenPirReadable "equalityAsData" equalityAsData , goldenPirReadable "fieldAccessor" fieldAccessor - , goldenPirReadable "MyMonoRecordAsListToData" + , goldenPirReadable + "MyMonoRecordAsListToData" (plc (Proxy @"MyMonoRecordAsListToData") (IsData.toBuiltinData @MyMonoRecordAsList)) , $(goldenCodeGen "MyMonoRecordAsList" (IsData.makeIsDataAsList ''MyMonoRecord)) , $(goldenCodeGen "MyMonoRecord" (IsData.unstableMakeIsData ''MyMonoRecord)) diff --git a/plutus-tx-plugin/test/List/Properties2.hs b/plutus-tx-plugin/test/List/Properties2.hs index 6cf63a5766e..72f86062070 100644 --- a/plutus-tx-plugin/test/List/Properties2.hs +++ b/plutus-tx-plugin/test/List/Properties2.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -- CSE is very unstable and produces different output, likely depending on the version of either @@ -30,8 +30,8 @@ import PlutusTx.Data.List qualified as Data.List import PlutusTx.Lift (liftCodeDef) import PlutusTx.List qualified as List import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import PlutusTx.TH (compile) +import PlutusTx.Test.Run.Code (evaluationResultMatchesHaskell) import List.Semantics @@ -187,9 +187,9 @@ findIndexSpec = property $ do unzipProgram :: CompiledCode ([(Integer, Integer)] -> ([Integer], [Integer])) unzipProgram = $$(compile [||List.unzip||]) -dataUnzipProgram - :: CompiledCode - (Data.List (Integer, Integer) -> (Data.List Integer, Data.List Integer)) +dataUnzipProgram :: + CompiledCode + (Data.List (Integer, Integer) -> (Data.List Integer, Data.List Integer)) dataUnzipProgram = $$(compile [||Data.List.unzip||]) unzipSpec :: Property @@ -380,8 +380,8 @@ dropWhileSpec = property $ do splitAtProgram :: CompiledCode (Integer -> [Integer] -> ([Integer], [Integer])) splitAtProgram = $$(compile [||List.splitAt||]) -dataSplitAtProgram - :: CompiledCode (Integer -> Data.List Integer -> (Data.List Integer, Data.List Integer)) +dataSplitAtProgram :: + CompiledCode (Integer -> Data.List Integer -> (Data.List Integer, Data.List Integer)) dataSplitAtProgram = $$(compile [||Data.List.splitAt||]) splitAtSpec :: Property diff --git a/plutus-tx-plugin/test/List/Semantics.hs b/plutus-tx-plugin/test/List/Semantics.hs index abc99952504..41be2884f8c 100644 --- a/plutus-tx-plugin/test/List/Semantics.hs +++ b/plutus-tx-plugin/test/List/Semantics.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} module List.Semantics where @@ -20,9 +20,8 @@ import Hedgehog (Gen, Property, Range, forAll, property, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -{-| Semantics of lists. Used to model the expected behavior of the various -PlutusTx list types. --} +-- | Semantics of lists. Used to model the expected behavior of the various +-- PlutusTx list types. newtype ListS a = ListS {getListS :: [a]} deriving stock (Show, Eq) deriving newtype (Semigroup, Monoid) @@ -60,7 +59,7 @@ semanticsToList (ListS l) = l listToSemantics :: [a] -> ListS a listToSemantics = ListS -semanticsToDataList :: (ToData a) => ListS a -> Data.List a +semanticsToDataList :: ToData a => ListS a -> Data.List a semanticsToDataList = Data.fromBuiltinList . BI.unsafeDataAsList . B.mkList . fmap toBuiltinData . getListS @@ -68,10 +67,10 @@ semanticsToDataListIntPair :: ListS (Integer, Integer) -> Data.List (Integer, In semanticsToDataListIntPair = Data.fromBuiltinList . BI.unsafeDataAsList . B.mkList . fmap toBuiltinData . getListS -dataListToSemantics :: (UnsafeFromData a) => Data.List a -> ListS a +dataListToSemantics :: UnsafeFromData a => Data.List a -> ListS a dataListToSemantics (Data.toBuiltinList -> l) = ListS . go $ l - where - go = B.caseList' [] (\h t -> unsafeFromBuiltinData h : go t) + where + go = B.caseList' [] (\h t -> unsafeFromBuiltinData h : go t) areInversesSpec :: Property areInversesSpec = property $ do @@ -106,7 +105,7 @@ anyS f (ListS l) = Haskell.any f l allS :: (a -> Bool) -> ListS a -> Bool allS f (ListS l) = Haskell.all f l -foldMapS :: (Monoid m) => (a -> m) -> ListS a -> m +foldMapS :: Monoid m => (a -> m) -> ListS a -> m foldMapS f (ListS l) = foldMap f l mapS :: (a -> b) -> ListS a -> ListS b @@ -116,7 +115,7 @@ lengthS :: ListS a -> Integer lengthS = fromIntegral . Haskell.length . getListS unconsS :: ListS a -> Maybe (a, ListS a) -unconsS (ListS []) = Nothing +unconsS (ListS []) = Nothing unconsS (ListS (h : t)) = Just (h, ListS t) andS :: ListS Bool -> Bool @@ -125,10 +124,10 @@ andS = Haskell.and . getListS orS :: ListS Bool -> Bool orS = Haskell.or . getListS -elemS :: (Eq a) => a -> ListS a -> Bool +elemS :: Eq a => a -> ListS a -> Bool elemS x (ListS l) = Haskell.elem x l -notElemS :: (Eq a) => a -> ListS a -> Bool +notElemS :: Eq a => a -> ListS a -> Bool notElemS x (ListS l) = Haskell.notElem x l foldrS :: (a -> b -> b) -> b -> ListS a -> b @@ -144,12 +143,12 @@ concatMapS :: (a -> ListS b) -> ListS a -> ListS b concatMapS f (ListS l) = ListS $ concatMap (getListS . f) l listToMaybeS :: ListS a -> Maybe a -listToMaybeS (ListS []) = Nothing +listToMaybeS (ListS []) = Nothing listToMaybeS (ListS (h : _)) = Just h uniqueElementS :: ListS a -> Maybe a uniqueElementS (ListS [x]) = Just x -uniqueElementS _ = Nothing +uniqueElementS _ = Nothing findIndexS :: (a -> Bool) -> ListS a -> Maybe Integer findIndexS f (ListS l) = toInteger <$> Haskell.findIndex f l @@ -159,9 +158,9 @@ indexS (ListS l) i = l Haskell.!! fromIntegral i revAppendS :: ListS a -> ListS a -> ListS a revAppendS (ListS l) (ListS l') = ListS $ rev l l' - where - rev [] a = a - rev (x : xs) a = rev xs (x : a) + where + rev [] a = a + rev (x : xs) a = rev xs (x : a) reverseS :: ListS a -> ListS a reverseS (ListS l) = ListS $ Haskell.reverse l @@ -205,15 +204,15 @@ splitAtS n (ListS l) = elemByS :: forall a. (a -> a -> Bool) -> a -> ListS a -> Bool elemByS eq y (ListS l) = go l - where - go :: [a] -> Bool - go [] = False - go (x : xs) = x `eq` y || go xs + where + go :: [a] -> Bool + go [] = False + go (x : xs) = x `eq` y || go xs nubByS :: (a -> a -> Bool) -> ListS a -> ListS a nubByS f (ListS l) = ListS $ Haskell.nubBy f l -nubS :: (Eq a) => ListS a -> ListS a +nubS :: Eq a => ListS a -> ListS a nubS (ListS l) = ListS $ Haskell.nub l replicateS :: Integer -> a -> ListS a @@ -227,5 +226,5 @@ partitionS f (ListS l) = sortBy :: (a -> a -> Ordering) -> ListS a -> ListS a sortBy f (ListS l) = ListS $ Haskell.sortBy f l -sort :: (Ord a) => ListS a -> ListS a +sort :: Ord a => ListS a -> ListS a sort (ListS l) = ListS $ Haskell.sort l diff --git a/plutus-tx-plugin/test/Optimization/Spec.hs b/plutus-tx-plugin/test/Optimization/Spec.hs index e8e09ee7c18..14890ae7f48 100644 --- a/plutus-tx-plugin/test/Optimization/Spec.hs +++ b/plutus-tx-plugin/test/Optimization/Spec.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Optimization.Spec where @@ -24,8 +24,8 @@ import PlutusTx.Builtins qualified as Builtins import PlutusTx.Code import PlutusTx.IsData qualified as IsData import PlutusTx.Plugin (plc) -import PlutusTx.Test import PlutusTx.TH (compile) +import PlutusTx.Test AsData.asData [d| diff --git a/plutus-tx-plugin/test/Plugin/Basic/Spec.hs b/plutus-tx-plugin/test/Plugin/Basic/Spec.hs index 62a8a886e57..71e69d44634 100644 --- a/plutus-tx-plugin/test/Plugin/Basic/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Basic/Spec.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# HLINT ignore "Eta reduce" #-} {-# HLINT ignore "Redundant if" #-} @@ -151,7 +151,7 @@ defaultCaseDuplicationNested = plc (Proxy @"defaultCaseDuplicationNested") do _ -> 3 integerCase :: CompiledCode Integer -integerCase = plc (Proxy @"integerCase") ((\case {1 -> 42; 2 -> 100; _ -> -1}) (2 :: Integer)) +integerCase = plc (Proxy @"integerCase") ((\case 1 -> 42; 2 -> 100; _ -> -1) (2 :: Integer)) integerMatchFunction :: Integer -> Integer integerMatchFunction 1 = 12 diff --git a/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs b/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs index d1e430aea7f..c2c12738a16 100644 --- a/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs @@ -1,12 +1,12 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin -fplugin-opt PlutusTx.Plugin:coverage-all #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Plugin.Coverage.Spec (coverage) where @@ -39,7 +39,7 @@ boolOtherFunction = plc (Proxy @"boolOtherFunction") fun fun :: Maybe Integer -> Maybe Bool fun x = case x of Just y | otherFun y -> Just False - _ -> Nothing + _ -> Nothing {-# INLINEABLE fun #-} otherFun :: Integer -> Bool @@ -68,24 +68,24 @@ mkTests nm cc heads ls = testGroup nm [applicationHeadsCorrect cc heads, linesIn applicationHeadsCorrect :: CompiledCode t -> Set String -> TestTree applicationHeadsCorrect cc heads = testCase "correct application heads" (assertEqual "" heads headSymbols) - where - headSymbols :: Set String - headSymbols = - -- TODO: This should really use a prism instead of going to and from lists I guess - Set.fromList $ - [ s - | covMeta <- cc ^. to getCovIdx . coverageMetadata . to Map.elems - , ApplicationHeadSymbol s <- Set.toList $ covMeta ^. metadataSet - ] + where + headSymbols :: Set String + headSymbols = + -- TODO: This should really use a prism instead of going to and from lists I guess + Set.fromList $ + [ s + | covMeta <- cc ^. to getCovIdx . coverageMetadata . to Map.elems + , ApplicationHeadSymbol s <- Set.toList $ covMeta ^. metadataSet + ] linesInCoverageIndex :: CompiledCode t -> [Int] -> TestTree linesInCoverageIndex cc ls = testCase "correct line coverage" (assertBool ("Lines " ++ show ls ++ " are not covered by " ++ show covLineSpans) covered) - where - covered = all (\l -> any (\(s, e) -> s <= l && l <= e) covLineSpans) ls - covLineSpans = - [ (covLoc ^. covLocStartLine, covLoc ^. covLocEndLine) - | CoverLocation covLoc <- cc ^. to getCovIdx . coverageMetadata . to Map.keys - ] + where + covered = all (\l -> any (\(s, e) -> s <= l && l <= e) covLineSpans) ls + covLineSpans = + [ (covLoc ^. covLocStartLine, covLoc ^. covLocEndLine) + | CoverLocation covLoc <- cc ^. to getCovIdx . coverageMetadata . to Map.keys + ] diff --git a/plutus-tx-plugin/test/Plugin/Data/Spec.hs b/plutus-tx-plugin/test/Plugin/Data/Spec.hs index 8fe7090d757..06546c44400 100644 --- a/plutus-tx-plugin/test/Plugin/Data/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Data/Spec.hs @@ -1,11 +1,11 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} @@ -75,9 +75,9 @@ data MyMonoData = Mono1 Integer Integer | Mono2 Integer | Mono3 Integer instance P.Eq MyMonoData where {-# INLINEABLE (==) #-} (Mono1 i1 j1) == (Mono1 i2 j2) = i1 P.== i2 && j1 P.== j2 - (Mono2 i1) == (Mono2 i2) = i1 P.== i2 - (Mono3 i1) == (Mono3 i2) = i1 P.== i2 - _ == _ = False + (Mono2 i1) == (Mono2 i2) = i1 P.== i2 + (Mono3 i1) == (Mono3 i2) = i1 P.== i2 + _ == _ = False -- pattern match to avoid type getting simplified away monoDataType :: CompiledCode (MyMonoData -> Integer) @@ -211,8 +211,8 @@ data MyPolyData a b = Poly1 a b | Poly2 a instance (P.Eq a, P.Eq b) => P.Eq (MyPolyData a b) where {-# INLINEABLE (==) #-} (Poly1 a1 b1) == (Poly1 a2 b2) = a1 P.== a2 && b1 P.== b2 - (Poly2 a1) == (Poly2 a2) = a1 P.== a2 - _ == _ = False + (Poly2 a1) == (Poly2 a2) = a1 P.== a2 + _ == _ = False -- pattern match to avoid type getting simplified away polyDataType :: CompiledCode (MyPolyData Integer Integer -> Integer) @@ -340,7 +340,7 @@ polyRec = ( let depth :: B a -> Integer depth tree = case tree of - One _ -> 1 + One _ -> 1 Two inner -> Builtins.addInteger 1 (depth inner) in \(t :: B Integer) -> depth t @@ -374,7 +374,7 @@ sameEmptyRose = (|.) :: ([EmptyRose] -> EmptyRose) -> (EmptyRose -> [EmptyRose]) -> EmptyRose -> EmptyRose (|.) = \g f x -> g (f x) map :: (EmptyRose -> EmptyRose) -> [EmptyRose] -> [EmptyRose] - map _ [] = [] + map _ [] = [] map f (x : xs) = f x : map f xs unEmptyRose (EmptyRose x) = x go = EmptyRose |. (map go .| unEmptyRose) @@ -383,9 +383,8 @@ sameEmptyRose = -- See Note [Non-regular data types in tests]. -{-| A type of lists containing two values at each node, with the types of those values getting -swapped each time we move from one node to the next one. --} +-- | A type of lists containing two values at each node, with the types of those values getting +-- swapped each time we move from one node to the next one. data InterList a b = InterNil | InterCons a b (InterList b a) -- Note that the parameters get swapped. @@ -402,10 +401,10 @@ processInterList = (Proxy @"foldrInterList") ( let foldrInterList :: forall a b r. (a -> b -> r -> r) -> r -> InterList a b -> r foldrInterList f0 z = go f0 - where - go :: forall a b. (a -> b -> r -> r) -> InterList a b -> r - go _ InterNil = z - go f (InterCons x y xs) = f x y (go (flip f) xs) + where + go :: forall a b. (a -> b -> r -> r) -> InterList a b -> r + go _ InterNil = z + go f (InterCons x y xs) = f x y (go (flip f) xs) in foldrInterList (\x b r -> if b then x else r) 0 ) diff --git a/plutus-tx-plugin/test/Plugin/Debug/Spec.hs b/plutus-tx-plugin/test/Plugin/Debug/Spec.hs index 4a348c0cbc8..67148f1709d 100644 --- a/plutus-tx-plugin/test/Plugin/Debug/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Debug/Spec.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Plugin.Debug.Spec where @@ -30,8 +30,8 @@ debug = [ goldenPirBy config "letFun" letFun , goldenPirBy config "fib" fib ] - where - config = PrettyConfigClassic prettyConfigNameSimple True + where + config = PrettyConfigClassic prettyConfigNameSimple True letFun :: CompiledCode (Integer -> Integer -> Bool) letFun = diff --git a/plutus-tx-plugin/test/Plugin/Functions/Spec.hs b/plutus-tx-plugin/test/Plugin/Functions/Spec.hs index f26f31ca46f..7d0a6a8c139 100644 --- a/plutus-tx-plugin/test/Plugin/Functions/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Functions/Spec.hs @@ -1,19 +1,19 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Plugin.Functions.Spec where @@ -74,7 +74,7 @@ sumDirect = plc (Proxy @"sumDirect") ( let sum :: [Integer] -> Integer - sum [] = 0 + sum [] = 0 sum (x : xs) = Builtins.addInteger x (sum xs) in sum ) @@ -92,15 +92,15 @@ evenMutual = lengthStrict :: [a] -> Integer lengthStrict l = go 0 l - where - go !acc [] = acc - go !acc (_ : tl) = go (acc `Builtins.addInteger` 1) tl + where + go !acc [] = acc + go !acc (_ : tl) = go (acc `Builtins.addInteger` 1) tl lengthLazy :: [a] -> Integer lengthLazy l = go 0 l - where - go acc [] = acc - go acc (_ : tl) = go (acc `Builtins.addInteger` 1) tl + where + go acc [] = acc + go acc (_ : tl) = go (acc `Builtins.addInteger` 1) tl strictLength :: CompiledCode ([Integer] -> Integer) strictLength = plc (Proxy @"strictLength") (lengthStrict @Integer) @@ -150,7 +150,7 @@ andPlcExternal = plc (Proxy @"andPlcExternal") (andExternal True False) -- self-recursion allDirect :: (a -> Bool) -> [a] -> Bool allDirect p l = case l of - [] -> True + [] -> True h : t -> andDirect (p h) (allDirect p t) allPlcDirect :: CompiledCode Bool @@ -167,7 +167,7 @@ recordSelectorExternal = plc (Proxy @"recordSelectorExternal") (\(x :: MyExterna mapDirect :: (a -> b) -> [a] -> [b] mapDirect f l = case l of - [] -> [] + [] -> [] x : xs -> f x : mapDirect f xs polyMap :: CompiledCode ([Integer]) @@ -203,12 +203,12 @@ unboxedTuples4 = plc (Proxy @"unboxedTuples4") (\x -> let a = unboxedTuple4 (# x unboxedTuples5 :: CompiledCode (Integer -> Integer) unboxedTuples5 = plc (Proxy @"unboxedTuples5") (\x -> let a = unboxedTuple5 (# x, x, x, x, x #) in a) -unboxedTuples2Tuple - :: (# - (# Integer, Integer, Integer, Integer, Integer #) - , (# Integer, Integer, Integer, Integer, Integer #) - #) - -> Integer +unboxedTuples2Tuple :: + (# + (# Integer, Integer, Integer, Integer, Integer #) + , (# Integer, Integer, Integer, Integer, Integer #) + #) -> + Integer unboxedTuples2Tuple (# i, j #) = unboxedTuple5 i `Builtins.addInteger` unboxedTuple5 j unboxedTuples2Tuples :: CompiledCode (Integer -> Integer) @@ -217,13 +217,13 @@ unboxedTuples2Tuples = (Proxy @"unboxedTuples2Tuples") (\x -> let a = unboxedTuples2Tuple (# (# x, x, x, x, x #), (# x, x, x, x, x #) #) in a) -unboxedTuples3Tuple - :: (# - (# Integer, Integer, Integer, Integer, Integer #) - , (# Integer, Integer, Integer, Integer, Integer #) - , (# Integer, Integer, Integer, Integer, Integer #) - #) - -> Integer +unboxedTuples3Tuple :: + (# + (# Integer, Integer, Integer, Integer, Integer #) + , (# Integer, Integer, Integer, Integer, Integer #) + , (# Integer, Integer, Integer, Integer, Integer #) + #) -> + Integer unboxedTuples3Tuple (# i, j, k #) = unboxedTuple5 i `Builtins.addInteger` unboxedTuple5 j `Builtins.addInteger` unboxedTuple5 k unboxedTuples3Tuples :: CompiledCode (Integer -> Integer) diff --git a/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs b/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs index fd4fda7c419..e3de1324191 100644 --- a/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs @@ -1,15 +1,15 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Plugin.Laziness.Spec where diff --git a/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs b/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs index 5ca4ccb493e..f894e1fe99a 100644 --- a/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs +++ b/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-unused-foralls #-} module Plugin.NoTrace.Lib where @@ -39,7 +39,7 @@ traceArgument x = trace x () traceShow :: () traceShow = - let f :: (Show s) => s -> () + let f :: Show s => s -> () f s = trace (show s) () in noinline f MkArg diff --git a/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs b/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs index c77d3946322..b399758bfb4 100644 --- a/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -33,7 +33,7 @@ pattern EInt' i = EInt i pattern ETwoBoth a b = ETwo a b pattern ETwo2 b <- ETwo _ b -pattern ERec{hello, world} <- ETwo hello world +pattern ERec {hello, world} <- ETwo hello world where ERec hello world = ETwo hello world @@ -45,17 +45,17 @@ psym1 = case e of EInt' i -> i ETwo2 _ -> 1 - _ -> 0 + _ -> 0 ) psymRec :: CompiledCode BuiltinString psymRec = plc (Proxy @"psymRec") - ( let r = ERec{hello = "wot", world = "yo"} + ( let r = ERec {hello = "wot", world = "yo"} in case r of - ERec{world} -> world - _ -> "no" + ERec {world} -> world + _ -> "no" ) patterns :: TestNested diff --git a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs index 13e4c260111..fb60d568eef 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs @@ -1,15 +1,15 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Plugin.Primitives.Spec where @@ -186,8 +186,7 @@ bsEquals :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteStri bsEquals = plc (Proxy @"bs32Equals") - ( \(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.equalsByteString x y - ) + (\(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.equalsByteString x y) bsLength :: CompiledCode (Builtins.BuiltinByteString -> Integer) bsLength = plc (Proxy @"bs32Length") (\(x :: Builtins.BuiltinByteString) -> Builtins.lengthOfByteString x) @@ -208,20 +207,18 @@ bsLt :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString - bsLt = plc (Proxy @"bsLt") - ( \(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.lessThanByteString x y - ) + (\(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.lessThanByteString x y) bsDecode :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinString) bsDecode = plc (Proxy @"bsDecode") (\(x :: Builtins.BuiltinByteString) -> Builtins.decodeUtf8 x) -verify - :: CompiledCode - (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool) +verify :: + CompiledCode + (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool) verify = plc (Proxy @"verify") - ( \(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) (z :: Builtins.BuiltinByteString) -> Builtins.verifyEd25519Signature x y z - ) + (\(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) (z :: Builtins.BuiltinByteString) -> Builtins.verifyEd25519Signature x y z) trace :: CompiledCode (Builtins.BuiltinString -> ()) trace = plc (Proxy @"trace") (\(x :: Builtins.BuiltinString) -> Builtins.trace x ()) @@ -257,8 +254,7 @@ deconstructData2 :: CompiledCode (Builtins.BuiltinData -> (Integer, [Integer])) deconstructData2 = plc (Proxy @"deconstructData2") - ( \(d :: Builtins.BuiltinData) -> (P.fmap . P.fmap) Builtins.unsafeDataAsI (Builtins.unsafeDataAsConstr d) - ) + (\(d :: Builtins.BuiltinData) -> (P.fmap . P.fmap) Builtins.unsafeDataAsI (Builtins.unsafeDataAsConstr d)) constructData3 :: CompiledCode (Builtins.BuiltinData) constructData3 = plc (Proxy @"constructData2") (Builtins.mkList [Builtins.mkI 2, Builtins.mkI 3]) @@ -270,8 +266,7 @@ matchData1 :: CompiledCode (Builtins.BuiltinData -> Maybe Integer) matchData1 = plc (Proxy @"matchData1") - ( \(d :: Builtins.BuiltinData) -> (Builtins.matchData d (\_ _ -> Nothing) (const Nothing) (const Nothing) (Just) (const Nothing)) - ) + (\(d :: Builtins.BuiltinData) -> (Builtins.matchData d (\_ _ -> Nothing) (const Nothing) (const Nothing) (Just) (const Nothing))) writeBitsIntegerToByteString :: CompiledCode (P.BuiltinByteString) writeBitsIntegerToByteString = diff --git a/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs b/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs index e3368aa5c84..5a700c115eb 100644 --- a/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:profile-all #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# HLINT ignore "Eta reduce" #-} {-# HLINT ignore "Use guards" #-} @@ -164,7 +164,7 @@ instance TwoMethods Integer where methodB = Builtins.subtractInteger -- Make a function that uses the typeclass polymorphically to check that -useTypeclass :: (TwoMethods a) => a -> a -> Integer +useTypeclass :: TwoMethods a => a -> a -> Integer useTypeclass a b = Builtins.addInteger (methodA a b) (methodB a b) -- Check that typeclass methods get traces diff --git a/plutus-tx-plugin/test/Plugin/Strict/Spec.hs b/plutus-tx-plugin/test/Plugin/Strict/Spec.hs index bd3fa82025a..d6820aa0036 100644 --- a/plutus-tx-plugin/test/Plugin/Strict/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Strict/Spec.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -- To ensure the traces don't get optimized away in the tests {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Plugin.Strict.Spec (strict) where diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs b/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs index 5d2b5bc765f..d30e599f002 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-typecheck #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module Plugin.Typeclasses.Spec where @@ -68,19 +68,19 @@ class PersonLike a where instance PersonLike Person where {-# INLINEABLE age #-} - age Jim = 30 + age Jim = 30 age Jane = 35 {-# INLINEABLE likesAnimal #-} likesAnimal Jane Cat = True - likesAnimal _ _ = False + likesAnimal _ _ = False instance PersonLike Alien where {-# INLINEABLE age #-} - age AlienJim = 300 + age AlienJim = 300 age AlienJane = 350 {-# INLINEABLE likesAnimal #-} likesAnimal AlienJane Dog = True - likesAnimal _ _ = False + likesAnimal _ _ = False multiFunction :: CompiledCode (Person -> Bool) multiFunction = @@ -88,7 +88,7 @@ multiFunction = (Proxy @"multiFunction") ( let {-# OPAQUE predicate #-} - predicate :: (PersonLike p) => p -> Bool + predicate :: PersonLike p => p -> Bool predicate p = likesAnimal p Cat P.&& (age p `Builtins.lessThanInteger` 30) in \(p :: Person) -> predicate p @@ -100,7 +100,7 @@ defaultMethods = (Proxy @"defaultMethods") ( let {-# OPAQUE f #-} - f :: (DefaultMethods a) => a -> Integer + f :: DefaultMethods a => a -> Integer f a = method2 a in \(a :: Integer) -> f a @@ -112,7 +112,7 @@ partialApplication = plc (Proxy @"partialApplication") (P.compare @Integer) sequenceTest :: CompiledCode (Maybe [Integer]) sequenceTest = plc (Proxy @"sequenceTests") (T.sequence [Just (1 :: Integer), Just (2 :: Integer)]) -opCompare :: (P.Ord a) => a -> a -> Ordering +opCompare :: P.Ord a => a -> a -> Ordering opCompare a b = case P.compare a b of LT -> GT EQ -> EQ diff --git a/plutus-tx-plugin/test/StdLib/Spec.hs b/plutus-tx-plugin/test/StdLib/Spec.hs index 735cae00100..1458d2ebc92 100644 --- a/plutus-tx-plugin/test/StdLib/Spec.hs +++ b/plutus-tx-plugin/test/StdLib/Spec.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} @@ -37,8 +37,8 @@ import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.Ratio qualified as Ratio import PlutusTx.Test (goldenPirReadable) import Test.Tasty (TestName, TestTree) -import Test.Tasty.Hedgehog (testPropertyNamed) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Test.Tasty.Hedgehog (testPropertyNamed) roundPlc :: CompiledCode (Ratio.Rational -> Integer) roundPlc = plc (Proxy @"roundPlc") Ratio.round @@ -61,9 +61,8 @@ tests = -- We really should use something like "Control.Exception.Enclosed" here and in other similar -- places. -{-| Evaluate (deeply, to get through tuples) a value, throwing away any exception and just -representing it as 'Nothing'. --} +-- | Evaluate (deeply, to get through tuples) a value, throwing away any exception and just +-- representing it as 'Nothing'. tryHard :: (MonadIO m, NFData a) => a -> m (Maybe a) -- We have @Strict@ enabled, hence without the tilda this function evaluates @a@ before evaluating -- the body, i.e. outside of the call to 'try', defeating the whole purpose. @@ -76,8 +75,8 @@ testRatioInterop = testCase "ratioInterop" do Left e -> assertFailure (show e) Right r -> r @?= Core.mkConstant () (4 :: Integer) -testRatioProperty - :: (Show a, Eq a) => TestName -> (Ratio.Rational -> a) -> (Rational -> a) -> TestNested +testRatioProperty :: + (Show a, Eq a) => TestName -> (Ratio.Rational -> a) -> (Rational -> a) -> TestNested testRatioProperty nm plutusFunc ghcFunc = embed $ testPropertyNamed nm (fromString nm) $ Hedgehog.property $ do rat <- Hedgehog.forAll $ Gen.realFrac_ (Range.linearFrac (-10000) 100000) @@ -130,7 +129,7 @@ eqData = Hedgehog.property $ do Hedgehog.annotateShow theData Hedgehog.assert (ghcResult && plutusResult) -genData :: (MonadGen m) => m PLC.Data +genData :: MonadGen m => m PLC.Data genData = let genInteger = Gen.integral (Range.linear (-10000) 100000) genBytes = Gen.bytes (Range.linear 0 1000) diff --git a/plutus-tx-plugin/test/TH/Spec.hs b/plutus-tx-plugin/test/TH/Spec.hs index 3ce9f2b939c..0eba0cdfb5f 100644 --- a/plutus-tx-plugin/test/TH/Spec.hs +++ b/plutus-tx-plugin/test/TH/Spec.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} module TH.Spec (tests) where diff --git a/plutus-tx/src/Data/Aeson/Extra.hs b/plutus-tx/src/Data/Aeson/Extra.hs index c638c916ae2..deaa942973b 100644 --- a/plutus-tx/src/Data/Aeson/Extra.hs +++ b/plutus-tx/src/Data/Aeson/Extra.hs @@ -14,54 +14,52 @@ import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KeyMap import Data.Char qualified as Char -{-| Build a JSON object omitting optional keys if a corresponding value is 'Nothing'. - -Example: -@ - buildObject - $ requiredField "field1" 'a' - . requiredField "field2" 'c' - . optionalField "field3" (Just "hello") - . optionalField "field4" Nothing -@ -builds this JSON object: -@ - { - "field1": 'a', - "field2": 'c', - "field3": "hello" - } -@ -omitting optional 'field4'. --} +-- | Build a JSON object omitting optional keys if a corresponding value is 'Nothing'. +-- +-- Example: +-- @ +-- buildObject +-- $ requiredField "field1" 'a' +-- . requiredField "field2" 'c' +-- . optionalField "field3" (Just "hello") +-- . optionalField "field4" Nothing +-- @ +-- builds this JSON object: +-- @ +-- { +-- "field1": 'a', +-- "field2": 'c', +-- "field3": "hello" +-- } +-- @ +-- omitting optional 'field4'. buildObject :: (Aeson.Object -> Aeson.Object) -> Aeson.Value buildObject = Aeson.Object . ($ KeyMap.empty) -optionalField :: (ToJSON a) => Aeson.Key -> Maybe a -> Aeson.Object -> Aeson.Object +optionalField :: ToJSON a => Aeson.Key -> Maybe a -> Aeson.Object -> Aeson.Object optionalField = maybe id . requiredField -requiredField :: (ToJSON a) => Aeson.Key -> a -> Aeson.Object -> Aeson.Object +requiredField :: ToJSON a => Aeson.Key -> a -> Aeson.Object -> Aeson.Object requiredField key value = KeyMap.insert key (toJSON value) -{-| A field label modifier that strips a prefix from the camelCased field name; ->>> stripPrefix "preamble" "preambleTitle" -"title" --} -stripPrefix - :: String - -- ^ Field prefix to strip - -> String - -- ^ Field name - -> String +-- | A field label modifier that strips a prefix from the camelCased field name; +-- >>> stripPrefix "preamble" "preambleTitle" +-- "title" +stripPrefix :: + -- | Field prefix to strip + String -> + -- | Field name + String -> + String stripPrefix prefix field = go (prefix, field) - where - go = \case - (p1 : ps, f1 : fs) | p1 == f1 -> go (ps, fs) - ([], f1 : fs) -> Char.toLower f1 : fs - _ -> - error $ - "Unexpected field name '" - ++ field - ++ "', must start from '" - ++ prefix - ++ "' and have other characters after." + where + go = \case + (p1 : ps, f1 : fs) | p1 == f1 -> go (ps, fs) + ([], f1 : fs) -> Char.toLower f1 : fs + _ -> + error $ + "Unexpected field name '" + ++ field + ++ "', must start from '" + ++ prefix + ++ "' and have other characters after." diff --git a/plutus-tx/src/PlutusTx/Applicative.hs b/plutus-tx/src/PlutusTx/Applicative.hs index b85624456cb..a0a6df3caf3 100644 --- a/plutus-tx/src/PlutusTx/Applicative.hs +++ b/plutus-tx/src/PlutusTx/Applicative.hs @@ -18,7 +18,7 @@ import PlutusTx.Monoid (Monoid (..), mappend) infixl 4 <*>, <*, *> -- | Plutus Tx version of 'Control.Applicative.Applicative'. -class (Functor f) => Applicative f where +class Functor f => Applicative f where {-# MINIMAL pure, (<*>) #-} -- | Plutus Tx version of 'Control.Applicative.pure'. @@ -28,22 +28,22 @@ class (Functor f) => Applicative f where (<*>) :: f (a -> b) -> f a -> f b -- | Plutus Tx version of 'Control.Applicative.liftA2'. -liftA2 :: (Applicative f) => (a -> b -> c) -> f a -> f b -> f c +liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 f x = (<*>) (fmap f x) {-# INLINEABLE liftA2 #-} -- | Plutus Tx version of '(Control.Applicative.*>)'. -(*>) :: (Applicative f) => f a -> f b -> f b +(*>) :: Applicative f => f a -> f b -> f b a1 *> a2 = (id <$ a1) <*> a2 {-# INLINEABLE (*>) #-} -- | Plutus Tx version of '(Control.Applicative.<*)'. -(<*) :: (Applicative f) => f a -> f b -> f a +(<*) :: Applicative f => f a -> f b -> f a (<*) = liftA2 const {-# INLINEABLE (<*) #-} -- | Plutus Tx version of 'Control.Monad.unless'. -unless :: (Applicative f) => Bool -> f () -> f () +unless :: Applicative f => Bool -> f () -> f () unless p s = if p then pure () else s {-# INLINEABLE unless #-} @@ -51,15 +51,15 @@ instance Applicative Maybe where {-# INLINEABLE pure #-} pure = Just {-# INLINEABLE (<*>) #-} - Nothing <*> _ = Nothing - _ <*> Nothing = Nothing + Nothing <*> _ = Nothing + _ <*> Nothing = Nothing Just f <*> Just x = Just (f x) instance Applicative (Either a) where {-# INLINEABLE pure #-} pure = Right {-# INLINEABLE (<*>) #-} - Left e <*> _ = Left e + Left e <*> _ = Left e Right f <*> r = fmap f r instance Applicative [] where @@ -75,7 +75,7 @@ instance Applicative Identity where (<*>) :: forall a b. Identity (a -> b) -> Identity a -> Identity b (<*>) = coerce (id :: (a -> b) -> a -> b) -instance (Monoid m) => Applicative (Const m) where +instance Monoid m => Applicative (Const m) where {-# INLINEABLE pure #-} pure _ = Const mempty {-# INLINEABLE (<*>) #-} diff --git a/plutus-tx/src/PlutusTx/AsData.hs b/plutus-tx/src/PlutusTx/AsData.hs index f4f28ffa9cd..ef95517a9a0 100644 --- a/plutus-tx/src/PlutusTx/AsData.hs +++ b/plutus-tx/src/PlutusTx/AsData.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module PlutusTx.AsData (asData, asDataFor) where @@ -22,51 +22,50 @@ import PlutusTx.IsData.TH (AsDataProdType (..), mkConstrCreateExpr, mkUnsafeCons import Prelude -{-| 'asData' takes a datatype declaration and "backs it" by 'BuiltinData'. It does -this by replacing the datatype with a newtype around 'BuiltinData', and providing -pattern synonyms that match the behaviour of the original datatype. - -Since 'BuiltinData' can only contain 'BuiltinData', the pattern synonyms -encode and decode all the fields using 'toBuiltinData' and 'unsafeFromBuiltinData'. -That means that these operations are called on every pattern match or construction. -This *can* be very efficient if, for example, the datatypes for the fields have -also been defined with 'asData', and so have trivial conversions to/from 'BuiltinData' -(or have very cheap conversions, like 'Integer' and 'ByteString'). -But it can be very expensive otherwise, so take care. - -Deriving clauses are transferred from the quoted declaration to the generated newtype -declaration. Note that you may therefore need to do strange things like use -@deriving newtype@ on a data declaration. - -__Example__: - -@ - $(asData [d| - data Example a = Ex1 Integer | Ex2 a a - deriving newtype (Eq) - |]) -@ - -becomes - -@ - newtype Example a = Example BuiltinData - deriving newtype (Eq) - - pattern Ex1 :: (ToData a, UnsafeFromData a) => Integer -> Example a - pattern Ex1 i <- Example (unsafeDataAsConstr -> ((==) 0 -> True, [unsafeFromBuiltinData -> i])) - where Ex1 i = Example (mkConstr 0 [toBuiltinData i]) - - pattern Ex2 :: (ToData a, UnsafeFromData a) => a -> a -> Example a - pattern Ex2 a1 a2 <- Example (unsafeDataAsConstr -> ((==) 1 -> True, - [ unsafeFromBuiltinData -> a1 - , unsafeFromBuiltinData -> a2 - ])) - where Ex2 a1 a2 = Example (mkConstr 1 [toBuiltinData a1, toBuiltinData a2]) - - {\-# COMPLETE Ex1, Ex2 #-\} -@ --} +-- | 'asData' takes a datatype declaration and "backs it" by 'BuiltinData'. It does +-- this by replacing the datatype with a newtype around 'BuiltinData', and providing +-- pattern synonyms that match the behaviour of the original datatype. +-- +-- Since 'BuiltinData' can only contain 'BuiltinData', the pattern synonyms +-- encode and decode all the fields using 'toBuiltinData' and 'unsafeFromBuiltinData'. +-- That means that these operations are called on every pattern match or construction. +-- This *can* be very efficient if, for example, the datatypes for the fields have +-- also been defined with 'asData', and so have trivial conversions to/from 'BuiltinData' +-- (or have very cheap conversions, like 'Integer' and 'ByteString'). +-- But it can be very expensive otherwise, so take care. +-- +-- Deriving clauses are transferred from the quoted declaration to the generated newtype +-- declaration. Note that you may therefore need to do strange things like use +-- @deriving newtype@ on a data declaration. +-- +-- __Example__: +-- +-- @ +-- $(asData [d| +-- data Example a = Ex1 Integer | Ex2 a a +-- deriving newtype (Eq) +-- |]) +-- @ +-- +-- becomes +-- +-- @ +-- newtype Example a = Example BuiltinData +-- deriving newtype (Eq) +-- +-- pattern Ex1 :: (ToData a, UnsafeFromData a) => Integer -> Example a +-- pattern Ex1 i <- Example (unsafeDataAsConstr -> ((==) 0 -> True, [unsafeFromBuiltinData -> i])) +-- where Ex1 i = Example (mkConstr 0 [toBuiltinData i]) +-- +-- pattern Ex2 :: (ToData a, UnsafeFromData a) => a -> a -> Example a +-- pattern Ex2 a1 a2 <- Example (unsafeDataAsConstr -> ((==) 1 -> True, +-- [ unsafeFromBuiltinData -> a1 +-- , unsafeFromBuiltinData -> a2 +-- ])) +-- where Ex2 a1 a2 = Example (mkConstr 1 [toBuiltinData a1, toBuiltinData a2]) +-- +-- {\-# COMPLETE Ex1, Ex2 #-\} +-- @ asData :: TH.Q [TH.Dec] -> TH.Q [TH.Dec] asData decQ = do decs <- decQ diff --git a/plutus-tx/src/PlutusTx/AsData/Internal.hs b/plutus-tx/src/PlutusTx/AsData/Internal.hs index db7e724d8cd..1479db70910 100644 --- a/plutus-tx/src/PlutusTx/AsData/Internal.hs +++ b/plutus-tx/src/PlutusTx/AsData/Internal.hs @@ -1,9 +1,8 @@ {-# LANGUAGE Strict #-} {-# OPTIONS_GHC -fexpose-all-unfoldings #-} -{-| Functions in this module are for internal compiler use only, and should not -be used elsewhere. --} +-- | Functions in this module are for internal compiler use only, and should not +-- be used elsewhere. module PlutusTx.AsData.Internal where import PlutusTx.Builtins.Internal as BI diff --git a/plutus-tx/src/PlutusTx/AssocMap.hs b/plutus-tx/src/PlutusTx/AssocMap.hs index b1b89ce4038..304b24b0de7 100644 --- a/plutus-tx/src/PlutusTx/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/AssocMap.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -- | A map represented as an "association list" of key-value pairs. @@ -69,22 +69,21 @@ import Prettyprinter (Pretty (..)) -- See Note [Optimising Value]. -{-| A 'Map' of key-value pairs. -A 'Map' is considered well-defined if there are no key collisions, meaning that each value -is uniquely identified by a key. - -Use 'safeFromList' to create well-defined 'Map's from arbitrary lists of pairs. - -If cost minimisation is required, then you can use 'unsafeFromList' but you must -be certain that the list you are converting to a 'Map' abides by the well-definedness condition. - -Most operations on 'Map's are definedness-preserving, meaning that for the resulting 'Map' to be -well-defined then the input 'Map'(s) have to also be well-defined. This is not checked explicitly -unless mentioned in the documentation. - -Take care when using 'fromBuiltinData' and 'unsafeFromBuiltinData', as neither function performs -deduplication of the input collection and may create invalid 'Map's! --} +-- | A 'Map' of key-value pairs. +-- A 'Map' is considered well-defined if there are no key collisions, meaning that each value +-- is uniquely identified by a key. +-- +-- Use 'safeFromList' to create well-defined 'Map's from arbitrary lists of pairs. +-- +-- If cost minimisation is required, then you can use 'unsafeFromList' but you must +-- be certain that the list you are converting to a 'Map' abides by the well-definedness condition. +-- +-- Most operations on 'Map's are definedness-preserving, meaning that for the resulting 'Map' to be +-- well-defined then the input 'Map'(s) have to also be well-defined. This is not checked explicitly +-- unless mentioned in the documentation. +-- +-- Take care when using 'fromBuiltinData' and 'unsafeFromBuiltinData', as neither function performs +-- deduplication of the input collection and may create invalid 'Map's! newtype Map k v = Map {unMap :: [(k, v)]} deriving stock (Generic, Haskell.Show, Data, TH.Lift) deriving newtype (NFData) @@ -97,26 +96,24 @@ instance (Haskell.Ord k, Haskell.Ord v) => Haskell.Ord (Map k v) where Map l <= Map r = on (Haskell.<=) HMap.fromList l r -{-| Hand-written instances to use the underlying 'Map' type in 'Data', and -to be reasonably efficient. --} +-- | Hand-written instances to use the underlying 'Map' type in 'Data', and +-- to be reasonably efficient. instance (ToData k, ToData v) => ToData (Map k v) where toBuiltinData (Map es) = BI.mkMap (mapToBuiltin es) - where - {-# INLINE mapToBuiltin #-} - mapToBuiltin :: [(k, v)] -> BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) - mapToBuiltin = go - where - go :: [(k, v)] -> BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) - go [] = P.mkNil - go ((k, v) : xs) = BI.mkCons (BI.mkPairData (toBuiltinData k) (toBuiltinData v)) (go xs) - -{-| A hand-written transformation from 'Data' to 'Map'. Compared to 'unsafeFromBuiltinData', -it is safe to call when it is unknown if the 'Data' is built with 'Data's 'Map' constructor. -Note that it is, however, unsafe in the sense that it assumes that any map -encoded in the 'Data' is well-formed, i.e. 'fromBuiltinData' does not perform any -deduplication of keys or of key-value pairs! --} + where + {-# INLINE mapToBuiltin #-} + mapToBuiltin :: [(k, v)] -> BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) + mapToBuiltin = go + where + go :: [(k, v)] -> BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) + go [] = P.mkNil + go ((k, v) : xs) = BI.mkCons (BI.mkPairData (toBuiltinData k) (toBuiltinData v)) (go xs) + +-- | A hand-written transformation from 'Data' to 'Map'. Compared to 'unsafeFromBuiltinData', +-- it is safe to call when it is unknown if the 'Data' is built with 'Data's 'Map' constructor. +-- Note that it is, however, unsafe in the sense that it assumes that any map +-- encoded in the 'Data' is well-formed, i.e. 'fromBuiltinData' does not perform any +-- deduplication of keys or of key-value pairs! instance (FromData k, FromData v) => FromData (Map k v) where fromBuiltinData d = P.matchData' @@ -126,54 +123,53 @@ instance (FromData k, FromData v) => FromData (Map k v) where (const Nothing) (const Nothing) (const Nothing) - where - {-# INLINE traverseFromBuiltin #-} - traverseFromBuiltin - :: BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) - -> Maybe [(k, v)] - traverseFromBuiltin = go - where - go :: BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) -> Maybe [(k, v)] - go = - P.caseList' - (pure []) - ( \tup tups -> - liftA2 - (:) - (liftA2 (,) (fromBuiltinData $ BI.fst tup) (fromBuiltinData $ BI.snd tup)) - (go tups) - ) - -{-| A hand-written transformation from 'Data' to 'Map'. It is unsafe because the -caller must provide the guarantee that the 'Data' is constructed using the 'Data's -'Map' constructor. -Note that it assumes, like the 'fromBuiltinData' transformation, that the map -encoded in the 'Data' is well-formed, i.e. 'unsafeFromBuiltinData' does not perform -any deduplication of keys or of key-value pairs! --} + where + {-# INLINE traverseFromBuiltin #-} + traverseFromBuiltin :: + BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) -> + Maybe [(k, v)] + traverseFromBuiltin = go + where + go :: BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) -> Maybe [(k, v)] + go = + P.caseList' + (pure []) + ( \tup tups -> + liftA2 + (:) + (liftA2 (,) (fromBuiltinData $ BI.fst tup) (fromBuiltinData $ BI.snd tup)) + (go tups) + ) + +-- | A hand-written transformation from 'Data' to 'Map'. It is unsafe because the +-- caller must provide the guarantee that the 'Data' is constructed using the 'Data's +-- 'Map' constructor. +-- Note that it assumes, like the 'fromBuiltinData' transformation, that the map +-- encoded in the 'Data' is well-formed, i.e. 'unsafeFromBuiltinData' does not perform +-- any deduplication of keys or of key-value pairs! instance (UnsafeFromData k, UnsafeFromData v) => UnsafeFromData (Map k v) where -- The `~` here enables `BI.unsafeDataAsMap d` to be inlined, which reduces costs slightly. -- Without the `~`, the inliner would consider it not effect safe to inline. -- We can remove the `~` once we make the inliner smart enough to inline them. -- See https://github.com/IntersectMBO/plutus/pull/5371#discussion_r1297833685 unsafeFromBuiltinData d = let ~es = BI.unsafeDataAsMap d in Map $ mapFromBuiltin es - where - {-# INLINE mapFromBuiltin #-} - mapFromBuiltin :: BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) -> [(k, v)] - mapFromBuiltin = go - where - go :: BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) -> [(k, v)] - go = - P.caseList' - [] - ( \tup tups -> - (unsafeFromBuiltinData $ BI.fst tup, unsafeFromBuiltinData $ BI.snd tup) - : go tups - ) + where + {-# INLINE mapFromBuiltin #-} + mapFromBuiltin :: BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) -> [(k, v)] + mapFromBuiltin = go + where + go :: BuiltinList (BuiltinPair BI.BuiltinData BI.BuiltinData) -> [(k, v)] + go = + P.caseList' + [] + ( \tup tups -> + (unsafeFromBuiltinData $ BI.fst tup, unsafeFromBuiltinData $ BI.snd tup) + : go tups + ) instance - (HasBlueprintDefinition k, HasBlueprintDefinition v) - => HasBlueprintDefinition (Map k v) + (HasBlueprintDefinition k, HasBlueprintDefinition v) => + HasBlueprintDefinition (Map k v) where type Unroll (Map k v) = [Map k v, k, v] definitionId = @@ -184,8 +180,8 @@ instance instance ( HasBlueprintSchema k referencedTypes , HasBlueprintSchema v referencedTypes - ) - => HasBlueprintSchema (Map k v) referencedTypes + ) => + HasBlueprintSchema (Map k v) referencedTypes where schema = SchemaMap @@ -221,19 +217,17 @@ instance (Eq k, Semigroup v) => Monoid (Map k v) where instance (Pretty k, Pretty v) => Pretty (Map k v) where pretty (Map mp) = pretty mp -{-| Unsafely create a 'Map' from a list of pairs. This should _only_ be applied to lists which -have been checked to not contain duplicate keys, otherwise the resulting 'Map' will contain -conflicting entries (two entries sharing the same key). -As usual, the "keys" are considered to be the first element of the pair. --} +-- | Unsafely create a 'Map' from a list of pairs. This should _only_ be applied to lists which +-- have been checked to not contain duplicate keys, otherwise the resulting 'Map' will contain +-- conflicting entries (two entries sharing the same key). +-- As usual, the "keys" are considered to be the first element of the pair. unsafeFromList :: [(k, v)] -> Map k v unsafeFromList = Map {-# INLINEABLE unsafeFromList #-} -{-| In case of duplicates, this function will keep only one entry (the one that precedes). -In other words, this function de-duplicates the input list. --} -safeFromList :: (Eq k) => [(k, v)] -> Map k v +-- | In case of duplicates, this function will keep only one entry (the one that precedes). +-- In other words, this function de-duplicates the input list. +safeFromList :: Eq k => [(k, v)] -> Map k v safeFromList = List.foldr (uncurry insert) empty {-# INLINEABLE safeFromList #-} @@ -241,66 +235,62 @@ toList :: Map k v -> [(k, v)] toList (Map l) = l {-# INLINEABLE toList #-} -{-| Find an entry in a 'Map'. If the 'Map' is not well-formed (it contains duplicate keys) -then this will return the value of the left-most pair in the underlying list of pairs. --} -lookup :: forall k v. (Eq k) => k -> Map k v -> Maybe v +-- | Find an entry in a 'Map'. If the 'Map' is not well-formed (it contains duplicate keys) +-- then this will return the value of the left-most pair in the underlying list of pairs. +lookup :: forall k v. Eq k => k -> Map k v -> Maybe v lookup c (Map xs) = let go :: [(k, v)] -> Maybe v - go [] = Nothing + go [] = Nothing go ((c', i) : xs') = if c' == c then Just i else go xs' in go xs {-# INLINEABLE lookup #-} -- | Is the key a member of the map? -member :: forall k v. (Eq k) => k -> Map k v -> Bool +member :: forall k v. Eq k => k -> Map k v -> Bool member k m = isJust (lookup k m) {-# INLINEABLE member #-} -- | If a key already exists in the map, its entry will be replaced with the new value. -insert :: forall k v. (Eq k) => k -> v -> Map k v -> Map k v +insert :: forall k v. Eq k => k -> v -> Map k v -> Map k v insert k v (Map xs) = Map (go xs) - where - go [] = [(k, v)] - go ((k', v') : rest) = if k == k' then (k, v) : rest else (k', v') : go rest + where + go [] = [(k, v)] + go ((k', v') : rest) = if k == k' then (k, v) : rest else (k', v') : go rest {-# INLINEABLE insert #-} -{-| Delete an entry from the 'Map'. Assumes that the 'Map' is well-formed, i.e. if the -underlying list of pairs contains pairs with duplicate keys then only the left-most -pair will be removed. --} -delete :: forall k v. (Eq k) => k -> Map k v -> Map k v +-- | Delete an entry from the 'Map'. Assumes that the 'Map' is well-formed, i.e. if the +-- underlying list of pairs contains pairs with duplicate keys then only the left-most +-- pair will be removed. +delete :: forall k v. Eq k => k -> Map k v -> Map k v delete key (Map ls) = Map (go ls) - where - go [] = [] - go ((k, v) : rest) - | k == key = rest - | otherwise = (k, v) : go rest + where + go [] = [] + go ((k, v) : rest) + | k == key = rest + | otherwise = (k, v) : go rest {-# INLINEABLE delete #-} -{-| The keys of a 'Map'. Semantically, the resulting list is only a set if the 'Map' -didn't contain duplicate keys. --} +-- | The keys of a 'Map'. Semantically, the resulting list is only a set if the 'Map' +-- didn't contain duplicate keys. keys :: Map k v -> [k] keys (Map xs) = P.fmap (\(k, _ :: v) -> k) xs {-# INLINEABLE keys #-} -{-| Combine two 'Map's. Keeps both values on key collisions. -Note that well-formedness is only preserved if the two input maps -are also well-formed. -Also, as an implementation detail, in the case that the right map contains -duplicate keys, and there exists a collision between the two maps, -then only the left-most value of the right map will be kept. --} -union :: forall k v r. (Eq k) => Map k v -> Map k r -> Map k (These v r) +-- | Combine two 'Map's. Keeps both values on key collisions. +-- Note that well-formedness is only preserved if the two input maps +-- are also well-formed. +-- Also, as an implementation detail, in the case that the right map contains +-- duplicate keys, and there exists a collision between the two maps, +-- then only the left-most value of the right map will be kept. +union :: forall k v r. Eq k => Map k v -> Map k r -> Map k (These v r) union (Map ls) (Map rs) = let f :: v -> Maybe r -> These v r f a b' = case b' of Nothing -> This a - Just b -> These a b + Just b -> These a b ls' :: [(k, These v r)] ls' = P.fmap (\(c, i) -> (c, f i (lookup c (Map rs)))) ls @@ -314,20 +304,19 @@ union (Map ls) (Map rs) = in Map (ls' List.++ rs'') -{-| Combine two 'Map's with the given combination function. -Note that well-formedness of the resulting map depends on the two input maps -being well-formed. -Also, as an implementation detail, in the case that the right map contains -duplicate keys, and there exists a collision between the two maps, -then only the left-most value of the right map will be kept. --} -unionWith :: forall k a. (Eq k) => (a -> a -> a) -> Map k a -> Map k a -> Map k a +-- | Combine two 'Map's with the given combination function. +-- Note that well-formedness of the resulting map depends on the two input maps +-- being well-formed. +-- Also, as an implementation detail, in the case that the right map contains +-- duplicate keys, and there exists a collision between the two maps, +-- then only the left-most value of the right map will be kept. +unionWith :: forall k a. Eq k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith merge (Map ls) (Map rs) = let f :: a -> Maybe a -> a f a b' = case b' of Nothing -> a - Just b -> merge a b + Just b -> merge a b ls' :: [(k, a)] ls' = P.fmap (\(c, i) -> (c, f i (lookup c (Map rs)))) ls @@ -341,13 +330,13 @@ unionWith merge (Map ls) (Map rs) = -- | A version of 'Data.Map.Lazy.mapEither' that works with 'These'. mapThese :: (v -> These a b) -> Map k v -> (Map k a, Map k b) mapThese f mps = (Map mpl, Map mpr) - where - (mpl, mpr) = List.foldr f' ([], []) mps' - Map mps' = fmap f mps - f' (k, v) (as, bs) = case v of - This a -> ((k, a) : as, bs) - That b -> (as, (k, b) : bs) - These a b -> ((k, a) : as, (k, b) : bs) + where + (mpl, mpr) = List.foldr f' ([], []) mps' + Map mps' = fmap f mps + f' (k, v) (as, bs) = case v of + This a -> ((k, a) : as, bs) + That b -> (as, (k, b) : bs) + These a b -> ((k, a) : as, (k, b) : bs) {-# INLINEABLE mapThese #-} -- | A singleton map. @@ -392,10 +381,10 @@ mapMaybeWithKey f (Map xs) = Map $ P.mapMaybe (\(k, v) -> (k,) <$> f k v) xs -- | Determines whether all elements in the map satisfy the predicate. all :: (a -> Bool) -> Map k a -> Bool all f (Map m) = go m - where - go = \case - [] -> True - (_, x) : xs -> if f x then go xs else False + where + go = \case + [] -> True + (_, x) : xs -> if f x then go xs else False {-# INLINEABLE all #-} ---------------------------------------------------------------------------------------------------- diff --git a/plutus-tx/src/PlutusTx/Base.hs b/plutus-tx/src/PlutusTx/Base.hs index 8fc0a9e2159..48e40dbe28d 100644 --- a/plutus-tx/src/PlutusTx/Base.hs +++ b/plutus-tx/src/PlutusTx/Base.hs @@ -38,10 +38,10 @@ flip f x y = f y x -- | Plutus Tx version of 'Prelude.until'. until :: (a -> Bool) -> (a -> a) -> a -> a until p f = go - where - go x - | p x = x - | otherwise = go (f x) + where + go x + | p x = x + | otherwise = go (f x) {-# INLINEABLE until #-} infixr 9 . diff --git a/plutus-tx/src/PlutusTx/Blueprint/Argument.hs b/plutus-tx/src/PlutusTx/Blueprint/Argument.hs index 0f2ccf35ca2..e247997bc19 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Argument.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Argument.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module PlutusTx.Blueprint.Argument where @@ -19,19 +19,19 @@ import PlutusTx.Blueprint.Schema (Schema) -- | Blueprint that defines a validator's runtime argument: datum or redeemer. data ArgumentBlueprint (referencedTypes :: [Type]) = MkArgumentBlueprint - { argumentTitle :: Maybe Text + { argumentTitle :: Maybe Text -- ^ A short and descriptive name for the redeemer or datum. , argumentDescription :: Maybe Text -- ^ An informative description of the redeemer or datum. - , argumentPurpose :: Set Purpose + , argumentPurpose :: Set Purpose -- ^ A possibly empty set of purposes for the redeemer or datum. - , argumentSchema :: Schema referencedTypes + , argumentSchema :: Schema referencedTypes -- ^ A Plutus Data Schema. } deriving stock (Show, Eq, Ord) instance ToJSON (ArgumentBlueprint referencedTypes) where - toJSON MkArgumentBlueprint{..} = + toJSON MkArgumentBlueprint {..} = buildObject $ requiredField "schema" argumentSchema . optionalField "title" argumentTitle diff --git a/plutus-tx/src/PlutusTx/Blueprint/Class.hs b/plutus-tx/src/PlutusTx/Blueprint/Class.hs index f402716147f..f3388ca4e7f 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Class.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Class.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusTx.Blueprint.Class where @@ -15,16 +15,20 @@ import Prelude hiding (maximum, minimum) import Data.ByteString (ByteString) import Data.Kind (Type) -import PlutusTx.Blueprint.Schema (ListSchema (..), PairSchema (..), Schema (..), emptyBytesSchema, - emptyIntegerSchema) +import PlutusTx.Blueprint.Schema ( + ListSchema (..), + PairSchema (..), + Schema (..), + emptyBytesSchema, + emptyIntegerSchema, + ) import PlutusTx.Blueprint.Schema.Annotation (emptySchemaInfo) import PlutusTx.Builtins (BuiltinByteString, BuiltinData, BuiltinString) import PlutusTx.Builtins.Internal (BuiltinList, BuiltinPair, BuiltinUnit) -{-| - A class of types that have a Blueprint schema definition - and can reference other schema definitions of other types. --} +-- | +-- A class of types that have a Blueprint schema definition +-- and can reference other schema definitions of other types. class HasBlueprintSchema (t :: Type) (referencedTypes :: [Type]) where schema :: Schema referencedTypes @@ -50,8 +54,8 @@ instance HasBlueprintSchema ByteString referencedTypes where schema = SchemaBytes emptySchemaInfo emptyBytesSchema instance - (HasBlueprintSchema a referencedTypes) - => HasBlueprintSchema [a] referencedTypes + HasBlueprintSchema a referencedTypes => + HasBlueprintSchema [a] referencedTypes where schema = SchemaList @@ -65,15 +69,15 @@ instance ) instance - (HasBlueprintSchema a referencedTypes) - => HasBlueprintSchema (BuiltinList a) referencedTypes + HasBlueprintSchema a referencedTypes => + HasBlueprintSchema (BuiltinList a) referencedTypes where schema = SchemaBuiltInList emptySchemaInfo (schema @a) instance ( HasBlueprintSchema a referencedTypes , HasBlueprintSchema b referencedTypes - ) - => HasBlueprintSchema (BuiltinPair a b) referencedTypes + ) => + HasBlueprintSchema (BuiltinPair a b) referencedTypes where schema = SchemaBuiltInPair emptySchemaInfo (MkPairSchema (schema @a) (schema @b)) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Contract.hs b/plutus-tx/src/PlutusTx/Blueprint/Contract.hs index 3af5e9450df..8c1af83ddfa 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Contract.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Contract.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module PlutusTx.Blueprint.Contract where @@ -22,28 +22,27 @@ import PlutusTx.Blueprint.Definition (DefinitionId, Definitions, definitionsToMa import PlutusTx.Blueprint.Preamble (Preamble) import PlutusTx.Blueprint.Validator (ValidatorBlueprint) -{-| A blueprint of a smart contract, as defined by the CIP-0057 - -The 'referencedTypes' type variable is used to track the types used in the contract -making sure their schemas are included in the blueprint and that they are referenced -in a type-safe way. See Note ["Unrolling" types] for more details. --} +-- | A blueprint of a smart contract, as defined by the CIP-0057 +-- +-- The 'referencedTypes' type variable is used to track the types used in the contract +-- making sure their schemas are included in the blueprint and that they are referenced +-- in a type-safe way. See Note ["Unrolling" types] for more details. data ContractBlueprint where - MkContractBlueprint - :: forall referencedTypes - . { contractId :: Maybe Text - -- ^ An optional identifier for the contract. - , contractPreamble :: Preamble - -- ^ An object with meta-information about the contract. - , contractValidators :: Set (ValidatorBlueprint referencedTypes) - -- ^ A set of validator blueprints that are part of the contract. - , contractDefinitions :: Definitions referencedTypes - -- ^ A registry of schema definitions used across the blueprint. - } - -> ContractBlueprint + MkContractBlueprint :: + forall referencedTypes. + { contractId :: Maybe Text + -- ^ An optional identifier for the contract. + , contractPreamble :: Preamble + -- ^ An object with meta-information about the contract. + , contractValidators :: Set (ValidatorBlueprint referencedTypes) + -- ^ A set of validator blueprints that are part of the contract. + , contractDefinitions :: Definitions referencedTypes + -- ^ A registry of schema definitions used across the blueprint. + } -> + ContractBlueprint instance ToJSON ContractBlueprint where - toJSON MkContractBlueprint{..} = + toJSON MkContractBlueprint {..} = Aeson.buildObject $ requiredField "$schema" schemaUrl . requiredField @@ -59,9 +58,9 @@ instance ToJSON ContractBlueprint where . requiredField "validators" contractValidators . optionalField "$id" contractId . optionalField "definitions" definitions - where - schemaUrl :: String - schemaUrl = "https://cips.cardano.org/cips/cip57/schemas/plutus-blueprint.json" + where + schemaUrl :: String + schemaUrl = "https://cips.cardano.org/cips/cip57/schemas/plutus-blueprint.json" - definitions :: Maybe (Map DefinitionId Aeson.Value) - definitions = ensure (not . Map.null) (definitionsToMap contractDefinitions toJSON) + definitions :: Maybe (Map DefinitionId Aeson.Value) + definitions = ensure (not . Map.null) (definitionsToMap contractDefinitions toJSON) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Definition/Derive.hs b/plutus-tx/src/PlutusTx/Blueprint/Definition/Derive.hs index 86d2b914b78..a8de7990bc2 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Definition/Derive.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Definition/Derive.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module PlutusTx.Blueprint.Definition.Derive where @@ -16,19 +16,18 @@ import PlutusTx.Blueprint.Definition.Unroll (HasBlueprintDefinition (definitionI import PlutusTx.Blueprint.Schema (Schema (..)) -- | Derive a 'Definitions' value for a list of types. -deriveDefinitions :: forall ts. (DefinitionsFor (UnrollAll ts)) => Definitions (UnrollAll ts) +deriveDefinitions :: forall ts. DefinitionsFor (UnrollAll ts) => Definitions (UnrollAll ts) deriveDefinitions = definitionsFor @(UnrollAll ts) -- | Construct a 'Schema' that is a reference to a schema definition. -definitionRef :: forall t ts. (HasBlueprintDefinition t) => Schema ts +definitionRef :: forall t ts. HasBlueprintDefinition t => Schema ts definitionRef = SchemaDefinitionRef (definitionId @t) -{-| This class and its two instances are used internally to derive 'Definitions' -for a given list of types. --} +-- | This class and its two instances are used internally to derive 'Definitions' +-- for a given list of types. type DefinitionsFor ts = DefinitionsFor' ts ts -definitionsFor :: forall ts. (DefinitionsFor ts) => Definitions ts +definitionsFor :: forall ts. DefinitionsFor ts => Definitions ts definitionsFor = definitionsFor' @ts @ts class DefinitionsFor' referencedTypes acc where @@ -41,8 +40,8 @@ instance ( HasBlueprintDefinition t , HasBlueprintSchema t referencedTypes , DefinitionsFor' referencedTypes ts - ) - => DefinitionsFor' referencedTypes (t ': ts) + ) => + DefinitionsFor' referencedTypes (t ': ts) where definitionsFor' = addDefinition diff --git a/plutus-tx/src/PlutusTx/Blueprint/Definition/Id.hs b/plutus-tx/src/PlutusTx/Blueprint/Definition/Id.hs index 5443fe213c1..26bc1dbd772 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Definition/Id.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Definition/Id.hs @@ -1,9 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} module PlutusTx.Blueprint.Definition.Id ( DefinitionId, @@ -35,14 +35,13 @@ instance Semigroup DefinitionId where (<>) l r = MkDefinitionId $ definitionIdToText l <> "_" <> definitionIdToText r -- | Creates a 'DefinitionId' from a type with a kind 'Type'. -definitionIdFromType :: forall (t :: Type). (Typeable t) => DefinitionId +definitionIdFromType :: forall (t :: Type). Typeable t => DefinitionId definitionIdFromType = MkDefinitionId . pack . show . typeRep $ Proxy @t -{-| Creates a 'DefinitionId' from a type with a kind other than 'Type'. -Example: -> definitionIdFromTypeK @(Type -> Type) @Maybe --} -definitionIdFromTypeK :: forall k (t :: k). (Typeable (t :: k)) => DefinitionId +-- | Creates a 'DefinitionId' from a type with a kind other than 'Type'. +-- Example: +-- > definitionIdFromTypeK @(Type -> Type) @Maybe +definitionIdFromTypeK :: forall k (t :: k). Typeable (t :: k) => DefinitionId definitionIdFromTypeK = MkDefinitionId . pack . show . typeRep $ Proxy @(t :: k) -- Special cases that we want to be alphanumeric instead of symbolic, diff --git a/plutus-tx/src/PlutusTx/Blueprint/Definition/Internal.hs b/plutus-tx/src/PlutusTx/Blueprint/Definition/Internal.hs index d2ecc8d06c0..82c143544ed 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Definition/Internal.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Definition/Internal.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -40,7 +40,7 @@ deriving stock instance Show (Definitions ts) -- | Add a schema definition to a registry. addDefinition :: Definitions ts -> Definition t ts -> Definitions ts -addDefinition NoDefinitions d = AddDefinition d NoDefinitions +addDefinition NoDefinitions d = AddDefinition d NoDefinitions addDefinition (AddDefinition t s) d = AddDefinition d (AddDefinition t s) definitionsToMap :: Definitions ts -> (forall xs. Schema xs -> v) -> Map DefinitionId v @@ -48,10 +48,9 @@ definitionsToMap NoDefinitions _k = Map.empty definitionsToMap (AddDefinition (MkDefinition defId v) s) k = Map.insert defId (k v) (definitionsToMap s k) -{-| - A constraint that checks if a schema definition is present in a list of schema definitions. - Gives a user-friendly error message if the schema definition is not found. --} +-- | +-- A constraint that checks if a schema definition is present in a list of schema definitions. +-- Gives a user-friendly error message if the schema definition is not found. type HasSchemaDefinition t ts = HasSchemaDefinition' t ts ts type HasSchemaDefinition' :: Type -> [Type] -> [Type] -> Constraint diff --git a/plutus-tx/src/PlutusTx/Blueprint/Definition/Unroll.hs b/plutus-tx/src/PlutusTx/Blueprint/Definition/Unroll.hs index f274b0490fd..fc5d0a4e801 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Definition/Unroll.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Definition/Unroll.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module PlutusTx.Blueprint.Definition.Unroll where @@ -24,13 +24,32 @@ import Data.Typeable (Typeable) import Data.Void (Void) import GHC.Generics (Generic (Rep), K1, M1, U1, type (:*:), type (:+:)) import GHC.TypeLits qualified as GHC -import PlutusTx.Blueprint.Definition.Id (DefinitionId (..), definitionIdFromType, - definitionIdFromTypeK, definitionIdList, - definitionIdTuple2, definitionIdTuple3, definitionIdUnit) -import PlutusTx.Blueprint.Definition.TF (Concat, IfStuckRep, IfStuckUnroll, Insert, Nub, Reverse, - type (++)) -import PlutusTx.Builtins.Internal (BuiltinByteString, BuiltinData, BuiltinList, BuiltinPair, - BuiltinString, BuiltinUnit) +import PlutusTx.Blueprint.Definition.Id ( + DefinitionId (..), + definitionIdFromType, + definitionIdFromTypeK, + definitionIdList, + definitionIdTuple2, + definitionIdTuple3, + definitionIdUnit, + ) +import PlutusTx.Blueprint.Definition.TF ( + Concat, + IfStuckRep, + IfStuckUnroll, + Insert, + Nub, + Reverse, + type (++), + ) +import PlutusTx.Builtins.Internal ( + BuiltinByteString, + BuiltinData, + BuiltinList, + BuiltinPair, + BuiltinString, + BuiltinUnit, + ) ---------------------------------------------------------------------------------------------------- -- Functionality to "unroll" types. -- For more context see Note ["Unrolling" types] ----------- @@ -74,11 +93,10 @@ type family will take care of discovering all the nested types: -} -{-| Designates a class of types that could be used as a Blueprint Definition. - Each such type: - - could be unrolled to a list of all nested types (including the type itself). - - has a unique 'DefinitionId'. --} +-- | Designates a class of types that could be used as a Blueprint Definition. +-- Each such type: +-- - could be unrolled to a list of all nested types (including the type itself). +-- - has a unique 'DefinitionId'. class HasBlueprintDefinition (t :: Type) where type Unroll t :: [Type] type Unroll t = Insert t (GUnroll (IfStuckRep (RepIsStuckError t) (Rep t))) @@ -86,7 +104,7 @@ class HasBlueprintDefinition (t :: Type) where definitionId :: DefinitionId -- | Derive a 'DefinitionId' for a type. - default definitionId :: (Typeable t) => DefinitionId + default definitionId :: Typeable t => DefinitionId definitionId = definitionIdFromType @t instance HasBlueprintDefinition Void where @@ -117,13 +135,13 @@ instance HasBlueprintDefinition BuiltinString where instance HasBlueprintDefinition BuiltinByteString where type Unroll BuiltinByteString = '[BuiltinByteString] -instance (HasBlueprintDefinition a) => HasBlueprintDefinition (BuiltinList a) where +instance HasBlueprintDefinition a => HasBlueprintDefinition (BuiltinList a) where type Unroll (BuiltinList a) = Insert (BuiltinList a) (Unrolled a) definitionId = definitionIdFromTypeK @(Type -> Type) @BuiltinList <> definitionId @a instance - (HasBlueprintDefinition a, HasBlueprintDefinition b) - => HasBlueprintDefinition (BuiltinPair a b) + (HasBlueprintDefinition a, HasBlueprintDefinition b) => + HasBlueprintDefinition (BuiltinPair a b) where type Unroll (BuiltinPair a b) = Insert (BuiltinPair a b) (Unrolled a ++ Unrolled b) definitionId = @@ -131,11 +149,11 @@ instance <> definitionId @a <> definitionId @b -instance (HasBlueprintDefinition a) => HasBlueprintDefinition (Maybe a) where +instance HasBlueprintDefinition a => HasBlueprintDefinition (Maybe a) where type Unroll (Maybe a) = Insert (Maybe a) (Unrolled a) definitionId = definitionIdFromTypeK @(Type -> Type) @Maybe <> definitionId @a -instance (HasBlueprintDefinition a) => HasBlueprintDefinition [a] where +instance HasBlueprintDefinition a => HasBlueprintDefinition [a] where type Unroll [a] = Insert [a] (Unrolled a) definitionId = definitionIdList <> definitionId @a @@ -144,22 +162,20 @@ instance (HasBlueprintDefinition a, HasBlueprintDefinition b) => HasBlueprintDef definitionId = definitionIdTuple2 <> definitionId @a <> definitionId @b instance - (HasBlueprintDefinition a, HasBlueprintDefinition b, HasBlueprintDefinition c) - => HasBlueprintDefinition (a, b, c) + (HasBlueprintDefinition a, HasBlueprintDefinition b, HasBlueprintDefinition c) => + HasBlueprintDefinition (a, b, c) where type Unroll (a, b, c) = Insert (a, b, c) (Unrolled a ++ Unrolled b ++ Unrolled c) definitionId = definitionIdTuple3 <> definitionId @a <> definitionId @b <> definitionId @c -{-| Compile-time error that happens when a type couldn't be unrolled -('Unroll' TF is "stuck") --} +-- | Compile-time error that happens when a type couldn't be unrolled +-- ('Unroll' TF is "stuck") type family UnrollIsStuckError x where UnrollIsStuckError x = GHC.TypeError (GHC.Text "No instance: " GHC.:<>: GHC.ShowType (HasBlueprintDefinition x)) -{-| Compile-time error that happens when type's generic representation is not defined -('Rep' TF is "stuck") --} +-- | Compile-time error that happens when type's generic representation is not defined +-- ('Rep' TF is "stuck") type family RepIsStuckError x where RepIsStuckError x = GHC.TypeError (GHC.Text "No instance: " GHC.:<>: GHC.ShowType (Generic x)) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Parameter.hs b/plutus-tx/src/PlutusTx/Blueprint/Parameter.hs index f4bc0d911de..3e64e97381f 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Parameter.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Parameter.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module PlutusTx.Blueprint.Parameter where @@ -18,26 +18,25 @@ import Data.Text (Text) import PlutusTx.Blueprint.Purpose (Purpose) import PlutusTx.Blueprint.Schema (Schema) -{-| Blueprint that defines validator's compile-time parameter. - - The 'referencedTypes' phantom type parameter is used to track the types used in the contract - making sure their schemas are included in the blueprint and that they are referenced - in a type-safe way. --} +-- | Blueprint that defines validator's compile-time parameter. +-- +-- The 'referencedTypes' phantom type parameter is used to track the types used in the contract +-- making sure their schemas are included in the blueprint and that they are referenced +-- in a type-safe way. data ParameterBlueprint (referencedTypes :: [Type]) = MkParameterBlueprint - { parameterTitle :: Maybe Text + { parameterTitle :: Maybe Text -- ^ A short and descriptive name for the parameter. , parameterDescription :: Maybe Text -- ^ An informative description of the parameter. - , parameterPurpose :: Set Purpose + , parameterPurpose :: Set Purpose -- ^ One of "spend", "mint", "withdraw" or "publish", or a oneOf applicator of those. - , parameterSchema :: Schema referencedTypes + , parameterSchema :: Schema referencedTypes -- ^ A Plutus Data Schema. } deriving stock (Show, Eq, Ord) instance ToJSON (ParameterBlueprint referencedTypes) where - toJSON MkParameterBlueprint{..} = + toJSON MkParameterBlueprint {..} = buildObject $ requiredField "schema" parameterSchema . optionalField "title" parameterTitle @@ -47,9 +46,9 @@ instance ToJSON (ParameterBlueprint referencedTypes) where ---------------------------------------------------------------------------------------------------- -- Helper functions -------------------------------------------------------------------------------- -oneOfASet :: (ToJSON a) => Set a -> Maybe Aeson.Value +oneOfASet :: ToJSON a => Set a -> Maybe Aeson.Value oneOfASet s = case Set.toList s of - [] -> Nothing + [] -> Nothing [x] -> Just $ toJSON x - xs -> Just $ Aeson.object ["oneOf" .= xs] + xs -> Just $ Aeson.object ["oneOf" .= xs] diff --git a/plutus-tx/src/PlutusTx/Blueprint/PlutusVersion.hs b/plutus-tx/src/PlutusTx/Blueprint/PlutusVersion.hs index cb25c530796..0c242aeee17 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/PlutusVersion.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/PlutusVersion.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module PlutusTx.Blueprint.PlutusVersion where @@ -8,11 +8,10 @@ import Prelude import Data.Aeson (ToJSON (..)) -{-| A "Plutus Version", as defined by the CIP-0057 -| -| This version corresponds to the "Plutus Ledger Language Version" -| defined by the plutus-tx-plugin. --} +-- | A "Plutus Version", as defined by the CIP-0057 +-- | +-- | This version corresponds to the "Plutus Ledger Language Version" +-- | defined by the plutus-tx-plugin. data PlutusVersion = PlutusV1 | PlutusV2 | PlutusV3 deriving stock (Show) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Preamble.hs b/plutus-tx/src/PlutusTx/Blueprint/Preamble.hs index c71ecdb00d3..df68ad4581b 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Preamble.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Preamble.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} module PlutusTx.Blueprint.Preamble where @@ -15,19 +15,18 @@ import PlutusTx.Blueprint.PlutusVersion (PlutusVersion) -- | Meta-information about the contract data Preamble = MkPreamble - { preambleTitle :: Text + { preambleTitle :: Text -- ^ A short and descriptive title of the contract application - , preambleDescription :: Maybe Text + , preambleDescription :: Maybe Text -- ^ A more elaborate description - , preambleVersion :: Text + , preambleVersion :: Text -- ^ A version number for the project. , preamblePlutusVersion :: PlutusVersion -- ^ The Plutus version assumed for all validators - , preambleLicense :: Maybe Text - {- ^ A license under which the specification - and contract code is distributed - -} + , preambleLicense :: Maybe Text + -- ^ A license under which the specification + -- and contract code is distributed } deriving stock (Show, Generic) -$(deriveToJSON defaultOptions{fieldLabelModifier = stripPrefix "preamble"} ''Preamble) +$(deriveToJSON defaultOptions {fieldLabelModifier = stripPrefix "preamble"} ''Preamble) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs b/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs index d207a4e64f9..8386e236471 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module PlutusTx.Blueprint.Purpose where @@ -11,10 +11,9 @@ import Data.Aeson qualified as Json import Data.Text (Text) import Language.Haskell.TH.Syntax (Lift) -{-| - As per CIP-57, a validator arguments (redeemer, datum) and validator parameters - all must specify a purpose that indicates in which context they are used. --} +-- | +-- As per CIP-57, a validator arguments (redeemer, datum) and validator parameters +-- all must specify a purpose that indicates in which context they are used. data Purpose = Spend | Mint | Withdraw | Publish deriving stock (Eq, Ord, Show, Lift) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Schema.hs b/plutus-tx/src/PlutusTx/Blueprint/Schema.hs index f4b8a5e8eb5..f9c814f6802 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Schema.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Schema.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusTx.Blueprint.Schema where @@ -33,13 +33,12 @@ import PlutusTx.Blueprint.Definition.Id (DefinitionId, definitionIdToText) import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo, comment, description, title) import Prelude hiding (max, maximum, min, minimum) -{-| Blueprint schema definition, as defined by the CIP-0057: - https://github.com/cardano-foundation/CIPs/tree/master/CIP-0057#core-vocabulary - - The 'referencedTypes' phantom type parameter is used to track the types used in the contract - making sure their schemas are included in the blueprint and that they are referenced - in a type-safe way. --} +-- | Blueprint schema definition, as defined by the CIP-0057: +-- https://github.com/cardano-foundation/CIPs/tree/master/CIP-0057#core-vocabulary +-- +-- The 'referencedTypes' phantom type parameter is used to track the types used in the contract +-- making sure their schemas are included in the blueprint and that they are referenced +-- in a type-safe way. data Schema (referencedTypes :: [Type]) = SchemaInteger SchemaInfo IntegerSchema | SchemaBytes SchemaInfo BytesSchema @@ -61,11 +60,11 @@ data Schema (referencedTypes :: [Type]) | SchemaDefinitionRef DefinitionId deriving stock (Eq, Ord, Show, Generic, Data) -deriving anyclass instance (Typeable referencedTypes) => Plated (Schema referencedTypes) +deriving anyclass instance Typeable referencedTypes => Plated (Schema referencedTypes) instance ToJSON (Schema referencedTypes) where toJSON = \case - SchemaInteger info MkIntegerSchema{..} -> + SchemaInteger info MkIntegerSchema {..} -> dataType info "integer" & optionalField "multipleOf" multipleOf & optionalField "minimum" minimum @@ -73,30 +72,30 @@ instance ToJSON (Schema referencedTypes) where & optionalField "exclusiveMinimum" exclusiveMinimum & optionalField "exclusiveMaximum" exclusiveMaximum & Aeson.Object - SchemaBytes info MkBytesSchema{..} -> + SchemaBytes info MkBytesSchema {..} -> dataType info "bytes" & optionalField "enum" (fmap toHex <$> nonEmpty enum) & optionalField "maxLength" maxLength & optionalField "minLength" minLength & Aeson.Object - where - toHex :: ByteString -> Text - toHex = Text.decodeUtf8 . Base16.encode - SchemaList info MkListSchema{..} -> + where + toHex :: ByteString -> Text + toHex = Text.decodeUtf8 . Base16.encode + SchemaList info MkListSchema {..} -> dataType info "list" & requiredField "items" itemSchema & optionalField "minItems" minItems & optionalField "maxItems" maxItems & optionalField "uniqueItems" uniqueItems & Aeson.Object - SchemaMap info MkMapSchema{..} -> + SchemaMap info MkMapSchema {..} -> dataType info "map" & requiredField "keys" keySchema & requiredField "values" valueSchema & optionalField "minItems" minItems & optionalField "maxItems" maxItems & Aeson.Object - SchemaConstructor info MkConstructorSchema{..} -> + SchemaConstructor info MkConstructorSchema {..} -> dataType info "constructor" & requiredField "index" index & requiredField "fields" fieldSchemas @@ -113,7 +112,7 @@ instance ToJSON (Schema referencedTypes) where Aeson.Object $ dataType info "#bytes" SchemaBuiltInString info -> Aeson.Object $ dataType info "#string" - SchemaBuiltInPair info MkPairSchema{left, right} -> + SchemaBuiltInPair info MkPairSchema {left, right} -> dataType info "#pair" & requiredField "left" left & requiredField "right" right @@ -132,16 +131,16 @@ instance ToJSON (Schema referencedTypes) where Aeson.object ["not" .= schema] SchemaDefinitionRef definitionId -> Aeson.object ["$ref" .= ("#/definitions/" <> definitionIdToText definitionId)] - where - dataType :: SchemaInfo -> String -> Aeson.Object - dataType info ty = requiredField "dataType" ty (infoFields info) + where + dataType :: SchemaInfo -> String -> Aeson.Object + dataType info ty = requiredField "dataType" ty (infoFields info) - infoFields :: SchemaInfo -> Aeson.Object - infoFields info = - KeyMap.empty - & optionalField "title" (title info) - & optionalField "description" (description info) - & optionalField "$comment" (comment info) + infoFields :: SchemaInfo -> Aeson.Object + infoFields info = + KeyMap.empty + & optionalField "title" (title info) + & optionalField "description" (description info) + & optionalField "$comment" (comment info) withSchemaInfo :: (SchemaInfo -> SchemaInfo) -> Schema referencedTypes -> Schema referencedTypes withSchemaInfo f = \case @@ -165,11 +164,11 @@ withSchemaInfo f = \case SchemaDefinitionRef definitionId -> SchemaDefinitionRef definitionId data IntegerSchema = MkIntegerSchema - { multipleOf :: Maybe Integer + { multipleOf :: Maybe Integer -- ^ An instance is valid if division by this value results in an integer. - , minimum :: Maybe Integer + , minimum :: Maybe Integer -- ^ An instance is valid only if it is greater than or exactly equal to "minimum". - , maximum :: Maybe Integer + , maximum :: Maybe Integer -- ^ An instance is valid only if it is less than or exactly equal to "maximum". , exclusiveMinimum :: Maybe Integer -- ^ An instance is valid only if it is strictly greater than "exclusiveMinimum". @@ -189,10 +188,9 @@ emptyIntegerSchema = } data BytesSchema = MkBytesSchema - { enum :: [ByteString] - {- ^ An instance validates successfully if once hex-encoded, - its value matches one of the specified values. - -} + { enum :: [ByteString] + -- ^ An instance validates successfully if once hex-encoded, + -- its value matches one of the specified values. , minLength :: Maybe Natural -- ^ An instance is valid if its length is greater than, or equal to, this value. , maxLength :: Maybe Natural @@ -201,19 +199,18 @@ data BytesSchema = MkBytesSchema deriving stock (Eq, Ord, Show, Generic, Data) emptyBytesSchema :: BytesSchema -emptyBytesSchema = MkBytesSchema{enum = [], minLength = Nothing, maxLength = Nothing} +emptyBytesSchema = MkBytesSchema {enum = [], minLength = Nothing, maxLength = Nothing} data ListSchema (referencedTypes :: [Type]) = MkListSchema - { itemSchema :: Schema referencedTypes + { itemSchema :: Schema referencedTypes -- ^ Element schema - , minItems :: Maybe Natural + , minItems :: Maybe Natural -- ^ An array instance is valid if its size is greater than, or equal to, this value. - , maxItems :: Maybe Natural + , maxItems :: Maybe Natural -- ^ An array instance is valid if its size is less than, or equal to, this value. , uniqueItems :: Maybe Bool - {- ^ If this value is false, the instance validates successfully. - If it is set to True, the instance validates successfully if all of its elements are unique. - -} + -- ^ If this value is false, the instance validates successfully. + -- If it is set to True, the instance validates successfully if all of its elements are unique. } deriving stock (Eq, Ord, Show, Generic, Data) @@ -227,19 +224,19 @@ mkListSchema itemSchema = } data MapSchema (referencedTypes :: [Type]) = MkMapSchema - { keySchema :: Schema referencedTypes + { keySchema :: Schema referencedTypes -- ^ Key schema , valueSchema :: Schema referencedTypes -- ^ Value schema - , minItems :: Maybe Natural + , minItems :: Maybe Natural -- ^ A map instance is valid if its size is greater than, or equal to, this value. - , maxItems :: Maybe Natural + , maxItems :: Maybe Natural -- ^ A map instance is valid if its size is less than, or equal to, this value. } deriving stock (Eq, Ord, Show, Generic, Data) data ConstructorSchema (referencedTypes :: [Type]) = MkConstructorSchema - { index :: Natural + { index :: Natural -- ^ Constructor index , fieldSchemas :: [Schema referencedTypes] -- ^ Field schemas @@ -247,7 +244,7 @@ data ConstructorSchema (referencedTypes :: [Type]) = MkConstructorSchema deriving stock (Eq, Ord, Show, Generic, Data) data PairSchema (referencedTypes :: [Type]) = MkPairSchema - { left :: Schema referencedTypes + { left :: Schema referencedTypes -- ^ Schema of the first element , right :: Schema referencedTypes -- ^ Schema of the second element diff --git a/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs b/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs index 84406c9d668..c71bc9cb6d0 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoStrict #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoStrict #-} module PlutusTx.Blueprint.Schema.Annotation ( SchemaInfo (..), @@ -23,9 +23,9 @@ import Prelude hiding (max, maximum, min, minimum) -- | Additional information optionally attached to any datatype schema definition. data SchemaInfo = MkSchemaInfo - { title :: Maybe String + { title :: Maybe String , description :: Maybe String - , comment :: Maybe String + , comment :: Maybe String } deriving stock (Eq, Ord, Show, Generic, Data, Lift) @@ -39,19 +39,19 @@ annotationsToSchemaInfo = (`execStateT` emptySchemaInfo) . traverse \case MkSchemaAnnTitle (SchemaTitle t) -> get >>= \info -> case title info of - Nothing -> put $ info{title = Just t} + Nothing -> put $ info {title = Just t} Just t' -> failOverride "SchemaTitle" t' t MkSchemaAnnDescription (SchemaDescription d) -> get >>= \info -> case description info of - Nothing -> put $ info{description = Just d} + Nothing -> put $ info {description = Just d} Just d' -> failOverride "SchemaDescription" d' d MkSchemaAnnComment (SchemaComment c) -> get >>= \info -> case comment info of - Nothing -> put $ info{comment = Just c} + Nothing -> put $ info {comment = Just c} Just c' -> failOverride "SchemaComment" c' c - where - failOverride label old new = - lift . Left $ concat [label, " annotation error: ", show old, " is overridden with ", show new] + where + failOverride label old new = + lift . Left $ concat [label, " annotation error: ", show old, " is overridden with ", show new] -- | Annotation that can be attached to a schema definition. data SchemaAnn @@ -60,41 +60,38 @@ data SchemaAnn | MkSchemaAnnComment SchemaComment deriving stock (Eq, Ord, Show, Generic, Data, Lift) -{-| An annotation for the "title" schema attribute. - -This annotation could be attached to a type or constructor: -@ -{\-# ANN type MyFoo (SchemaTitle "My Foo Title") #-\} -{\-# ANN MkMyFoo (SchemaTitle "Title") #-\} -newtype MyFoo = MkMyFoo Int -@ --} +-- | An annotation for the "title" schema attribute. +-- +-- This annotation could be attached to a type or constructor: +-- @ +-- {\-# ANN type MyFoo (SchemaTitle "My Foo Title") #-\} +-- {\-# ANN MkMyFoo (SchemaTitle "Title") #-\} +-- newtype MyFoo = MkMyFoo Int +-- @ newtype SchemaTitle = SchemaTitle {schemaTitleToString :: String} deriving newtype (Eq, Ord, Show, ToJSON) deriving stock (Data, Lift) -{-| An annotation for the "description" schema attribute. - -This annotation could be attached to a type or constructor: -@ -{\-# ANN type MyFoo (SchemaDescription "My Foo Description") #-\} -{\-# ANN MkMyFoo (SchemaDescription "Description") #-\} -newtype MyFoo = MkMyFoo Int -@ --} +-- | An annotation for the "description" schema attribute. +-- +-- This annotation could be attached to a type or constructor: +-- @ +-- {\-# ANN type MyFoo (SchemaDescription "My Foo Description") #-\} +-- {\-# ANN MkMyFoo (SchemaDescription "Description") #-\} +-- newtype MyFoo = MkMyFoo Int +-- @ newtype SchemaDescription = SchemaDescription {schemaDescriptionToString :: String} deriving newtype (Eq, Ord, Show, ToJSON) deriving stock (Data, Lift) -{-| An annotation for the "$comment" schema attribute. - -This annotation could be attached to a type or constructor: -@ -{\-# ANN type MyFoo (SchemaComment "My Foo Comment") #-\} -{\-# ANN MkMyFoo (SchemaComment "Comment") #-\} -newtype MyFoo = MkMyFoo Int -@ --} +-- | An annotation for the "$comment" schema attribute. +-- +-- This annotation could be attached to a type or constructor: +-- @ +-- {\-# ANN type MyFoo (SchemaComment "My Foo Comment") #-\} +-- {\-# ANN MkMyFoo (SchemaComment "Comment") #-\} +-- newtype MyFoo = MkMyFoo Int +-- @ newtype SchemaComment = SchemaComment {schemaCommentToString :: String} deriving newtype (Eq, Ord, Show, ToJSON) deriving stock (Data, Lift) diff --git a/plutus-tx/src/PlutusTx/Blueprint/TH.hs b/plutus-tx/src/PlutusTx/Blueprint/TH.hs index fc0ead65a2c..87c989112b9 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/TH.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/TH.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} module PlutusTx.Blueprint.TH where @@ -29,16 +29,22 @@ import PlutusTx.Blueprint.Definition.Unroll (HasBlueprintDefinition) import PlutusTx.Blueprint.Parameter (ParameterBlueprint (..)) import PlutusTx.Blueprint.Purpose (Purpose) import PlutusTx.Blueprint.Schema (ConstructorSchema (..), Schema (..)) -import PlutusTx.Blueprint.Schema.Annotation (SchemaAnn (..), SchemaComment, SchemaDescription, - SchemaInfo (..), SchemaTitle, annotationsToSchemaInfo, - schemaDescriptionToString, schemaTitleToString) +import PlutusTx.Blueprint.Schema.Annotation ( + SchemaAnn (..), + SchemaComment, + SchemaDescription, + SchemaInfo (..), + SchemaTitle, + annotationsToSchemaInfo, + schemaDescriptionToString, + schemaTitleToString, + ) import PlutusTx.IsData.TH (makeIsDataIndexed) -{-| - Generate a 'ToData', 'FromData', 'UnsafeFromData', 'HasBlueprintSchema' instances for a type, - using an explicit mapping of constructor names to indices. - Use this for types where you need to keep the representation stable. --} +-- | +-- Generate a 'ToData', 'FromData', 'UnsafeFromData', 'HasBlueprintSchema' instances for a type, +-- using an explicit mapping of constructor names to indices. +-- Use this for types where you need to keep the representation stable. makeIsDataSchemaIndexed :: TH.Name -> [(TH.Name, Natural)] -> TH.Q [TH.InstanceDec] makeIsDataSchemaIndexed dataTypeName indices = do dataInstances <- makeIsDataIndexed dataTypeName (fmap fromIntegral <$> indices) @@ -75,11 +81,11 @@ makeHasSchemaInstance dataTypeName indices = do nub . join $ -- Every type in the constructor fields must have a schema definition. [ ( case fieldType of - TH.VarT{} -> (TH.classPred ''HasBlueprintDefinition [fieldType] :) - _ -> id + TH.VarT {} -> (TH.classPred ''HasBlueprintDefinition [fieldType] :) + _ -> id ) [TH.classPred ''HasSchemaDefinition [fieldType, referencedTypes]] - | (TH.ConstructorInfo{constructorFields}, _info, _index) <- indexedCons + | (TH.ConstructorInfo {constructorFields}, _info, _index) <- indexedCons , fieldType <- constructorFields ] @@ -97,43 +103,43 @@ makeHasSchemaInstance dataTypeName indices = do (TH.classPred ''HasBlueprintSchema [appliedType, referencedTypes]) [schemaPrag, schemaDecl] ] - where - -- Lookup all annotations (SchemaTitle, SchemdDescription, SchemaComment) attached to a name. - lookupSchemaAnns :: TH.Name -> TH.Q [SchemaAnn] - lookupSchemaAnns name = do - title <- MkSchemaAnnTitle <<$>> lookupAnn @SchemaTitle name - description <- MkSchemaAnnDescription <<$>> lookupAnn @SchemaDescription name - comment <- MkSchemaAnnComment <<$>> lookupAnn @SchemaComment name - pure $ title ++ description ++ comment - - -- \| Make SchemaInfo from a list of schema annotations, failing in case of ambiguity. - schemaInfoFromAnns :: [SchemaAnn] -> TH.Q SchemaInfo - schemaInfoFromAnns = either fail pure . annotationsToSchemaInfo + where + -- Lookup all annotations (SchemaTitle, SchemdDescription, SchemaComment) attached to a name. + lookupSchemaAnns :: TH.Name -> TH.Q [SchemaAnn] + lookupSchemaAnns name = do + title <- MkSchemaAnnTitle <<$>> lookupAnn @SchemaTitle name + description <- MkSchemaAnnDescription <<$>> lookupAnn @SchemaDescription name + comment <- MkSchemaAnnComment <<$>> lookupAnn @SchemaComment name + pure $ title ++ description ++ comment + + -- \| Make SchemaInfo from a list of schema annotations, failing in case of ambiguity. + schemaInfoFromAnns :: [SchemaAnn] -> TH.Q SchemaInfo + schemaInfoFromAnns = either fail pure . annotationsToSchemaInfo -- | Make a clause for the 'schema' function. -mkSchemaClause - :: TH.Type - -- ^ The type for the 'HasBlueprintSchema' instance. - -> [(TH.ConstructorInfo, SchemaInfo, Natural)] - -- ^ The constructors of the type with their schema infos and indices. - -> TH.ClauseQ - -- ^ The clause for the 'schema' function. +mkSchemaClause :: + -- | The type for the 'HasBlueprintSchema' instance. + TH.Type -> + -- | The constructors of the type with their schema infos and indices. + [(TH.ConstructorInfo, SchemaInfo, Natural)] -> + -- | The clause for the 'schema' function. + TH.ClauseQ mkSchemaClause ts ctorIndexes = case ctorIndexes of [] -> fail "At least one constructor index must be specified." [ctorIndex] -> mkBody (mkSchemaConstructor ctorIndex) _ -> mkBody [|SchemaOneOf (NE.fromList $(TH.listE (map mkSchemaConstructor ctorIndexes)))|] - where - mkBody :: TH.ExpQ -> TH.ClauseQ - mkBody body = do - let patterns = [] - let whereDecls = [] - TH.clause patterns (TH.normalB body) whereDecls - - mkSchemaConstructor :: (TH.ConstructorInfo, SchemaInfo, Natural) -> TH.ExpQ - mkSchemaConstructor (TH.ConstructorInfo{..}, info, naturalToInteger -> ctorIndex) = do - fields <- for constructorFields $ \t -> [|definitionRef @($(pure t)) @($(pure ts))|] - [|SchemaConstructor info (MkConstructorSchema ctorIndex $(pure (TH.ListE fields)))|] + where + mkBody :: TH.ExpQ -> TH.ClauseQ + mkBody body = do + let patterns = [] + let whereDecls = [] + TH.clause patterns (TH.normalB body) whereDecls + + mkSchemaConstructor :: (TH.ConstructorInfo, SchemaInfo, Natural) -> TH.ExpQ + mkSchemaConstructor (TH.ConstructorInfo {..}, info, naturalToInteger -> ctorIndex) = do + fields <- for constructorFields $ \t -> [|definitionRef @($(pure t)) @($(pure ts))|] + [|SchemaConstructor info (MkConstructorSchema ctorIndex $(pure (TH.ListE fields)))|] deriveParameterBlueprint :: TH.Name -> Set Purpose -> TH.ExpQ deriveParameterBlueprint tyName purpose = do @@ -164,7 +170,7 @@ deriveArgumentBlueprint tyName purpose = do ---------------------------------------------------------------------------------------------------- -- TH Utilities ------------------------------------------------------------------------------------ -lookupAnn :: (Data a) => TH.Name -> TH.Q [a] +lookupAnn :: Data a => TH.Name -> TH.Q [a] lookupAnn = TH.reifyAnnotations . TH.AnnLookupName lookupSchemaTitle :: TH.Name -> TH.Q (Maybe SchemaTitle) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Validator.hs b/plutus-tx/src/PlutusTx/Blueprint/Validator.hs index 24e42017c97..0d4d6e01e38 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Validator.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Validator.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module PlutusTx.Blueprint.Validator where @@ -23,24 +23,23 @@ import PlutusTx.Blueprint.Argument (ArgumentBlueprint) import PlutusTx.Blueprint.Parameter (ParameterBlueprint) import PlutusTx.Blueprint.PlutusVersion (PlutusVersion (..)) -{-| A blueprint of a validator, as defined by the CIP-0057 - -The 'referencedTypes' phantom type parameter is used to track the types used in the contract -making sure their schemas are included in the blueprint and that they are referenced -in a type-safe way. --} +-- | A blueprint of a validator, as defined by the CIP-0057 +-- +-- The 'referencedTypes' phantom type parameter is used to track the types used in the contract +-- making sure their schemas are included in the blueprint and that they are referenced +-- in a type-safe way. data ValidatorBlueprint (referencedTypes :: [Type]) = MkValidatorBlueprint - { validatorTitle :: Text + { validatorTitle :: Text -- ^ A short and descriptive name for the validator. , validatorDescription :: Maybe Text -- ^ An informative description of the validator. - , validatorRedeemer :: ArgumentBlueprint referencedTypes + , validatorRedeemer :: ArgumentBlueprint referencedTypes -- ^ A description of the redeemer format expected by this validator. - , validatorDatum :: Maybe (ArgumentBlueprint referencedTypes) + , validatorDatum :: Maybe (ArgumentBlueprint referencedTypes) -- ^ A description of the datum format expected by this validator. - , validatorParameters :: [ParameterBlueprint referencedTypes] + , validatorParameters :: [ParameterBlueprint referencedTypes] -- ^ A list of parameters required by the script. - , validatorCompiled :: Maybe CompiledValidator + , validatorCompiled :: Maybe CompiledValidator -- ^ A full compiled and CBOR-encoded serialized flat script together with its hash. } deriving stock (Show, Eq, Ord) @@ -58,14 +57,14 @@ compiledValidator version code = , compiledValidatorHash = blake2b_224 (BS.singleton (versionTag version) <> code) } - where - versionTag = \case - PlutusV1 -> 0x1 - PlutusV2 -> 0x2 - PlutusV3 -> 0x3 + where + versionTag = \case + PlutusV1 -> 0x1 + PlutusV2 -> 0x2 + PlutusV3 -> 0x3 instance ToJSON (ValidatorBlueprint referencedTypes) where - toJSON MkValidatorBlueprint{..} = + toJSON MkValidatorBlueprint {..} = buildObject $ requiredField "title" validatorTitle . requiredField "redeemer" validatorRedeemer @@ -74,6 +73,6 @@ instance ToJSON (ValidatorBlueprint referencedTypes) where . optionalField "parameters" (NE.nonEmpty validatorParameters) . optionalField "compiledCode" (toHex . compiledValidatorCode <$> validatorCompiled) . optionalField "hash" (toHex . compiledValidatorHash <$> validatorCompiled) - where - toHex :: ByteString -> Text - toHex = Text.decodeUtf8 . Base16.encode + where + toHex :: ByteString -> Text + toHex = Text.decodeUtf8 . Base16.encode diff --git a/plutus-tx/src/PlutusTx/Bool.hs b/plutus-tx/src/PlutusTx/Bool.hs index 33a04c5d403..71b4b9eee6d 100644 --- a/plutus-tx/src/PlutusTx/Bool.hs +++ b/plutus-tx/src/PlutusTx/Bool.hs @@ -11,33 +11,30 @@ import Prelude (Bool (..), otherwise) -- `(&&)` and `(||)` are handled specially in the plugin to make sure they can short-circuit. -- See Note [Lazy boolean operators] in the plugin. -{-| Logical AND. Short-circuits if the first argument evaluates to `False`. - - >>> True && False - False --} +-- | Logical AND. Short-circuits if the first argument evaluates to `False`. +-- +-- >>> True && False +-- False infixr 3 && (&&) :: Bool -> Bool -> Bool (&&) l r = if l then r else False {-# OPAQUE (&&) #-} -{-| Logical OR. Short-circuits if the first argument evaluates to `True`. - - >>> True || False - True --} +-- | Logical OR. Short-circuits if the first argument evaluates to `True`. +-- +-- >>> True || False +-- True infixr 2 || (||) :: Bool -> Bool -> Bool (||) l r = if l then True else r {-# OPAQUE (||) #-} -{-| Logical negation - - >>> not True - False --} +-- | Logical negation +-- +-- >>> not True +-- False not :: Bool -> Bool not a = if a then False else True {-# INLINEABLE not #-} diff --git a/plutus-tx/src/PlutusTx/BuiltinList.hs b/plutus-tx/src/PlutusTx/BuiltinList.hs index 7959c42b77f..1306fb63a71 100644 --- a/plutus-tx/src/PlutusTx/BuiltinList.hs +++ b/plutus-tx/src/PlutusTx/BuiltinList.hs @@ -76,7 +76,7 @@ uncons = B.uncons {-# INLINEABLE uncons #-} -- | Plutus Tx version of '[]' for 'BuiltinList'. -empty :: forall a. (MkNil a) => BuiltinList a +empty :: forall a. MkNil a => BuiltinList a empty = B.mkNil {-# INLINEABLE empty #-} @@ -86,7 +86,7 @@ null = B.null {-# INLINEABLE null #-} -- | Make a list with one element. -singleton :: forall a. (MkNil a) => a -> BuiltinList a +singleton :: forall a. MkNil a => a -> BuiltinList a singleton x = x <| empty {-# INLINEABLE singleton #-} @@ -99,63 +99,62 @@ caseList = B.caseList {-# INLINEABLE caseList #-} -- | Plutus Tx version of 'Data.List.map' for 'BuiltinList'. -map :: forall a b. (MkNil b) => (a -> b) -> BuiltinList a -> BuiltinList b +map :: forall a b. MkNil b => (a -> b) -> BuiltinList a -> BuiltinList b map f = go - where - go :: BuiltinList a -> BuiltinList b - go = caseList' empty (\x xs -> f x <| go xs) + where + go :: BuiltinList a -> BuiltinList b + go = caseList' empty (\x xs -> f x <| go xs) {-# INLINEABLE map #-} -- | Plutus Tx version of 'Data.List.mapMaybe' for 'BuiltinList'. -mapMaybe :: forall a b. (MkNil b) => (a -> Maybe b) -> BuiltinList a -> BuiltinList b +mapMaybe :: forall a b. MkNil b => (a -> Maybe b) -> BuiltinList a -> BuiltinList b mapMaybe f = go - where - go :: BuiltinList a -> BuiltinList b - go = - caseList' - empty - ( \x xs -> case f x of - Nothing -> go xs - Just y -> y <| go xs - ) + where + go :: BuiltinList a -> BuiltinList b + go = + caseList' + empty + ( \x xs -> case f x of + Nothing -> go xs + Just y -> y <| go xs + ) {-# INLINEABLE mapMaybe #-} -- | Does the element occur in the list? -elem :: forall a. (Eq a) => a -> BuiltinList a -> Bool +elem :: forall a. Eq a => a -> BuiltinList a -> Bool elem a = go - where - go :: BuiltinList a -> Bool - go = caseList' False (\x xs -> if a == x then True else go xs) + where + go :: BuiltinList a -> Bool + go = caseList' False (\x xs -> if a == x then True else go xs) {-# INLINEABLE elem #-} -- | Returns the leftmost element matching the predicate, or `Nothing` if there's no such element. find :: forall a. (a -> Bool) -> BuiltinList a -> Maybe a find p = go - where - go :: BuiltinList a -> Maybe a - go = caseList' Nothing (\x xs -> if p x then Just x else go xs) + where + go :: BuiltinList a -> Maybe a + go = caseList' Nothing (\x xs -> if p x then Just x else go xs) {-# INLINEABLE find #-} -- | Determines whether any element of the structure satisfies the predicate. any :: forall a. (a -> Bool) -> BuiltinList a -> Bool any p = go - where - go :: BuiltinList a -> Bool - go = caseList' False (\x xs -> if p x then True else go xs) + where + go :: BuiltinList a -> Bool + go = caseList' False (\x xs -> if p x then True else go xs) {-# INLINEABLE any #-} -- | Determines whether all elements of the list satisfy the predicate. all :: forall a. (a -> Bool) -> BuiltinList a -> Bool all p = go - where - go :: BuiltinList a -> Bool - go = caseList' True (\x xs -> if p x then go xs else False) + where + go :: BuiltinList a -> Bool + go = caseList' True (\x xs -> if p x then go xs else False) {-# INLINEABLE all #-} -{-| Get the element at a given index. -This function throws an error if the index is negative or larger than the length -of the list. --} +-- | Get the element at a given index. +-- This function throws an error if the index is negative or larger than the length +-- of the list. infixl 9 !! (!!) :: forall a. BuiltinList a -> Integer -> a @@ -184,24 +183,24 @@ or = any (\x -> BI.ifThenElse x True False) {-# INLINEABLE or #-} -- | The negation of `elem`. -notElem :: forall a. (Eq a) => a -> BuiltinList a -> Bool +notElem :: forall a. Eq a => a -> BuiltinList a -> Bool notElem a = not . elem a {-# INLINEABLE notElem #-} -- | Plutus Tx version of 'Data.List.foldr' for 'BuiltinList'. foldr :: forall a b. (a -> b -> b) -> b -> BuiltinList a -> b foldr f acc = go - where - go :: BuiltinList a -> b - go = caseList' acc (\x xs -> f x (go xs)) + where + go :: BuiltinList a -> b + go = caseList' acc (\x xs -> f x (go xs)) {-# INLINEABLE foldr #-} -- | Plutus Tx velsion of 'Data.List.foldl' for 'BuiltinList'. foldl :: forall a b. (b -> a -> b) -> b -> BuiltinList a -> b foldl f = go - where - go :: b -> BuiltinList a -> b - go acc = caseList' acc (\x xs -> go (f acc x) xs) + where + go :: b -> BuiltinList a -> b + go acc = caseList' acc (\x xs -> go (f acc x) xs) {-# INLINEABLE foldl #-} -- | Plutus Tx version of '(Data.List.++)' for 'BuiltinList'. @@ -217,17 +216,17 @@ append = (++) {-# INLINEABLE append #-} -- | Plutus Tx version of 'Data.List.concat' for 'BuiltinList'. -concat :: forall a. (MkNil a) => BuiltinList (BuiltinList a) -> BuiltinList a +concat :: forall a. MkNil a => BuiltinList (BuiltinList a) -> BuiltinList a concat = foldr (++) empty {-# INLINEABLE concat #-} -- | Plutus Tx version of 'Data.List.concatMap' for 'BuiltinList'. -concatMap :: forall a b. (MkNil b) => (a -> BuiltinList b) -> BuiltinList a -> BuiltinList b +concatMap :: forall a b. MkNil b => (a -> BuiltinList b) -> BuiltinList a -> BuiltinList b concatMap f = foldr (\x ys -> f x ++ ys) empty {-# INLINEABLE concatMap #-} -- | Plutus Tx version of 'Data.List.filter' for 'BuiltinList'. -filter :: forall a. (MkNil a) => (a -> Bool) -> BuiltinList a -> BuiltinList a +filter :: forall a. MkNil a => (a -> Bool) -> BuiltinList a -> BuiltinList a filter p = foldr (\x xs -> if p x then x <| xs else xs) empty {-# INLINEABLE filter #-} @@ -247,58 +246,57 @@ uniqueElement = -- | Plutus Tx version of 'Data.List.findIndices' for 'BuiltinList'. findIndices :: forall a. (a -> Bool) -> BuiltinList a -> BuiltinList Integer findIndices p = go 0 - where - go :: Integer -> BuiltinList a -> BuiltinList Integer - go i = - caseList' - empty - ( \x xs -> - let indices = go (B.addInteger i 1) xs - in if p x then i <| indices else indices - ) + where + go :: Integer -> BuiltinList a -> BuiltinList Integer + go i = + caseList' + empty + ( \x xs -> + let indices = go (B.addInteger i 1) xs + in if p x then i <| indices else indices + ) {-# INLINEABLE findIndices #-} -- | Plutus Tx version of 'Data.List.findIndex'. findIndex :: forall a. (a -> Bool) -> BuiltinList a -> Maybe Integer findIndex f = go 0 - where - go :: Integer -> BuiltinList a -> Maybe Integer - go i = - caseList' - Nothing - (\x xs -> if f x then Just i else go (B.addInteger i 1) xs) + where + go :: Integer -> BuiltinList a -> Maybe Integer + go i = + caseList' + Nothing + (\x xs -> if f x then Just i else go (B.addInteger i 1) xs) {-# INLINEABLE findIndex #-} -{-| Cons each element of the first list to the second one in reverse order -(i.e. the last element of the first list is the head of the result). - -> revAppend xs ys === reverse xs ++ ys --} +-- | Cons each element of the first list to the second one in reverse order +-- (i.e. the last element of the first list is the head of the result). +-- +-- > revAppend xs ys === reverse xs ++ ys revAppend :: forall a. BuiltinList a -> BuiltinList a -> BuiltinList a revAppend l r = caseList' r (\x xs -> revAppend xs (x <| r)) l {-# INLINEABLE revAppend #-} -- | Plutus Tx version of 'Data.List.reverse' for 'BuiltinList'. -reverse :: forall a. (MkNil a) => BuiltinList a -> BuiltinList a +reverse :: forall a. MkNil a => BuiltinList a -> BuiltinList a reverse xs = revAppend xs empty {-# INLINEABLE reverse #-} -- | Plutus Tx version of 'Data.List.zip' for 'BuiltinList'. -_zip - :: forall a b - . (MkNil a, MkNil b) - => BuiltinList a - -> BuiltinList b - -> BuiltinList (BuiltinPair a b) +_zip :: + forall a b. + (MkNil a, MkNil b) => + BuiltinList a -> + BuiltinList b -> + BuiltinList (BuiltinPair a b) _zip = zipWith (curry BI.BuiltinPair) {-# INLINEABLE _zip #-} -- | Plutus Tx version of 'Data.List.unzip' for 'BuiltinList'. -_unzip - :: forall a b - . (MkNil a, MkNil b) - => BuiltinList (BuiltinPair a b) - -> BuiltinPair (BuiltinList a) (BuiltinList b) +_unzip :: + forall a b. + (MkNil a, MkNil b) => + BuiltinList (BuiltinPair a b) -> + BuiltinPair (BuiltinList a) (BuiltinList b) _unzip = caseList' emptyPair @@ -310,9 +308,9 @@ _unzip = let ys' = BI.snd l' BI.BuiltinPair (x <| xs', y <| ys') ) - where - emptyPair :: BuiltinPair (BuiltinList a) (BuiltinList b) - emptyPair = BI.BuiltinPair (empty, empty) + where + emptyPair :: BuiltinPair (BuiltinList a) (BuiltinList b) + emptyPair = BI.BuiltinPair (empty, empty) {-# INLINEABLE _unzip #-} -- | Plutus Tx version of 'Data.List.head' for 'BuiltinList'. @@ -337,7 +335,7 @@ tail = caseList (\_ -> traceError lastEmptyBuiltinListError) (\_ xs -> xs) {-# INLINEABLE tail #-} -- | Plutus Tx version of 'Data.List.take' for 'BuiltinList'. -take :: forall a. (MkNil a) => Integer -> BuiltinList a -> BuiltinList a +take :: forall a. MkNil a => Integer -> BuiltinList a -> BuiltinList a take n l | n `B.lessThanEqualsInteger` 0 = empty | otherwise = @@ -348,7 +346,7 @@ take n l {-# INLINEABLE take #-} -- | Plutus Tx version of 'Data.List.drop' for 'BuiltinList'. -drop :: forall a. (MkNil a) => Integer -> BuiltinList a -> BuiltinList a +drop :: forall a. MkNil a => Integer -> BuiltinList a -> BuiltinList a drop n l | n `B.lessThanEqualsInteger` 0 = l | otherwise = @@ -359,12 +357,12 @@ drop n l {-# INLINEABLE drop #-} -- | Plutus Tx version of 'Data.List.splitAt' for 'BuiltinList'. -_splitAt - :: forall a - . (MkNil a) - => Integer - -> BuiltinList a - -> BuiltinPair (BuiltinList a) (BuiltinList a) +_splitAt :: + forall a. + MkNil a => + Integer -> + BuiltinList a -> + BuiltinPair (BuiltinList a) (BuiltinList a) _splitAt n xs | n `B.lessThanEqualsInteger` 0 = BI.BuiltinPair (empty, xs) | B.null xs = BI.BuiltinPair (empty, empty) @@ -382,79 +380,79 @@ nub = nubBy (==) -- | Plutus Tx version of 'Data.List.elemBy' for 'BuiltinList'. elemBy :: forall a. (a -> a -> Bool) -> a -> BuiltinList a -> Bool elemBy eq y = go - where - go :: BuiltinList a -> Bool - go = caseList' False (\x xs -> if eq x y then True else go xs) + where + go :: BuiltinList a -> Bool + go = caseList' False (\x xs -> if eq x y then True else go xs) {-# INLINEABLE elemBy #-} -- | Plutus Tx version of 'Data.List.nubBy' for 'BuiltinList'. -nubBy :: forall a. (MkNil a) => (a -> a -> Bool) -> BuiltinList a -> BuiltinList a +nubBy :: forall a. MkNil a => (a -> a -> Bool) -> BuiltinList a -> BuiltinList a nubBy eq = flip go empty - where - go :: BuiltinList a -> BuiltinList a -> BuiltinList a - go l xs = - caseList' - empty - ( \y ys -> - if elemBy eq y xs - then go ys xs - else y <| go ys (y <| xs) - ) - l + where + go :: BuiltinList a -> BuiltinList a -> BuiltinList a + go l xs = + caseList' + empty + ( \y ys -> + if elemBy eq y xs + then go ys xs + else y <| go ys (y <| xs) + ) + l {-# INLINEABLE nubBy #-} -- | Plutus Tx version of 'Data.List.zipWith' for 'BuiltinList'. -zipWith - :: forall a b c - . (MkNil c) - => (a -> b -> c) - -> BuiltinList a - -> BuiltinList b - -> BuiltinList c +zipWith :: + forall a b c. + MkNil c => + (a -> b -> c) -> + BuiltinList a -> + BuiltinList b -> + BuiltinList c zipWith f = go - where - go :: BuiltinList a -> BuiltinList b -> BuiltinList c - go xs ys = - caseList' - empty - ( \x xs' -> - caseList' - empty - (\y ys' -> f x y <| go xs' ys') - ys - ) - xs + where + go :: BuiltinList a -> BuiltinList b -> BuiltinList c + go xs ys = + caseList' + empty + ( \x xs' -> + caseList' + empty + (\y ys' -> f x y <| go xs' ys') + ys + ) + xs {-# INLINEABLE zipWith #-} -- | Plutus Tx version of 'Data.List.dropWhile' for 'BuiltinList'. dropWhile :: forall a. (a -> Bool) -> BuiltinList a -> BuiltinList a dropWhile p = go - where - go :: BuiltinList a -> BuiltinList a - go xs = caseList' xs (\x xs' -> if p x then go xs' else xs) xs + where + go :: BuiltinList a -> BuiltinList a + go xs = caseList' xs (\x xs' -> if p x then go xs' else xs) xs {-# INLINEABLE dropWhile #-} -- | Plutus Tx version of 'Data.List.replicate' for 'BuiltinList'. -replicate :: forall a. (MkNil a) => Integer -> a -> BuiltinList a +replicate :: forall a. MkNil a => Integer -> a -> BuiltinList a replicate n0 x = go n0 - where - go :: Integer -> BuiltinList a - go n - | n `B.lessThanEqualsInteger` 0 = empty - | otherwise = x <| go (B.subtractInteger n 1) + where + go :: Integer -> BuiltinList a + go n + | n `B.lessThanEqualsInteger` 0 = empty + | otherwise = x <| go (B.subtractInteger n 1) {-# INLINEABLE replicate #-} -- | Plutus Tx version of 'Data.List.partition' for 'BuiltinList'. -_partition - :: forall a - . (MkNil a) - => (a -> Bool) - -> BuiltinList a - -> BuiltinPair (BuiltinList a) (BuiltinList a) +_partition :: + forall a. + MkNil a => + (a -> Bool) -> + BuiltinList a -> + BuiltinPair (BuiltinList a) (BuiltinList a) _partition p = BI.BuiltinPair . foldr select (empty, empty) - where - select :: a -> (BuiltinList a, BuiltinList a) -> (BuiltinList a, BuiltinList a) - select x ~(ts, fs) = if p x then (x <| ts, fs) else (ts, x <| fs) + where + select :: a -> (BuiltinList a, BuiltinList a) -> (BuiltinList a, BuiltinList a) + select x ~(ts, fs) = if p x then (x <| ts, fs) else (ts, x <| fs) {-# INLINEABLE _partition #-} -- | Plutus Tx version of 'Data.List.sort' for 'BuiltinList'. @@ -463,54 +461,54 @@ _sort = _sortBy compare {-# INLINEABLE _sort #-} -- | Plutus Tx version of 'Data.List.sortBy' for 'BuiltinList'. -_sortBy :: (MkNil a) => (a -> a -> Ordering) -> BuiltinList a -> BuiltinList a +_sortBy :: MkNil a => (a -> a -> Ordering) -> BuiltinList a -> BuiltinList a _sortBy cmp = mergeAll . sequences - where - sequences = caseList'' empty (singleton . singleton) f - where - f a b xs - | a `cmp` b == GT = descending b (singleton a) xs - | otherwise = ascending b (cons a) xs - - descending a as l = caseList' d f l - where - d = (a <| as) <| sequences l - f b bs - | a `cmp` b == GT = descending b (a <| as) bs - | otherwise = d - - ascending a as l = caseList' d f l - where - d = as (singleton a) <| sequences l - f b bs - | a `cmp` b /= GT = ascending b (as . cons a) bs - | otherwise = d - - mergeAll l = - case uniqueElement l of - Nothing -> - mergeAll (mergePairs l) - Just x -> - x - - mergePairs = caseList'' empty singleton f - where - f a b xs = merge a b <| mergePairs xs - - merge as bs - | null as = bs - | null bs = as - | otherwise = do - let a = head as - let b = head bs - let as' = tail as - let bs' = tail bs - if a `cmp` b == GT - then - b <| merge as bs' - else - a <| merge as' bs - - caseList'' :: forall a r. r -> (a -> r) -> (a -> a -> BuiltinList a -> r) -> BuiltinList a -> r - caseList'' f0 f1 f2 = caseList' f0 (\x xs -> caseList' (f1 x) (\y ys -> f2 x y ys) xs) + where + sequences = caseList'' empty (singleton . singleton) f + where + f a b xs + | a `cmp` b == GT = descending b (singleton a) xs + | otherwise = ascending b (cons a) xs + + descending a as l = caseList' d f l + where + d = (a <| as) <| sequences l + f b bs + | a `cmp` b == GT = descending b (a <| as) bs + | otherwise = d + + ascending a as l = caseList' d f l + where + d = as (singleton a) <| sequences l + f b bs + | a `cmp` b /= GT = ascending b (as . cons a) bs + | otherwise = d + + mergeAll l = + case uniqueElement l of + Nothing -> + mergeAll (mergePairs l) + Just x -> + x + + mergePairs = caseList'' empty singleton f + where + f a b xs = merge a b <| mergePairs xs + + merge as bs + | null as = bs + | null bs = as + | otherwise = do + let a = head as + let b = head bs + let as' = tail as + let bs' = tail bs + if a `cmp` b == GT + then + b <| merge as bs' + else + a <| merge as' bs + + caseList'' :: forall a r. r -> (a -> r) -> (a -> a -> BuiltinList a -> r) -> BuiltinList a -> r + caseList'' f0 f1 f2 = caseList' f0 (\x xs -> caseList' (f1 x) (\y ys -> f2 x y ys) xs) {-# INLINEABLE _sortBy #-} diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index e20ca01c993..4736700406a 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -172,9 +172,14 @@ import Data.Maybe import PlutusTx.Bool (Bool (..)) import PlutusTx.Builtins.HasBuiltin import PlutusTx.Builtins.HasOpaque -import PlutusTx.Builtins.Internal (BuiltinBLS12_381_G1_Element (..), - BuiltinBLS12_381_G2_Element (..), BuiltinBLS12_381_MlResult (..), - BuiltinByteString (..), BuiltinData, BuiltinString) +import PlutusTx.Builtins.Internal ( + BuiltinBLS12_381_G1_Element (..), + BuiltinBLS12_381_G2_Element (..), + BuiltinBLS12_381_MlResult (..), + BuiltinByteString (..), + BuiltinData, + BuiltinString, + ) import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Integer (Integer) @@ -240,18 +245,17 @@ ripemd_160 :: BuiltinByteString -> BuiltinByteString ripemd_160 = BI.ripemd_160 {-# INLINEABLE ripemd_160 #-} -{-| Ed25519 signature verification. Verify that the signature is a signature of -the message by the public key. This will fail if key or the signature are not -of the expected length. --} -verifyEd25519Signature - :: BuiltinByteString - -- ^ Public Key (32 bytes) - -> BuiltinByteString - -- ^ Message (arbirtary length) - -> BuiltinByteString - -- ^ Signature (64 bytes) - -> Bool +-- | Ed25519 signature verification. Verify that the signature is a signature of +-- the message by the public key. This will fail if key or the signature are not +-- of the expected length. +verifyEd25519Signature :: + -- | Public Key (32 bytes) + BuiltinByteString -> + -- | Message (arbirtary length) + BuiltinByteString -> + -- | Signature (64 bytes) + BuiltinByteString -> + Bool verifyEd25519Signature pubKey message signature = fromOpaque (BI.verifyEd25519Signature pubKey message signature) {-# INLINEABLE verifyEd25519Signature #-} @@ -286,87 +290,85 @@ decodeUtf8 :: BuiltinByteString -> BuiltinString decodeUtf8 = BI.decodeUtf8 {-# INLINEABLE decodeUtf8 #-} -{-| Given an ECDSA SECP256k1 verification key, an ECDSA SECP256k1 signature, -and an ECDSA SECP256k1 message hash (all as 'BuiltinByteString's), verify the -hash with that key and signature. - -= Note - -There are additional well-formation requirements for the arguments beyond -their length: - -* The first byte of the public key must correspond to the sign of the /y/ -coordinate: this is @0x02@ if /y/ is even, and @0x03@ otherwise. -* The remaining bytes of the public key must correspond to the /x/ -coordinate, as a big-endian integer. -* The first 32 bytes of the signature must correspond to the big-endian -integer representation of _r_. -* The last 32 bytes of the signature must correspond to the big-endian -integer representation of _s_. - -While this primitive /accepts/ a hash, any caller should only pass it hashes -that they computed themselves: specifically, they should receive the -/message/ from a sender and hash it, rather than receiving the /hash/ from -said sender. Failure to do so can be -[dangerous](https://bitcoin.stackexchange.com/a/81116/35586). Other than -length, we make no requirements of what hash gets used. - -= See also - -* -[@secp256k1_ec_pubkey_serialize@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1.h#L394); -this implements the format for the verification key that we accept, given a -length argument of 33 and the @SECP256K1_EC_COMPRESSED@ flag. -* -[@secp256k1_ecdsa_serialize_compact@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1.h#L487); -this implements the format for the signature that we accept. --} -verifyEcdsaSecp256k1Signature - :: BuiltinByteString - -- ^ Verification key (33 bytes) - -> BuiltinByteString - -- ^ Message hash (32 bytes) - -> BuiltinByteString - -- ^ Signature (64 bytes) - -> Bool +-- | Given an ECDSA SECP256k1 verification key, an ECDSA SECP256k1 signature, +-- and an ECDSA SECP256k1 message hash (all as 'BuiltinByteString's), verify the +-- hash with that key and signature. +-- +-- = Note +-- +-- There are additional well-formation requirements for the arguments beyond +-- their length: +-- +-- * The first byte of the public key must correspond to the sign of the /y/ +-- coordinate: this is @0x02@ if /y/ is even, and @0x03@ otherwise. +-- * The remaining bytes of the public key must correspond to the /x/ +-- coordinate, as a big-endian integer. +-- * The first 32 bytes of the signature must correspond to the big-endian +-- integer representation of _r_. +-- * The last 32 bytes of the signature must correspond to the big-endian +-- integer representation of _s_. +-- +-- While this primitive /accepts/ a hash, any caller should only pass it hashes +-- that they computed themselves: specifically, they should receive the +-- /message/ from a sender and hash it, rather than receiving the /hash/ from +-- said sender. Failure to do so can be +-- [dangerous](https://bitcoin.stackexchange.com/a/81116/35586). Other than +-- length, we make no requirements of what hash gets used. +-- +-- = See also +-- +-- * +-- [@secp256k1_ec_pubkey_serialize@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1.h#L394); +-- this implements the format for the verification key that we accept, given a +-- length argument of 33 and the @SECP256K1_EC_COMPRESSED@ flag. +-- * +-- [@secp256k1_ecdsa_serialize_compact@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1.h#L487); +-- this implements the format for the signature that we accept. +verifyEcdsaSecp256k1Signature :: + -- | Verification key (33 bytes) + BuiltinByteString -> + -- | Message hash (32 bytes) + BuiltinByteString -> + -- | Signature (64 bytes) + BuiltinByteString -> + Bool verifyEcdsaSecp256k1Signature vk msg sig = fromOpaque (BI.verifyEcdsaSecp256k1Signature vk msg sig) {-# INLINEABLE verifyEcdsaSecp256k1Signature #-} -{-| Given a Schnorr SECP256k1 verification key, a Schnorr SECP256k1 signature, -and a message (all as 'BuiltinByteString's), verify the message with that key -and signature. - -= Note - -There are additional well-formation requirements for the arguments beyond -their length. Throughout, we refer to co-ordinates of the point @R@. - -* The bytes of the public key must correspond to the /x/ coordinate, as a -big-endian integer, as specified in BIP-340. -* The first 32 bytes of the signature must correspond to the /x/ coordinate, -as a big-endian integer, as specified in BIP-340. -* The last 32 bytes of the signature must correspond to the bytes of /s/, as -a big-endian integer, as specified in BIP-340. - -= See also - -* [BIP-340](https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki) -* -[@secp256k1_xonly_pubkey_serialize@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1_extrakeys.h#L61); -this implements the format for the verification key that we accept. -* -[@secp256k1_schnorrsig_sign@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1_schnorrsig.h#L129); -this implements the signing logic for signatures this builtin can verify. --} -verifySchnorrSecp256k1Signature - :: BuiltinByteString - -- ^ Verification key (32 bytes) - -> BuiltinByteString - -- ^ Message (arbitrary length) - -> BuiltinByteString - -- ^ Signature (64 bytes) - -> Bool +-- | Given a Schnorr SECP256k1 verification key, a Schnorr SECP256k1 signature, +-- and a message (all as 'BuiltinByteString's), verify the message with that key +-- and signature. +-- +-- = Note +-- +-- There are additional well-formation requirements for the arguments beyond +-- their length. Throughout, we refer to co-ordinates of the point @R@. +-- +-- * The bytes of the public key must correspond to the /x/ coordinate, as a +-- big-endian integer, as specified in BIP-340. +-- * The first 32 bytes of the signature must correspond to the /x/ coordinate, +-- as a big-endian integer, as specified in BIP-340. +-- * The last 32 bytes of the signature must correspond to the bytes of /s/, as +-- a big-endian integer, as specified in BIP-340. +-- +-- = See also +-- +-- * [BIP-340](https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki) +-- * +-- [@secp256k1_xonly_pubkey_serialize@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1_extrakeys.h#L61); +-- this implements the format for the verification key that we accept. +-- * +-- [@secp256k1_schnorrsig_sign@](https://github.com/bitcoin-core/secp256k1/blob/master/include/secp256k1_schnorrsig.h#L129); +-- this implements the signing logic for signatures this builtin can verify. +verifySchnorrSecp256k1Signature :: + -- | Verification key (32 bytes) + BuiltinByteString -> + -- | Message (arbitrary length) + BuiltinByteString -> + -- | Signature (64 bytes) + BuiltinByteString -> + Bool verifySchnorrSecp256k1Signature vk msg sig = fromOpaque (BI.verifySchnorrSecp256k1Signature vk msg sig) {-# INLINEABLE verifySchnorrSecp256k1Signature #-} @@ -501,9 +503,8 @@ sopListToArray :: (HasToOpaque a arep, MkNil arep) => [a] -> BI.BuiltinArray are sopListToArray l = BI.listToArray (toOpaque l) {-# INLINEABLE sopListToArray #-} -{-| Given five values for the five different constructors of 'BuiltinData', selects -one depending on which corresponds to the actual constructor of the given value. --} +-- | Given five values for the five different constructors of 'BuiltinData', selects +-- one depending on which corresponds to the actual constructor of the given value. chooseData :: forall a. BuiltinData -> a -> a -> a -> a -> a -> a chooseData = BI.chooseData {-# INLINEABLE chooseData #-} @@ -568,14 +569,14 @@ equalsData :: BuiltinData -> BuiltinData -> Bool equalsData d1 d2 = fromOpaque (BI.equalsData d1 d2) {-# INLINEABLE equalsData #-} -matchData' - :: BuiltinData - -> (Integer -> BI.BuiltinList BuiltinData -> r) - -> (BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> r) - -> (BI.BuiltinList BuiltinData -> r) - -> (Integer -> r) - -> (BuiltinByteString -> r) - -> r +matchData' :: + BuiltinData -> + (Integer -> BI.BuiltinList BuiltinData -> r) -> + (BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> r) -> + (BI.BuiltinList BuiltinData -> r) -> + (Integer -> r) -> + (BuiltinByteString -> r) -> + r -- See Note [Making arguments non-strict in case and match functions] matchData' d ~constrCase ~mapCase ~listCase ~iCase ~bCase = chooseData @@ -588,17 +589,16 @@ matchData' d ~constrCase ~mapCase ~listCase ~iCase ~bCase = () {-# INLINEABLE matchData' #-} -{-| Given a 'BuiltinData' value and matching functions for the five constructors, -applies the appropriate matcher to the arguments of the constructor and returns the result. --} -matchData - :: BuiltinData - -> (Integer -> [BuiltinData] -> r) - -> ([(BuiltinData, BuiltinData)] -> r) - -> ([BuiltinData] -> r) - -> (Integer -> r) - -> (BuiltinByteString -> r) - -> r +-- | Given a 'BuiltinData' value and matching functions for the five constructors, +-- applies the appropriate matcher to the arguments of the constructor and returns the result. +matchData :: + BuiltinData -> + (Integer -> [BuiltinData] -> r) -> + ([(BuiltinData, BuiltinData)] -> r) -> + ([BuiltinData] -> r) -> + (Integer -> r) -> + (BuiltinByteString -> r) -> + r -- See Note [Making arguments non-strict in case and match functions] matchData d ~constrCase ~mapCase ~listCase ~iCase ~bCase = matchData' @@ -615,8 +615,8 @@ bls12_381_G1_equals :: BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Elemen bls12_381_G1_equals a b = fromOpaque (BI.bls12_381_G1_equals a b) {-# INLINEABLE bls12_381_G1_equals #-} -bls12_381_G1_add - :: BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element +bls12_381_G1_add :: + BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element bls12_381_G1_add = BI.bls12_381_G1_add {-# INLINEABLE bls12_381_G1_add #-} @@ -657,8 +657,8 @@ bls12_381_G2_equals :: BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Elemen bls12_381_G2_equals a b = fromOpaque (BI.bls12_381_G2_equals a b) {-# INLINEABLE bls12_381_G2_equals #-} -bls12_381_G2_add - :: BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element +bls12_381_G2_add :: + BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element bls12_381_G2_add = BI.bls12_381_G2_add {-# INLINEABLE bls12_381_G2_add #-} @@ -695,13 +695,13 @@ bls12_381_G2_compressed_generator = BI.bls12_381_G2_compressed_generator {-# INLINEABLE bls12_381_G2_compressed_generator #-} -- Pairing -- -bls12_381_millerLoop - :: BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_MlResult +bls12_381_millerLoop :: + BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_MlResult bls12_381_millerLoop = BI.bls12_381_millerLoop {-# INLINEABLE bls12_381_millerLoop #-} -bls12_381_mulMlResult - :: BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult +bls12_381_mulMlResult :: + BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult bls12_381_mulMlResult = BI.bls12_381_mulMlResult {-# INLINEABLE bls12_381_mulMlResult #-} @@ -714,35 +714,33 @@ bls12_381_finalVerify a b = fromOpaque (BI.bls12_381_finalVerify a b) -- The PLC builtins take a boolean argument to indicate the endianness of the -- conversion, but here we use GHC.ByteOrder.ByteOrder for clarity. byteOrderToBool :: ByteOrder -> Bool -byteOrderToBool BigEndian = True +byteOrderToBool BigEndian = True byteOrderToBool LittleEndian = False {-# INLINEABLE byteOrderToBool #-} -{-| Convert a 'BuiltinInteger' into a 'BuiltinByteString', as described in -[CIP-121](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0121). -The first argument indicates the endianness of the conversion and the third -argument is the integer to be converted, which must be non-negative. The -second argument must also be non-negative and it indicates the required width -of the output. If the width is zero then the output is the smallest -bytestring which can contain the converted input (and in this case, the -integer 0 encodes to the empty bytestring). If the width is nonzero then the -output bytestring will be padded to the required width with 0x00 bytes (on -the left for big-endian conversions and on the right for little-endian -conversions); if the input integer is too big to fit into a bytestring of the -specified width then the conversion will fail. Conversion will also fail if -the specified width is greater than 8192 or the input integer is too big to -fit into a bytestring of length 8192. --} +-- | Convert a 'BuiltinInteger' into a 'BuiltinByteString', as described in +-- [CIP-121](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0121). +-- The first argument indicates the endianness of the conversion and the third +-- argument is the integer to be converted, which must be non-negative. The +-- second argument must also be non-negative and it indicates the required width +-- of the output. If the width is zero then the output is the smallest +-- bytestring which can contain the converted input (and in this case, the +-- integer 0 encodes to the empty bytestring). If the width is nonzero then the +-- output bytestring will be padded to the required width with 0x00 bytes (on +-- the left for big-endian conversions and on the right for little-endian +-- conversions); if the input integer is too big to fit into a bytestring of the +-- specified width then the conversion will fail. Conversion will also fail if +-- the specified width is greater than 8192 or the input integer is too big to +-- fit into a bytestring of length 8192. integerToByteString :: ByteOrder -> Integer -> Integer -> BuiltinByteString integerToByteString endianness = BI.integerToByteString (toOpaque (byteOrderToBool endianness)) {-# INLINEABLE integerToByteString #-} -{-| Convert a 'BuiltinByteString' to a 'BuiltinInteger', as described in -[CIP-121](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0121). -The first argument indicates the endianness of the conversion and the second -is the bytestring to be converted. There is no limitation on the size of -the bytestring. The empty bytestring is converted to the integer 0. --} +-- | Convert a 'BuiltinByteString' to a 'BuiltinInteger', as described in +-- [CIP-121](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0121). +-- The first argument indicates the endianness of the conversion and the second +-- is the bytestring to be converted. There is no limitation on the size of +-- the bytestring. The empty bytestring is converted to the integer 0. byteStringToInteger :: ByteOrder -> BuiltinByteString -> Integer byteStringToInteger endianness = BI.byteStringToInteger (toOpaque (byteOrderToBool endianness)) @@ -750,200 +748,188 @@ byteStringToInteger endianness = -- Bitwise operations -{-| Shift a 'BuiltinByteString', as per -[CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). --} +-- | Shift a 'BuiltinByteString', as per +-- [CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). shiftByteString :: BuiltinByteString -> Integer -> BuiltinByteString shiftByteString = BI.shiftByteString {-# INLINEABLE shiftByteString #-} -{-| Rotate a 'BuiltinByteString', as per -[CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). --} +-- | Rotate a 'BuiltinByteString', as per +-- [CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). rotateByteString :: BuiltinByteString -> Integer -> BuiltinByteString rotateByteString = BI.rotateByteString {-# INLINEABLE rotateByteString #-} -{-| Count the set bits in a 'BuiltinByteString', as per -[CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). --} +-- | Count the set bits in a 'BuiltinByteString', as per +-- [CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). countSetBits :: BuiltinByteString -> Integer countSetBits = BI.countSetBits {-# INLINEABLE countSetBits #-} -{-| Find the lowest index of a set bit in a 'BuiltinByteString', as per -[CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). - -If given a 'BuiltinByteString' which consists only of zero bytes (including the empty -'BuiltinByteString', this returns @-1@. --} +-- | Find the lowest index of a set bit in a 'BuiltinByteString', as per +-- [CIP-123](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0123). +-- +-- If given a 'BuiltinByteString' which consists only of zero bytes (including the empty +-- 'BuiltinByteString', this returns @-1@. findFirstSetBit :: BuiltinByteString -> Integer findFirstSetBit = BI.findFirstSetBit {-# INLINEABLE findFirstSetBit #-} -- Logical operations -{-| Perform logical AND on two 'BuiltinByteString' arguments, as described in -[CIP-122](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicaland). - -The first argument indicates whether padding semantics should be used or not; -if 'False', truncation semantics will be used instead. - -= See also - -* [Padding and truncation -semantics](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#padding-versus-truncation-semantics) -* [Bit indexing -scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) --} -andByteString - :: Bool - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString +-- | Perform logical AND on two 'BuiltinByteString' arguments, as described in +-- [CIP-122](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicaland). +-- +-- The first argument indicates whether padding semantics should be used or not; +-- if 'False', truncation semantics will be used instead. +-- +-- = See also +-- +-- * [Padding and truncation +-- semantics](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#padding-versus-truncation-semantics) +-- * [Bit indexing +-- scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) +andByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString andByteString b = BI.andByteString (toOpaque b) {-# INLINEABLE andByteString #-} -{-| Perform logical OR on two 'BuiltinByteString' arguments, as described -[here](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicalor). - -The first argument indicates whether padding semantics should be used or not; -if 'False', truncation semantics will be used instead. - -= See also - -* [Padding and truncation -semantics](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#padding-versus-truncation-semantics) -* [Bit indexing -scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) --} -orByteString - :: Bool - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString +-- | Perform logical OR on two 'BuiltinByteString' arguments, as described +-- [here](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicalor). +-- +-- The first argument indicates whether padding semantics should be used or not; +-- if 'False', truncation semantics will be used instead. +-- +-- = See also +-- +-- * [Padding and truncation +-- semantics](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#padding-versus-truncation-semantics) +-- * [Bit indexing +-- scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) +orByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString orByteString b = BI.orByteString (toOpaque b) {-# INLINEABLE orByteString #-} -{-| Perform logical XOR on two 'BuiltinByteString' arguments, as described -[here](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicalxor). - -The first argument indicates whether padding semantics should be used or not; -if 'False', truncation semantics will be used instead. - -= See also - -* [Padding and truncation -semantics](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#padding-versus-truncation-semantics) -* [Bit indexing -scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) --} -xorByteString - :: Bool - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString +-- | Perform logical XOR on two 'BuiltinByteString' arguments, as described +-- [here](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicalxor). +-- +-- The first argument indicates whether padding semantics should be used or not; +-- if 'False', truncation semantics will be used instead. +-- +-- = See also +-- +-- * [Padding and truncation +-- semantics](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#padding-versus-truncation-semantics) +-- * [Bit indexing +-- scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) +xorByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString xorByteString b = BI.xorByteString (toOpaque b) {-# INLINEABLE xorByteString #-} -{-| Perform logical complement on a 'BuiltinByteString', as described -[here](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicalcomplement). - -= See also - -* [Bit indexing -scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) --} -complementByteString - :: BuiltinByteString - -> BuiltinByteString +-- | Perform logical complement on a 'BuiltinByteString', as described +-- [here](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bitwiselogicalcomplement). +-- +-- = See also +-- +-- * [Bit indexing +-- scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) +complementByteString :: + BuiltinByteString -> + BuiltinByteString complementByteString = BI.complementByteString {-# INLINEABLE complementByteString #-} -{-| Read a bit at the _bit_ index given by the 'Integer' argument in the -'BuiltinByteString' argument. The result will be 'True' if the corresponding bit is set, and -'False' if it is clear. Will error if given an out-of-bounds index argument; that is, if the -index is either negative, or equal to or greater than the total number of bits in the -'BuiltinByteString' argument. - -= See also - -* [Bit indexing -scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) -* [Operation -description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#readbit) --} -readBit - :: BuiltinByteString - -> Integer - -> Bool +-- | Read a bit at the _bit_ index given by the 'Integer' argument in the +-- 'BuiltinByteString' argument. The result will be 'True' if the corresponding bit is set, and +-- 'False' if it is clear. Will error if given an out-of-bounds index argument; that is, if the +-- index is either negative, or equal to or greater than the total number of bits in the +-- 'BuiltinByteString' argument. +-- +-- = See also +-- +-- * [Bit indexing +-- scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) +-- * [Operation +-- description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#readbit) +readBit :: + BuiltinByteString -> + Integer -> + Bool readBit bs i = fromOpaque (BI.readBit bs i) {-# INLINEABLE readBit #-} -{-| Given a 'BuiltinByteString', a list of indexes to change, and a boolean -value 'b' to change those indexes to, set the /bit/ at each of the specified -index as follows: - -* If 'b' is 'True', set that bit; -* Otherwise, clear that bit. - -Will error if any of the indexes are out-of-bounds: that is, if the index is either negative, or -equal to or greater than the total number of bits in the 'BuiltinByteString' argument. - -= Note - -This differs slightly from the description of the [corresponding operation in -CIP-122](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#writebits); -instead of a single changelist argument comprised of pairs, we instead pass a -single list of indexes to change, and a single boolean value to change those -indexes to. The original proposal allowed one to set and clear bits in a -single operation, but constructing the list of boolean values for the updates -was somewhat expensive. If it's really necessary to set some bits and clear -others then it is easier to call the function twice, once to set bits and -and once to clear them. - -= See also - -* [Bit indexing -scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) -* [Operation -description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#writebits) --} -writeBits - :: BuiltinByteString - -> [Integer] - -> Bool - -> BuiltinByteString +-- | Given a 'BuiltinByteString', a list of indexes to change, and a boolean +-- value 'b' to change those indexes to, set the /bit/ at each of the specified +-- index as follows: +-- +-- * If 'b' is 'True', set that bit; +-- * Otherwise, clear that bit. +-- +-- Will error if any of the indexes are out-of-bounds: that is, if the index is either negative, or +-- equal to or greater than the total number of bits in the 'BuiltinByteString' argument. +-- +-- = Note +-- +-- This differs slightly from the description of the [corresponding operation in +-- CIP-122](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#writebits); +-- instead of a single changelist argument comprised of pairs, we instead pass a +-- single list of indexes to change, and a single boolean value to change those +-- indexes to. The original proposal allowed one to set and clear bits in a +-- single operation, but constructing the list of boolean values for the updates +-- was somewhat expensive. If it's really necessary to set some bits and clear +-- others then it is easier to call the function twice, once to set bits and +-- and once to clear them. +-- +-- = See also +-- +-- * [Bit indexing +-- scheme](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#bit-indexing-scheme) +-- * [Operation +-- description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#writebits) +writeBits :: + BuiltinByteString -> + [Integer] -> + Bool -> + BuiltinByteString writeBits bs ixes bit = BI.writeBits bs (toOpaque ixes) (toOpaque bit) {-# INLINEABLE writeBits #-} -{-| Given a length (first argument) and a byte (second argument), produce a 'BuiltinByteString' of -that length, with that byte in every position. Will error if given a negative length, or a second -argument that isn't a byte (less than 0, greater than 255). - -= See also - -* [Operation -description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#replicateByteString) --} -replicateByte - :: Integer - -> Integer - -> BuiltinByteString +-- | Given a length (first argument) and a byte (second argument), produce a 'BuiltinByteString' of +-- that length, with that byte in every position. Will error if given a negative length, or a second +-- argument that isn't a byte (less than 0, greater than 255). +-- +-- = See also +-- +-- * [Operation +-- description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#replicateByteString) +replicateByte :: + Integer -> + Integer -> + BuiltinByteString replicateByte = BI.replicateByte {-# INLINEABLE replicateByte #-} -{-| FIXME(https://github.com/IntersectMBO/plutus-private/issues/1609): - -= See also - -* [Operation -description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0109) --} -expModInteger - :: Integer - -> Integer - -> Integer - -> Integer +-- | FIXME(https://github.com/IntersectMBO/plutus-private/issues/1609): +-- +-- = See also +-- +-- * [Operation +-- description](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0109) +expModInteger :: + Integer -> + Integer -> + Integer -> + Integer expModInteger = BI.expModInteger {-# INLINEABLE expModInteger #-} diff --git a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs index f8944de94a5..d4e4bf03893 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module PlutusTx.Builtins.HasBuiltin where @@ -37,21 +37,19 @@ useFromOpaque x = x -- Also see Note [Built-in types and their Haskell counterparts]. -{-| A class for converting values of Haskell-defined built-in types to their Plutus Tx -counterparts. --} +-- | A class for converting values of Haskell-defined built-in types to their Plutus Tx +-- counterparts. type HasToBuiltin :: GHC.Type -> GHC.Constraint -class (PLC.DefaultUni `PLC.Contains` a) => HasToBuiltin a where +class PLC.DefaultUni `PLC.Contains` a => HasToBuiltin a where type ToBuiltin a toBuiltin :: a -> ToBuiltin a -- Also see Note [Built-in types and their Haskell counterparts]. -{-| A class for converting values of Plutus Tx built-in types to their Haskell-defined -counterparts. --} +-- | A class for converting values of Plutus Tx built-in types to their Haskell-defined +-- counterparts. type HasFromBuiltin :: GHC.Type -> GHC.Constraint -class (HasToBuiltin (FromBuiltin arep)) => HasFromBuiltin arep where +class HasToBuiltin (FromBuiltin arep) => HasFromBuiltin arep where type FromBuiltin arep fromBuiltin :: arep -> FromBuiltin arep @@ -90,17 +88,17 @@ instance HasFromBuiltin Bool where type FromBuiltin Bool = Bool fromBuiltin = id -instance (HasToBuiltin a) => HasToBuiltin [a] where +instance HasToBuiltin a => HasToBuiltin [a] where type ToBuiltin [a] = BuiltinList (ToBuiltin a) toBuiltin = useToOpaque BuiltinList . map toBuiltin -instance (HasFromBuiltin a) => HasFromBuiltin (BuiltinList a) where +instance HasFromBuiltin a => HasFromBuiltin (BuiltinList a) where type FromBuiltin (BuiltinList a) = [FromBuiltin a] fromBuiltin (BuiltinList xs) = map fromBuiltin xs -instance (HasToBuiltin a) => HasToBuiltin (Strict.Vector a) where +instance HasToBuiltin a => HasToBuiltin (Strict.Vector a) where type ToBuiltin (Strict.Vector a) = BuiltinArray (ToBuiltin a) toBuiltin = useToOpaque (BuiltinArray . fmap toBuiltin) -instance (HasFromBuiltin a) => HasFromBuiltin (BuiltinArray a) where +instance HasFromBuiltin a => HasFromBuiltin (BuiltinArray a) where type FromBuiltin (BuiltinArray a) = Strict.Vector (FromBuiltin a) fromBuiltin (BuiltinArray xs) = fmap fromBuiltin xs diff --git a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs index 55736bc52af..8c285aba3be 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -17,11 +17,25 @@ import Control.DeepSeq (NFData (..)) import PlutusCore.Pretty (Pretty (..)) import PlutusTx.Base (id) import PlutusTx.Bool (Bool (..)) -import PlutusTx.Builtins.Internal (BuiltinBLS12_381_G1_Element, BuiltinBLS12_381_G2_Element, - BuiltinBLS12_381_MlResult, BuiltinByteString (..), BuiltinData, - BuiltinInteger, BuiltinList (..), BuiltinPair, - BuiltinString (..), BuiltinUnit, BuiltinValue, caseList', - casePair, chooseUnit, mkCons, mkPairData, unitval) +import PlutusTx.Builtins.Internal ( + BuiltinBLS12_381_G1_Element, + BuiltinBLS12_381_G2_Element, + BuiltinBLS12_381_MlResult, + BuiltinByteString (..), + BuiltinData, + BuiltinInteger, + BuiltinList (..), + BuiltinPair, + BuiltinString (..), + BuiltinUnit, + BuiltinValue, + caseList', + casePair, + chooseUnit, + mkCons, + mkPairData, + unitval, + ) import Codec.Serialise (Serialise) import Data.ByteArray qualified as BA @@ -198,14 +212,13 @@ type application on a type variable. So fundeps are much nicer here. -- See Note [HasFromOpaque/HasToOpaque instances for polymorphic builtin types]. -- See Note [Fundeps versus type families in HasFromOpaque/HasToOpaque]. -{-| A class for converting values of transparent Haskell-defined built-in types (such as '()', -'Bool', '[]' etc) to their opaque Plutus Tx counterparts. Instances for built-in types that are -not transparent are provided as well, simply as identities, since those types are already opaque. --} +-- | A class for converting values of transparent Haskell-defined built-in types (such as '()', +-- 'Bool', '[]' etc) to their opaque Plutus Tx counterparts. Instances for built-in types that are +-- not transparent are provided as well, simply as identities, since those types are already opaque. type HasToOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint class HasToOpaque a arep | a -> arep where toOpaque :: a -> arep - default toOpaque :: (a ~ arep) => a -> arep + default toOpaque :: a ~ arep => a -> arep toOpaque = id {-# INLINEABLE toOpaque #-} @@ -213,14 +226,13 @@ class HasToOpaque a arep | a -> arep where -- See Note [HasFromOpaque/HasToOpaque instances for polymorphic builtin types]. -- See Note [Fundeps versus type families in HasFromOpaque/HasToOpaque]. -{-| A class for converting values of opaque Plutus Tx types to their transparent Haskell-defined -counterparts (a.k.a. pattern-matchable) built-in types (such as '()', 'Bool', '[]' etc). If no -transparent counterpart exists, then the implementation is identity. --} +-- | A class for converting values of opaque Plutus Tx types to their transparent Haskell-defined +-- counterparts (a.k.a. pattern-matchable) built-in types (such as '()', 'Bool', '[]' etc). If no +-- transparent counterpart exists, then the implementation is identity. type HasFromOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint class HasFromOpaque arep a | arep -> a where fromOpaque :: arep -> a - default fromOpaque :: (a ~ arep) => arep -> a + default fromOpaque :: a ~ arep => arep -> a fromOpaque = id {-# INLINEABLE fromOpaque #-} @@ -255,10 +267,9 @@ instance HasFromOpaque BuiltinUnit () where instance HasToOpaque Bool Bool instance HasFromOpaque Bool Bool -{-| The empty list of elements of the given type that gets spotted by the plugin (grep for -'mkNilOpaque' in the plugin code) and replaced by the actual empty list constant for types that -are supported (a subset of built-in types). --} +-- | The empty list of elements of the given type that gets spotted by the plugin (grep for +-- 'mkNilOpaque' in the plugin code) and replaced by the actual empty list constant for types that +-- are supported (a subset of built-in types). mkNilOpaque :: BuiltinList a mkNilOpaque = BuiltinList [] {-# OPAQUE mkNilOpaque #-} @@ -273,33 +284,33 @@ instance MkNil BuiltinData instance MkNil BuiltinValue instance MkNil BuiltinBLS12_381_G1_Element instance MkNil BuiltinBLS12_381_G2_Element -instance (MkNil a) => MkNil (BuiltinList a) +instance MkNil a => MkNil (BuiltinList a) instance (MkNil a, MkNil b) => MkNil (BuiltinPair a b) instance (HasToOpaque a arep, MkNil arep) => HasToOpaque [a] (BuiltinList arep) where toOpaque = goList - where - goList :: [a] -> BuiltinList arep - goList [] = mkNil - goList (d : ds) = mkCons (toOpaque d) (goList ds) + where + goList :: [a] -> BuiltinList arep + goList [] = mkNil + goList (d : ds) = mkCons (toOpaque d) (goList ds) {-# INLINEABLE toOpaque #-} -instance (HasFromOpaque arep a) => HasFromOpaque (BuiltinList arep) [a] where +instance HasFromOpaque arep a => HasFromOpaque (BuiltinList arep) [a] where fromOpaque = go - where - -- The combination of both INLINABLE and a type signature seems to stop this getting - -- lifted to the top level, which means it gets a proper unfolding, which means that - -- specialization can work, which can actually help quite a bit here. - go :: BuiltinList arep -> [a] - go = caseList' [] (\x xs -> fromOpaque x : go xs) - {-# INLINEABLE go #-} + where + -- The combination of both INLINABLE and a type signature seems to stop this getting + -- lifted to the top level, which means it gets a proper unfolding, which means that + -- specialization can work, which can actually help quite a bit here. + go :: BuiltinList arep -> [a] + go = caseList' [] (\x xs -> fromOpaque x : go xs) + {-# INLINEABLE go #-} {-# INLINEABLE fromOpaque #-} instance HasToOpaque (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where toOpaque (d1, d2) = mkPairData (toOpaque d1) (toOpaque d2) {-# INLINEABLE toOpaque #-} instance - (HasFromOpaque arep a, HasFromOpaque brep b) - => HasFromOpaque (BuiltinPair arep brep) (a, b) + (HasFromOpaque arep a, HasFromOpaque brep b) => + HasFromOpaque (BuiltinPair arep brep) (a, b) where fromOpaque p = casePair p (\l r -> (fromOpaque l, fromOpaque r)) {-# INLINEABLE fromOpaque #-} diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 1d3861f3467..662b1c1bf5f 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -1,33 +1,33 @@ -- editorconfig-checker-disable-file {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -- 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 OPAQUE! {-# OPTIONS_GHC -O0 #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use newtype instead of data" #-} -- See Note [Opaque builtin types] - -{-| This module contains the special Haskell names that are used to map to builtin types or functions - in Plutus Core. - - Most users should not use this module directly, but rather use 'PlutusTx.Builtins'. - - Please note that the documentation for each function will only include operational invariants - if there are any. This documentation assumes that the type system correctly enforces and - prevents any structural errors on the generated UPLC. See Note [Structural vs operational errors - within builtins]. +{-# HLINT ignore "Use newtype instead of data" #-} +-- See Note [Opaque builtin types] - Also note that all builtin functions will fail if the CEK machine exceeds its evaluation budget. - Builtin functions with dynamic costing are particularly prone to budget overruns: for example, - addInteger and appendByteString differ cost based on input size, so supplying very large integers or - byte strings will cause these functions to abort when the budget limit is reached and fail. - See Note [Budgeting]. --} +-- | This module contains the special Haskell names that are used to map to builtin types or functions +-- in Plutus Core. +-- +-- Most users should not use this module directly, but rather use 'PlutusTx.Builtins'. +-- +-- Please note that the documentation for each function will only include operational invariants +-- if there are any. This documentation assumes that the type system correctly enforces and +-- prevents any structural errors on the generated UPLC. See Note [Structural vs operational errors +-- within builtins]. +-- +-- Also note that all builtin functions will fail if the CEK machine exceeds its evaluation budget. +-- Builtin functions with dynamic costing are particularly prone to budget overruns: for example, +-- addInteger and appendByteString differ cost based on input size, so supplying very large integers or +-- byte strings will cause these functions to abort when the budget limit is reached and fail. +-- See Note [Budgeting]. module PlutusTx.Builtins.Internal where import Codec.Serialise @@ -123,7 +123,7 @@ UNIT -} -- See Note [Opaque builtin types] -data BuiltinUnit = BuiltinUnit ~() deriving stock Data +data BuiltinUnit = BuiltinUnit ~() deriving stock (Data) -- | Unit unitval :: BuiltinUnit @@ -158,10 +158,9 @@ multiplyInteger :: BuiltinInteger -> BuiltinInteger -> BuiltinInteger multiplyInteger = coerce ((*) @Integer) {-# OPAQUE multiplyInteger #-} -{-| Finds the quotient of two integers and fails when the second argument, the divisor, is zero. -See Note [Integer division operations] for explanation on 'divideInteger', 'modInteger', -'quotientInteger', and 'remainderInteger'. --} +-- | Finds the quotient of two integers and fails when the second argument, the divisor, is zero. +-- See Note [Integer division operations] for explanation on 'divideInteger', 'modInteger', +-- 'quotientInteger', and 'remainderInteger'. divideInteger :: BuiltinInteger -> BuiltinInteger -> BuiltinInteger divideInteger = coerce (div @Integer) {-# OPAQUE divideInteger #-} @@ -181,16 +180,14 @@ remainderInteger :: BuiltinInteger -> BuiltinInteger -> BuiltinInteger remainderInteger = coerce (rem @Integer) {-# OPAQUE remainderInteger #-} -{-| Compares two integers and returns true when the first argument is less than the second -| argument. --} +-- | Compares two integers and returns true when the first argument is less than the second +-- | argument. lessThanInteger :: BuiltinInteger -> BuiltinInteger -> Bool lessThanInteger x y = coerce ((<) @Integer) x y {-# OPAQUE lessThanInteger #-} -{-| Compares two integers and returns true when the first argument is less or equal to than the -| second argument. --} +-- | Compares two integers and returns true when the first argument is less or equal to than the +-- | second argument. lessThanEqualsInteger :: BuiltinInteger -> BuiltinInteger -> Bool lessThanEqualsInteger x y = coerce ((<=) @Integer) x y {-# OPAQUE lessThanEqualsInteger #-} @@ -207,7 +204,7 @@ BYTESTRING -- See Note [Opaque builtin types] -- | An opaque type representing Plutus Core ByteStrings. -data BuiltinByteString = BuiltinByteString ~BS.ByteString deriving stock Data +data BuiltinByteString = BuiltinByteString ~BS.ByteString deriving stock (Data) instance Haskell.Show BuiltinByteString where show (BuiltinByteString bs) = show bs @@ -240,21 +237,19 @@ appendByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString appendByteString (BuiltinByteString b1) (BuiltinByteString b2) = BuiltinByteString $ BS.append b1 b2 {-# OPAQUE appendByteString #-} -{-| Appends a byte to the given bytestring. - The semantics of this function differ based on [Builtin semantics variants]. - - For builtin semantics variant A and B, that is for PlutusV1 and PlutusV2, this reduces the first argument - modulo 256 and will never fail. - - For builtin semantics variant C, that is for PlutusV3, this will expect first argument to be in range - @[0..255]@ and fail otherwise. --} +-- | Appends a byte to the given bytestring. +-- The semantics of this function differ based on [Builtin semantics variants]. +-- - For builtin semantics variant A and B, that is for PlutusV1 and PlutusV2, this reduces the first argument +-- modulo 256 and will never fail. +-- - For builtin semantics variant C, that is for PlutusV3, this will expect first argument to be in range +-- @[0..255]@ and fail otherwise. consByteString :: BuiltinInteger -> BuiltinByteString -> BuiltinByteString consByteString n (BuiltinByteString b) = BuiltinByteString $ BS.cons (fromIntegral n) b {-# OPAQUE consByteString #-} -{-| Slices the given bytestring and never fails. The first integer marks the beginning index and the - second marks the end. Indices are expected to be 0-indexed, and when the first integer is greater - than the second, it returns an empty bytestring. --} +-- | Slices the given bytestring and never fails. The first integer marks the beginning index and the +-- second marks the end. Indices are expected to be 0-indexed, and when the first integer is greater +-- than the second, it returns an empty bytestring. sliceByteString :: BuiltinInteger -> BuiltinInteger -> BuiltinByteString -> BuiltinByteString sliceByteString start n (BuiltinByteString b) = BuiltinByteString $ BS.take (fromIntegral n) (BS.drop (fromIntegral start) b) {-# OPAQUE sliceByteString #-} @@ -264,9 +259,8 @@ lengthOfByteString :: BuiltinByteString -> BuiltinInteger lengthOfByteString (BuiltinByteString b) = toInteger $ BS.length b {-# OPAQUE lengthOfByteString #-} -{-| Returns the n-th byte from the bytestring. Fails if the given index is not in the range @[0..j)@, - where @j@ is the length of the bytestring. --} +-- | Returns the n-th byte from the bytestring. Fails if the given index is not in the range @[0..j)@, +-- where @j@ is the length of the bytestring. indexByteString :: BuiltinByteString -> BuiltinInteger -> BuiltinInteger indexByteString (BuiltinByteString b) i = toInteger $ BS.index b (fromInteger i) {-# OPAQUE indexByteString #-} @@ -306,10 +300,9 @@ ripemd_160 :: BuiltinByteString -> BuiltinByteString ripemd_160 (BuiltinByteString b) = BuiltinByteString $ Hash.ripemd_160 b {-# OPAQUE ripemd_160 #-} -{-| Ed25519 signature verification. The first bytestring is the public key (32 bytes), followed - by an arbitrary-size message and the signature (64 bytes). The sizes of the public - key and signature are enforced, and it fails when given bytestrings of incorrect size. --} +-- | Ed25519 signature verification. The first bytestring is the public key (32 bytes), followed +-- by an arbitrary-size message and the signature (64 bytes). The sizes of the public +-- key and signature are enforced, and it fails when given bytestrings of incorrect size. verifyEd25519Signature :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> Bool verifyEd25519Signature (BuiltinByteString vk) (BuiltinByteString msg) (BuiltinByteString sig) = case PlutusCore.Crypto.Ed25519.verifyEd25519Signature vk msg sig of @@ -320,15 +313,14 @@ verifyEd25519Signature (BuiltinByteString vk) (BuiltinByteString msg) (BuiltinBy Haskell.error "Ed25519 signature verification errored." {-# OPAQUE verifyEd25519Signature #-} -{-| ECDSA signature verification on the SECP256k1 curve. The first bytestring is the public key (32 bytes), - followed by the message hash (32 bytes) and the signature (64 bytes). The sizes of the public key and signature - are enforced, and it fails when given bytestrings of incorrect size. --} -verifyEcdsaSecp256k1Signature - :: BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> Bool +-- | ECDSA signature verification on the SECP256k1 curve. The first bytestring is the public key (32 bytes), +-- followed by the message hash (32 bytes) and the signature (64 bytes). The sizes of the public key and signature +-- are enforced, and it fails when given bytestrings of incorrect size. +verifyEcdsaSecp256k1Signature :: + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + Bool verifyEcdsaSecp256k1Signature (BuiltinByteString vk) (BuiltinByteString msg) (BuiltinByteString sig) = case PlutusCore.Crypto.Secp256k1.verifyEcdsaSecp256k1Signature vk msg sig of BuiltinSuccess b -> b @@ -338,15 +330,14 @@ verifyEcdsaSecp256k1Signature (BuiltinByteString vk) (BuiltinByteString msg) (Bu Haskell.error "ECDSA SECP256k1 signature verification errored." {-# OPAQUE verifyEcdsaSecp256k1Signature #-} -{-| Schnorr signature verification on the SECP256k1 curve. The first bytestring is the public key (32 bytes), - followed by an arbitrary-length message and the signature (64 bytes). The sizes of the public key and signature - are enforced, and it fails when given bytestrings of incorrect size. --} -verifySchnorrSecp256k1Signature - :: BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString - -> Bool +-- | Schnorr signature verification on the SECP256k1 curve. The first bytestring is the public key (32 bytes), +-- followed by an arbitrary-length message and the signature (64 bytes). The sizes of the public key and signature +-- are enforced, and it fails when given bytestrings of incorrect size. +verifySchnorrSecp256k1Signature :: + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString -> + Bool verifySchnorrSecp256k1Signature (BuiltinByteString vk) (BuiltinByteString msg) (BuiltinByteString sig) = case PlutusCore.Crypto.Secp256k1.verifySchnorrSecp256k1Signature vk msg sig of BuiltinSuccess b -> b @@ -357,9 +348,9 @@ verifySchnorrSecp256k1Signature (BuiltinByteString vk) (BuiltinByteString msg) ( {-# OPAQUE verifySchnorrSecp256k1Signature #-} -- | Runs trace for each element in a foldable structure. -traceAll - :: forall (a :: Type) (f :: Type -> Type) - . (Foldable f) => f Text -> a -> a +traceAll :: + forall (a :: Type) (f :: Type -> Type). + Foldable f => f Text -> a -> a traceAll logs x = Foldable.foldl' (\acc t -> trace (BuiltinString t) acc) x logs -- | Checks the equality of two bytestrings and never fails @@ -367,10 +358,9 @@ equalsByteString :: BuiltinByteString -> BuiltinByteString -> Bool equalsByteString (BuiltinByteString b1) (BuiltinByteString b2) = b1 == b2 {-# OPAQUE equalsByteString #-} -{-| Checks if the first bytestring is less than the second bytestring and never fails. Comparison of the - bytestrings will behave identically to the 'compare' implementation in 'ByteString.Ord'. It will compare - two bytestrings byte by byte—lexicographical ordering. --} +-- | Checks if the first bytestring is less than the second bytestring and never fails. Comparison of the +-- bytestrings will behave identically to the 'compare' implementation in 'ByteString.Ord'. It will compare +-- two bytestrings byte by byte—lexicographical ordering. lessThanByteString :: BuiltinByteString -> BuiltinByteString -> Bool lessThanByteString (BuiltinByteString b1) (BuiltinByteString b2) = b1 < b2 {-# OPAQUE lessThanByteString #-} @@ -390,7 +380,7 @@ STRING -} -- See Note [Opaque builtin types] -data BuiltinString = BuiltinString ~Text deriving stock Data +data BuiltinString = BuiltinString ~Text deriving stock (Data) instance Haskell.Show BuiltinString where show (BuiltinString t) = show t @@ -429,7 +419,7 @@ PAIR -} -- See Note [Opaque builtin types] -data BuiltinPair a b = BuiltinPair ~(a, b) deriving stock Data +data BuiltinPair a b = BuiltinPair ~(a, b) deriving stock (Data) instance (Haskell.Show a, Haskell.Show b) => Haskell.Show (BuiltinPair a b) where show (BuiltinPair p) = show p @@ -458,44 +448,43 @@ LIST -} -- See Note [Opaque builtin types] -data BuiltinList a = BuiltinList ~[a] deriving stock Data +data BuiltinList a = BuiltinList ~[a] deriving stock (Data) -instance (Haskell.Show a) => Haskell.Show (BuiltinList a) where +instance Haskell.Show a => Haskell.Show (BuiltinList a) where show (BuiltinList l) = show l -instance (Haskell.Eq a) => Haskell.Eq (BuiltinList a) where +instance Haskell.Eq a => Haskell.Eq (BuiltinList a) where (==) (BuiltinList l) (BuiltinList l') = (==) l l' -instance (Haskell.Ord a) => Haskell.Ord (BuiltinList a) where +instance Haskell.Ord a => Haskell.Ord (BuiltinList a) where compare (BuiltinList l) (BuiltinList l') = compare l l' -- | Checks if the given list is empty. null :: BuiltinList a -> Bool null (BuiltinList (_ : _)) = False -null (BuiltinList []) = True +null (BuiltinList []) = True {-# OPAQUE null #-} -- | Takes the first element of the list and fails if given list is empty. head :: BuiltinList a -> a head (BuiltinList (x : _)) = x -head (BuiltinList []) = Haskell.error "empty list" +head (BuiltinList []) = Haskell.error "empty list" {-# OPAQUE head #-} -- | Takes the last element of the list and fails if given list is empty. tail :: BuiltinList a -> BuiltinList a tail (BuiltinList (_ : xs)) = BuiltinList xs -tail (BuiltinList []) = Haskell.error "empty list" +tail (BuiltinList []) = Haskell.error "empty list" {-# OPAQUE tail #-} -{-| Branches out depending on the structure of given list and never fails. If given list is empty, - it will take the first branch and if not it will take the second branch. --} +-- | Branches out depending on the structure of given list and never fails. If given list is empty, +-- it will take the first branch and if not it will take the second branch. chooseList :: BuiltinList a -> b -> b -> b -chooseList (BuiltinList []) b1 _ = b1 +chooseList (BuiltinList []) b1 _ = b1 chooseList (BuiltinList (_ : _)) _ b2 = b2 {-# OPAQUE chooseList #-} -- | Similar to 'chooseList' but deconstructs the list in case provided list is not empty. caseList' :: forall a r. r -> (a -> BuiltinList a -> r) -> BuiltinList a -> r -caseList' nilCase _ (BuiltinList []) = nilCase +caseList' nilCase _ (BuiltinList []) = nilCase caseList' _ consCase (BuiltinList (x : xs)) = consCase x (BuiltinList xs) {-# OPAQUE caseList' #-} @@ -504,16 +493,14 @@ drop :: Integer -> BuiltinList a -> BuiltinList a drop i (BuiltinList xs) = BuiltinList (Haskell.genericDrop i xs) {-# OPAQUE drop #-} -{-| Creates an empty data list and never fails. Prefer using constant. -See Note [Constants vs built-in functions] --} +-- | Creates an empty data list and never fails. Prefer using constant. +-- See Note [Constants vs built-in functions] mkNilData :: BuiltinUnit -> BuiltinList BuiltinData mkNilData _ = BuiltinList [] {-# OPAQUE mkNilData #-} -{-| Creates an empty data pair list and never fails. Prefer using constant. -See Note [Constants vs built-in functions] --} +-- | Creates an empty data pair list and never fails. Prefer using constant. +-- See Note [Constants vs built-in functions] mkNilPairData :: BuiltinUnit -> BuiltinList (BuiltinPair BuiltinData BuiltinData) mkNilPairData _ = BuiltinList [] {-# OPAQUE mkNilPairData #-} @@ -527,18 +514,17 @@ mkCons a (BuiltinList as) = BuiltinList (a : as) DATA -} -{-| -A type corresponding to the Plutus Core builtin equivalent of 'PLC.Data'. - -The point of this type is to be an opaque equivalent of 'PLC.Data', so as to -ensure that it is only used in ways that the compiler can handle. - -As such, you should use this type in your on-chain code, and in any data structures -that you want to be representable on-chain. - -For off-chain usage, there are conversion functions 'builtinDataToData' and -'dataToBuiltinData', but note that these will not work on-chain. --} +-- | +-- A type corresponding to the Plutus Core builtin equivalent of 'PLC.Data'. +-- +-- The point of this type is to be an opaque equivalent of 'PLC.Data', so as to +-- ensure that it is only used in ways that the compiler can handle. +-- +-- As such, you should use this type in your on-chain code, and in any data structures +-- that you want to be representable on-chain. +-- +-- For off-chain usage, there are conversion functions 'builtinDataToData' and +-- 'dataToBuiltinData', but note that these will not work on-chain. data BuiltinData = BuiltinData ~PLC.Data deriving stock (Data, Generic) @@ -570,11 +556,11 @@ dataToBuiltinData = BuiltinData -- | Branches out depending on the structure of given data and never fails. chooseData :: forall a. BuiltinData -> a -> a -> a -> a -> a -> a chooseData (BuiltinData d) constrCase mapCase listCase iCase bCase = case d of - PLC.Constr{} -> constrCase - PLC.Map{} -> mapCase - PLC.List{} -> listCase - PLC.I{} -> iCase - PLC.B{} -> bCase + PLC.Constr {} -> constrCase + PLC.Map {} -> mapCase + PLC.List {} -> listCase + PLC.I {} -> iCase + PLC.B {} -> bCase {-# OPAQUE chooseData #-} -- | Creates 'Constr' data value with the given index and elements; never fails. @@ -585,8 +571,8 @@ mkConstr i (BuiltinList args) = BuiltinData (PLC.Constr i (fmap builtinDataToDat -- | Creates 'Map' data value with the given list of pairs and never fails. mkMap :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> BuiltinData mkMap (BuiltinList es) = BuiltinData (PLC.Map (fmap p2p es)) - where - p2p (BuiltinPair (d, d')) = (builtinDataToData d, builtinDataToData d') + where + p2p (BuiltinPair (d, d')) = (builtinDataToData d, builtinDataToData d') {-# OPAQUE mkMap #-} -- | Creates 'List' data value with the given list and never fails. @@ -613,27 +599,27 @@ unsafeDataAsConstr _ = Haskell.error "not a Constr" -- | Deconstructs the given data as a 'Map', failing if it is not a 'Map'. unsafeDataAsMap :: BuiltinData -> BuiltinList (BuiltinPair BuiltinData BuiltinData) unsafeDataAsMap (BuiltinData (PLC.Map m)) = BuiltinList (fmap p2p m) - where - p2p (d, d') = BuiltinPair (dataToBuiltinData d, dataToBuiltinData d') + where + p2p (d, d') = BuiltinPair (dataToBuiltinData d, dataToBuiltinData d') unsafeDataAsMap _ = Haskell.error "not a Map" {-# OPAQUE unsafeDataAsMap #-} -- | Deconstructs the given data as a 'List', failing if it is not a 'List'. unsafeDataAsList :: BuiltinData -> BuiltinList BuiltinData unsafeDataAsList (BuiltinData (PLC.List l)) = BuiltinList (fmap dataToBuiltinData l) -unsafeDataAsList _ = Haskell.error "not a List" +unsafeDataAsList _ = Haskell.error "not a List" {-# OPAQUE unsafeDataAsList #-} -- | Deconstructs the given data as a 'I', failing if it is not a 'I'. unsafeDataAsI :: BuiltinData -> BuiltinInteger unsafeDataAsI (BuiltinData (PLC.I i)) = i -unsafeDataAsI _ = Haskell.error "not an I" +unsafeDataAsI _ = Haskell.error "not an I" {-# OPAQUE unsafeDataAsI #-} -- | Deconstructs the given data as a 'B', failing if it is not a 'B'. unsafeDataAsB :: BuiltinData -> BuiltinByteString unsafeDataAsB (BuiltinData (PLC.B b)) = BuiltinByteString b -unsafeDataAsB _ = Haskell.error "not a B" +unsafeDataAsB _ = Haskell.error "not a B" {-# OPAQUE unsafeDataAsB #-} -- | Checks equality of two data and never fails. @@ -641,9 +627,8 @@ equalsData :: BuiltinData -> BuiltinData -> Bool equalsData (BuiltinData b1) (BuiltinData b2) = b1 Haskell.== b2 {-# OPAQUE equalsData #-} -{-| Serialize the given data into CBOR bytestring. See 'PlutusCore.Data' for exact encoder as 'Data' -does not uses Generic version. --} +-- | Serialize the given data into CBOR bytestring. See 'PlutusCore.Data' for exact encoder as 'Data' +-- does not uses Generic version. serialiseData :: BuiltinData -> BuiltinByteString serialiseData (BuiltinData b) = BuiltinByteString $ BSL.toStrict $ serialise b {-# OPAQUE serialiseData #-} @@ -661,11 +646,11 @@ ARRAY data BuiltinArray a = BuiltinArray ~(Vector a) deriving stock (Data) -instance (Haskell.Show a) => Haskell.Show (BuiltinArray a) where +instance Haskell.Show a => Haskell.Show (BuiltinArray a) where show (BuiltinArray v) = show v -instance (Haskell.Eq a) => Haskell.Eq (BuiltinArray a) where +instance Haskell.Eq a => Haskell.Eq (BuiltinArray a) where (==) (BuiltinArray v1) (BuiltinArray v2) = (==) v1 v2 -instance (Haskell.Ord a) => Haskell.Ord (BuiltinArray a) where +instance Haskell.Ord a => Haskell.Ord (BuiltinArray a) where compare (BuiltinArray v1) (BuiltinArray v2) = compare v1 v2 -- | Returns the length of the provided array and never fails @@ -678,9 +663,8 @@ listToArray :: BuiltinList a -> BuiltinArray a listToArray (BuiltinList l) = BuiltinArray (Vector.fromList l) {-# OPAQUE listToArray #-} -{-| Returns the n-th element from the array. Fails if the given index is not in the range @[0..j)@, - where @j@ is the length of the array. --} +-- | Returns the n-th element from the array. Fails if the given index is not in the range @[0..j)@, +-- where @j@ is the length of the array. indexArray :: BuiltinArray a -> BuiltinInteger -> a indexArray (BuiltinArray v) i = v Vector.! fromInteger i {-# OPAQUE indexArray #-} @@ -723,8 +707,8 @@ bls12_381_G1_equals a b = coerce ((==) @BuiltinBLS12_381_G1_Element) a b {-# OPAQUE bls12_381_G1_equals #-} -- | Adds two G1 elements and never fails. -bls12_381_G1_add - :: BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element +bls12_381_G1_add :: + BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element bls12_381_G1_add (BuiltinBLS12_381_G1_Element a) (BuiltinBLS12_381_G1_Element b) = BuiltinBLS12_381_G1_Element (BLS12_381.G1.add a b) {-# OPAQUE bls12_381_G1_add #-} @@ -734,8 +718,8 @@ bls12_381_G1_neg (BuiltinBLS12_381_G1_Element a) = BuiltinBLS12_381_G1_Element ( {-# OPAQUE bls12_381_G1_neg #-} -- | Multiplies a G1 element by a scalar and never fails. -bls12_381_G1_scalarMul - :: BuiltinInteger -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element +bls12_381_G1_scalarMul :: + BuiltinInteger -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element bls12_381_G1_scalarMul n (BuiltinBLS12_381_G1_Element a) = BuiltinBLS12_381_G1_Element (BLS12_381.G1.scalarMul n a) {-# OPAQUE bls12_381_G1_scalarMul #-} @@ -754,17 +738,16 @@ bls12_381_G1_uncompress :: BuiltinByteString -> BuiltinBLS12_381_G1_Element bls12_381_G1_uncompress (BuiltinByteString b) = case BLS12_381.G1.uncompress b of Left err -> Haskell.error $ "BSL12_381 G1 uncompression error: " ++ show err - Right a -> BuiltinBLS12_381_G1_Element a + Right a -> BuiltinBLS12_381_G1_Element a {-# OPAQUE bls12_381_G1_uncompress #-} -{-| Hashes an arbitrary bytestring message to a G1 element using the given domain separation tag (DST), -failing if length of the DST is bigger than 255 bytes. --} +-- | Hashes an arbitrary bytestring message to a G1 element using the given domain separation tag (DST), +-- failing if length of the DST is bigger than 255 bytes. bls12_381_G1_hashToGroup :: BuiltinByteString -> BuiltinByteString -> BuiltinBLS12_381_G1_Element bls12_381_G1_hashToGroup (BuiltinByteString msg) (BuiltinByteString dst) = case BLS12_381.G1.hashToGroup msg dst of Left err -> Haskell.error $ show err - Right p -> BuiltinBLS12_381_G1_Element p + Right p -> BuiltinBLS12_381_G1_Element p {-# OPAQUE bls12_381_G1_hashToGroup #-} -- | The compressed form of the G1 identity element. @@ -796,8 +779,8 @@ bls12_381_G2_equals a b = coerce ((==) @BuiltinBLS12_381_G2_Element) a b {-# OPAQUE bls12_381_G2_equals #-} -- | Adds two G2 elements and never fails. -bls12_381_G2_add - :: BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element +bls12_381_G2_add :: + BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element bls12_381_G2_add (BuiltinBLS12_381_G2_Element a) (BuiltinBLS12_381_G2_Element b) = BuiltinBLS12_381_G2_Element (BLS12_381.G2.add a b) {-# OPAQUE bls12_381_G2_add #-} @@ -807,8 +790,8 @@ bls12_381_G2_neg (BuiltinBLS12_381_G2_Element a) = BuiltinBLS12_381_G2_Element ( {-# OPAQUE bls12_381_G2_neg #-} -- | Multiplies a G2 element by a scalar and never fails. -bls12_381_G2_scalarMul - :: BuiltinInteger -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element +bls12_381_G2_scalarMul :: + BuiltinInteger -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element bls12_381_G2_scalarMul n (BuiltinBLS12_381_G2_Element a) = BuiltinBLS12_381_G2_Element (BLS12_381.G2.scalarMul n a) {-# OPAQUE bls12_381_G2_scalarMul #-} @@ -827,17 +810,16 @@ bls12_381_G2_uncompress :: BuiltinByteString -> BuiltinBLS12_381_G2_Element bls12_381_G2_uncompress (BuiltinByteString b) = case BLS12_381.G2.uncompress b of Left err -> Haskell.error $ "BSL12_381 G2 uncompression error: " ++ show err - Right a -> BuiltinBLS12_381_G2_Element a + Right a -> BuiltinBLS12_381_G2_Element a {-# OPAQUE bls12_381_G2_uncompress #-} -{-| Hashes an arbitrary bytestring message to a G2 element using the given domain separation tag (DST), -failing if length of the DST is bigger than 255 bytes. --} +-- | Hashes an arbitrary bytestring message to a G2 element using the given domain separation tag (DST), +-- failing if length of the DST is bigger than 255 bytes. bls12_381_G2_hashToGroup :: BuiltinByteString -> BuiltinByteString -> BuiltinBLS12_381_G2_Element bls12_381_G2_hashToGroup (BuiltinByteString msg) (BuiltinByteString dst) = case BLS12_381.G2.hashToGroup msg dst of Left err -> Haskell.error $ show err - Right p -> BuiltinBLS12_381_G2_Element p + Right p -> BuiltinBLS12_381_G2_Element p {-# OPAQUE bls12_381_G2_hashToGroup #-} -- | The compressed form of the G2 identity element (also known as zero or point at infinity). @@ -864,22 +846,21 @@ instance Pretty BuiltinBLS12_381_MlResult where pretty (BuiltinBLS12_381_MlResult a) = pretty a -- | Computes the Miller loop between a G1 element and a G2 element and never fails. -bls12_381_millerLoop - :: BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_MlResult +bls12_381_millerLoop :: + BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_MlResult bls12_381_millerLoop (BuiltinBLS12_381_G1_Element a) (BuiltinBLS12_381_G2_Element b) = BuiltinBLS12_381_MlResult $ BLS12_381.Pairing.millerLoop a b {-# OPAQUE bls12_381_millerLoop #-} -- | Multiplies two Miller loop results and never fails. -bls12_381_mulMlResult - :: BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult +bls12_381_mulMlResult :: + BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult bls12_381_mulMlResult (BuiltinBLS12_381_MlResult a) (BuiltinBLS12_381_MlResult b) = BuiltinBLS12_381_MlResult $ BLS12_381.Pairing.mulMlResult a b {-# OPAQUE bls12_381_mulMlResult #-} -{-| Performs the final verification step of a pairing check. Returns true if e(P,Q) == e(R,S) for -the given Miller loop results, and never fails. --} +-- | Performs the final verification step of a pairing check. Returns true if e(P,Q) == e(R,S) for +-- the given Miller loop results, and never fails. bls12_381_finalVerify :: BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult -> Bool bls12_381_finalVerify (BuiltinBLS12_381_MlResult a) (BuiltinBLS12_381_MlResult b) = BLS12_381.Pairing.finalVerify a b @@ -889,17 +870,16 @@ bls12_381_finalVerify (BuiltinBLS12_381_MlResult a) (BuiltinBLS12_381_MlResult b CONVERSION -} -{- | Converts the given integer to a bytestring. The first argument specifies - endianness (True for big-endian), followed by the target length of the resulting bytestring - and the integer itself. Fails if the target length is greater than 8192 or if the length - argument is 0 and the result won't fit into 8192 bytes. - See 'PlutusCore.Bitwise.integerToByteString' for its invariants in detail. --} -integerToByteString - :: Bool - -> BuiltinInteger - -> BuiltinInteger - -> BuiltinByteString +-- | Converts the given integer to a bytestring. The first argument specifies +-- endianness (True for big-endian), followed by the target length of the resulting bytestring +-- and the integer itself. Fails if the target length is greater than 8192 or if the length +-- argument is 0 and the result won't fit into 8192 bytes. +-- See 'PlutusCore.Bitwise.integerToByteString' for its invariants in detail. +integerToByteString :: + Bool -> + BuiltinInteger -> + BuiltinInteger -> + BuiltinByteString integerToByteString endiannessArg paddingArg input = case Bitwise.integerToByteString endiannessArg paddingArg input of BuiltinSuccess bs -> BuiltinByteString bs @@ -909,13 +889,12 @@ integerToByteString endiannessArg paddingArg input = Haskell.error "Integer to ByteString conversion errored." {-# OPAQUE integerToByteString #-} -{-| Converts the given bytestring to the integer and never fails. The first argument specifies -endianness (True for big-endian), followed by the bytestring. --} -byteStringToInteger - :: Bool - -> BuiltinByteString - -> BuiltinInteger +-- | Converts the given bytestring to the integer and never fails. The first argument specifies +-- endianness (True for big-endian), followed by the bytestring. +byteStringToInteger :: + Bool -> + BuiltinByteString -> + BuiltinInteger byteStringToInteger statedEndianness (BuiltinByteString input) = Bitwise.byteStringToInteger statedEndianness input {-# OPAQUE byteStringToInteger #-} @@ -924,42 +903,39 @@ byteStringToInteger statedEndianness (BuiltinByteString input) = BITWISE -} -{-| Shifts the bytestring to the left if the second argument is positive, and to the right otherwise. -Right-shifts fill with 0s from the left (logical shift); left-shifts fill with 0s from the right. -Never fails. --} -shiftByteString - :: BuiltinByteString - -> BuiltinInteger - -> BuiltinByteString +-- | Shifts the bytestring to the left if the second argument is positive, and to the right otherwise. +-- Right-shifts fill with 0s from the left (logical shift); left-shifts fill with 0s from the right. +-- Never fails. +shiftByteString :: + BuiltinByteString -> + BuiltinInteger -> + BuiltinByteString shiftByteString (BuiltinByteString bs) = BuiltinByteString . Bitwise.shiftByteString bs {-# OPAQUE shiftByteString #-} -{-| Rotates the bytestring to the left if the second argument is positive, and to the right otherwise. -Never fails. --} -rotateByteString - :: BuiltinByteString - -> BuiltinInteger - -> BuiltinByteString +-- | Rotates the bytestring to the left if the second argument is positive, and to the right otherwise. +-- Never fails. +rotateByteString :: + BuiltinByteString -> + BuiltinInteger -> + BuiltinByteString rotateByteString (BuiltinByteString bs) = BuiltinByteString . Bitwise.rotateByteString bs {-# OPAQUE rotateByteString #-} -- | Counts the number of bits set to 1 in the bytestring and never fails. -countSetBits - :: BuiltinByteString - -> BuiltinInteger +countSetBits :: + BuiltinByteString -> + BuiltinInteger countSetBits (BuiltinByteString bs) = fromIntegral . Bitwise.countSetBits $ bs {-# OPAQUE countSetBits #-} -{-| Finds the index of the first bit set to 1 in the bytestring. If the bytestring consists only of -0s, it returns the length of the bytestring in bits. Never fails. --} -findFirstSetBit - :: BuiltinByteString - -> BuiltinInteger +-- | Finds the index of the first bit set to 1 in the bytestring. If the bytestring consists only of +-- 0s, it returns the length of the bytestring in bits. Never fails. +findFirstSetBit :: + BuiltinByteString -> + BuiltinInteger findFirstSetBit (BuiltinByteString bs) = fromIntegral . Bitwise.findFirstSetBit $ bs {-# OPAQUE findFirstSetBit #-} @@ -968,55 +944,52 @@ findFirstSetBit (BuiltinByteString bs) = LOGICAL -} -{-| Performs a bitwise AND on two bytestrings. The first boolean argument indicates whether to use -padding (True) or truncation (False) if the bytestrings have different lengths. Never fails. --} -andByteString - :: Bool - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString +-- | Performs a bitwise AND on two bytestrings. The first boolean argument indicates whether to use +-- padding (True) or truncation (False) if the bytestrings have different lengths. Never fails. +andByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString andByteString isPaddingSemantics (BuiltinByteString data1) (BuiltinByteString data2) = BuiltinByteString . Bitwise.andByteString isPaddingSemantics data1 $ data2 {-# OPAQUE andByteString #-} -{-| Performs a bitwise OR on two bytestrings. The first boolean argument indicates whether to use -padding (True) or truncation (False) if the bytestrings have different lengths. Never fails. --} -orByteString - :: Bool - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString +-- | Performs a bitwise OR on two bytestrings. The first boolean argument indicates whether to use +-- padding (True) or truncation (False) if the bytestrings have different lengths. Never fails. +orByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString orByteString isPaddingSemantics (BuiltinByteString data1) (BuiltinByteString data2) = BuiltinByteString . Bitwise.orByteString isPaddingSemantics data1 $ data2 {-# OPAQUE orByteString #-} -{-| Performs a bitwise XOR on two bytestrings. The first boolean argument indicates whether to use -padding (True) or truncation (False) if the bytestrings have different lengths. Never fails. --} -xorByteString - :: Bool - -> BuiltinByteString - -> BuiltinByteString - -> BuiltinByteString +-- | Performs a bitwise XOR on two bytestrings. The first boolean argument indicates whether to use +-- padding (True) or truncation (False) if the bytestrings have different lengths. Never fails. +xorByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString xorByteString isPaddingSemantics (BuiltinByteString data1) (BuiltinByteString data2) = BuiltinByteString . Bitwise.xorByteString isPaddingSemantics data1 $ data2 {-# OPAQUE xorByteString #-} -- | Performs a bitwise complement on the bytestring and never fails. -complementByteString - :: BuiltinByteString - -> BuiltinByteString +complementByteString :: + BuiltinByteString -> + BuiltinByteString complementByteString (BuiltinByteString bs) = BuiltinByteString . Bitwise.complementByteString $ bs {-# OPAQUE complementByteString #-} -- | Reads the bit at the given index in the bytestring. Fails if the index is out of bounds. -readBit - :: BuiltinByteString - -> BuiltinInteger - -> Bool +readBit :: + BuiltinByteString -> + BuiltinInteger -> + Bool readBit (BuiltinByteString bs) i = case Bitwise.readBit bs (fromIntegral i) of BuiltinFailure logs err -> @@ -1026,14 +999,13 @@ readBit (BuiltinByteString bs) i = BuiltinSuccessWithLogs logs b -> traceAll logs b {-# OPAQUE readBit #-} -{-| Writes the given bit (third argument, True for 1, False for 0) at the specified indices (second argument) in the bytestring. -Fails if any index is out of bounds. --} -writeBits - :: BuiltinByteString - -> BuiltinList BuiltinInteger - -> Bool - -> BuiltinByteString +-- | Writes the given bit (third argument, True for 1, False for 0) at the specified indices (second argument) in the bytestring. +-- Fails if any index is out of bounds. +writeBits :: + BuiltinByteString -> + BuiltinList BuiltinInteger -> + Bool -> + BuiltinByteString writeBits (BuiltinByteString bs) (BuiltinList ixes) bit = case Bitwise.writeBits bs ixes bit of BuiltinFailure logs err -> @@ -1043,10 +1015,9 @@ writeBits (BuiltinByteString bs) (BuiltinList ixes) bit = BuiltinSuccessWithLogs logs bs' -> traceAll logs $ BuiltinByteString bs' {-# OPAQUE writeBits #-} -{- | Creates a bytestring of a given length by repeating the given byte. -Fails if the byte, second argument, is not in range @[0,255]@, the length is negative, -or when the length is greater than 8192. --} +-- | Creates a bytestring of a given length by repeating the given byte. +-- Fails if the byte, second argument, is not in range @[0,255]@, the length is negative, +-- or when the length is greater than 8192. replicateByte :: BuiltinInteger -> BuiltinInteger -> @@ -1060,14 +1031,13 @@ replicateByte n w8 = BuiltinSuccessWithLogs logs bs -> traceAll logs $ BuiltinByteString bs {-# OPAQUE replicateByte #-} -{-| Computes modular exponentiation (base^exponent mod modulus). Fails if the modulus is zero or negative, -or if the exponent is negative and the modular inverse does not exist. --} -expModInteger - :: BuiltinInteger - -> BuiltinInteger - -> BuiltinInteger - -> BuiltinInteger +-- | Computes modular exponentiation (base^exponent mod modulus). Fails if the modulus is zero or negative, +-- or if the exponent is negative and the modular inverse does not exist. +expModInteger :: + BuiltinInteger -> + BuiltinInteger -> + BuiltinInteger -> + BuiltinInteger expModInteger b e m = -- (fromInteger @Natural) correctly throws an underflow exception upon negative integer case ExpMod.expMod b e (fromInteger m) of @@ -1078,12 +1048,12 @@ expModInteger b e m = BuiltinSuccessWithLogs logs bs -> traceAll logs $ toInteger bs {-# OPAQUE expModInteger #-} -insertCoin - :: BuiltinByteString - -> BuiltinByteString - -> BuiltinInteger - -> BuiltinValue - -> BuiltinValue +insertCoin :: + BuiltinByteString -> + BuiltinByteString -> + BuiltinInteger -> + BuiltinValue -> + BuiltinValue insertCoin (BuiltinByteString c) (BuiltinByteString t) amt (BuiltinValue v0) = case Value.insertCoin c t amt v0 of BuiltinSuccess v -> BuiltinValue v @@ -1093,11 +1063,11 @@ insertCoin (BuiltinByteString c) (BuiltinByteString t) amt (BuiltinValue v0) = Haskell.error "insertCoin errored." {-# OPAQUE insertCoin #-} -lookupCoin - :: BuiltinByteString - -> BuiltinByteString - -> BuiltinValue - -> Integer +lookupCoin :: + BuiltinByteString -> + BuiltinByteString -> + BuiltinValue -> + Integer lookupCoin (BuiltinByteString c) (BuiltinByteString t) (BuiltinValue v) = Value.lookupCoin c t v {-# OPAQUE lookupCoin #-} diff --git a/plutus-tx/src/PlutusTx/Code.hs b/plutus-tx/src/PlutusTx/Code.hs index 5e908d04fd9..f189ebe675a 100644 --- a/plutus-tx/src/PlutusTx/Code.hs +++ b/plutus-tx/src/PlutusTx/Code.hs @@ -1,15 +1,15 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusTx.Code where @@ -40,44 +40,43 @@ type role CompiledCodeIn representational representational nominal -- in the plugin code that generates values of this type. That is -- done by code generation so it's not typechecked normally. -{-| A compiled Plutus Tx program. The last type parameter indicates -the type of the Haskell expression that was compiled, and -hence the type of the compiled code. - -Note: the compiled PLC program does *not* have normalized types, -if you want to put it on the chain you must normalize the types first. --} +-- | A compiled Plutus Tx program. The last type parameter indicates +-- the type of the Haskell expression that was compiled, and +-- hence the type of the compiled code. +-- +-- Note: the compiled PLC program does *not* have normalized types, +-- if you want to put it on the chain you must normalize the types first. data CompiledCodeIn uni fun a = SerializedCode + -- | Serialized UPLC program of type 'UPLC.Program NamedDeBruijn uni fun SrcSpans'. BS.ByteString - -- ^ Serialized UPLC program of type 'UPLC.Program NamedDeBruijn uni fun SrcSpans'. + -- | Serialized PIR program of type 'PIR.Program PIR.TyName PIR.Name uni fun SrcSpans'. (Maybe BS.ByteString) - -- ^ Serialized PIR program of type 'PIR.Program PIR.TyName PIR.Name uni fun SrcSpans'. CoverageIndex | -- Metadata used for program coverage. DeserializedCode + -- | Deserialized UPLC program (UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans) - -- ^ Deserialized UPLC program + -- | Deserialized PIR program, if available (Maybe (PIR.Program PLC.TyName PLC.Name uni fun SrcSpans)) - -- ^ Deserialized PIR program, if available + -- | Metadata used for program coverage. CoverageIndex - -- ^ Metadata used for program coverage. -- | 'CompiledCodeIn' instantiated with default built-in types and functions. type CompiledCode = CompiledCodeIn PLC.DefaultUni PLC.DefaultFun -- | Apply a compiled function to a compiled argument. Will fail if the versions don't match. -applyCode - :: ( PLC.Closed uni - , uni `PLC.Everywhere` Flat - , Flat fun - , Pretty fun - , PLC.Everywhere uni PrettyConst - , PrettyBy RenderContext (PLC.SomeTypeIn uni) - ) - => CompiledCodeIn uni fun (a -> b) - -> CompiledCodeIn uni fun a - -> Either String (CompiledCodeIn uni fun b) +applyCode :: + ( PLC.Closed uni + , uni `PLC.Everywhere` Flat + , Flat fun + , Pretty fun + , PLC.Everywhere uni PrettyConst + , PrettyBy RenderContext (PLC.SomeTypeIn uni) + ) => + CompiledCodeIn uni fun (a -> b) -> + CompiledCodeIn uni fun a -> + Either String (CompiledCodeIn uni fun b) applyCode fun arg = do let uplc = unsafeFromRight $ UPLC.applyProgram (getPlc fun) (getPlc arg) -- Probably this could be done with more appropriate combinators, but the @@ -87,7 +86,7 @@ applyCode fun arg = do (Just funPir, Just argPir) -> case PIR.applyProgram funPir argPir of Right appliedPir -> pure (Just appliedPir) -- Had PIR for both, but failed to apply them, this should fail - Left err -> Left $ show err + Left err -> Left $ show err -- Missing PIR for one or both, this succeeds but has no PIR (Just funPir, Nothing) -> Left $ @@ -103,27 +102,26 @@ applyCode fun arg = do pure $ DeserializedCode uplc pir (getCovIdx fun <> getCovIdx arg) -{-| Apply a compiled function to a compiled argument. Will throw if the versions don't match, -should only be used in non-production code. --} -unsafeApplyCode - :: ( PLC.Closed uni - , uni `PLC.Everywhere` Flat - , Flat fun - , Pretty fun - , PLC.Everywhere uni PrettyConst - , PrettyBy RenderContext (PLC.SomeTypeIn uni) - ) - => CompiledCodeIn uni fun (a -> b) -> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b +-- | Apply a compiled function to a compiled argument. Will throw if the versions don't match, +-- should only be used in non-production code. +unsafeApplyCode :: + ( PLC.Closed uni + , uni `PLC.Everywhere` Flat + , Flat fun + , Pretty fun + , PLC.Everywhere uni PrettyConst + , PrettyBy RenderContext (PLC.SomeTypeIn uni) + ) => + CompiledCodeIn uni fun (a -> b) -> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b unsafeApplyCode fun arg = case applyCode fun arg of - Right c -> c + Right c -> c Left err -> error err -- | The size of a 'CompiledCodeIn' as measured in AST nodes. -countAstNodes - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a - -> Integer +countAstNodes :: + (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => + CompiledCodeIn uni fun a -> + Integer countAstNodes = UPLC.unAstSize . UPLC.programAstSize . getPlc {- Note [Deserializing the AST] @@ -137,38 +135,38 @@ instance Show ImpossibleDeserialisationFailure where show (ImpossibleDeserialisationFailure e) = "Failed to deserialise our own program! This is a bug, please report it. Caused by: " ++ show e -- | Get the actual Plutus Core program out of a 'CompiledCodeIn'. -getPlc - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans +getPlc :: + (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => + CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans getPlc wrapper = case wrapper of SerializedCode plc _ _ -> case unflat (BSL.fromStrict plc) of - Left e -> throw $ ImpossibleDeserialisationFailure e + Left e -> throw $ ImpossibleDeserialisationFailure e Right (UPLC.UnrestrictedProgram p) -> p DeserializedCode plc _ _ -> plc -getPlcNoAnn - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun () +getPlcNoAnn :: + (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => + CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun () getPlcNoAnn = void . getPlc -- | Get the Plutus IR program, if there is one, out of a 'CompiledCodeIn'. -getPir - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun SrcSpans) +getPir :: + (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => + CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun SrcSpans) getPir wrapper = case wrapper of SerializedCode _ pir _ -> case pir of Just bs -> case unflat (BSL.fromStrict bs) of - Left e -> throw $ ImpossibleDeserialisationFailure e + Left e -> throw $ ImpossibleDeserialisationFailure e Right p -> Just p Nothing -> Nothing DeserializedCode _ pir _ -> pir -getPirNoAnn - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun ()) +getPirNoAnn :: + (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => + CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun ()) getPirNoAnn = fmap void . getPir getCovIdx :: CompiledCodeIn uni fun a -> CoverageIndex getCovIdx wrapper = case wrapper of - SerializedCode _ _ idx -> idx + SerializedCode _ _ idx -> idx DeserializedCode _ _ idx -> idx diff --git a/plutus-tx/src/PlutusTx/Coverage.hs b/plutus-tx/src/PlutusTx/Coverage.hs index 9a37b1d3284..968ac2793b0 100644 --- a/plutus-tx/src/PlutusTx/Coverage.hs +++ b/plutus-tx/src/PlutusTx/Coverage.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module PlutusTx.Coverage ( @@ -72,15 +72,15 @@ import Prelude -- | A source location for coverage data CovLoc = CovLoc - { _covLocFile :: String + { _covLocFile :: String , _covLocStartLine :: Int - , _covLocEndLine :: Int - , _covLocStartCol :: Int - , _covLocEndCol :: Int + , _covLocEndLine :: Int + , _covLocStartCol :: Int + , _covLocEndCol :: Int } deriving stock (Ord, Eq, Show, Read, Generic) deriving anyclass (Serialise) - deriving Flat via (FlatViaSerialise CovLoc) + deriving (Flat) via (FlatViaSerialise CovLoc) deriving anyclass (NFData, ToJSON, FromJSON) makeLenses ''CovLoc @@ -94,22 +94,21 @@ data CoverageAnnotation | CoverBool CovLoc Bool deriving stock (Ord, Eq, Show, Read, Generic) deriving anyclass (Serialise) - deriving Flat via (FlatViaSerialise CoverageAnnotation) + deriving (Flat) via (FlatViaSerialise CoverageAnnotation) deriving anyclass (NFData, ToJSON, FromJSON, ToJSONKey, FromJSONKey) instance Pretty CoverageAnnotation where pretty (CoverLocation loc) = pretty loc - pretty (CoverBool loc b) = pretty loc <+> "=" <+> pretty b + pretty (CoverBool loc b) = pretty loc <+> "=" <+> pretty b data Metadata = ApplicationHeadSymbol String - | {-| Location that is not interesting to cover. This is not generated by the - compiler, but can be added later using `addCoverageMetadata`. - -} + | -- | Location that is not interesting to cover. This is not generated by the + -- compiler, but can be added later using `addCoverageMetadata`. IgnoredAnnotation deriving stock (Ord, Eq, Show, Generic) deriving anyclass (Serialise) - deriving Flat via (FlatViaSerialise Metadata) + deriving (Flat) via (FlatViaSerialise Metadata) deriving anyclass (NFData, ToJSON, FromJSON) instance Pretty Metadata where @@ -119,21 +118,20 @@ newtype CoverageMetadata = CoverageMetadata {_metadataSet :: Set Metadata} deriving stock (Ord, Eq, Show, Generic) deriving anyclass (Serialise, NFData, ToJSON, FromJSON) deriving newtype (Semigroup, Monoid) - deriving Flat via (FlatViaSerialise CoverageMetadata) + deriving (Flat) via (FlatViaSerialise CoverageMetadata) makeLenses ''CoverageMetadata instance Pretty CoverageMetadata where pretty (CoverageMetadata s) = vsep . map pretty . Set.toList $ s -{-| This type keeps track of all coverage annotations and where they have been inserted / what -annotations are expected to be found when executing a piece of code. --} +-- | This type keeps track of all coverage annotations and where they have been inserted / what +-- annotations are expected to be found when executing a piece of code. newtype CoverageIndex = CoverageIndex {_coverageMetadata :: Map CoverageAnnotation CoverageMetadata} deriving stock (Ord, Eq, Show, Generic) deriving anyclass (Serialise) - deriving Flat via (FlatViaSerialise CoverageIndex) + deriving (Flat) via (FlatViaSerialise CoverageIndex) deriving anyclass (NFData, ToJSON, FromJSON) makeLenses ''CoverageIndex @@ -153,16 +151,16 @@ instance Monoid CoverageIndex where mempty = CoverageIndex Map.empty -- | Include a location coverage annotation in the index -addLocationToCoverageIndex :: (MonadWriter CoverageIndex m) => CovLoc -> m CoverageAnnotation +addLocationToCoverageIndex :: MonadWriter CoverageIndex m => CovLoc -> m CoverageAnnotation addLocationToCoverageIndex src = do let ann = CoverLocation src tell $ CoverageIndex $ Map.singleton ann mempty pure ann -- | Include a boolean coverage annotation in the index -addBoolCaseToCoverageIndex - :: (MonadWriter CoverageIndex m) - => CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation +addBoolCaseToCoverageIndex :: + MonadWriter CoverageIndex m => + CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation addBoolCaseToCoverageIndex src b meta = do let ann = CoverBool src b tell $ CoverageIndex (Map.singleton ann meta) @@ -187,7 +185,7 @@ makeLenses ''CoverageData data CoverageReport = CoverageReport { _coverageIndex :: CoverageIndex - , _coverageData :: CoverageData + , _coverageData :: CoverageData } deriving stock (Ord, Eq, Show, Generic) deriving anyclass (NFData, ToJSON, FromJSON) @@ -215,10 +213,10 @@ instance Pretty CoverageReport where ++ (map pretty . Set.toList $ uncoveredAnns) ++ ["=========[IGNORED]=========="] ++ (map pretty . Set.toList $ ignoredAnns Set.\\ coveredAnns) - where - allAnns = report ^. coverageIndex . coverageAnnotations - coveredAnns = report ^. coverageData . coveredAnnotations - ignoredAnns = report ^. coverageIndex . ignoredAnnotations - uncoveredAnns = allAnns Set.\\ (coveredAnns <> ignoredAnns) + where + allAnns = report ^. coverageIndex . coverageAnnotations + coveredAnns = report ^. coverageData . coveredAnnotations + ignoredAnns = report ^. coverageIndex . ignoredAnnotations + uncoveredAnns = allAnns Set.\\ (coveredAnns <> ignoredAnns) - metadata ann = Map.lookup ann (report ^. coverageIndex . coverageMetadata) + metadata ann = Map.lookup ann (report ^. coverageIndex . coverageMetadata) diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index ab9c2403f82..2d7c4deffcf 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} module PlutusTx.Data.AssocMap ( Map, @@ -51,26 +51,25 @@ import Prettyprinter (Pretty (..)) import Prelude qualified as Haskell -{-| A map associating keys and values backed by `P.BuiltinData`. - -This implementation has the following characteristics: - - * The `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations are no-op. - * Other operations are slower than @PlutusTx.AssocMap.Map@, although equality - checks on keys can be faster due to `P.equalsData`. - * Many operations involve converting the keys and\/or values to\/from `P.BuiltinData`. - -Therefore this implementation is likely a better choice than "PlutusTx.AssocMap.Map" -if it is part of a data type defined using @asData@, and the key and value types -have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they -are primitive types or types defined using @asData@). - -A `Map` is considered well-defined if it has no duplicate keys. Most operations -preserve the definedness of the resulting `Map` unless otherwise noted. -It is important to observe that, in comparison to standard map implementations, -this implementation provides slow lookup and update operations because it is based -on a list representation. --} +-- | A map associating keys and values backed by `P.BuiltinData`. +-- +-- This implementation has the following characteristics: +-- +-- * The `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations are no-op. +-- * Other operations are slower than @PlutusTx.AssocMap.Map@, although equality +-- checks on keys can be faster due to `P.equalsData`. +-- * Many operations involve converting the keys and\/or values to\/from `P.BuiltinData`. +-- +-- Therefore this implementation is likely a better choice than "PlutusTx.AssocMap.Map" +-- if it is part of a data type defined using @asData@, and the key and value types +-- have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they +-- are primitive types or types defined using @asData@). +-- +-- A `Map` is considered well-defined if it has no duplicate keys. Most operations +-- preserve the definedness of the resulting `Map` unless otherwise noted. +-- It is important to observe that, in comparison to standard map implementations, +-- this implementation provides slow lookup and update operations because it is based +-- on a list representation. newtype Map k a = Map (BuiltinList (BuiltinPair BuiltinData BuiltinData)) deriving stock (Haskell.Show) @@ -90,107 +89,104 @@ instance , Pretty a , P.UnsafeFromData k , P.UnsafeFromData a - ) - => Pretty (Map k a) + ) => + Pretty (Map k a) where pretty = pretty . toSOPList -{-| Look up the value corresponding to the key. -If the `Map` is not well-defined, the result is the value associated with -the left-most occurrence of the key in the list. -This operation is O(n). --} +-- | Look up the value corresponding to the key. +-- If the `Map` is not well-defined, the result is the value associated with +-- the left-most occurrence of the key in the list. +-- This operation is O(n). lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> Map k a -> Maybe a lookup (P.toBuiltinData -> k) (Map m) = P.unsafeFromBuiltinData <$> lookup' k m {-# INLINEABLE lookup #-} -lookup' - :: BuiltinData - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> Maybe BuiltinData +lookup' :: + BuiltinData -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + Maybe BuiltinData lookup' k m = go m - where - go = - P.caseList' - Nothing - ( \hd -> - let k' = BI.fst hd - in if P.equalsData k k' - then \_ -> Just (BI.snd hd) - else go - ) + where + go = + P.caseList' + Nothing + ( \hd -> + let k' = BI.fst hd + in if P.equalsData k k' + then \_ -> Just (BI.snd hd) + else go + ) -- | Check if the key is in the `Map`. -member :: forall k a. (P.ToData k) => k -> Map k a -> Bool +member :: forall k a. P.ToData k => k -> Map k a -> Bool member (P.toBuiltinData -> k) (Map m) = member' k m {-# INLINEABLE member #-} member' :: BuiltinData -> BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool member' k = go - where - go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool - go = - P.caseList' - False - ( \hd -> - let k' = BI.fst hd - in if P.equalsData k k' - then \_ -> True - else go - ) + where + go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool + go = + P.caseList' + False + ( \hd -> + let k' = BI.fst hd + in if P.equalsData k k' + then \_ -> True + else go + ) -{-| Insert a key-value pair into the `Map`. If the key is already present, -the value is updated. --} +-- | Insert a key-value pair into the `Map`. If the key is already present, +-- the value is updated. insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a -> Map k a insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) (Map m) = Map $ insert' k a m {-# INLINEABLE insert #-} -insert' - :: BuiltinData - -> BuiltinData - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) +insert' :: + BuiltinData -> + BuiltinData -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) insert' k a = go - where - nilCase = BI.mkCons (BI.mkPairData k a) nil - go - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - go = - P.caseList' - nilCase - ( \hd -> - if P.equalsData k (BI.fst hd) - then BI.mkCons (BI.mkPairData k a) - else BI.mkCons hd . go - ) + where + nilCase = BI.mkCons (BI.mkPairData k a) nil + go :: + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) + go = + P.caseList' + nilCase + ( \hd -> + if P.equalsData k (BI.fst hd) + then BI.mkCons (BI.mkPairData k a) + else BI.mkCons hd . go + ) -{-| Delete a key value pair from the `Map`. -If the `Map` is not well-defined, it deletes the pair associated with the -left-most occurrence of the key in the list. --} -delete :: forall k a. (P.ToData k) => k -> Map k a -> Map k a +-- | Delete a key value pair from the `Map`. +-- If the `Map` is not well-defined, it deletes the pair associated with the +-- left-most occurrence of the key in the list. +delete :: forall k a. P.ToData k => k -> Map k a -> Map k a delete (P.toBuiltinData -> k) = coerce $ delete' k {-# INLINEABLE delete #-} -delete' - :: BuiltinData - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) +delete' :: + BuiltinData -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) delete' k = go - where - go - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - go = - P.caseList' - nil - ( \hd -> - if P.equalsData k (BI.fst hd) - then id - else BI.mkCons hd . go - ) + where + go :: + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) + go = + P.caseList' + nil + ( \hd -> + if P.equalsData k (BI.fst hd) + then id + else BI.mkCons hd . go + ) -- | Create an `Map` with a single key-value pair. singleton :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a @@ -211,34 +207,32 @@ null = P.null {-# INLINEABLE null #-} -{-| Create an `Map` from a sums of products list of key-value pairs. -In case of duplicates, this function will keep only one entry (the one that precedes). -In other words, this function de-duplicates the input list. -Warning: this function is very slow. If you know that the input list does not contain -duplicate keys, use one of the unsafe functions instead. --} +-- | Create an `Map` from a sums of products list of key-value pairs. +-- In case of duplicates, this function will keep only one entry (the one that precedes). +-- In other words, this function de-duplicates the input list. +-- Warning: this function is very slow. If you know that the input list does not contain +-- duplicate keys, use one of the unsafe functions instead. safeFromSOPList :: forall k a. (P.ToData k, P.ToData a) => [(k, a)] -> Map k a safeFromSOPList = Map . toOpaque . SOP.List.foldr (uncurry go) [] - where - go :: k -> a -> [(BuiltinData, BuiltinData)] -> [(BuiltinData, BuiltinData)] - go k v [] = [(P.toBuiltinData k, P.toBuiltinData v)] - go k v ((k', v') : rest) = - if P.toBuiltinData k == k' - then (P.toBuiltinData k, P.toBuiltinData v) : go k v rest - else (k', v') : go k v rest + where + go :: k -> a -> [(BuiltinData, BuiltinData)] -> [(BuiltinData, BuiltinData)] + go k v [] = [(P.toBuiltinData k, P.toBuiltinData v)] + go k v ((k', v') : rest) = + if P.toBuiltinData k == k' + then (P.toBuiltinData k, P.toBuiltinData v) : go k v rest + else (k', v') : go k v rest {-# INLINEABLE safeFromSOPList #-} -{-| Unsafely create an 'Map' from a sums of products list of pairs. -This should _only_ be applied to lists which have been checked to not -contain duplicate keys, otherwise the resulting 'Map' will contain -conflicting entries (two entries sharing the same key), and therefore be ill-defined. -Warning: this requires traversing the list and encoding the keys and values, so it -should be avoided in favor of 'unsafeFromBuiltinList' if the input is already in -'BuiltinData' form. --} +-- | Unsafely create an 'Map' from a sums of products list of pairs. +-- This should _only_ be applied to lists which have been checked to not +-- contain duplicate keys, otherwise the resulting 'Map' will contain +-- conflicting entries (two entries sharing the same key), and therefore be ill-defined. +-- Warning: this requires traversing the list and encoding the keys and values, so it +-- should be avoided in favor of 'unsafeFromBuiltinList' if the input is already in +-- 'BuiltinData' form. unsafeFromSOPList :: (P.ToData k, P.ToData a) => [(k, a)] -> Map k a unsafeFromSOPList = Map @@ -246,51 +240,48 @@ unsafeFromSOPList = . SOP.List.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) {-# INLINEABLE unsafeFromSOPList #-} -{-| Unsafely create an 'Map' from a `P.BuiltinList` of key-value pairs. This operation -is O(1). -This function is unsafe because it assumes that the elements of the list can be safely -decoded from their 'BuiltinData' representation. It also does not deduplicate the keys. --} -unsafeFromBuiltinList - :: forall k a - . BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> Map k a +-- | Unsafely create an 'Map' from a `P.BuiltinList` of key-value pairs. This operation +-- is O(1). +-- This function is unsafe because it assumes that the elements of the list can be safely +-- decoded from their 'BuiltinData' representation. It also does not deduplicate the keys. +unsafeFromBuiltinList :: + forall k a. + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + Map k a unsafeFromBuiltinList = coerce {-# INLINEABLE unsafeFromBuiltinList #-} -{-| Unsafely create an 'Map' from a `List` of key-value pairs. -This function is unsafe because it assumes that the elements of the list can be safely -decoded from their 'BuiltinData' representation. It also does not deduplicate the keys. --} +-- | Unsafely create an 'Map' from a `List` of key-value pairs. +-- This function is unsafe because it assumes that the elements of the list can be safely +-- decoded from their 'BuiltinData' representation. It also does not deduplicate the keys. unsafeFromDataList :: List (a, k) -> Map k a unsafeFromDataList = coerce . go . Data.List.toBuiltinList - where - go - :: BuiltinList BuiltinData - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - go = - P.caseList' - nil - ( \hd tl -> - let (a, b) = P.unsafeFromBuiltinData hd - in BI.mkCons (BI.mkPairData a b) (go tl) - ) + where + go :: + BuiltinList BuiltinData -> + BuiltinList (BuiltinPair BuiltinData BuiltinData) + go = + P.caseList' + nil + ( \hd tl -> + let (a, b) = P.unsafeFromBuiltinData hd + in BI.mkCons (BI.mkPairData a b) (go tl) + ) {-# INLINEABLE unsafeFromDataList #-} -{-| Convert the `Map` to a list of key-value pairs. This operation is O(n). -See 'toBuiltinList' for a more efficient alternative. --} +-- | Convert the `Map` to a list of key-value pairs. This operation is O(n). +-- See 'toBuiltinList' for a more efficient alternative. toSOPList :: (P.UnsafeFromData k, P.UnsafeFromData a) => Map k a -> [(k, a)] toSOPList d = go (toBuiltinList d) - where - go = - P.caseList' - [] - ( \hd tl -> - (P.unsafeFromBuiltinData (BI.fst hd), P.unsafeFromBuiltinData (BI.snd hd)) - : go tl - ) + where + go = + P.caseList' + [] + ( \hd tl -> + (P.unsafeFromBuiltinData (BI.fst hd), P.unsafeFromBuiltinData (BI.snd hd)) + : go tl + ) {-# INLINEABLE toSOPList #-} -- | Convert the `Map` to a `P.BuiltinList` of key-value pairs. This operation is O(1). @@ -301,155 +292,155 @@ toBuiltinList = coerce -- | Check if the `Map` is well-defined. Warning: this operation is O(n^2). noDuplicateKeys :: forall k a. Map k a -> Bool noDuplicateKeys (Map m) = go m - where - go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool - go = - P.caseList' - True - ( \hd tl -> - if member' (BI.fst hd) tl then False else go tl - ) + where + go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool + go = + P.caseList' + True + ( \hd tl -> + if member' (BI.fst hd) tl then False else go tl + ) {-# INLINEABLE noDuplicateKeys #-} --- | Check if all values in the `Map` satisfy the predicate. -all :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool +all :: forall k a. P.UnsafeFromData a => (a -> Bool) -> Map k a -> Bool all p = coerce go - where - go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool - go = - P.caseList' - True - ( \hd -> - if p (P.unsafeFromBuiltinData (BI.snd hd)) - then go - else \_ -> False - ) + where + go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool + go = + P.caseList' + True + ( \hd -> + if p (P.unsafeFromBuiltinData (BI.snd hd)) + then go + else \_ -> False + ) {-# INLINEABLE all #-} -- | Check if any value in the `Map` satisfies the predicate. -any :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool +any :: forall k a. P.UnsafeFromData a => (a -> Bool) -> Map k a -> Bool any p = coerce go - where - go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool - go = - P.caseList' - False - ( \hd -> - if p (P.unsafeFromBuiltinData (BI.snd hd)) - then \_ -> True - else go - ) + where + go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool + go = + P.caseList' + False + ( \hd -> + if p (P.unsafeFromBuiltinData (BI.snd hd)) + then \_ -> True + else go + ) {-# INLINEABLE any #-} -- | Combine two 'Map's into one. It saves both values if the key is present in both maps. -union - :: forall k a b - . (P.UnsafeFromData a, P.UnsafeFromData b, P.ToData a, P.ToData b) - => Map k a - -> Map k b - -> Map k (These a b) +union :: + forall k a b. + (P.UnsafeFromData a, P.UnsafeFromData b, P.ToData a, P.ToData b) => + Map k a -> + Map k b -> + Map k (These a b) union (Map ls) (Map rs) = Map res - where - goLeft = - P.caseList' - nil - ( \hd tl -> - let k = BI.fst hd - v = BI.snd hd - v' = case lookup' k rs of - Just r -> - P.toBuiltinData - ( These - (P.unsafeFromBuiltinData v) - (P.unsafeFromBuiltinData r) - :: These a b - ) - Nothing -> - P.toBuiltinData (This (P.unsafeFromBuiltinData v) :: These a b) - in BI.mkCons (BI.mkPairData k v') (goLeft tl) - ) - - goRight = - P.caseList' - nil - ( \hd tl -> - let k = BI.fst hd - v = BI.snd hd - v' = case lookup' k ls of - Just r -> - P.toBuiltinData - ( These - (P.unsafeFromBuiltinData v) - (P.unsafeFromBuiltinData r) - :: These a b - ) - Nothing -> - P.toBuiltinData (That (P.unsafeFromBuiltinData v) :: These a b) - in BI.mkCons (BI.mkPairData k v') (goRight tl) - ) - - res = goLeft ls `safeAppend` goRight rs - - safeAppend xs1 xs2 = - P.matchList' - xs1 - xs2 - ( \hd tl -> - let k = BI.fst hd - v = BI.snd hd - in insert' k v (safeAppend tl xs2) - ) -{-# INLINEABLE union #-} - --- | Combine two 'Map's with the given combination function. -unionWith - :: forall k a - . (P.UnsafeFromData a, P.ToData a) - => (a -> a -> a) - -> Map k a - -> Map k a - -> Map k a -unionWith f (Map ls) (Map rs) = - Map res - where - ls' :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - ls' = go ls - where - go = + where + goLeft = P.caseList' nil ( \hd tl -> - let k' = BI.fst hd - v' = BI.snd hd - v'' = case lookup' k' rs of + let k = BI.fst hd + v = BI.snd hd + v' = case lookup' k rs of Just r -> P.toBuiltinData - (f (P.unsafeFromBuiltinData v') (P.unsafeFromBuiltinData r)) - Nothing -> v' - in BI.mkCons (BI.mkPairData k' v'') (go tl) + ( These + (P.unsafeFromBuiltinData v) + (P.unsafeFromBuiltinData r) :: + These a b + ) + Nothing -> + P.toBuiltinData (This (P.unsafeFromBuiltinData v) :: These a b) + in BI.mkCons (BI.mkPairData k v') (goLeft tl) ) - rs' :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - rs' = go rs - where - go = + goRight = P.caseList' nil ( \hd tl -> - let k' = BI.fst hd - tl' = go tl - in if member' k' ls - then tl' - else BI.mkCons hd tl' + let k = BI.fst hd + v = BI.snd hd + v' = case lookup' k ls of + Just r -> + P.toBuiltinData + ( These + (P.unsafeFromBuiltinData v) + (P.unsafeFromBuiltinData r) :: + These a b + ) + Nothing -> + P.toBuiltinData (That (P.unsafeFromBuiltinData v) :: These a b) + in BI.mkCons (BI.mkPairData k v') (goRight tl) ) - res :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - res = go rs' ls' - where - go acc = - P.caseList' - acc - (\hd -> go (BI.mkCons hd acc)) + res = goLeft ls `safeAppend` goRight rs + + safeAppend xs1 xs2 = + P.matchList' + xs1 + xs2 + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + in insert' k v (safeAppend tl xs2) + ) +{-# INLINEABLE union #-} + +-- | Combine two 'Map's with the given combination function. +unionWith :: + forall k a. + (P.UnsafeFromData a, P.ToData a) => + (a -> a -> a) -> + Map k a -> + Map k a -> + Map k a +unionWith f (Map ls) (Map rs) = + Map res + where + ls' :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + ls' = go ls + where + go = + P.caseList' + nil + ( \hd tl -> + let k' = BI.fst hd + v' = BI.snd hd + v'' = case lookup' k' rs of + Just r -> + P.toBuiltinData + (f (P.unsafeFromBuiltinData v') (P.unsafeFromBuiltinData r)) + Nothing -> v' + in BI.mkCons (BI.mkPairData k' v'') (go tl) + ) + + rs' :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + rs' = go rs + where + go = + P.caseList' + nil + ( \hd tl -> + let k' = BI.fst hd + tl' = go tl + in if member' k' ls + then tl' + else BI.mkCons hd tl' + ) + + res :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + res = go rs' ls' + where + go acc = + P.caseList' + acc + (\hd -> go (BI.mkCons hd acc)) {-# INLINEABLE unionWith #-} -- | An empty `P.BuiltinList` of key-value pairs. @@ -457,17 +448,17 @@ nil :: BuiltinList (BuiltinPair BuiltinData BuiltinData) nil = P.mkNil {-# INLINEABLE nil #-} -keys' - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList BuiltinData +keys' :: + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList BuiltinData keys' = go - where - go = - P.caseList' - P.mkNil - ( \hd -> - BI.mkCons (BI.fst hd) . go - ) + where + go = + P.caseList' + P.mkNil + ( \hd -> + BI.mkCons (BI.fst hd) . go + ) keys :: forall k a. Map k a -> List k keys = Data.List.fromBuiltinList . keys' . coerce @@ -475,158 +466,158 @@ keys = Data.List.fromBuiltinList . keys' . coerce elems :: forall k a. Map k a -> List a elems = Data.List.fromBuiltinList . go . coerce - where - go - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList BuiltinData - go = - P.caseList' - P.mkNil - ( \hd -> - BI.mkCons (BI.snd hd) . go - ) + where + go :: + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + BuiltinList BuiltinData + go = + P.caseList' + P.mkNil + ( \hd -> + BI.mkCons (BI.snd hd) . go + ) {-# INLINEABLE elems #-} -mapThese - :: forall v k a b - . (P.ToData a, P.ToData b, P.UnsafeFromData v) - => (v -> These a b) -> Map k v -> (Map k a, Map k b) +mapThese :: + forall v k a b. + (P.ToData a, P.ToData b, P.UnsafeFromData v) => + (v -> These a b) -> Map k v -> (Map k a, Map k b) mapThese f (Map m) = (Map ls, Map rs) - where - nilCase = (nil, nil) - (ls, rs) = go m - go - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> ( BuiltinList (BuiltinPair BuiltinData BuiltinData) - , BuiltinList (BuiltinPair BuiltinData BuiltinData) - ) - go = - P.caseList' - nilCase - ( \hd tl -> - let k = BI.fst hd - v = BI.snd hd - (ls', rs') = go tl - in case f' v of - This l' -> (BI.mkCons (BI.mkPairData k (P.toBuiltinData l')) ls', rs') - That r' -> (ls', BI.mkCons (BI.mkPairData k (P.toBuiltinData r')) rs') - These l' r' -> - ( BI.mkCons (BI.mkPairData k (P.toBuiltinData l')) ls' - , BI.mkCons (BI.mkPairData k (P.toBuiltinData r')) rs' - ) + where + nilCase = (nil, nil) + (ls, rs) = go m + go :: + BuiltinList (BuiltinPair BuiltinData BuiltinData) -> + ( BuiltinList (BuiltinPair BuiltinData BuiltinData) + , BuiltinList (BuiltinPair BuiltinData BuiltinData) ) - f' :: BuiltinData -> These a b - f' = f . P.unsafeFromBuiltinData + go = + P.caseList' + nilCase + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + (ls', rs') = go tl + in case f' v of + This l' -> (BI.mkCons (BI.mkPairData k (P.toBuiltinData l')) ls', rs') + That r' -> (ls', BI.mkCons (BI.mkPairData k (P.toBuiltinData r')) rs') + These l' r' -> + ( BI.mkCons (BI.mkPairData k (P.toBuiltinData l')) ls' + , BI.mkCons (BI.mkPairData k (P.toBuiltinData r')) rs' + ) + ) + f' :: BuiltinData -> These a b + f' = f . P.unsafeFromBuiltinData {-# INLINEABLE mapThese #-} map :: forall k a b. (P.UnsafeFromData a, P.ToData b) => (a -> b) -> Map k a -> Map k b map f = coerce go - where - go = - P.caseList' - nil - ( \hd -> - let (k, v) = P.pairToPair hd - in BI.mkCons - (BI.mkPairData k (P.toBuiltinData (f (P.unsafeFromBuiltinData v)))) - . go - ) + where + go = + P.caseList' + nil + ( \hd -> + let (k, v) = P.pairToPair hd + in BI.mkCons + (BI.mkPairData k (P.toBuiltinData (f (P.unsafeFromBuiltinData v)))) + . go + ) {-# INLINEABLE map #-} -foldr - :: forall a b k - . (P.UnsafeFromData a) - => (a -> b -> b) -> b -> Map k a -> b +foldr :: + forall a b k. + P.UnsafeFromData a => + (a -> b -> b) -> b -> Map k a -> b foldr f z = coerce go - where - go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> b - go = - P.caseList' - z - ( \hd -> - f (P.unsafeFromBuiltinData (BI.snd hd)) . go - ) + where + go :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> b + go = + P.caseList' + z + ( \hd -> + f (P.unsafeFromBuiltinData (BI.snd hd)) . go + ) {-# INLINEABLE foldr #-} -filter - :: forall k a - . (P.UnsafeFromData a) - => (a -> Bool) -> Map k a -> Map k a +filter :: + forall k a. + P.UnsafeFromData a => + (a -> Bool) -> Map k a -> Map k a filter p = coerce go - where - go = - P.caseList' - nil - ( \hd -> - if p (P.unsafeFromBuiltinData (BI.snd hd)) - then BI.mkCons hd . go - else go - ) + where + go = + P.caseList' + nil + ( \hd -> + if p (P.unsafeFromBuiltinData (BI.snd hd)) + then BI.mkCons hd . go + else go + ) {-# INLINEABLE filter #-} -mapWithKey - :: forall k a b - . (P.UnsafeFromData k, P.UnsafeFromData a, P.ToData b) - => (k -> a -> b) -> Map k a -> Map k b +mapWithKey :: + forall k a b. + (P.UnsafeFromData k, P.UnsafeFromData a, P.ToData b) => + (k -> a -> b) -> Map k a -> Map k b mapWithKey f = coerce go - where - go = - P.caseList' - nil - ( \hd -> - let (k, v) = P.pairToPair hd - in BI.mkCons - ( BI.mkPairData - k - ( P.toBuiltinData - ( f - (P.unsafeFromBuiltinData k) - (P.unsafeFromBuiltinData v) - ) - ) - ) - . go - ) + where + go = + P.caseList' + nil + ( \hd -> + let (k, v) = P.pairToPair hd + in BI.mkCons + ( BI.mkPairData + k + ( P.toBuiltinData + ( f + (P.unsafeFromBuiltinData k) + (P.unsafeFromBuiltinData v) + ) + ) + ) + . go + ) {-# INLINEABLE mapWithKey #-} -mapMaybe - :: forall k a b - . (P.UnsafeFromData a, P.ToData b) - => (a -> Maybe b) -> Map k a -> Map k b +mapMaybe :: + forall k a b. + (P.UnsafeFromData a, P.ToData b) => + (a -> Maybe b) -> Map k a -> Map k b mapMaybe f = coerce go - where - go = - P.caseList' - nil - ( \hd -> - let (k, v) = P.pairToPair hd - in case f (P.unsafeFromBuiltinData v) of - Just v' -> - BI.mkCons - (BI.mkPairData k (P.toBuiltinData v')) - . go - Nothing -> go - ) + where + go = + P.caseList' + nil + ( \hd -> + let (k, v) = P.pairToPair hd + in case f (P.unsafeFromBuiltinData v) of + Just v' -> + BI.mkCons + (BI.mkPairData k (P.toBuiltinData v')) + . go + Nothing -> go + ) {-# INLINEABLE mapMaybe #-} -mapMaybeWithKey - :: forall k a b - . (P.UnsafeFromData k, P.UnsafeFromData a, P.ToData b) - => (k -> a -> Maybe b) -> Map k a -> Map k b +mapMaybeWithKey :: + forall k a b. + (P.UnsafeFromData k, P.UnsafeFromData a, P.ToData b) => + (k -> a -> Maybe b) -> Map k a -> Map k b mapMaybeWithKey f = coerce go - where - go = - P.caseList' - nil - ( \hd -> - let (k, v) = P.pairToPair hd - in case f (P.unsafeFromBuiltinData k) (P.unsafeFromBuiltinData v) of - Just v' -> - BI.mkCons - (BI.mkPairData k (P.toBuiltinData v')) - . go - Nothing -> go - ) + where + go = + P.caseList' + nil + ( \hd -> + let (k, v) = P.pairToPair hd + in case f (P.unsafeFromBuiltinData k) (P.unsafeFromBuiltinData v) of + Just v' -> + BI.mkCons + (BI.mkPairData k (P.toBuiltinData v')) + . go + Nothing -> go + ) {-# INLINEABLE mapMaybeWithKey #-} makeLift ''Map diff --git a/plutus-tx/src/PlutusTx/Data/List.hs b/plutus-tx/src/PlutusTx/Data/List.hs index 3c9e5145513..358ea837e46 100644 --- a/plutus-tx/src/PlutusTx/Data/List.hs +++ b/plutus-tx/src/PlutusTx/Data/List.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module PlutusTx.Data.List ( List, @@ -65,9 +65,25 @@ import PlutusTx.Builtins.Internal (BuiltinList) import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.IsData.Class (FromData (..), ToData (..), UnsafeFromData (..)) import PlutusTx.Lift (makeLift) -import PlutusTx.Prelude (Bool (..), BuiltinData, Eq (..), Integer, Maybe (..), Monoid (..), - Ord (..), Semigroup (..), fmap, not, pure, traceError, ($), (&&), (.), - (<$>), (||)) +import PlutusTx.Prelude ( + Bool (..), + BuiltinData, + Eq (..), + Integer, + Maybe (..), + Monoid (..), + Ord (..), + Semigroup (..), + fmap, + not, + pure, + traceError, + ($), + (&&), + (.), + (<$>), + (||), + ) import Prettyprinter (Pretty (..)) import Data.Coerce (coerce) @@ -75,9 +91,8 @@ import Data.Semigroup qualified as Haskell import PlutusTx.ErrorCodes (indexTooLargeError, lastEmptyListError, negativeIndexError) import Prelude qualified as Haskell -{-| A list type backed directly by 'Data'. It is meant to be used whenever fast -encoding/decoding to/from 'Data' is needed. --} +-- | A list type backed directly by 'Data'. It is meant to be used whenever fast +-- encoding/decoding to/from 'Data' is needed. newtype List a = List (BuiltinList BuiltinData) deriving stock (Haskell.Show, Haskell.Eq) @@ -130,31 +145,30 @@ inlined, which can lead to significant performance penalty. -} -- | Matching on the given `List`. -caseList - :: forall a r - . (UnsafeFromData a) - => (() -> r) - -- ^ Nil case - -> (a -> List a -> r) - -- ^ Cons case - -> List a - -> r +caseList :: + forall a r. + UnsafeFromData a => + -- | Nil case + (() -> r) -> + -- | Cons case + (a -> List a -> r) -> + List a -> + r -- See Note [Making arguments non-strict in case and match functions] caseList ~n ~c (List l) = B.caseList n (\x -> c (unsafeFromBuiltinData x) . List) l {-# INLINEABLE caseList #-} -{-| Like `caseList`, except the nil case takes an `r` directly, which is evaluated strictly. -If `r` is an error or expensive computation, consider using `caseList` instead. --} -caseList' - :: forall a r - . (UnsafeFromData a) - => r - -- ^ Nil case - -> (a -> List a -> r) - -- ^ Cons case - -> List a - -> r +-- | Like `caseList`, except the nil case takes an `r` directly, which is evaluated strictly. +-- If `r` is an error or expensive computation, consider using `caseList` instead. +caseList' :: + forall a r. + UnsafeFromData a => + -- | Nil case + r -> + -- | Cons case + (a -> List a -> r) -> + List a -> + r -- See Note [Making arguments non-strict in case and match functions] caseList' ~n ~c (List l) = B.caseList' n (\x -> c (unsafeFromBuiltinData x) . List) l {-# INLINEABLE caseList' #-} @@ -166,12 +180,12 @@ null = B.null . coerce @_ @(BuiltinList BuiltinData) -- | Prepend an element to the list. infixr 5 <| -(<|) :: (ToData a) => a -> List a -> List a +(<|) :: ToData a => a -> List a -> List a (<|) h = coerce . BI.mkCons (toBuiltinData h) . coerce {-# INLINEABLE (<|) #-} -- | Synonym for `<|`. -cons :: (ToData a) => a -> List a -> List a +cons :: ToData a => a -> List a -> List a cons = (<|) {-# INLINEABLE cons #-} @@ -181,243 +195,229 @@ nil = List B.mkNil {-# INLINEABLE nil #-} -- | Create a list from a single element. -singleton :: (ToData a) => a -> List a +singleton :: ToData a => a -> List a singleton a = cons a nil {-# INLINEABLE singleton #-} append :: List a -> List a -> List a append (List l) (List l') = List (go l) - where - go = - B.caseList' - l' - (\h t -> BI.mkCons h (go t)) + where + go = + B.caseList' + l' + (\h t -> BI.mkCons h (go t)) {-# INLINEABLE append #-} -{-| Find the first element that satisfies a predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -find :: (UnsafeFromData a) => (a -> Bool) -> List a -> Maybe a +-- | Find the first element that satisfies a predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +find :: UnsafeFromData a => (a -> Bool) -> List a -> Maybe a find pred' = go - where - go = - caseList' - Nothing - ( \h t -> - if pred' h - then Just h - else go t - ) + where + go = + caseList' + Nothing + ( \h t -> + if pred' h + then Just h + else go t + ) {-# INLINEABLE find #-} -{-| Find the indices of all elements that satisfy a predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -findIndices :: (UnsafeFromData a) => (a -> Bool) -> List a -> List Integer +-- | Find the indices of all elements that satisfy a predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +findIndices :: UnsafeFromData a => (a -> Bool) -> List a -> List Integer findIndices pred' = go 0 - where - go i = - caseList' - mempty - ( \h t -> - let indices = go (B.addInteger 1 i) t - in if pred' h - then i <| indices - else indices - ) + where + go i = + caseList' + mempty + ( \h t -> + let indices = go (B.addInteger 1 i) t + in if pred' h + then i <| indices + else indices + ) {-# INLINEABLE findIndices #-} -{-| Filter a list using a predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} +-- | Filter a list using a predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. filter :: (UnsafeFromData a, ToData a) => (a -> Bool) -> List a -> List a filter pred1 = go - where - go = - caseList' - mempty - ( \h t -> - if pred1 h then h <| go t else go t - ) + where + go = + caseList' + mempty + ( \h t -> + if pred1 h then h <| go t else go t + ) {-# INLINEABLE filter #-} -{-| Map a function over a list and discard the results that are 'Nothing'. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData', or if the result of applying -'f' is expensive to encode to 'BuiltinData'. --} +-- | Map a function over a list and discard the results that are 'Nothing'. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData', or if the result of applying +-- 'f' is expensive to encode to 'BuiltinData'. mapMaybe :: (UnsafeFromData a, ToData b) => (a -> Maybe b) -> List a -> List b mapMaybe f = go - where - go = - caseList' - mempty - ( \h t -> - case f h of - Just b -> b <| go t - Nothing -> go t - ) + where + go = + caseList' + mempty + ( \h t -> + case f h of + Just b -> b <| go t + Nothing -> go t + ) {-# INLINEABLE mapMaybe #-} -{-| Check if any element in the list satisfies a predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -any :: (UnsafeFromData a) => (a -> Bool) -> List a -> Bool +-- | Check if any element in the list satisfies a predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +any :: UnsafeFromData a => (a -> Bool) -> List a -> Bool any pred1 = go - where - go = - caseList' - False - (\h t -> pred1 h || go t) + where + go = + caseList' + False + (\h t -> pred1 h || go t) {-# INLINEABLE any #-} -{-| Check if all elements in the list satisfy a predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -all :: (UnsafeFromData a) => (a -> Bool) -> List a -> Bool +-- | Check if all elements in the list satisfy a predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +all :: UnsafeFromData a => (a -> Bool) -> List a -> Bool all pred1 = go - where - go = - caseList' - True - (\h t -> pred1 h && go t) + where + go = + caseList' + True + (\h t -> pred1 h && go t) {-# INLINEABLE all #-} -{-| Fold a list using a monoid. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} +-- | Fold a list using a monoid. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. foldMap :: (UnsafeFromData a, Monoid m) => (a -> m) -> List a -> m foldMap f = go - where - go = - caseList' - mempty - (\h t -> f h <> go t) + where + go = + caseList' + mempty + (\h t -> f h <> go t) {-# INLINEABLE foldMap #-} -{-| Map a function over a list. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData', or if the result of applying -'f' is expensive to encode to 'BuiltinData'. --} +-- | Map a function over a list. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData', or if the result of applying +-- 'f' is expensive to encode to 'BuiltinData'. map :: (UnsafeFromData a, ToData b) => (a -> b) -> List a -> List b map f = coerce go - where - go = - caseList' - B.mkNil - ( \h t -> - BI.mkCons - (toBuiltinData $ f h) - (go t) - ) + where + go = + caseList' + B.mkNil + ( \h t -> + BI.mkCons + (toBuiltinData $ f h) + (go t) + ) {-# INLINEABLE map #-} -- | Get the length of a list. length :: List a -> Integer length (List l) = go l - where - go = BI.caseList' 0 (\_ -> B.addInteger 1 . go) + where + go = BI.caseList' 0 (\_ -> B.addInteger 1 . go) {-# INLINEABLE length #-} -{-| Concatenate a list of monoids. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} +-- | Concatenate a list of monoids. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. mconcat :: (Monoid a, UnsafeFromData a) => List a -> a mconcat = go - where - go = - caseList' - mempty - (\h t -> h <> go t) + where + go = + caseList' + mempty + (\h t -> h <> go t) {-# INLINEABLE mconcat #-} -- | Get the first element of a list and the rest of the list. -uncons :: (UnsafeFromData a) => List a -> Maybe (a, List a) +uncons :: UnsafeFromData a => List a -> Maybe (a, List a) uncons (List l) = do (h, t) <- B.uncons l pure (unsafeFromBuiltinData h, List t) {-# INLINEABLE uncons #-} -{-| Check if all elements in the list are 'True'. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} +-- | Check if all elements in the list are 'True'. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. and :: List Bool -> Bool and = go - where - go = - caseList' - True - (\h t -> h && go t) + where + go = + caseList' + True + (\h t -> h && go t) {-# INLINEABLE and #-} -{-| Check if any element in the list is 'True'. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} +-- | Check if any element in the list is 'True'. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. or :: List Bool -> Bool or = go . coerce - where - go = - caseList' - False - (\h t -> h || go t) + where + go = + caseList' + False + (\h t -> h || go t) {-# INLINEABLE or #-} -{-| Check if an element is in the list. -Note: this function can leverage the better performance of equality checks -for 'BuiltinData'. --} -elem :: (ToData a) => a -> List a -> Bool +-- | Check if an element is in the list. +-- Note: this function can leverage the better performance of equality checks +-- for 'BuiltinData'. +elem :: ToData a => a -> List a -> Bool elem x = go . coerce - where - go = - let x' = toBuiltinData x - in B.caseList' - False - (\h t -> x' == h || go t) + where + go = + let x' = toBuiltinData x + in B.caseList' + False + (\h t -> x' == h || go t) {-# INLINEABLE elem #-} -- | Check if an element is not in the list. -notElem :: (ToData a) => a -> List a -> Bool +notElem :: ToData a => a -> List a -> Bool notElem x = not . elem x {-# INLINEABLE notElem #-} -{-| Fold a list from the right. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -foldr :: (UnsafeFromData a) => (a -> b -> b) -> b -> List a -> b +-- | Fold a list from the right. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +foldr :: UnsafeFromData a => (a -> b -> b) -> b -> List a -> b foldr f z = go z . coerce - where - go u = - B.caseList' - u - (\h -> f (unsafeFromBuiltinData h) . go u) + where + go u = + B.caseList' + u + (\h -> f (unsafeFromBuiltinData h) . go u) {-# INLINEABLE foldr #-} -{-| Fold a list from the left. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -foldl :: (UnsafeFromData a) => (b -> a -> b) -> b -> List a -> b +-- | Fold a list from the left. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +foldl :: UnsafeFromData a => (b -> a -> b) -> b -> List a -> b foldl f z = go z . coerce - where - go acc = - B.caseList' - acc - ( \h t -> - let h' = unsafeFromBuiltinData h - in go (f acc h') t - ) + where + go acc = + B.caseList' + acc + ( \h t -> + let h' = unsafeFromBuiltinData h + in go (f acc h') t + ) {-# INLINEABLE foldl #-} -- | Flatten a list of lists into a single list. @@ -426,17 +426,17 @@ concat = foldr append mempty {-# INLINEABLE concat #-} -- | Map a function over a list and concatenate the results. -concatMap :: (UnsafeFromData a) => (a -> List b) -> List a -> List b +concatMap :: UnsafeFromData a => (a -> List b) -> List a -> List b concatMap = foldMap {-# INLINEABLE concatMap #-} -- | Get the first element of a list if it is not empty. -listToMaybe :: (UnsafeFromData a) => List a -> Maybe a +listToMaybe :: UnsafeFromData a => List a -> Maybe a listToMaybe (List l) = unsafeFromBuiltinData <$> B.headMaybe l {-# INLINEABLE listToMaybe #-} -- | Get the element of a list if it has exactly one element. -uniqueElement :: (UnsafeFromData a) => List a -> Maybe a +uniqueElement :: UnsafeFromData a => List a -> Maybe a uniqueElement (List l) = do (h, t) <- B.uncons l if B.null t @@ -444,38 +444,37 @@ uniqueElement (List l) = do else Nothing {-# INLINEABLE uniqueElement #-} -{-| Get the element at a given index. -Warning: this is a partial function and will fail if the index is negative or -greater than the length of the list. -Note: this function has the same precedence as (!!) from 'PlutusTx.List'. --} +-- | Get the element at a given index. +-- Warning: this is a partial function and will fail if the index is negative or +-- greater than the length of the list. +-- Note: this function has the same precedence as (!!) from 'PlutusTx.List'. infixl 9 !! -(!!) :: (UnsafeFromData a) => List a -> Integer -> a +(!!) :: UnsafeFromData a => List a -> Integer -> a (List l) !! n = if B.lessThanInteger n 0 then traceError negativeIndexError else go n l - where - go n' = - B.caseList - (\() -> traceError indexTooLargeError) - ( \h t -> - if B.equalsInteger n' 0 - then unsafeFromBuiltinData h - else go (B.subtractInteger n' 1) t - ) + where + go n' = + B.caseList + (\() -> traceError indexTooLargeError) + ( \h t -> + if B.equalsInteger n' 0 + then unsafeFromBuiltinData h + else go (B.subtractInteger n' 1) t + ) {-# INLINEABLE (!!) #-} -- | Append two lists in reverse order. revAppend :: List a -> List a -> List a revAppend (List l) (List l') = List $ rev l l' - where - rev l1 l2 = - B.caseList' - l2 - (\h t -> rev t (BI.mkCons h l2)) - l1 + where + rev l1 l2 = + B.caseList' + l2 + (\h t -> rev t (BI.mkCons h l2)) + l1 {-# INLINEABLE revAppend #-} -- | Reverse a list. @@ -484,81 +483,78 @@ reverse l = revAppend l mempty {-# INLINEABLE reverse #-} -- | Replicate a value n times. -replicate :: (ToData a) => Integer -> a -> List a +replicate :: ToData a => Integer -> a -> List a replicate n (toBuiltinData -> x) = coerce $ go n - where - go n' = - if B.equalsInteger n' 0 - then B.mkNil - else BI.mkCons x (go (B.subtractInteger n' 1)) + where + go n' = + if B.equalsInteger n' 0 + then B.mkNil + else BI.mkCons x (go (B.subtractInteger n' 1)) {-# INLINEABLE replicate #-} -{-| Find the index of the first element that satisfies a predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -findIndex :: (UnsafeFromData a) => (a -> Bool) -> List a -> Maybe Integer +-- | Find the index of the first element that satisfies a predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +findIndex :: UnsafeFromData a => (a -> Bool) -> List a -> Maybe Integer findIndex pred' = go 0 . coerce - where - go i = - B.caseList' - Nothing - ( \h t -> - if pred' (unsafeFromBuiltinData h) then Just i else go (B.addInteger 1 i) t - ) + where + go i = + B.caseList' + Nothing + ( \h t -> + if pred' (unsafeFromBuiltinData h) then Just i else go (B.addInteger 1 i) t + ) {-# INLINEABLE findIndex #-} -- | Split a list of pairs into a pair of lists. unzip :: forall a b. List (a, b) -> (List a, List b) unzip = coerce go - where - go :: BuiltinList BuiltinData -> (BuiltinList BuiltinData, BuiltinList BuiltinData) - go = - B.caseList' - (B.mkNil, B.mkNil) - ( \h t -> - let (a, b) = unsafeFromBuiltinData h - (as, bs) = go t - in (a `BI.mkCons` as, b `BI.mkCons` bs) - ) + where + go :: BuiltinList BuiltinData -> (BuiltinList BuiltinData, BuiltinList BuiltinData) + go = + B.caseList' + (B.mkNil, B.mkNil) + ( \h t -> + let (a, b) = unsafeFromBuiltinData h + (as, bs) = go t + in (a `BI.mkCons` as, b `BI.mkCons` bs) + ) {-# INLINEABLE unzip #-} -{-| Zip two lists together using a function. -Warning: this function can be very inefficient if the lists contain elements -that are expensive to decode from 'BuiltinData', or if the result of applying -'f' is expensive to encode to 'BuiltinData'. --} -zipWith - :: (UnsafeFromData a, UnsafeFromData b, ToData c) - => (a -> b -> c) -> List a -> List b -> List c +-- | Zip two lists together using a function. +-- Warning: this function can be very inefficient if the lists contain elements +-- that are expensive to decode from 'BuiltinData', or if the result of applying +-- 'f' is expensive to encode to 'BuiltinData'. +zipWith :: + (UnsafeFromData a, UnsafeFromData b, ToData c) => + (a -> b -> c) -> List a -> List b -> List c zipWith f = coerce go - where - go :: BuiltinList BuiltinData -> BuiltinList BuiltinData -> BuiltinList BuiltinData - go l1' l2' = - B.caseList' - B.mkNil - ( \h1 t1 -> - B.caseList' - B.mkNil - ( \h2 t2 -> - BI.mkCons - ( toBuiltinData - $ f - (unsafeFromBuiltinData h1) - (unsafeFromBuiltinData h2) - ) - (go t1 t2) - ) - l2' - ) - l1' + where + go :: BuiltinList BuiltinData -> BuiltinList BuiltinData -> BuiltinList BuiltinData + go l1' l2' = + B.caseList' + B.mkNil + ( \h1 t1 -> + B.caseList' + B.mkNil + ( \h2 t2 -> + BI.mkCons + ( toBuiltinData + $ f + (unsafeFromBuiltinData h1) + (unsafeFromBuiltinData h2) + ) + (go t1 t2) + ) + l2' + ) + l1' {-# INLINEABLE zipWith #-} -{-| Return the head of a list. -Warning: this is a partial function and will fail if the list is empty. --} -head :: forall a. (UnsafeFromData a) => List a -> a +-- | Return the head of a list. +-- Warning: this is a partial function and will fail if the list is empty. +head :: forall a. UnsafeFromData a => List a -> a head = coerce @(BuiltinList BuiltinData -> a) @@ -566,30 +562,28 @@ head = (unsafeFromBuiltinData . B.head) {-# INLINEABLE head #-} -{-| Return the last element of a list. -Warning: this is a partial function and will fail if the list is empty. --} -last :: forall a. (UnsafeFromData a) => List a -> a +-- | Return the last element of a list. +-- Warning: this is a partial function and will fail if the list is empty. +last :: forall a. UnsafeFromData a => List a -> a last = coerce @(BuiltinList BuiltinData -> a) @(List a -> a) (unsafeFromBuiltinData . go) - where - go :: BuiltinList BuiltinData -> BuiltinData - go = - B.caseList - (\() -> traceError lastEmptyListError) - ( \h t -> - if B.null t - then h - else go t - ) + where + go :: BuiltinList BuiltinData -> BuiltinData + go = + B.caseList + (\() -> traceError lastEmptyListError) + ( \h t -> + if B.null t + then h + else go t + ) {-# INLINEABLE last #-} -{-| Return the tail of a list. -Warning: this is a partial function and will fail if the list is empty. --} +-- | Return the tail of a list. +-- Warning: this is a partial function and will fail if the list is empty. tail :: forall a. List a -> List a tail = coerce @(BuiltinList BuiltinData) @(List a) . B.tail . coerce {-# INLINEABLE tail #-} @@ -597,130 +591,125 @@ tail = coerce @(BuiltinList BuiltinData) @(List a) . B.tail . coerce -- | Take the first n elements from the list. take :: forall a. Integer -> List a -> List a take n = coerce $ go n - where - go :: Integer -> BuiltinList BuiltinData -> BuiltinList BuiltinData - go n' = - B.caseList' - B.mkNil - ( \h t -> - if B.equalsInteger n' 0 - then B.mkNil - else BI.mkCons h (go (B.subtractInteger n' 1) t) - ) + where + go :: Integer -> BuiltinList BuiltinData -> BuiltinList BuiltinData + go n' = + B.caseList' + B.mkNil + ( \h t -> + if B.equalsInteger n' 0 + then B.mkNil + else BI.mkCons h (go (B.subtractInteger n' 1) t) + ) {-# INLINEABLE take #-} -- | Drop the first n elements from the list. drop :: forall a. Integer -> List a -> List a drop n = coerce $ go n - where - go :: Integer -> BuiltinList BuiltinData -> BuiltinList BuiltinData - go n' xs = - if n' <= 0 - then xs - else - B.caseList' - B.mkNil - (\_ -> go (B.subtractInteger n' 1)) - xs + where + go :: Integer -> BuiltinList BuiltinData -> BuiltinList BuiltinData + go n' xs = + if n' <= 0 + then xs + else + B.caseList' + B.mkNil + (\_ -> go (B.subtractInteger n' 1)) + xs {-# INLINEABLE drop #-} -{-| Drop elements from the list while the predicate holds. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -dropWhile :: forall a. (UnsafeFromData a) => (a -> Bool) -> List a -> List a +-- | Drop elements from the list while the predicate holds. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +dropWhile :: forall a. UnsafeFromData a => (a -> Bool) -> List a -> List a dropWhile pred1 = coerce @_ @(List a -> List a) $ go - where - go :: BuiltinList BuiltinData -> BuiltinList BuiltinData - go xs = - B.caseList' - B.mkNil - ( \h t -> - if pred1 (unsafeFromBuiltinData h) then go t else xs - ) - xs + where + go :: BuiltinList BuiltinData -> BuiltinList BuiltinData + go xs = + B.caseList' + B.mkNil + ( \h t -> + if pred1 (unsafeFromBuiltinData h) then go t else xs + ) + xs {-# INLINEABLE dropWhile #-} -- | Split a list at a given index. splitAt :: forall a. Integer -> List a -> (List a, List a) splitAt n l = coerce $ go n (coerce @_ @(BuiltinList BuiltinData) l) - where - go n' xs = - if n' <= 0 - then (B.mkNil, xs) - else - B.caseList' - (B.mkNil, B.mkNil) - ( \h t -> - if B.equalsInteger n' 0 - then (B.mkNil, coerce @_ @(BuiltinList BuiltinData) l) - else - let (l1, l2) = go (B.subtractInteger n' 1) t - in (BI.mkCons h l1, l2) - ) - xs + where + go n' xs = + if n' <= 0 + then (B.mkNil, xs) + else + B.caseList' + (B.mkNil, B.mkNil) + ( \h t -> + if B.equalsInteger n' 0 + then (B.mkNil, coerce @_ @(BuiltinList BuiltinData) l) + else + let (l1, l2) = go (B.subtractInteger n' 1) t + in (BI.mkCons h l1, l2) + ) + xs {-# INLINEABLE splitAt #-} -{-| Check if an element satisfying a binary predicate is in the list. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -elemBy :: (UnsafeFromData a) => (a -> a -> Bool) -> a -> List a -> Bool +-- | Check if an element satisfying a binary predicate is in the list. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +elemBy :: UnsafeFromData a => (a -> a -> Bool) -> a -> List a -> Bool elemBy pred2 x = go . coerce - where - go = - B.caseList' - False - (\h t -> pred2 (unsafeFromBuiltinData h) x || go t) + where + go = + B.caseList' + False + (\h t -> pred2 (unsafeFromBuiltinData h) x || go t) {-# INLINEABLE elemBy #-} -{-| Removes elements from the list that satisfy a binary predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -nubBy :: forall a. (UnsafeFromData a) => (a -> a -> Bool) -> List a -> List a +-- | Removes elements from the list that satisfy a binary predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +nubBy :: forall a. UnsafeFromData a => (a -> a -> Bool) -> List a -> List a nubBy pred2 l = coerce @_ @(List a) $ go (coerce @_ @(BuiltinList BuiltinData) l) B.mkNil - where - go ys xs = - B.caseList' - B.mkNil - ( \h t -> - if elemBy pred2 (unsafeFromBuiltinData h) (coerce xs) - then go t xs - else BI.mkCons h (go t (BI.mkCons h xs)) - ) - ys + where + go ys xs = + B.caseList' + B.mkNil + ( \h t -> + if elemBy pred2 (unsafeFromBuiltinData h) (coerce xs) + then go t xs + else BI.mkCons h (go t (BI.mkCons h xs)) + ) + ys {-# INLINEABLE nubBy #-} -{-| Removes duplicate elements from the list. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} +-- | Removes duplicate elements from the list. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. nub :: (Eq a, UnsafeFromData a) => List a -> List a nub = nubBy (==) {-# INLINEABLE nub #-} -{-| Partition a list into two lists based on a predicate. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -partition :: (UnsafeFromData a) => (a -> Bool) -> List a -> (List a, List a) +-- | Partition a list into two lists based on a predicate. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +partition :: UnsafeFromData a => (a -> Bool) -> List a -> (List a, List a) partition pred1 l = coerce $ go (coerce l) - where - go = - B.caseList' - (B.mkNil, B.mkNil) - ( \h t -> - let h' = unsafeFromBuiltinData h - (l1, l2) = go t - in if pred1 h' - then (h `BI.mkCons` l1, l2) - else (l1, h `BI.mkCons` l2) - ) + where + go = + B.caseList' + (B.mkNil, B.mkNil) + ( \h t -> + let h' = unsafeFromBuiltinData h + (l1, l2) = go t + in if pred1 h' + then (h `BI.mkCons` l1, l2) + else (l1, h `BI.mkCons` l2) + ) {-# INLINEABLE partition #-} toBuiltinList :: List a -> BuiltinList BuiltinData @@ -731,22 +720,20 @@ fromBuiltinList :: BuiltinList BuiltinData -> List a fromBuiltinList = coerce {-# INLINEABLE fromBuiltinList #-} -{-| Convert a data-backed list to a sums of products list. -Warning: this function can be very inefficient if the list contains elements -that are expensive to decode from 'BuiltinData'. --} -toSOP :: forall a. (UnsafeFromData a) => List a -> [a] +-- | Convert a data-backed list to a sums of products list. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to decode from 'BuiltinData'. +toSOP :: forall a. UnsafeFromData a => List a -> [a] toSOP = coerce go - where - go :: BuiltinList BuiltinData -> [a] - go = B.caseList' [] (\h t -> unsafeFromBuiltinData h : go t) + where + go :: BuiltinList BuiltinData -> [a] + go = B.caseList' [] (\h t -> unsafeFromBuiltinData h : go t) {-# INLINEABLE toSOP #-} -{-| Convert a sums of products list to a data-backed list. -Warning: this function can be very inefficient if the list contains elements -that are expensive to encode to 'BuiltinData'. --} -fromSOP :: forall a. (ToData a) => [a] -> List a +-- | Convert a sums of products list to a data-backed list. +-- Warning: this function can be very inefficient if the list contains elements +-- that are expensive to encode to 'BuiltinData'. +fromSOP :: forall a. ToData a => [a] -> List a fromSOP = coerce . BI.unsafeDataAsList . B.mkList . fmap toBuiltinData {-# INLINEABLE fromSOP #-} diff --git a/plutus-tx/src/PlutusTx/Data/List/TH.hs b/plutus-tx/src/PlutusTx/Data/List/TH.hs index 0d684ff8239..f281c23c238 100644 --- a/plutus-tx/src/PlutusTx/Data/List/TH.hs +++ b/plutus-tx/src/PlutusTx/Data/List/TH.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module PlutusTx.Data.List.TH where @@ -11,33 +11,32 @@ import Language.Haskell.TH qualified as TH import PlutusTx.Data.List qualified as List import Prelude -{-| Generate variables bound to the given indices of a @BuiltinList@. - -Sample Usage: - - @ - f :: List Integer -> Integer - f list = - $( destructList - "s" - (Set.fromList [1, 4, 5]) - 'list - [|s1 + s4 + s5|] - ) - @ - -This computes the sum of list elements at indices 1, 4 and 5. --} -destructList - :: String - -- ^ Prefix of the generated bindings - -> Set Int - -- ^ Element ids you need, starting from 0 - -> TH.Name - -- ^ The builtin list to destruct - -> TH.ExpQ - -- ^ The computation that consumes the elements - -> TH.ExpQ +-- | Generate variables bound to the given indices of a @BuiltinList@. +-- +-- Sample Usage: +-- +-- @ +-- f :: List Integer -> Integer +-- f list = +-- $( destructList +-- "s" +-- (Set.fromList [1, 4, 5]) +-- 'list +-- [|s1 + s4 + s5|] +-- ) +-- @ +-- +-- This computes the sum of list elements at indices 1, 4 and 5. +destructList :: + -- | Prefix of the generated bindings + String -> + -- | Element ids you need, starting from 0 + Set Int -> + -- | The builtin list to destruct + TH.Name -> + -- | The computation that consumes the elements + TH.ExpQ -> + TH.ExpQ destructList p is n k = do let strict = TH.bangP . TH.varP nonstrict = TH.tildeP . TH.varP diff --git a/plutus-tx/src/PlutusTx/Enum.hs b/plutus-tx/src/PlutusTx/Enum.hs index e12442cee97..cdc50ef9025 100644 --- a/plutus-tx/src/PlutusTx/Enum.hs +++ b/plutus-tx/src/PlutusTx/Enum.hs @@ -13,18 +13,16 @@ import PlutusTx.Trace -- | Class 'Enum' defines operations on sequentially ordered types. class Enum a where - {-| The successor of a value. For numeric types, 'succ' adds 1. - - For types that implement 'Ord', @succ x@ should be the least element - that is greater than @x@, and 'error' if there is none. - -} + -- | The successor of a value. For numeric types, 'succ' adds 1. + -- + -- For types that implement 'Ord', @succ x@ should be the least element + -- that is greater than @x@, and 'error' if there is none. succ :: a -> a - {-| The predecessor of a value. For numeric types, 'pred' subtracts 1. - - For types that implement 'Ord', @pred x@ should be the greatest element - that is less than @x@, and 'error' if there is none. - -} + -- | The predecessor of a value. For numeric types, 'pred' subtracts 1. + -- + -- For types that implement 'Ord', @pred x@ should be the greatest element + -- that is less than @x@, and 'error' if there is none. pred :: a -> a -- | Convert from an 'Integer'. @@ -36,10 +34,9 @@ class Enum a where -- | Construct a list from the given range (corresponds to [a..b]). enumFromTo :: a -> a -> [a] - {-| Construct a list from the given range (corresponds to [a,b..c]). This - has the same semantics as the Haskell version,so if a==b and c>=b then you - get an infinite list, which you probably don't want in Plutus Core. - -} + -- | Construct a list from the given range (corresponds to [a,b..c]). This + -- has the same semantics as the Haskell version,so if a==b and c>=b then you + -- get an infinite list, which you probably don't want in Plutus Core. enumFromThenTo :: a -> a -> a -> [a] instance Enum Integer where @@ -65,16 +62,16 @@ instance Enum Integer where if delta >= 0 then up_list x else dn_list x - where - delta = subtractInteger y x - up_list x1 = - if x1 > lim - then [] - else x1 : up_list (addInteger x1 delta) - dn_list x1 = - if x1 < lim - then [] - else x1 : dn_list (addInteger x1 delta) + where + delta = subtractInteger y x + up_list x1 = + if x1 > lim + then [] + else x1 : up_list (addInteger x1 delta) + dn_list x1 = + if x1 < lim + then [] + else x1 : dn_list (addInteger x1 delta) instance Enum () where {-# INLINEABLE succ #-} @@ -101,10 +98,10 @@ instance Enum () where instance Enum Bool where {-# INLINEABLE succ #-} succ False = True - succ True = traceError succBoolBadArgumentError + succ True = traceError succBoolBadArgumentError {-# INLINEABLE pred #-} - pred True = False + pred True = False pred False = traceError predBoolBadArgumentError {-# INLINEABLE toEnum #-} @@ -115,7 +112,7 @@ instance Enum Bool where {-# INLINEABLE fromEnum #-} fromEnum False = 0 - fromEnum True = 1 + fromEnum True = 1 {-# INLINEABLE enumFromTo #-} enumFromTo x lim = map toEnum (enumFromTo (fromEnum x) (fromEnum lim)) diff --git a/plutus-tx/src/PlutusTx/Eq.hs b/plutus-tx/src/PlutusTx/Eq.hs index 6f34ebef1d8..7d1ee4de39f 100644 --- a/plutus-tx/src/PlutusTx/Eq.hs +++ b/plutus-tx/src/PlutusTx/Eq.hs @@ -21,7 +21,7 @@ class Eq a where -- (/=) deliberately omitted, to make this a one-method class which has a -- simpler representation -(/=) :: (Eq a) => a -> a -> Bool +(/=) :: Eq a => a -> a -> Bool x /= y = not (x == y) {-# INLINEABLE (/=) #-} @@ -49,29 +49,29 @@ instance Eq Builtins.BuiltinBLS12_381_G2_Element where {-# INLINEABLE (==) #-} (==) = Builtins.bls12_381_G2_equals -instance (Eq a) => Eq [a] where +instance Eq a => Eq [a] where {-# INLINEABLE (==) #-} - [] == [] = True + [] == [] = True (x : xs) == (y : ys) = x == y && xs == ys - _ == _ = False + _ == _ = False instance Eq Bool where {-# INLINEABLE (==) #-} - True == True = True + True == True = True False == False = True - _ == _ = False + _ == _ = False -instance (Eq a) => Eq (Maybe a) where +instance Eq a => Eq (Maybe a) where {-# INLINEABLE (==) #-} (Just a1) == (Just a2) = a1 == a2 - Nothing == Nothing = True - _ == _ = False + Nothing == Nothing = True + _ == _ = False instance (Eq a, Eq b) => Eq (Either a b) where {-# INLINEABLE (==) #-} - (Left a1) == (Left a2) = a1 == a2 + (Left a1) == (Left a2) = a1 == a2 (Right b1) == (Right b2) = b1 == b2 - _ == _ = False + _ == _ = False instance Eq () where {-# INLINEABLE (==) #-} @@ -83,7 +83,7 @@ instance (Eq a, Eq b) => Eq (a, b) where instance (Eq a, Eq b) => Eq (These a b) where {-# INLINEABLE (==) #-} - (This a) == (This a') = a == a' - (That b) == (That b') = b == b' + (This a) == (This a') = a == a' + (That b) == (That b') = b == b' (These a b) == (These a' b') = a == a' && b == b' - _ == _ = False + _ == _ = False diff --git a/plutus-tx/src/PlutusTx/ErrorCodes.hs b/plutus-tx/src/PlutusTx/ErrorCodes.hs index f94df70f630..c3905f6e088 100644 --- a/plutus-tx/src/PlutusTx/ErrorCodes.hs +++ b/plutus-tx/src/PlutusTx/ErrorCodes.hs @@ -36,32 +36,33 @@ When writing a new error description please follow existing patterns: -- | All error codes used in the plutus prelude associated with a human-readable description. plutusPreludeErrorCodes :: Map Builtins.BuiltinString String -plutusPreludeErrorCodes = Map.fromList - [ ("PT1", "TH Generation of Indexed Data Error") - , ("PT2", "PlutusTx.IsData.Class.unsafeFromBuiltinData: Void is not supported") - , ("PT3", "PlutusTx.Ratio: zero denominator") - , ("PT5", "PlutusTx.Prelude.check: input is 'False'") - , ("PT6", "PlutusTx.List.!!: negative index") - , ("PT7", "PlutusTx.List.!!: index too large") - , ("PT8", "PlutusTx.List.head: empty list") - , ("PT9", "PlutusTx.List.tail: empty list") - , ("PT10", "PlutusTx.Enum.().succ: bad argument") - , ("PT11", "PlutusTx.Enum.().pred: bad argument") - , ("PT12", "PlutusTx.Enum.().toEnum: bad argument") - , ("PT13", "PlutusTx.Enum.Bool.succ: bad argument") - , ("PT14", "PlutusTx.Enum.Bool.pred: bad argument") - , ("PT15", "PlutusTx.Enum.Bool.toEnum: bad argument") - , ("PT16", "PlutusTx.Enum.Ordering.succ: bad argument") - , ("PT17", "PlutusTx.Enum.Ordering.pred: bad argument") - , ("PT18", "PlutusTx.Enum.Ordering.toEnum: bad argument") - , ("PT19", "PlutusTx.List.last: empty list") - , ("PT20", "PlutusTx.Ratio.recip: reciprocal of zero") - , ("PT21", "PlutusTx.BuiltinList.!!: negative index") - , ("PT22", "PlutusTx.BuiltinList.!!: index too large") - , ("PT23", "PlutusTx.BuiltinList.head: empty list") - , ("PT24", "PlutusTx.BuiltinList.tail: empty list") - , ("PT25", "PlutusTx.BuiltinList.last: empty list") - ] +plutusPreludeErrorCodes = + Map.fromList + [ ("PT1", "TH Generation of Indexed Data Error") + , ("PT2", "PlutusTx.IsData.Class.unsafeFromBuiltinData: Void is not supported") + , ("PT3", "PlutusTx.Ratio: zero denominator") + , ("PT5", "PlutusTx.Prelude.check: input is 'False'") + , ("PT6", "PlutusTx.List.!!: negative index") + , ("PT7", "PlutusTx.List.!!: index too large") + , ("PT8", "PlutusTx.List.head: empty list") + , ("PT9", "PlutusTx.List.tail: empty list") + , ("PT10", "PlutusTx.Enum.().succ: bad argument") + , ("PT11", "PlutusTx.Enum.().pred: bad argument") + , ("PT12", "PlutusTx.Enum.().toEnum: bad argument") + , ("PT13", "PlutusTx.Enum.Bool.succ: bad argument") + , ("PT14", "PlutusTx.Enum.Bool.pred: bad argument") + , ("PT15", "PlutusTx.Enum.Bool.toEnum: bad argument") + , ("PT16", "PlutusTx.Enum.Ordering.succ: bad argument") + , ("PT17", "PlutusTx.Enum.Ordering.pred: bad argument") + , ("PT18", "PlutusTx.Enum.Ordering.toEnum: bad argument") + , ("PT19", "PlutusTx.List.last: empty list") + , ("PT20", "PlutusTx.Ratio.recip: reciprocal of zero") + , ("PT21", "PlutusTx.BuiltinList.!!: negative index") + , ("PT22", "PlutusTx.BuiltinList.!!: index too large") + , ("PT23", "PlutusTx.BuiltinList.head: empty list") + , ("PT24", "PlutusTx.BuiltinList.tail: empty list") + , ("PT25", "PlutusTx.BuiltinList.last: empty list") + ] -- | The error happens in TH generation of indexed data reconstructCaseError :: Builtins.BuiltinString @@ -166,19 +167,19 @@ builtinListNegativeIndexError = "PT21" -- | PlutusTx.BuiltinList.!!: index too large builtinListIndexTooLargeError :: Builtins.BuiltinString builtinListIndexTooLargeError = "PT22" -{-# INLINABLE builtinListIndexTooLargeError #-} +{-# INLINEABLE builtinListIndexTooLargeError #-} -- | PlutusTx.BuiltinList.head: empty list headEmptyBuiltinListError :: Builtins.BuiltinString headEmptyBuiltinListError = "PT23" -{-# INLINABLE headEmptyBuiltinListError #-} +{-# INLINEABLE headEmptyBuiltinListError #-} -- | PlutusTx.BuiltinList.tail: empty list tailEmptyBuiltinListError :: Builtins.BuiltinString tailEmptyBuiltinListError = "PT24" -{-# INLINABLE tailEmptyBuiltinListError #-} +{-# INLINEABLE tailEmptyBuiltinListError #-} -- | PlutusTx.BuiltinList.last: empty list lastEmptyBuiltinListError :: Builtins.BuiltinString lastEmptyBuiltinListError = "PT25" -{-# INLINABLE lastEmptyBuiltinListError #-} +{-# INLINEABLE lastEmptyBuiltinListError #-} diff --git a/plutus-tx/src/PlutusTx/Eval.hs b/plutus-tx/src/PlutusTx/Eval.hs index abcdf7d3f87..fd135021adf 100644 --- a/plutus-tx/src/PlutusTx/Eval.hs +++ b/plutus-tx/src/PlutusTx/Eval.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module PlutusTx.Eval where @@ -22,23 +22,28 @@ import PlutusCore.Pretty import PlutusTx.Code (CompiledCode, getPlcNoAnn) import Prettyprinter (dot, indent, plural, vsep, (<+>)) import UntypedPlutusCore (DefaultFun, DefaultUni, Program (..)) -import UntypedPlutusCore.Evaluation.Machine.Cek (CekEvaluationException, CekReport (..), - CountingSt (..), cekResultToEither, counting, - logEmitter) +import UntypedPlutusCore.Evaluation.Machine.Cek ( + CekEvaluationException, + CekReport (..), + CountingSt (..), + cekResultToEither, + counting, + logEmitter, + ) import UntypedPlutusCore.Evaluation.Machine.Cek.Internal (NTerm, runCekDeBruijn) data EvalResult = EvalResult - { evalResult - :: Either - (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) - (NTerm DefaultUni DefaultFun ()) + { evalResult :: + Either + (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) + (NTerm DefaultUni DefaultFun ()) , evalResultBudget :: ExBudget , evalResultTraces :: [Text] } deriving stock (Show) instance Pretty EvalResult where - pretty EvalResult{..} = + pretty EvalResult {..} = vsep [ case evalResult of Left err -> @@ -82,28 +87,26 @@ displayExBudget = render . prettyExBudget prettyExBudget :: ExBudget -> Doc ann prettyExBudget - ExBudget{exBudgetCPU = ExCPU cpu, exBudgetMemory = ExMemory mem} = + ExBudget {exBudgetCPU = ExCPU cpu, exBudgetMemory = ExMemory mem} = vsep [ "CPU" <+> pretty (format commas (unSatInt cpu)) , "MEM" <+> pretty (format commas (unSatInt mem)) ] -{-| Evaluates the given 'CompiledCode' using the CEK machine -with the default machine parameters. --} +-- | Evaluates the given 'CompiledCode' using the CEK machine +-- with the default machine parameters. evaluateCompiledCode :: CompiledCode a -> EvalResult evaluateCompiledCode = evaluateCompiledCode' defaultCekParametersForTesting -{-| Evaluates the given 'CompiledCode' using the CEK machine -with the given machine parameters. --} -evaluateCompiledCode' - :: DefaultMachineParameters -> CompiledCode a -> EvalResult -evaluateCompiledCode' params code = EvalResult{..} - where - Program _ann _version term = getPlcNoAnn code - CekReport (cekResultToEither -> evalResult) (CountingSt evalResultBudget) evalResultTraces = - runCekDeBruijn params counting logEmitter term +-- | Evaluates the given 'CompiledCode' using the CEK machine +-- with the given machine parameters. +evaluateCompiledCode' :: + DefaultMachineParameters -> CompiledCode a -> EvalResult +evaluateCompiledCode' params code = EvalResult {..} + where + Program _ann _version term = getPlcNoAnn code + CekReport (cekResultToEither -> evalResult) (CountingSt evalResultBudget) evalResultTraces = + runCekDeBruijn params counting logEmitter term evaluatesToError :: CompiledCode a -> Bool evaluatesToError = not . evaluatesWithoutError diff --git a/plutus-tx/src/PlutusTx/Foldable.hs b/plutus-tx/src/PlutusTx/Foldable.hs index 3f1e2548729..0c2dcbb9bce 100644 --- a/plutus-tx/src/PlutusTx/Foldable.hs +++ b/plutus-tx/src/PlutusTx/Foldable.hs @@ -48,10 +48,10 @@ class Foldable t where instance Foldable [] where {-# INLINEABLE foldr #-} foldr f z = go - where - go = \case - [] -> z - x : xs -> f x (go xs) + where + go = \case + [] -> z + x : xs -> f x (go xs) instance Foldable Maybe where {-# INLINEABLE foldr #-} @@ -87,17 +87,17 @@ foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap f = foldr ((<>) . f) mempty -- | Plutus Tx version of 'Data.Foldable.foldl'. -foldl :: (Foldable t) => (b -> a -> b) -> b -> t a -> b +foldl :: Foldable t => (b -> a -> b) -> b -> t a -> b foldl f z t = foldr (\a g b -> g (f b a)) id t z {-# INLINEABLE foldl #-} -- | Plutus Tx version of 'Data.Foldable.toList'. -toList :: (Foldable t) => t a -> [a] +toList :: Foldable t => t a -> [a] toList t = build (\c n -> foldr c n t) {-# INLINE toList #-} -- | Plutus Tx version of 'Data.Foldable.length'. -length :: (Foldable t) => t a -> Integer +length :: Foldable t => t a -> Integer length = foldr (\_ acc -> acc + 1) 0 {-# INLINEABLE length #-} @@ -114,9 +114,9 @@ product = foldr (*) one -- | Plutus Tx version of 'Data.Foldable.traverse_'. traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ f = foldr c (pure ()) - where - c x k = f x *> k - {-# INLINE c #-} + where + c x k = f x *> k + {-# INLINE c #-} -- | Plutus Tx version of 'Data.Foldable.for_'. for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () @@ -126,9 +126,9 @@ for_ = flip traverse_ -- | Plutus Tx version of 'Data.Foldable.sequenceA_'. sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () sequenceA_ = foldr c (pure ()) - where - c m k = m *> k - {-# INLINE c #-} + where + c m k = m *> k + {-# INLINE c #-} -- | Plutus Tx version of 'Data.Foldable.asum'. asum :: (Foldable t, Alternative f) => t (f a) -> f a @@ -136,11 +136,11 @@ asum = foldr (<|>) empty {-# INLINE asum #-} -- | Plutus Tx version of 'Data.Foldable.concat'. -concat :: (Foldable t) => t [a] -> [a] +concat :: Foldable t => t [a] -> [a] concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs) {-# INLINE concat #-} -- | Plutus Tx version of 'Data.Foldable.concatMap'. -concatMap :: (Foldable t) => (a -> [b]) -> t a -> [b] +concatMap :: Foldable t => (a -> [b]) -> t a -> [b] concatMap f xs = build (\c n -> foldr (\x b -> foldr c b (f x)) n xs) {-# INLINE concatMap #-} diff --git a/plutus-tx/src/PlutusTx/Functor.hs b/plutus-tx/src/PlutusTx/Functor.hs index c427a94c5f7..3f5ff655a8b 100644 --- a/plutus-tx/src/PlutusTx/Functor.hs +++ b/plutus-tx/src/PlutusTx/Functor.hs @@ -1,5 +1,5 @@ {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Functor (Functor (..), (<$>), (<&>), (<$)) where @@ -25,41 +25,41 @@ class Functor f where infixl 4 <$> -- | Plutus Tx version of '(Data.Functor.<$>)'. -(<$>) :: (Functor f) => (a -> b) -> f a -> f b +(<$>) :: Functor f => (a -> b) -> f a -> f b (<$>) = fmap {-# INLINEABLE (<$>) #-} infixl 1 <&> -- | Plutus Tx version of '(Data.Functor.<&>)'. -(<&>) :: (Functor f) => f a -> (a -> b) -> f b +(<&>) :: Functor f => f a -> (a -> b) -> f b as <&> f = f <$> as {-# INLINEABLE (<&>) #-} infixl 4 <$ -- | Plutus Tx version of '(Data.Functor.<$)'. -(<$) :: (Functor f) => a -> f b -> f a +(<$) :: Functor f => a -> f b -> f a (<$) a = fmap (const a) {-# INLINEABLE (<$) #-} instance Functor [] where {-# INLINEABLE fmap #-} fmap f = go - where - go = \case - [] -> [] - x : xs -> f x : go xs + where + go = \case + [] -> [] + x : xs -> f x : go xs instance Functor Maybe where {-# INLINEABLE fmap #-} fmap f (Just a) = Just (f a) - fmap _ Nothing = Nothing + fmap _ Nothing = Nothing instance Functor (Either c) where {-# INLINEABLE fmap #-} fmap f (Right a) = Right (f a) - fmap _ (Left c) = Left c + fmap _ (Left c) = Left c instance Functor ((,) c) where {-# INLINEABLE fmap #-} diff --git a/plutus-tx/src/PlutusTx/IsData/Class.hs b/plutus-tx/src/PlutusTx/IsData/Class.hs index 2fbf9f86e4a..aa0ee629b5e 100644 --- a/plutus-tx/src/PlutusTx/IsData/Class.hs +++ b/plutus-tx/src/PlutusTx/IsData/Class.hs @@ -1,11 +1,11 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} @@ -44,14 +44,13 @@ class FromData (a :: Type) where fromBuiltinData :: BuiltinData -> Maybe a class UnsafeFromData (a :: Type) where - {-| Convert a value from 'BuiltinData', calling 'error' if this fails. - This is typically much faster than 'fromBuiltinData'. - - When implementing this function, make sure to call 'unsafeFromBuiltinData' - rather than 'fromBuiltinData' when converting substructures! - - This is a simple type without any validation, __use with caution__. - -} + -- | Convert a value from 'BuiltinData', calling 'error' if this fails. + -- This is typically much faster than 'fromBuiltinData'. + -- + -- When implementing this function, make sure to call 'unsafeFromBuiltinData' + -- rather than 'fromBuiltinData' when converting substructures! + -- + -- This is a simple type without any validation, __use with caution__. unsafeFromBuiltinData :: BuiltinData -> a instance ToData BuiltinData where @@ -65,18 +64,18 @@ instance UnsafeFromData BuiltinData where unsafeFromBuiltinData d = d instance - (TypeError ('Text "Int is not supported, use Integer instead")) - => ToData Haskell.Int + TypeError ('Text "Int is not supported, use Integer instead") => + ToData Haskell.Int where toBuiltinData = Haskell.error "unsupported" instance - (TypeError ('Text "Int is not supported, use Integer instead")) - => FromData Haskell.Int + TypeError ('Text "Int is not supported, use Integer instead") => + FromData Haskell.Int where fromBuiltinData = Haskell.error "unsupported" instance - (TypeError ('Text "Int is not supported, use Integer instead")) - => UnsafeFromData Haskell.Int + TypeError ('Text "Int is not supported, use Integer instead") => + UnsafeFromData Haskell.Int where unsafeFromBuiltinData = Haskell.error "unsupported" @@ -102,18 +101,18 @@ instance UnsafeFromData Builtins.BuiltinByteString where {-# INLINEABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData = BI.unsafeDataAsB -instance (ToData a) => ToData [a] where +instance ToData a => ToData [a] where {-# INLINEABLE toBuiltinData #-} toBuiltinData l = BI.mkList (mapToBuiltin l) - where - {-# INLINE mapToBuiltin #-} - mapToBuiltin :: [a] -> BI.BuiltinList BI.BuiltinData - mapToBuiltin = go - where - go :: [a] -> BI.BuiltinList BI.BuiltinData - go [] = mkNil - go (x : xs) = BI.mkCons (toBuiltinData x) (go xs) -instance (FromData a) => FromData [a] where + where + {-# INLINE mapToBuiltin #-} + mapToBuiltin :: [a] -> BI.BuiltinList BI.BuiltinData + mapToBuiltin = go + where + go :: [a] -> BI.BuiltinList BI.BuiltinData + go [] = mkNil + go (x : xs) = BI.mkCons (toBuiltinData x) (go xs) +instance FromData a => FromData [a] where {-# INLINEABLE fromBuiltinData #-} fromBuiltinData d = matchData' @@ -123,23 +122,23 @@ instance (FromData a) => FromData [a] where traverseFromBuiltin (\_ -> Nothing) (\_ -> Nothing) - where - {-# INLINE traverseFromBuiltin #-} - traverseFromBuiltin :: BI.BuiltinList BI.BuiltinData -> Maybe [a] - traverseFromBuiltin = go - where - go :: BI.BuiltinList BI.BuiltinData -> Maybe [a] - go = caseList' (pure []) (\x xs -> liftA2 (:) (fromBuiltinData x) (go xs)) -instance (UnsafeFromData a) => UnsafeFromData [a] where + where + {-# INLINE traverseFromBuiltin #-} + traverseFromBuiltin :: BI.BuiltinList BI.BuiltinData -> Maybe [a] + traverseFromBuiltin = go + where + go :: BI.BuiltinList BI.BuiltinData -> Maybe [a] + go = caseList' (pure []) (\x xs -> liftA2 (:) (fromBuiltinData x) (go xs)) +instance UnsafeFromData a => UnsafeFromData [a] where {-# INLINEABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData d = mapFromBuiltin (BI.unsafeDataAsList d) - where - {-# INLINE mapFromBuiltin #-} - mapFromBuiltin :: BI.BuiltinList BI.BuiltinData -> [a] - mapFromBuiltin = go - where - go :: BI.BuiltinList BI.BuiltinData -> [a] - go = caseList' [] (\x xs -> unsafeFromBuiltinData x : go xs) + where + {-# INLINE mapFromBuiltin #-} + mapFromBuiltin :: BI.BuiltinList BI.BuiltinData -> [a] + mapFromBuiltin = go + where + go :: BI.BuiltinList BI.BuiltinData -> [a] + go = caseList' [] (\x xs -> unsafeFromBuiltinData x : go xs) instance ToData Void where {-# INLINEABLE toBuiltinData #-} @@ -151,14 +150,13 @@ instance UnsafeFromData Void where {-# INLINEABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData _ = traceError voidIsNotSupportedError -{-| For the BLS12-381 G1 and G2 types we use the `compress` functions to convert - to a ByteString and then encode that as Data as usual. We have to be more - careful going the other way because we decode a Data object to (possibly) get - a BuiltinByteString and then uncompress the underlying ByteString to get a - group element. However uncompression can fail so we have to check what - happens: we don't use bls12_381_G?_uncompress because that invokes `error` if - something goes wrong (but we do use it for unsafeFromData). --} +-- | For the BLS12-381 G1 and G2 types we use the `compress` functions to convert +-- to a ByteString and then encode that as Data as usual. We have to be more +-- careful going the other way because we decode a Data object to (possibly) get +-- a BuiltinByteString and then uncompress the underlying ByteString to get a +-- group element. However uncompression can fail so we have to check what +-- happens: we don't use bls12_381_G?_uncompress because that invokes `error` if +-- something goes wrong (but we do use it for unsafeFromData). instance ToData Builtins.BuiltinBLS12_381_G1_Element where {-# INLINEABLE toBuiltinData #-} toBuiltinData = toBuiltinData . Builtins.bls12_381_G1_compress @@ -186,36 +184,35 @@ instance UnsafeFromData Builtins.BuiltinBLS12_381_G2_Element where {-# INLINEABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData = Builtins.bls12_381_G2_uncompress . unsafeFromBuiltinData -{-| We do not provide instances of any of these classes for - BuiltinBLS12_381_MlResult since there is no serialisation format: we expect - that values of that type will only occur as the result of on-chain - computations. --} +-- | We do not provide instances of any of these classes for +-- BuiltinBLS12_381_MlResult since there is no serialisation format: we expect +-- that values of that type will only occur as the result of on-chain +-- computations. instance - (TypeError ('Text "toBuiltinData is not supported for BuiltinBLS12_381_MlResult")) - => ToData Builtins.BuiltinBLS12_381_MlResult + TypeError ('Text "toBuiltinData is not supported for BuiltinBLS12_381_MlResult") => + ToData Builtins.BuiltinBLS12_381_MlResult where toBuiltinData = Haskell.error "unsupported" instance - (TypeError ('Text "fromBuiltinData is not supported for BuiltinBLS12_381_MlResult")) - => FromData Builtins.BuiltinBLS12_381_MlResult + TypeError ('Text "fromBuiltinData is not supported for BuiltinBLS12_381_MlResult") => + FromData Builtins.BuiltinBLS12_381_MlResult where fromBuiltinData = Haskell.error "unsupported" instance - (TypeError ('Text "unsafeFromBuiltinData is not supported for BuiltinBLS12_381_MlResult")) - => UnsafeFromData Builtins.BuiltinBLS12_381_MlResult + TypeError ('Text "unsafeFromBuiltinData is not supported for BuiltinBLS12_381_MlResult") => + UnsafeFromData Builtins.BuiltinBLS12_381_MlResult where unsafeFromBuiltinData = Haskell.error "unsupported" -- | Convert a value to 'PLC.Data'. -toData :: (ToData a) => a -> PLC.Data +toData :: ToData a => a -> PLC.Data toData a = builtinDataToData (toBuiltinData a) -- | Convert a value from 'PLC.Data', returning 'Nothing' if this fails. -fromData :: (FromData a) => PLC.Data -> Maybe a +fromData :: FromData a => PLC.Data -> Maybe a fromData d = fromBuiltinData (BuiltinData d) -- | Convert a value from 'PLC.Data', throwing if this fails. -unsafeFromData :: (UnsafeFromData a) => PLC.Data -> a +unsafeFromData :: UnsafeFromData a => PLC.Data -> a unsafeFromData d = unsafeFromBuiltinData (BuiltinData d) diff --git a/plutus-tx/src/PlutusTx/IsData/TH.hs b/plutus-tx/src/PlutusTx/IsData/TH.hs index 0b544ceea1a..fa2db4d4443 100644 --- a/plutus-tx/src/PlutusTx/IsData/TH.hs +++ b/plutus-tx/src/PlutusTx/IsData/TH.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} module PlutusTx.IsData.TH ( unsafeFromDataClause, @@ -14,7 +14,6 @@ module PlutusTx.IsData.TH ( mkConstrPartsMatchPattern, mkUnsafeConstrPartsMatchPattern, AsDataProdType (..), - fromDataClause, ) where @@ -60,10 +59,10 @@ mkConstrPartsMatchPattern conIx extractFieldNames = extractFieldNames <&> \n -> [p|(fromBuiltinData -> Just $(TH.varP n))|] extractArgsPat = go extractArgPats - where - go [] = [p|_|] - go [x] = [p|(Builtins.headMaybe -> Just $x)|] - go (x : xs) = [p|(Builtins.uncons -> Just ($x, $(go xs)))|] + where + go [] = [p|_|] + go [x] = [p|(Builtins.headMaybe -> Just $x)|] + go (x : xs) = [p|(Builtins.uncons -> Just ($x, $(go xs)))|] pat = [p|($ixMatchPat, $extractArgsPat)|] in pat @@ -75,25 +74,25 @@ mkListPartsMatchPattern extractFieldNames = extractArgPats = extractFieldNames <&> \n -> [p|(fromBuiltinData -> Just $(TH.varP n))|] - go [] = [p|_|] - go [x] = [p|(Builtins.headMaybe -> Just $x)|] + go [] = [p|_|] + go [x] = [p|(Builtins.headMaybe -> Just $x)|] go (x : xs) = [p|(Builtins.uncons -> Just ($x, $(go xs)))|] - in [p|$(go extractArgPats)|] + in + [p|$(go extractArgPats)|] -{-| If generating pattern synonyms for a product type declared with 'asData', -we can avoid the index match, as we know that the type only has one constructor. --} +-- | If generating pattern synonyms for a product type declared with 'asData', +-- we can avoid the index match, as we know that the type only has one constructor. data AsDataProdType = IsAsDataProdType | IsNotAsDataProdType -- TODO: safe match for the whole thing? not needed atm -mkUnsafeConstrMatchPattern - :: AsDataProdType - -> Integer - -> [TH.Name] - -> TH.PatQ +mkUnsafeConstrMatchPattern :: + AsDataProdType -> + Integer -> + [TH.Name] -> + TH.PatQ mkUnsafeConstrMatchPattern isProduct conIx extractFieldNames = case isProduct of IsAsDataProdType -> @@ -113,11 +112,11 @@ mkUnsafeConstrMatchPattern isProduct conIx extractFieldNames = ) |] -mkUnsafeConstrPartsMatchPattern - :: AsDataProdType - -> Integer - -> [TH.Name] - -> TH.PatQ +mkUnsafeConstrPartsMatchPattern :: + AsDataProdType -> + Integer -> + [TH.Name] -> + TH.PatQ mkUnsafeConstrPartsMatchPattern isProduct conIx extractFieldNames = let -- (==) i -> True @@ -127,26 +126,26 @@ mkUnsafeConstrPartsMatchPattern isProduct conIx extractFieldNames = extractFieldNames <&> \n -> [p|(unsafeFromBuiltinData -> $(TH.varP n))|] extractArgsPat = go extractArgPats - where - go [] = [p|_|] - go [x] = [p|(BI.head -> $x)|] - go (x : xs) = [p|(wrapUnsafeUncons -> ($x, $(go xs)))|] + where + go [] = [p|_|] + go [x] = [p|(BI.head -> $x)|] + go (x : xs) = [p|(wrapUnsafeUncons -> ($x, $(go xs)))|] pat = -- We can safely omit the index match if we know that the type is a product type case isProduct of - IsAsDataProdType -> [p|$extractArgsPat|] + IsAsDataProdType -> [p|$extractArgsPat|] IsNotAsDataProdType -> [p|($ixMatchPat, $extractArgsPat)|] in pat toDataClause :: (TH.ConstructorInfo, Int) -> TH.Q TH.Clause -toDataClause (TH.ConstructorInfo{TH.constructorName = name, TH.constructorFields = argTys}, index) = do +toDataClause (TH.ConstructorInfo {TH.constructorName = name, TH.constructorFields = argTys}, index) = do argNames <- for argTys $ \_ -> TH.newName "arg" let create = mkConstrCreateExpr (fromIntegral index) argNames TH.clause [TH.conP name (fmap TH.varP argNames)] (TH.normalB create) [] toDataListClause :: TH.ConstructorInfo -> TH.Q TH.Clause -toDataListClause TH.ConstructorInfo{TH.constructorName = name, TH.constructorFields = argTys} = do +toDataListClause TH.ConstructorInfo {TH.constructorName = name, TH.constructorFields = argTys} = do argNames <- for argTys $ \_ -> TH.newName "arg" let create = [|BI.mkList $(mkListCreateExpr argNames)|] TH.clause [TH.conP name (fmap TH.varP argNames)] (TH.normalB create) [] @@ -155,7 +154,7 @@ toDataClauses :: [(TH.ConstructorInfo, Int)] -> [TH.Q TH.Clause] toDataClauses indexedCons = toDataClause <$> indexedCons reconstructCase :: (TH.ConstructorInfo, Int) -> TH.MatchQ -reconstructCase (TH.ConstructorInfo{TH.constructorName = name, TH.constructorFields = argTys}, index) = do +reconstructCase (TH.ConstructorInfo {TH.constructorName = name, TH.constructorFields = argTys}, index) = do argNames <- for argTys $ \_ -> TH.newName "arg" -- Build the constructor application, assuming that all the arguments are in scope @@ -192,7 +191,7 @@ fromDataClause indexedCons = do TH.clause [TH.varP dName] (TH.normalB body) [] fromDataListClause :: TH.ConstructorInfo -> TH.Q TH.Clause -fromDataListClause TH.ConstructorInfo{TH.constructorName = consName, TH.constructorFields = argTys} = do +fromDataListClause TH.ConstructorInfo {TH.constructorName = consName, TH.constructorFields = argTys} = do dName <- TH.newName "d" argsName <- TH.newName "args" -- Call the clause for each constructor, falling through to the next one, until we get to the end in which case we call 'error' @@ -222,7 +221,7 @@ fromDataListClause TH.ConstructorInfo{TH.constructorName = consName, TH.construc TH.clause [TH.varP dName] (TH.normalB body) [] unsafeReconstructCase :: (TH.ConstructorInfo, Int) -> TH.MatchQ -unsafeReconstructCase (TH.ConstructorInfo{TH.constructorName = name, TH.constructorFields = argTys}, index) = do +unsafeReconstructCase (TH.ConstructorInfo {TH.constructorName = name, TH.constructorFields = argTys}, index) = do argNames <- for argTys $ \_ -> TH.newName "arg" -- Build the constructor application, assuming that all the arguments are in scope @@ -234,7 +233,7 @@ unsafeReconstructCase (TH.ConstructorInfo{TH.constructorName = name, TH.construc [] unsafeReconstructListCase :: TH.ConstructorInfo -> TH.MatchQ -unsafeReconstructListCase TH.ConstructorInfo{TH.constructorName = name, TH.constructorFields = argTys} = do +unsafeReconstructListCase TH.ConstructorInfo {TH.constructorName = name, TH.constructorFields = argTys} = do argNames <- for argTys $ \_ -> TH.newName "arg" -- Build the constructor application, assuming that all the arguments are in scope @@ -261,7 +260,7 @@ unsafeFromDataClause indexedCons = do intCasingEligible = let idxs = snd <$> indexedConsSorted - in [0..(length idxs - 1)] == idxs + in [0 .. (length idxs - 1)] == idxs if intCasingEligible then do @@ -269,12 +268,13 @@ unsafeFromDataClause indexedCons = do kases = TH.listE $ (\(conInfo, _) -> TH.lamCaseE [unsafeReconstructListCase conInfo, finalCase]) - <$> indexedConsSorted + <$> indexedConsSorted body = - [| BI.casePair (BI.unsafeDataAsConstr $(TH.varE dName)) $ - \($(TH.varP indexName)) ($(TH.varP argsName)) -> - (caseInteger $(TH.varE indexName) $kases) $(TH.varE argsName) - |] + [| + BI.casePair (BI.unsafeDataAsConstr $(TH.varE dName)) $ + \($(TH.varP indexName)) ($(TH.varP argsName)) -> + (caseInteger $(TH.varE indexName) $kases) $(TH.varE argsName) + |] TH.clause [TH.varP dName] (TH.normalB body) [] else do @@ -318,17 +318,15 @@ defaultIndex name = do info <- TH.reifyDatatype name pure $ zip (TH.constructorName <$> TH.datatypeCons info) [0 ..] -{-| Generate a 'FromData' and a 'ToData' instance for a type. -This may not be stable in the face of constructor additions, -renamings, etc. Use 'makeIsDataIndexed' if you need stability. --} +-- | Generate a 'FromData' and a 'ToData' instance for a type. +-- This may not be stable in the face of constructor additions, +-- renamings, etc. Use 'makeIsDataIndexed' if you need stability. unstableMakeIsData :: TH.Name -> TH.Q [TH.Dec] unstableMakeIsData name = makeIsDataIndexed name =<< defaultIndex name -{-| Generate a 'ToData', 'FromData and a 'UnsafeFromData' instances for a type, -using an explicit mapping of constructor names to indices. -Use this for types where you need to keep the representation stable. --} +-- | Generate a 'ToData', 'FromData and a 'UnsafeFromData' instances for a type, +-- using an explicit mapping of constructor names to indices. +-- Use this for types where you need to keep the representation stable. makeIsDataIndexed :: TH.Name -> [(TH.Name, Int)] -> TH.Q [TH.Dec] makeIsDataIndexed dataTypeName indices = do dataTypeInfo <- TH.reifyDatatype dataTypeName @@ -337,7 +335,7 @@ makeIsDataIndexed dataTypeName indices = do indexedCons <- for (TH.datatypeCons dataTypeInfo) $ \ctorInfo -> case lookup (TH.constructorName ctorInfo) indices of - Just i -> pure (ctorInfo, i) + Just i -> pure (ctorInfo, i) Nothing -> fail $ "No index given for constructor" ++ show (TH.constructorName ctorInfo) toDataInst <- do @@ -377,7 +375,7 @@ makeIsDataIndexed dataTypeName indices = do [unsafeFromDataPrag, unsafeFromDataDecl] pure [toDataInst, fromDataInst, unsafeFromDataInst] - where + where #if MIN_VERSION_template_haskell(2,17,0) tyvarbndrName (TH.PlainTV n _) = n tyvarbndrName (TH.KindedTV n _ _) = n @@ -386,11 +384,10 @@ makeIsDataIndexed dataTypeName indices = do tyvarbndrName (TH.KindedTV n _) = n #endif -{-| Generates `FromData` and `ToData` instances for a type. -Requires the type to have exactly one constructor, -since instances created by `deriveIsDataAsList` use a list encoding -instead of `Constr` and thus cannot represent constructor indices. --} +-- | Generates `FromData` and `ToData` instances for a type. +-- Requires the type to have exactly one constructor, +-- since instances created by `deriveIsDataAsList` use a list encoding +-- instead of `Constr` and thus cannot represent constructor indices. makeIsDataAsList :: TH.Name -> TH.Q [TH.Dec] makeIsDataAsList dataTypeName = do dataTypeInfo <- TH.reifyDatatype dataTypeName @@ -400,7 +397,7 @@ makeIsDataAsList dataTypeName = do cons <- case TH.datatypeCons dataTypeInfo of [cons] -> pure cons - _ -> fail "Only data types with single constructor are eligible for 'makeIsDataAsList'" + _ -> fail "Only data types with single constructor are eligible for 'makeIsDataAsList'" toDataInst <- do let constraints = @@ -439,7 +436,7 @@ makeIsDataAsList dataTypeName = do [unsafeFromDataPrag, unsafeFromDataDecl] pure [toDataInst, fromDataInst, unsafeFromDataInst] - where + where #if MIN_VERSION_template_haskell(2,17,0) tyvarbndrName (TH.PlainTV n _) = n tyvarbndrName (TH.KindedTV n _ _) = n @@ -448,7 +445,6 @@ makeIsDataAsList dataTypeName = do tyvarbndrName (TH.KindedTV n _) = n #endif - {- Note [indexMatchCase and fallthrough] `indexMatchCase` and `fallthrough` need to be non-strict, because (1) at most one of them needs to be evaluated; (2) evaluating `indexMatchCase` when it shouldn't be evaluated diff --git a/plutus-tx/src/PlutusTx/Lattice.hs b/plutus-tx/src/PlutusTx/Lattice.hs index 5f6daa3e031..4adef2ab00f 100644 --- a/plutus-tx/src/PlutusTx/Lattice.hs +++ b/plutus-tx/src/PlutusTx/Lattice.hs @@ -6,37 +6,33 @@ import PlutusTx.Bool import PlutusTx.Monoid import PlutusTx.Semigroup -{-| A join semi-lattice, i.e. a partially ordered set equipped with a -binary operation '(\/)'. - -Note that the mathematical definition would require an ordering constraint - -we omit that so we can define instances for e.g. '(->)'. --} +-- | A join semi-lattice, i.e. a partially ordered set equipped with a +-- binary operation '(\/)'. +-- +-- Note that the mathematical definition would require an ordering constraint - +-- we omit that so we can define instances for e.g. '(->)'. class JoinSemiLattice a where (\/) :: a -> a -> a -{-| A meet semi-lattice, i.e. a partially ordered set equipped with a -binary operation '(/\)'. - -Note that the mathematical definition would require an ordering constraint - -we omit that so we can define instances for e.g. '(->)'. --} +-- | A meet semi-lattice, i.e. a partially ordered set equipped with a +-- binary operation '(/\)'. +-- +-- Note that the mathematical definition would require an ordering constraint - +-- we omit that so we can define instances for e.g. '(->)'. class MeetSemiLattice a where (/\) :: a -> a -> a -- | A lattice. type Lattice a = (JoinSemiLattice a, MeetSemiLattice a) -{-| A bounded join semi-lattice, i.e. a join semi-lattice augmented with -a distinguished element 'bottom' which is the unit of '(\/)'. --} -class (JoinSemiLattice a) => BoundedJoinSemiLattice a where +-- | A bounded join semi-lattice, i.e. a join semi-lattice augmented with +-- a distinguished element 'bottom' which is the unit of '(\/)'. +class JoinSemiLattice a => BoundedJoinSemiLattice a where bottom :: a -{-| A bounded meet semi-lattice, i.e. a meet semi-lattice augmented with -a distinguished element 'top' which is the unit of '(/\)'. --} -class (MeetSemiLattice a) => BoundedMeetSemiLattice a where +-- | A bounded meet semi-lattice, i.e. a meet semi-lattice augmented with +-- a distinguished element 'top' which is the unit of '(/\)'. +class MeetSemiLattice a => BoundedMeetSemiLattice a where top :: a -- | A bounded lattice. @@ -47,19 +43,19 @@ type BoundedLattice a = (BoundedJoinSemiLattice a, BoundedMeetSemiLattice a) -- | A wrapper witnessing that a join semi-lattice is a monoid with '(\/)' and 'bottom'. newtype Join a = Join a -instance (JoinSemiLattice a) => Semigroup (Join a) where +instance JoinSemiLattice a => Semigroup (Join a) where Join l <> Join r = Join (l \/ r) -instance (BoundedJoinSemiLattice a) => Monoid (Join a) where +instance BoundedJoinSemiLattice a => Monoid (Join a) where mempty = Join bottom -- | A wrapper witnessing that a meet semi-lattice is a monoid with '(/\)' and 'top'. newtype Meet a = Meet a -instance (MeetSemiLattice a) => Semigroup (Meet a) where +instance MeetSemiLattice a => Semigroup (Meet a) where Meet l <> Meet r = Meet (l /\ r) -instance (BoundedMeetSemiLattice a) => Monoid (Meet a) where +instance BoundedMeetSemiLattice a => Monoid (Meet a) where mempty = Meet top -- Instances @@ -96,18 +92,18 @@ instance (BoundedMeetSemiLattice a, BoundedMeetSemiLattice b) => BoundedMeetSemi {-# INLINEABLE top #-} top = (top, top) -instance (JoinSemiLattice b) => JoinSemiLattice (a -> b) where +instance JoinSemiLattice b => JoinSemiLattice (a -> b) where {-# INLINEABLE (\/) #-} (f \/ g) a = f a \/ g a -instance (BoundedJoinSemiLattice b) => BoundedJoinSemiLattice (a -> b) where +instance BoundedJoinSemiLattice b => BoundedJoinSemiLattice (a -> b) where {-# INLINEABLE bottom #-} bottom _ = bottom -instance (MeetSemiLattice b) => MeetSemiLattice (a -> b) where +instance MeetSemiLattice b => MeetSemiLattice (a -> b) where {-# INLINEABLE (/\) #-} (f /\ g) a = f a /\ g a -instance (BoundedMeetSemiLattice b) => BoundedMeetSemiLattice (a -> b) where +instance BoundedMeetSemiLattice b => BoundedMeetSemiLattice (a -> b) where {-# INLINEABLE top #-} top _ = top diff --git a/plutus-tx/src/PlutusTx/Lift.hs b/plutus-tx/src/PlutusTx/Lift.hs index 80e7d6d9409..baf29e6f9a0 100644 --- a/plutus-tx/src/PlutusTx/Lift.hs +++ b/plutus-tx/src/PlutusTx/Lift.hs @@ -1,8 +1,8 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} module PlutusTx.Lift ( safeLiftWith, @@ -66,32 +66,31 @@ import Data.Proxy -- We do not use qualified import because the whole module contains off-chain code import Prelude as Haskell -{-| Get a Plutus Core term corresponding to the given value. Allows configuring -PIR and UPLC optimization options. --} -safeLiftWith - :: forall a uni fun m - . ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => (PIR.CompilationOpts () -> PIR.CompilationOpts ()) - -- ^ Modifier of PIR compilation options - -> (PLC.CompilationOpts Name fun (Provenance ()) -> PLC.CompilationOpts Name fun (Provenance ())) - -- ^ Modifier of UPLC compilation options - -> PLC.Version - -> a - -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) +-- | Get a Plutus Core term corresponding to the given value. Allows configuring +-- PIR and UPLC optimization options. +safeLiftWith :: + forall a uni fun m. + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + -- | Modifier of PIR compilation options + (PIR.CompilationOpts () -> PIR.CompilationOpts ()) -> + -- | Modifier of UPLC compilation options + (PLC.CompilationOpts Name fun (Provenance ()) -> PLC.CompilationOpts Name fun (Provenance ())) -> + PLC.Version -> + a -> + m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) safeLiftWith f g v x = do pir <- liftQuote $ runDefT () $ Lift.lift x tcConfig <- modifyError (PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig $ Original () @@ -111,52 +110,50 @@ safeLiftWith f g v x = do modifyError (PLCError . PLC.FreeVariableErrorE) $ traverseOf UPLC.progTerm UPLC.deBruijnTerm uplc pure (void pir, void db) -{-| Get a Plutus Core term corresponding to the given value, applying default PIR/UPLC -optimizations. --} -safeLift - :: forall a uni fun m - . ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) +-- | Get a Plutus Core term corresponding to the given value, applying default PIR/UPLC +-- optimizations. +safeLift :: + forall a uni fun m. + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) safeLift = safeLiftWith id id -{-| Like `safeLift` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -safeLiftUnopt - :: forall a uni fun m - . ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) +-- | Like `safeLift` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +safeLiftUnopt :: + forall a uni fun m. + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) safeLiftUnopt = safeLiftWith (set coMaxSimplifierIterations 0) @@ -164,68 +161,66 @@ safeLiftUnopt = . set (PLC.coSimplifyOpts . UPLC.soMaxCseIterations) 0 ) -{-| Get a Plutus Core program corresponding to the given value, applying default PIR/UPLC -optimizations. --} -safeLiftProgram - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) +-- | Get a Plutus Core program corresponding to the given value, applying default PIR/UPLC +-- optimizations. +safeLiftProgram :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) safeLiftProgram v x = bimap (PIR.Program () v) (UPLC.Program () v) <$> safeLift v x -{-| Like `safeLiftProgram` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -safeLiftProgramUnopt - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) +-- | Like `safeLiftProgram` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +safeLiftProgramUnopt :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) safeLiftProgramUnopt v x = bimap (PIR.Program () v) (UPLC.Program () v) <$> safeLiftUnopt v x -safeLiftCode - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version -> a -> m (CompiledCodeIn uni fun a) +safeLiftCode :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> a -> m (CompiledCodeIn uni fun a) safeLiftCode v = fmap ( \(pir, uplc) -> @@ -233,25 +228,24 @@ safeLiftCode v = ) . safeLiftProgram v -{-| Like `safeLiftCode` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -safeLiftCodeUnopt - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version -> a -> m (CompiledCodeIn uni fun a) +-- | Like `safeLiftCode` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +safeLiftCodeUnopt :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> a -> m (CompiledCodeIn uni fun a) safeLiftCodeUnopt v = fmap ( \(pir, uplc) -> @@ -259,180 +253,174 @@ safeLiftCodeUnopt v = ) . safeLiftProgramUnopt v -unsafely - :: (ThrowableBuiltins uni fun) - => ExceptT (Error uni fun (Provenance ())) Quote a -> a +unsafely :: + ThrowableBuiltins uni fun => + ExceptT (Error uni fun (Provenance ())) Quote a -> a unsafely ma = runQuote $ do run <- runExceptT ma case run of - Left e -> throw e + Left e -> throw e Right t -> pure t -{-| Get a Plutus Core term corresponding to the given value, throwing any errors that -occur as exceptions and ignoring fresh names. The default PIR/UPLC optimizations -are applied. --} -lift - :: ( Lift.Lift uni a - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.GEq uni - , PLC.Everywhere uni Eq - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) +-- | Get a Plutus Core term corresponding to the given value, throwing any errors that +-- occur as exceptions and ignoring fresh names. The default PIR/UPLC optimizations +-- are applied. +lift :: + ( Lift.Lift uni a + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.GEq uni + , PLC.Everywhere uni Eq + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) lift v a = unsafely $ safeLift v a -{-| Like `lift` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -liftUnopt - :: ( Lift.Lift uni a - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.GEq uni - , PLC.Everywhere uni Eq - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) +-- | Like `lift` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +liftUnopt :: + ( Lift.Lift uni a + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.GEq uni + , PLC.Everywhere uni Eq + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) liftUnopt v a = unsafely $ safeLiftUnopt v a -- | Get a Plutus Core program corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names. -liftProgram - :: ( Lift.Lift uni a - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.GEq uni - , PLC.Everywhere uni Eq - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) +liftProgram :: + ( Lift.Lift uni a + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.GEq uni + , PLC.Everywhere uni Eq + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) liftProgram v x = unsafely $ safeLiftProgram v x -{-| Like `liftProgram` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -liftProgramUnopt - :: ( Lift.Lift uni a - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.GEq uni - , PLC.Everywhere uni Eq - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version - -> a - -> (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) +-- | Like `liftProgram` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +liftProgramUnopt :: + ( Lift.Lift uni a + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.GEq uni + , PLC.Everywhere uni Eq + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> + a -> + (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) liftProgramUnopt v x = unsafely $ safeLiftProgram v x -- | Get a Plutus Core program in the default universe with the default version, corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names. -liftProgramDef - :: (Lift.Lift PLC.DefaultUni a) - => a - -> ( PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () - , UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () - ) +liftProgramDef :: + Lift.Lift PLC.DefaultUni a => + a -> + ( PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () + , UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + ) liftProgramDef = liftProgram PLC.latestVersion -{-| Like `liftProgramDef` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -liftProgramDefUnopt - :: (Lift.Lift PLC.DefaultUni a) - => a - -> ( PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () - , UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () - ) +-- | Like `liftProgramDef` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +liftProgramDefUnopt :: + Lift.Lift PLC.DefaultUni a => + a -> + ( PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () + , UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + ) liftProgramDefUnopt = liftProgramUnopt PLC.latestVersion -- | Get a Plutus Core program corresponding to the given value as a 'CompiledCodeIn', throwing any errors that occur as exceptions and ignoring fresh names. -liftCode - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version -> a -> CompiledCodeIn uni fun a +liftCode :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> a -> CompiledCodeIn uni fun a liftCode v x = unsafely $ safeLiftCode v x -{-| Like `liftCode` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -liftCodeUnopt - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => PLC.Version -> a -> CompiledCodeIn uni fun a +-- | Like `liftCode` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +liftCodeUnopt :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + PLC.Version -> a -> CompiledCodeIn uni fun a liftCodeUnopt v x = unsafely $ safeLiftCodeUnopt v x -- | Get a Plutus Core program with the default version, corresponding to the given value as a 'CompiledCodeIn', throwing any errors that occur as exceptions and ignoring fresh names. -liftCodeDef - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => a -> CompiledCodeIn uni fun a +liftCodeDef :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + a -> CompiledCodeIn uni fun a liftCodeDef = liftCode PLC.latestVersion -{-| Like `liftCodeDef` but does not apply PIR/UPLC optimizations. Use this option -where lifting speed is more important than optimal code. --} -liftCodeDefUnopt - :: ( Lift.Lift uni a - , PLC.GEq uni - , PLC.Everywhere uni Eq - , ThrowableBuiltins uni fun - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => a -> CompiledCodeIn uni fun a +-- | Like `liftCodeDef` but does not apply PIR/UPLC optimizations. Use this option +-- where lifting speed is more important than optimal code. +liftCodeDefUnopt :: + ( Lift.Lift uni a + , PLC.GEq uni + , PLC.Everywhere uni Eq + , ThrowableBuiltins uni fun + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + a -> CompiledCodeIn uni fun a liftCodeDefUnopt = liftCodeUnopt PLC.latestVersion {- Note [Checking the type of a term with Typeable] @@ -448,23 +436,23 @@ iff the original term has the given type. We opt for `(\x : -> x) ter -} -- | Check that PLC term has the given type. -typeCheckAgainst - :: forall a uni fun m - . ( Lift.Typeable uni a - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.GEq uni - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - ) - => Proxy a - -> PLC.Program PLC.TyName PLC.Name uni fun () - -> m () +typeCheckAgainst :: + forall a uni fun m. + ( Lift.Typeable uni a + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.GEq uni + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + ) => + Proxy a -> + PLC.Program PLC.TyName PLC.Name uni fun () -> + m () typeCheckAgainst p (PLC.Program _ v plcTerm) = do -- See Note [Checking the type of a term with Typeable] term <- PIR.embedTerm <$> PLC.rename plcTerm @@ -488,25 +476,25 @@ typeCheckAgainst p (PLC.Program _ v plcTerm) = do void $ modifyError (PLCError . PLC.TypeErrorE) $ PLC.inferTypeOfProgram tcConfig compiled -- | Try to interpret a PLC program as a 'CompiledCodeIn' of the given type. Returns successfully iff the program has the right type. -typeCode - :: forall a uni fun m - . ( Lift.Typeable uni a - , MonadError (PIR.Error uni fun (Provenance ())) m - , MonadQuote m - , PLC.GEq uni - , PLC.Everywhere uni Eq - , PLC.Typecheckable uni fun - , PLC.CaseBuiltin uni - , PrettyUni uni - , Pretty fun - , Default (PLC.CostingPart uni fun) - , Default (PIR.BuiltinsInfo uni fun) - , Default (PIR.RewriteRules uni fun) - , Hashable fun - ) - => Proxy a - -> PLC.Program PLC.TyName PLC.Name uni fun () - -> m (CompiledCodeIn uni fun a) +typeCode :: + forall a uni fun m. + ( Lift.Typeable uni a + , MonadError (PIR.Error uni fun (Provenance ())) m + , MonadQuote m + , PLC.GEq uni + , PLC.Everywhere uni Eq + , PLC.Typecheckable uni fun + , PLC.CaseBuiltin uni + , PrettyUni uni + , Pretty fun + , Default (PLC.CostingPart uni fun) + , Default (PIR.BuiltinsInfo uni fun) + , Default (PIR.RewriteRules uni fun) + , Hashable fun + ) => + Proxy a -> + PLC.Program PLC.TyName PLC.Name uni fun () -> + m (CompiledCodeIn uni fun a) typeCode p prog = do _ <- typeCheckAgainst p prog compiled <- diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index f64cd9080ca..f5ac45d7a68 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -1,19 +1,19 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusTx.Lift.Class ( Typeable (..), @@ -34,8 +34,13 @@ import PlutusCore.Value import PlutusIR.MkPir import PlutusTx.Builtins import PlutusTx.Builtins.HasBuiltin (FromBuiltin, HasFromBuiltin) -import PlutusTx.Builtins.Internal (BuiltinInteger, BuiltinList, BuiltinPair, BuiltinUnit, - BuiltinValue) +import PlutusTx.Builtins.Internal ( + BuiltinInteger, + BuiltinList, + BuiltinPair, + BuiltinUnit, + BuiltinValue, + ) import Language.Haskell.TH qualified as TH hiding (newName) @@ -78,16 +83,14 @@ inline all the definitions so that the overall expression can have the right con type RTCompile uni fun = DefT TH.Name uni fun () Quote -{-| Class for types which have a corresponding Plutus IR type. Instances should always be derived, -do not write your own instance! --} +-- | Class for types which have a corresponding Plutus IR type. Instances should always be derived, +-- do not write your own instance! class Typeable uni (a :: k) where -- | Get the Plutus IR type corresponding to this type. typeRep :: Proxy a -> RTCompile uni fun (Type TyName uni ()) -{-| Class for types which can be lifted into Plutus IR. Instances should be derived, do not write -your own instance! --} +-- | Class for types which can be lifted into Plutus IR. Instances should be derived, do not write +-- your own instance! class Lift uni a where -- | Get a Plutus IR term corresponding to the given value. lift :: a -> RTCompile uni fun (Term TyName Name uni fun ()) @@ -120,161 +123,160 @@ instance Typeable uni (->) where -- Primitives -typeRepBuiltin - :: forall k (a :: k) uni fun - . (uni `PLC.HasTypeLevel` a) - => Proxy a -> RTCompile uni fun (Type TyName uni ()) +typeRepBuiltin :: + forall k (a :: k) uni fun. + uni `PLC.HasTypeLevel` a => + Proxy a -> RTCompile uni fun (Type TyName uni ()) typeRepBuiltin (_ :: Proxy a) = pure $ mkTyBuiltin @_ @a () -liftBuiltin - :: forall a uni fun - . (uni `PLC.HasTermLevel` a) - => a -> RTCompile uni fun (Term TyName Name uni fun ()) +liftBuiltin :: + forall a uni fun. + uni `PLC.HasTermLevel` a => + a -> RTCompile uni fun (Term TyName Name uni fun ()) liftBuiltin = pure . mkConstant () instance - (TypeError ('Text "Int is not supported, use Integer instead")) - => Typeable uni Int + TypeError ('Text "Int is not supported, use Integer instead") => + Typeable uni Int where typeRep = Haskell.error "unsupported" instance - (TypeError ('Text "Int is not supported, use Integer instead")) - => Lift uni Int + TypeError ('Text "Int is not supported, use Integer instead") => + Lift uni Int where lift = Haskell.error "unsupported" -instance (uni `PLC.HasTypeLevel` Integer) => Typeable uni BuiltinInteger where +instance uni `PLC.HasTypeLevel` Integer => Typeable uni BuiltinInteger where typeRep = typeRepBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTermLevel` Integer) => Lift uni BuiltinInteger where +instance uni `PLC.HasTermLevel` Integer => Lift uni BuiltinInteger where lift = liftBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` BS.ByteString) => Typeable uni BuiltinByteString where +instance uni `PLC.HasTypeLevel` BS.ByteString => Typeable uni BuiltinByteString where typeRep _ = typeRepBuiltin (Proxy @BS.ByteString) -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTermLevel` BS.ByteString) => Lift uni BuiltinByteString where +instance uni `PLC.HasTermLevel` BS.ByteString => Lift uni BuiltinByteString where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` T.Text) => Typeable uni BuiltinString where +instance uni `PLC.HasTypeLevel` T.Text => Typeable uni BuiltinString where typeRep _ = typeRepBuiltin (Proxy @T.Text) -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTermLevel` T.Text) => Lift uni BuiltinString where +instance uni `PLC.HasTermLevel` T.Text => Lift uni BuiltinString where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` ()) => Typeable uni BuiltinUnit where +instance uni `PLC.HasTypeLevel` () => Typeable uni BuiltinUnit where typeRep _ = typeRepBuiltin (Proxy @()) -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTermLevel` ()) => Lift uni BuiltinUnit where +instance uni `PLC.HasTermLevel` () => Lift uni BuiltinUnit where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` Bool) => Typeable uni Bool where +instance uni `PLC.HasTypeLevel` Bool => Typeable uni Bool where typeRep _ = typeRepBuiltin (Proxy @Bool) -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTermLevel` Bool) => Lift uni Bool where +instance uni `PLC.HasTermLevel` Bool => Lift uni Bool where lift = liftBuiltin . fromBuiltin - -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` []) => Typeable uni BuiltinList where +instance uni `PLC.HasTypeLevel` [] => Typeable uni BuiltinList where typeRep _ = typeRepBuiltin (Proxy @[]) -- See Note [Lift and Typeable instances for builtins] instance - (HasFromBuiltin arep, uni `PLC.HasTermLevel` [FromBuiltin arep]) - => Lift uni (BuiltinList arep) + (HasFromBuiltin arep, uni `PLC.HasTermLevel` [FromBuiltin arep]) => + Lift uni (BuiltinList arep) where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` Strict.Vector) => Typeable uni BuiltinArray where +instance uni `PLC.HasTypeLevel` Strict.Vector => Typeable uni BuiltinArray where typeRep _ = typeRepBuiltin (Proxy @Strict.Vector) -- See Note [Lift and Typeable instances for builtins] instance ( HasFromBuiltin arep , uni `PLC.HasTermLevel` Strict.Vector (FromBuiltin arep) - ) - => Lift uni (BuiltinArray arep) + ) => + Lift uni (BuiltinArray arep) where lift = liftBuiltin . fromBuiltin -instance (uni `PLC.HasTypeLevel` (,)) => Typeable uni BuiltinPair where +instance uni `PLC.HasTypeLevel` (,) => Typeable uni BuiltinPair where typeRep _ = typeRepBuiltin (Proxy @(,)) instance ( HasFromBuiltin arep , HasFromBuiltin brep , uni `PLC.HasTermLevel` (FromBuiltin arep, FromBuiltin brep) - ) - => Lift uni (BuiltinPair arep brep) + ) => + Lift uni (BuiltinPair arep brep) where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` Data) => Typeable uni BuiltinData where +instance uni `PLC.HasTypeLevel` Data => Typeable uni BuiltinData where typeRep _ = typeRepBuiltin (Proxy @Data) -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTypeLevel` Value) => Typeable uni BuiltinValue where +instance uni `PLC.HasTypeLevel` Value => Typeable uni BuiltinValue where typeRep _ = typeRepBuiltin (Proxy @Value) -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTermLevel` Data) => Lift uni BuiltinData where +instance uni `PLC.HasTermLevel` Data => Lift uni BuiltinData where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] -instance (uni `PLC.HasTermLevel` Value) => Lift uni BuiltinValue where +instance uni `PLC.HasTermLevel` Value => Lift uni BuiltinValue where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] instance - (uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.G1.Element) - => Typeable uni BuiltinBLS12_381_G1_Element + uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.G1.Element => + Typeable uni BuiltinBLS12_381_G1_Element where typeRep _ = typeRepBuiltin (Proxy @PlutusCore.Crypto.BLS12_381.G1.Element) -- See Note [Lift and Typeable instances for builtins] instance - (uni `PLC.HasTermLevel` PlutusCore.Crypto.BLS12_381.G1.Element) - => Lift uni BuiltinBLS12_381_G1_Element + uni `PLC.HasTermLevel` PlutusCore.Crypto.BLS12_381.G1.Element => + Lift uni BuiltinBLS12_381_G1_Element where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] instance - (uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.G2.Element) - => Typeable uni BuiltinBLS12_381_G2_Element + uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.G2.Element => + Typeable uni BuiltinBLS12_381_G2_Element where typeRep _ = typeRepBuiltin (Proxy @PlutusCore.Crypto.BLS12_381.G2.Element) -- See Note [Lift and Typeable instances for builtins] instance - (uni `PLC.HasTermLevel` PlutusCore.Crypto.BLS12_381.G2.Element) - => Lift uni BuiltinBLS12_381_G2_Element + uni `PLC.HasTermLevel` PlutusCore.Crypto.BLS12_381.G2.Element => + Lift uni BuiltinBLS12_381_G2_Element where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] instance - (uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.Pairing.MlResult) - => Typeable uni BuiltinBLS12_381_MlResult + uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.Pairing.MlResult => + Typeable uni BuiltinBLS12_381_MlResult where typeRep _ = typeRepBuiltin (Proxy @PlutusCore.Crypto.BLS12_381.Pairing.MlResult) -- See Note [Lift and Typeable instances for builtins] instance - (uni `PLC.HasTermLevel` PlutusCore.Crypto.BLS12_381.Pairing.MlResult) - => Lift uni BuiltinBLS12_381_MlResult + uni `PLC.HasTermLevel` PlutusCore.Crypto.BLS12_381.Pairing.MlResult => + Lift uni BuiltinBLS12_381_MlResult where lift = liftBuiltin . fromBuiltin diff --git a/plutus-tx/src/PlutusTx/Lift/TH.hs b/plutus-tx/src/PlutusTx/Lift/TH.hs index 4ded54adb92..b338ed8e767 100644 --- a/plutus-tx/src/PlutusTx/Lift/TH.hs +++ b/plutus-tx/src/PlutusTx/Lift/TH.hs @@ -1,20 +1,20 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- It is complex to mix TH with polymorphisms. Core lint can sometimes catch problems -- caused by using polymorphisms the wrong way, e.g., accidentally using impredicative types. {-# OPTIONS_GHC -dcore-lint #-} @@ -75,9 +75,9 @@ data LiftError instance PP.Pretty LiftError where pretty (UnsupportedLiftType t) = "Unsupported lift type: " PP.<+> PP.viaShow t pretty (UnsupportedLiftKind t) = "Unsupported lift kind: " PP.<+> PP.viaShow t - pretty (UserLiftError t) = PP.pretty t + pretty (UserLiftError t) = PP.pretty t pretty (LiftMissingDataCons n) = "Constructors not created for type: " PP.<+> PP.viaShow n - pretty (LiftMissingVar n) = "Unknown local variable: " PP.<+> PP.viaShow n + pretty (LiftMissingVar n) = "Unknown local variable: " PP.<+> PP.viaShow n instance Show LiftError where show = show . PP.pretty -- for Control.Exception @@ -111,25 +111,25 @@ for different variants of this impredicative type. Which is annoying, but does w -- See Note [Impredicative function universe wrappers] newtype CompileTerm = CompileTerm - { unCompileTerm - :: forall fun - . RTCompile PLC.DefaultUni fun (Term TyName Name PLC.DefaultUni fun ()) + { unCompileTerm :: + forall fun. + RTCompile PLC.DefaultUni fun (Term TyName Name PLC.DefaultUni fun ()) } newtype CompileType = CompileType - { unCompileType - :: forall fun - . RTCompile PLC.DefaultUni fun (Type TyName PLC.DefaultUni ()) + { unCompileType :: + forall fun. + RTCompile PLC.DefaultUni fun (Type TyName PLC.DefaultUni ()) } newtype CompileTypeScope = CompileTypeScope - { unCompileTypeScope - :: forall fun - . RTCompileScope PLC.DefaultUni fun (Type TyName PLC.DefaultUni ()) + { unCompileTypeScope :: + forall fun. + RTCompileScope PLC.DefaultUni fun (Type TyName PLC.DefaultUni ()) } newtype CompileDeclFun = CompileDeclFun - { unCompileDeclFun - :: forall fun - . Type TyName PLC.DefaultUni () - -> RTCompileScope PLC.DefaultUni fun (VarDecl TyName Name PLC.DefaultUni ()) + { unCompileDeclFun :: + forall fun. + Type TyName PLC.DefaultUni () -> + RTCompileScope PLC.DefaultUni fun (VarDecl TyName Name PLC.DefaultUni ()) } {- Note [Type variables] @@ -182,21 +182,20 @@ These are then cashed out into constraints on the instance. data Dep = TypeableDep TH.Type | LiftDep TH.Type deriving stock (Show, Eq, Ord) type Deps = Set.Set Dep -withTyVars :: (MonadReader (LocalVars uni) m) => [(TH.Name, TyVarDecl TyName ())] -> m a -> m a +withTyVars :: MonadReader (LocalVars uni) m => [(TH.Name, TyVarDecl TyName ())] -> m a -> m a withTyVars mappings = local (\scope -> foldl' (\acc (n, tvd) -> Map.insert n (mkTyVar () tvd) acc) scope mappings) -thWithTyVars :: (MonadReader THLocalVars m) => [TH.Name] -> m a -> m a +thWithTyVars :: MonadReader THLocalVars m => [TH.Name] -> m a -> m a thWithTyVars names = local (\scope -> foldr Set.insert scope names) -{-| Get all the named types which we depend on to define the current type. -Note that this relies on dependencies having been added with type synonyms -resolved! --} +-- | Get all the named types which we depend on to define the current type. +-- Note that this relies on dependencies having been added with type synonyms +-- resolved! getTyConDeps :: Deps -> Set.Set TH.Name getTyConDeps deps = Set.fromList $ mapMaybe typeableDep $ Set.toList deps - where - typeableDep (TypeableDep (TH.ConT n)) = Just n - typeableDep _ = Nothing + where + typeableDep (TypeableDep (TH.ConT n)) = Just n + typeableDep _ = Nothing addTypeableDep :: TH.Type -> THCompile () addTypeableDep ty = do @@ -239,7 +238,7 @@ normalizeAndResolve ty = normalizeType <$> (Trans.lift $ Trans.lift $ Trans.lift -- See Note [Ordering of constructors] sortedCons :: TH.DatatypeInfo -> [TH.ConstructorInfo] -sortedCons TH.DatatypeInfo{TH.datatypeName = tyName, TH.datatypeCons = cons} = +sortedCons TH.DatatypeInfo {TH.datatypeName = tyName, TH.datatypeCons = cons} = -- We need to compare 'TH.Name's on their string name *not* on the unique let sorted = sortBy @@ -320,7 +319,7 @@ compileTypeableType ty name = do in CompileTypeScope $ do maybeType <- lookupType () name case maybeType of - Just t -> pure t + Just t -> pure t -- this will need some additional constraints in scope Nothing -> trep' ||] @@ -330,17 +329,17 @@ recordAlias' :: TH.Name -> RTCompileScope PLC.DefaultUni fun () recordAlias' = recordAlias -- Just here so we can pin down the type variables without using TypeApplications in the generated code -defineDatatype' - :: TH.Name - -> DatatypeDef TyName Name PLC.DefaultUni () - -> Set.Set TH.Name - -> RTCompileScope PLC.DefaultUni fun () +defineDatatype' :: + TH.Name -> + DatatypeDef TyName Name PLC.DefaultUni () -> + Set.Set TH.Name -> + RTCompileScope PLC.DefaultUni fun () defineDatatype' = defineDatatype -- TODO: there is an unpleasant amount of duplication between this and the main compiler, but -- I'm not sure how to unify them better compileTypeRep :: TH.DatatypeInfo -> THCompile (TH.TExpQ CompileType) -compileTypeRep dt@TH.DatatypeInfo{TH.datatypeName = tyName, TH.datatypeVars = tvs} = do +compileTypeRep dt@TH.DatatypeInfo {TH.datatypeName = tyName, TH.datatypeVars = tvs} = do tvNamesAndKinds <- traverse tvNameAndKind tvs -- annoyingly th-abstraction doesn't give us a kind we can compile here let typeKind = foldr (\(_, k) acc -> KindArrow () k acc) (Type ()) tvNamesAndKinds @@ -351,7 +350,7 @@ compileTypeRep dt@TH.DatatypeInfo{TH.datatypeName = tyName, TH.datatypeVars = tv then do -- Extract the unique field of the unique constructor argTy <- case cons of - [TH.ConstructorInfo{TH.constructorFields = [argTy]}] -> (compileType <=< normalizeAndResolve) argTy + [TH.ConstructorInfo {TH.constructorFields = [argTy]}] -> (compileType <=< normalizeAndResolve) argTy _ -> throwError $ UserLiftError "Newtypes must have a single constructor with a single argument" deps <- gets getTyConDeps pure . TH.examineCode $ @@ -415,10 +414,10 @@ compileTypeRep dt@TH.DatatypeInfo{TH.datatypeName = tyName, TH.datatypeVars = tv CompileType $ runReaderT act mempty ||] -compileConstructorDecl - :: TH.ConstructorInfo - -> THCompile (TH.TExpQ CompileDeclFun) -compileConstructorDecl TH.ConstructorInfo{TH.constructorName = name, TH.constructorFields = argTys} = do +compileConstructorDecl :: + TH.ConstructorInfo -> + THCompile (TH.TExpQ CompileDeclFun) +compileConstructorDecl TH.ConstructorInfo {TH.constructorName = name, TH.constructorFields = argTys} = do tyExprs <- traverse (compileType <=< normalizeAndResolve) argTys pure . TH.examineCode $ [|| @@ -452,9 +451,9 @@ makeTypeable uni name = do compileLift :: TH.DatatypeInfo -> THCompile [TH.Q TH.Clause] compileLift dt = traverse (uncurry (compileConstructorClause dt)) (zip [0 ..] (sortedCons dt)) -compileConstructorClause - :: TH.DatatypeInfo -> Int -> TH.ConstructorInfo -> THCompile (TH.Q TH.Clause) -compileConstructorClause dt@TH.DatatypeInfo{TH.datatypeName = tyName, TH.datatypeVars = tvs} index TH.ConstructorInfo{TH.constructorName = name, TH.constructorFields = argTys} = do +compileConstructorClause :: + TH.DatatypeInfo -> Int -> TH.ConstructorInfo -> THCompile (TH.Q TH.Clause) +compileConstructorClause dt@TH.DatatypeInfo {TH.datatypeName = tyName, TH.datatypeVars = tvs} index TH.ConstructorInfo {TH.constructorName = name, TH.constructorFields = argTys} = do -- need to be able to lift the argument types traverse_ addLiftDep argTys @@ -566,5 +565,5 @@ runTHCompile m = do . flip runReaderT mempty $ flip runStateT mempty m case res of - Left a -> fail $ "Generating Lift instances: " ++ show (PP.pretty a) + Left a -> fail $ "Generating Lift instances: " ++ show (PP.pretty a) Right b -> pure b diff --git a/plutus-tx/src/PlutusTx/Lift/THUtils.hs b/plutus-tx/src/PlutusTx/Lift/THUtils.hs index 0ccbb31c827..b4cdd3513a4 100644 --- a/plutus-tx/src/PlutusTx/Lift/THUtils.hs +++ b/plutus-tx/src/PlutusTx/Lift/THUtils.hs @@ -1,5 +1,5 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module PlutusTx.Lift.THUtils where @@ -20,16 +20,15 @@ import Language.Haskell.TH.Syntax qualified as TH -- We do not use qualified import because the whole module contains off-chain code import Prelude as Haskell -{-| Very nearly the same as 'TH.showName', but doesn't print uniques, since we don't need to -incorporate them into our names. --} +-- | Very nearly the same as 'TH.showName', but doesn't print uniques, since we don't need to +-- incorporate them into our names. showName :: TH.Name -> T.Text showName n = T.pack $ case n of - TH.Name occ TH.NameS -> TH.occString occ - TH.Name occ (TH.NameQ m) -> TH.modString m ++ "." ++ TH.occString occ + TH.Name occ TH.NameS -> TH.occString occ + TH.Name occ (TH.NameQ m) -> TH.modString m ++ "." ++ TH.occString occ TH.Name occ (TH.NameG _ _ m) -> TH.modString m ++ "." ++ TH.occString occ - TH.Name occ (TH.NameU _) -> TH.occString occ - TH.Name occ (TH.NameL _) -> TH.occString occ + TH.Name occ (TH.NameU _) -> TH.occString occ + TH.Name occ (TH.NameL _) -> TH.occString occ -- | Normalize a type, in particular getting rid of things like 'TH.ListT' in favour of applications of the actual name. normalizeType :: TH.Type -> TH.Type @@ -52,15 +51,15 @@ requireExtension ext = do enabled <- TH.isExtEnabled ext unless enabled $ fail $ "Extension must be enabled: " ++ show ext -mkTyVarDecl :: (MonadQuote m) => TH.Name -> Kind () -> m (TH.Name, TyVarDecl TyName ()) +mkTyVarDecl :: MonadQuote m => TH.Name -> Kind () -> m (TH.Name, TyVarDecl TyName ()) mkTyVarDecl name kind = do tyName <- safeFreshTyName $ showName name pure (name, TyVarDecl () tyName kind) isNewtype :: TH.DatatypeInfo -> Bool -isNewtype TH.DatatypeInfo{TH.datatypeVariant = variant} = case variant of +isNewtype TH.DatatypeInfo {TH.datatypeVariant = variant} = case variant of TH.Newtype -> True - _ -> False + _ -> False -- | "Safe" wrapper around 'TH.listE' for typed TH. tyListE :: [TH.TExpQ a] -> TH.TExpQ [a] diff --git a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs index de84f39b508..29b912486c9 100644 --- a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs +++ b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module PlutusTx.Lift.TestInstances () where @@ -18,23 +18,22 @@ import PlutusTx.Lift.Class import Data.Kind qualified as GHC -- | @BuiltinSatisfies pre post a@ holds if @pre (ToBuiltin a)@ implies @post (ToBuiltin a)@. -type BuiltinSatisfies - :: (GHC.Type -> GHC.Constraint) - -> (GHC.Type -> GHC.Constraint) - -> GHC.Type - -> GHC.Constraint -class ((pre (ToBuiltin a)) => post (ToBuiltin a)) => BuiltinSatisfies pre post a - -instance ((pre (ToBuiltin a)) => post (ToBuiltin a)) => BuiltinSatisfies pre post a - -{-| Test that each built-in type @a@ from 'PLC.DefaultUni' satisfies @post (ToBuiltin a)@ given -@pre (ToBuiltin a)@. --} -type TestAllBuiltinsSatisfy - :: (GHC.Type -> GHC.Constraint) - -> (GHC.Type -> GHC.Constraint) - -> GHC.Constraint -class (PLC.DefaultUni `PLC.Everywhere` BuiltinSatisfies pre post) => TestAllBuiltinsSatisfy pre post +type BuiltinSatisfies :: + (GHC.Type -> GHC.Constraint) -> + (GHC.Type -> GHC.Constraint) -> + GHC.Type -> + GHC.Constraint +class (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a + +instance (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a + +-- | Test that each built-in type @a@ from 'PLC.DefaultUni' satisfies @post (ToBuiltin a)@ given +-- @pre (ToBuiltin a)@. +type TestAllBuiltinsSatisfy :: + (GHC.Type -> GHC.Constraint) -> + (GHC.Type -> GHC.Constraint) -> + GHC.Constraint +class PLC.DefaultUni `PLC.Everywhere` BuiltinSatisfies pre post => TestAllBuiltinsSatisfy pre post -- | Test that each built-in type from 'PLC.DefaultUni' has a 'Typeable' instance. instance @@ -42,11 +41,10 @@ instance (PLC.AllBuiltinArgs PLC.DefaultUni (Typeable PLC.DefaultUni)) (Typeable PLC.DefaultUni) -{-| Test that each built-in type from 'PLC.DefaultUni' has a 'Lift' instance. Since the 'Lift' -instances are defined in terms of 'fromBuiltin', this also tests that each built-in type has a -'FromBuiltin' instance. Which in turn requires a 'ToBuiltin' instance to exist due to the -superclass constraint, so this is implicitly tested as well. --} +-- | Test that each built-in type from 'PLC.DefaultUni' has a 'Lift' instance. Since the 'Lift' +-- instances are defined in terms of 'fromBuiltin', this also tests that each built-in type has a +-- 'FromBuiltin' instance. Which in turn requires a 'ToBuiltin' instance to exist due to the +-- superclass constraint, so this is implicitly tested as well. instance TestAllBuiltinsSatisfy (PLC.AllBuiltinArgs PLC.DefaultUni HasFromBuiltin) diff --git a/plutus-tx/src/PlutusTx/List.hs b/plutus-tx/src/PlutusTx/List.hs index a554459bf69..9910bb8bff8 100644 --- a/plutus-tx/src/PlutusTx/List.hs +++ b/plutus-tx/src/PlutusTx/List.hs @@ -1,51 +1,51 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.List ( - uncons, - null, - length, - map, - and, - or, - any, - all, - elem, - notElem, - find, - filter, - listToMaybe, - uniqueElement, - findIndices, - findIndex, - foldr, - foldl, - revAppend, - reverse, - concat, - concatMap, - zip, - unzip, - (++), - (!!), - head, - last, - tail, - take, - drop, - splitAt, - nub, - nubBy, - zipWith, - dropWhile, - replicate, - partition, - sort, - sortBy, - elemBy, - ) where + uncons, + null, + length, + map, + and, + or, + any, + all, + elem, + notElem, + find, + filter, + listToMaybe, + uniqueElement, + findIndices, + findIndex, + foldr, + foldl, + revAppend, + reverse, + concat, + concatMap, + zip, + unzip, + (++), + (!!), + head, + last, + tail, + take, + drop, + splitAt, + nub, + nubBy, + zipWith, + dropWhile, + replicate, + partition, + sort, + sortBy, + elemBy, +) where import PlutusTx.Bool (Bool (..), not, otherwise, (||)) import PlutusTx.Builtins (Integer) @@ -74,24 +74,23 @@ null = \case length :: [a] -> Integer length = go - where - go = \case - [] -> 0 - _ : xs -> Builtins.addInteger 1 (go xs) + where + go = \case + [] -> 0 + _ : xs -> Builtins.addInteger 1 (go xs) {-# INLINEABLE length #-} -{-| Plutus Tx version of 'Data.List.map'. - - >>> map (\i -> i + 1) [1, 2, 3] - [2,3,4] --} +-- | Plutus Tx version of 'Data.List.map'. +-- +-- >>> map (\i -> i + 1) [1, 2, 3] +-- [2,3,4] map :: forall a b. (a -> b) -> [a] -> [b] map f = go - where - go :: [a] -> [b] - go = \case - [] -> [] - x : xs -> f x : go xs + where + go :: [a] -> [b] + go = \case + [] -> [] + x : xs -> f x : go xs {-# INLINEABLE map #-} -- | Returns the conjunction of a list of Bools. @@ -111,87 +110,83 @@ or = \case -- | Determines whether any element of the structure satisfies the predicate. any :: forall a. (a -> Bool) -> [a] -> Bool any f = go - where - go :: [a] -> Bool - go = \case - [] -> False - x : xs -> if f x then True else go xs + where + go :: [a] -> Bool + go = \case + [] -> False + x : xs -> if f x then True else go xs {-# INLINEABLE any #-} -- | Determines whether all elements of the list satisfy the predicate. all :: forall a. (a -> Bool) -> [a] -> Bool all f = go - where - go :: [a] -> Bool - go = \case - [] -> True - x : xs -> if f x then go xs else False + where + go :: [a] -> Bool + go = \case + [] -> True + x : xs -> if f x then go xs else False {-# INLINEABLE all #-} -- | Does the element occur in the list? -elem :: (Eq a) => a -> [a] -> Bool +elem :: Eq a => a -> [a] -> Bool elem = any . (==) {-# INLINEABLE elem #-} -- | The negation of `elem`. -notElem :: (Eq a) => a -> [a] -> Bool +notElem :: Eq a => a -> [a] -> Bool notElem a = not . elem a {-# INLINEABLE notElem #-} -- | Returns the leftmost element matching the predicate, or `Nothing` if there's no such element. find :: forall a. (a -> Bool) -> [a] -> Maybe a find f = go - where - go :: [a] -> Maybe a - go = \case - [] -> Nothing - x : xs -> if f x then Just x else go xs + where + go :: [a] -> Maybe a + go = \case + [] -> Nothing + x : xs -> if f x then Just x else go xs {-# INLINEABLE find #-} -{-| Plutus Tx version of 'Data.List.foldr'. - - >>> foldr (\i s -> s + i) 0 [1, 2, 3, 4] - 10 --} +-- | Plutus Tx version of 'Data.List.foldr'. +-- +-- >>> foldr (\i s -> s + i) 0 [1, 2, 3, 4] +-- 10 foldr :: forall a b. (a -> b -> b) -> b -> [a] -> b foldr f acc = go - where - go :: [a] -> b - go = \case - [] -> acc - x : xs -> f x (go xs) + where + go :: [a] -> b + go = \case + [] -> acc + x : xs -> f x (go xs) {-# INLINEABLE foldr #-} -{-| Plutus Tx velsion of 'Data.List.foldl'. - - >>> foldl (\s i -> s + i) 0 [1, 2, 3, 4] - 10 --} +-- | Plutus Tx velsion of 'Data.List.foldl'. +-- +-- >>> foldl (\s i -> s + i) 0 [1, 2, 3, 4] +-- 10 foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b foldl f = go - where - go :: b -> [a] -> b - go acc = \case - [] -> acc - x : xs -> go (f acc x) xs + where + go :: b -> [a] -> b + go acc = \case + [] -> acc + x : xs -> go (f acc x) xs {-# INLINEABLE foldl #-} -{-| Plutus Tx version of '(Data.List.++)'. - - >>> [0, 1, 2] ++ [1, 2, 3, 4] - [0,1,2,1,2,3,4] --} +-- | Plutus Tx version of '(Data.List.++)'. +-- +-- >>> [0, 1, 2] ++ [1, 2, 3, 4] +-- [0,1,2,1,2,3,4] infixr 5 ++ (++) :: [a] -> [a] -> [a] (++) l r = foldr (:) r l {-# INLINEABLE (++) #-} -{-| Plutus Tx version of 'Data.List.concat'. - - >>> concat [[1, 2], [3], [4, 5]] - [1,2,3,4,5] --} +-- | Plutus Tx version of 'Data.List.concat'. +-- +-- >>> concat [[1, 2], [3], [4, 5]] +-- [1,2,3,4,5] concat :: [[a]] -> [a] concat = foldr (++) [] {-# INLINEABLE concat #-} @@ -201,77 +196,75 @@ concatMap :: (a -> [b]) -> [a] -> [b] concatMap f = foldr (\x ys -> f x ++ ys) [] {-# INLINEABLE concatMap #-} -{-| Plutus Tx version of 'Data.List.filter'. - - >>> filter (> 1) [1, 2, 3, 4] - [2,3,4] --} +-- | Plutus Tx version of 'Data.List.filter'. +-- +-- >>> filter (> 1) [1, 2, 3, 4] +-- [2,3,4] filter :: (a -> Bool) -> [a] -> [a] filter p = foldr (\e xs -> if p e then e : xs else xs) [] {-# INLINEABLE filter #-} -- | Plutus Tx version of 'Data.List.listToMaybe'. listToMaybe :: [a] -> Maybe a -listToMaybe [] = Nothing +listToMaybe [] = Nothing listToMaybe (x : _) = Just x {-# INLINEABLE listToMaybe #-} -- | Return the element in the list, if there is precisely one. uniqueElement :: [a] -> Maybe a uniqueElement [x] = Just x -uniqueElement _ = Nothing +uniqueElement _ = Nothing {-# INLINEABLE uniqueElement #-} -- | Plutus Tx version of 'Data.List.findIndices'. findIndices :: (a -> Bool) -> [a] -> [Integer] findIndices p = go 0 - where - go i l = case l of - [] -> [] - (x : xs) -> let indices = go (Builtins.addInteger i 1) xs in if p x then i : indices else indices + where + go i l = case l of + [] -> [] + (x : xs) -> let indices = go (Builtins.addInteger i 1) xs in if p x then i : indices else indices {-# INLINEABLE findIndices #-} -- | Plutus Tx version of 'Data.List.findIndex'. findIndex :: (a -> Bool) -> [a] -> Maybe Integer findIndex f = go 0 - where - go i = \case - [] -> Nothing - x : xs -> if f x then Just i else go (Builtins.addInteger i 1) xs + where + go i = \case + [] -> Nothing + x : xs -> if f x then Just i else go (Builtins.addInteger i 1) xs {-# INLINEABLE findIndex #-} -{-| Plutus Tx version of '(GHC.List.!!)'. - - >>> [10, 11, 12] !! 2 - 12 --} +-- | Plutus Tx version of '(GHC.List.!!)'. +-- +-- >>> [10, 11, 12] !! 2 +-- 12 infixl 9 !! + (!!) :: forall a. [a] -> Integer -> a -_ !! n0 | n0 < 0 = traceError negativeIndexError +_ !! n0 | n0 < 0 = traceError negativeIndexError xs0 !! n0 = go n0 xs0 where go :: Integer -> [a] -> a - go _ [] = traceError indexTooLargeError + go _ [] = traceError indexTooLargeError go n (x : xs) = - if Builtins.equalsInteger n 0 - then x - else go (Builtins.subtractInteger n 1) xs -{-# INLINABLE (!!) #-} - -{-| Cons each element of the first list to the second one in reverse order (i.e. the last element -of the first list is the head of the result). - -> revAppend xs ys === reverse xs ++ ys - ->>> revAppend "abc" "de" -"cbade" --} + if Builtins.equalsInteger n 0 + then x + else go (Builtins.subtractInteger n 1) xs +{-# INLINEABLE (!!) #-} + +-- | Cons each element of the first list to the second one in reverse order (i.e. the last element +-- of the first list is the head of the result). +-- +-- > revAppend xs ys === reverse xs ++ ys +-- +-- >>> revAppend "abc" "de" +-- "cbade" revAppend :: forall a. [a] -> [a] -> [a] revAppend = rev - where - rev :: [a] -> [a] -> [a] - rev [] a = a - rev (x : xs) a = rev xs (x : a) + where + rev :: [a] -> [a] -> [a] + rev [] a = a + rev (x : xs) a = rev xs (x : a) {-# INLINEABLE revAppend #-} -- | Plutus Tx version of 'Data.List.reverse'. @@ -282,60 +275,60 @@ reverse l = revAppend l [] -- | Plutus Tx version of 'Data.List.zip'. zip :: forall a b. [a] -> [b] -> [(a, b)] zip = go - where - go :: [a] -> [b] -> [(a, b)] - go [] _bs = [] - go _as [] = [] - go (a : as) (b : bs) = (a, b) : go as bs + where + go :: [a] -> [b] -> [(a, b)] + go [] _bs = [] + go _as [] = [] + go (a : as) (b : bs) = (a, b) : go as bs {-# INLINEABLE zip #-} -- | Plutus Tx version of 'Data.List.unzip'. unzip :: forall a b. [(a, b)] -> ([a], [b]) unzip = go - where - go :: [(a, b)] -> ([a], [b]) - go [] = ([], []) - go ((x, y) : xys) = case go xys of - (xs, ys) -> (x : xs, y : ys) + where + go :: [(a, b)] -> ([a], [b]) + go [] = ([], []) + go ((x, y) : xys) = case go xys of + (xs, ys) -> (x : xs, y : ys) {-# INLINEABLE unzip #-} -- | Plutus Tx version of 'Data.List.head'. head :: [a] -> a -head [] = traceError headEmptyListError +head [] = traceError headEmptyListError head (x : _) = x {-# INLINEABLE head #-} -- | Plutus Tx version of 'Data.List.last'. last :: [a] -> a -last [] = traceError lastEmptyListError -last [x] = x +last [] = traceError lastEmptyListError +last [x] = x last (_ : xs) = last xs {-# INLINEABLE last #-} -- | Plutus Tx version of 'Data.List.tail'. tail :: [a] -> [a] tail (_ : as) = as -tail [] = traceError tailEmptyListError +tail [] = traceError tailEmptyListError {-# INLINEABLE tail #-} -- | Plutus Tx version of 'Data.List.take'. take :: forall a. Integer -> [a] -> [a] take = go - where - go :: Integer -> [a] -> [a] - go n _ | n <= 0 = [] - go _ [] = [] - go n (x : xs) = x : go (Builtins.subtractInteger n 1) xs + where + go :: Integer -> [a] -> [a] + go n _ | n <= 0 = [] + go _ [] = [] + go n (x : xs) = x : go (Builtins.subtractInteger n 1) xs {-# INLINEABLE take #-} -- | Plutus Tx version of 'Data.List.drop'. drop :: forall a. Integer -> [a] -> [a] drop = go - where - go :: Integer -> [a] -> [a] - go n xs | n <= 0 = xs - go _ [] = [] - go n (_ : xs) = go (Builtins.subtractInteger n 1) xs + where + go :: Integer -> [a] -> [a] + go n xs | n <= 0 = xs + go _ [] = [] + go n (_ : xs) = go (Builtins.subtractInteger n 1) xs {-# INLINEABLE drop #-} -- | Plutus Tx version of 'Data.List.splitAt'. @@ -343,65 +336,65 @@ splitAt :: forall a. Integer -> [a] -> ([a], [a]) splitAt n xs | n <= 0 = ([], xs) | otherwise = go n xs - where - go :: Integer -> [a] -> ([a], [a]) - go _ [] = ([], []) - go m (y : ys) - | m == 1 = ([y], ys) - | otherwise = case go (Builtins.subtractInteger m 1) ys of - (zs, ws) -> (y : zs, ws) + where + go :: Integer -> [a] -> ([a], [a]) + go _ [] = ([], []) + go m (y : ys) + | m == 1 = ([y], ys) + | otherwise = case go (Builtins.subtractInteger m 1) ys of + (zs, ws) -> (y : zs, ws) {-# INLINEABLE splitAt #-} -- | Plutus Tx version of 'Data.List.nub'. -nub :: (Eq a) => [a] -> [a] +nub :: Eq a => [a] -> [a] nub = nubBy (==) {-# INLINEABLE nub #-} elemBy :: forall a. (a -> a -> Bool) -> a -> [a] -> Bool elemBy eq y = go - where - go :: [a] -> Bool - go [] = False - go (x : xs) = x `eq` y || go xs + where + go :: [a] -> Bool + go [] = False + go (x : xs) = x `eq` y || go xs {-# INLINEABLE elemBy #-} -- | Plutus Tx version of 'Data.List.nubBy'. nubBy :: (a -> a -> Bool) -> [a] -> [a] nubBy eq l = nubBy' l [] - where - nubBy' [] _ = [] - nubBy' (y : ys) xs - | elemBy eq y xs = nubBy' ys xs - | otherwise = y : nubBy' ys (y : xs) + where + nubBy' [] _ = [] + nubBy' (y : ys) xs + | elemBy eq y xs = nubBy' ys xs + | otherwise = y : nubBy' ys (y : xs) {-# INLINEABLE nubBy #-} -- | Plutus Tx version of 'Data.List.zipWith'. zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith f = go - where - go :: [a] -> [b] -> [c] - go [] _ = [] - go _ [] = [] - go (x : xs) (y : ys) = f x y : go xs ys + where + go :: [a] -> [b] -> [c] + go [] _ = [] + go _ [] = [] + go (x : xs) (y : ys) = f x y : go xs ys {-# INLINEABLE zipWith #-} -- | Plutus Tx version of 'Data.List.dropWhile'. dropWhile :: forall a. (a -> Bool) -> [a] -> [a] dropWhile p = go - where - go :: [a] -> [a] - go [] = [] - go xs@(x : xs') - | p x = go xs' - | otherwise = xs + where + go :: [a] -> [a] + go [] = [] + go xs@(x : xs') + | p x = go xs' + | otherwise = xs {-# INLINEABLE dropWhile #-} -- | Plutus Tx version of 'Data.List.replicate'. replicate :: forall a. Integer -> a -> [a] replicate n0 x = go n0 - where - go n | n <= 0 = [] - go n = x : go (Builtins.subtractInteger n 1) + where + go n | n <= 0 = [] + go n = x : go (Builtins.subtractInteger n 1) {-# INLINEABLE replicate #-} -- | Plutus Tx version of 'Data.List.partition'. @@ -415,40 +408,40 @@ select p x ~(ts, fs) | otherwise = (ts, x : fs) -- | Plutus Tx version of 'Data.List.sort'. -sort :: (Ord a) => [a] -> [a] +sort :: Ord a => [a] -> [a] sort = sortBy compare {-# INLINEABLE sort #-} -- | Plutus Tx version of 'Data.List.sortBy'. sortBy :: (a -> a -> Ordering) -> [a] -> [a] sortBy cmp l = mergeAll (sequences l) - where - sequences (a : b : xs) - | a `cmp` b == GT = descending b [a] xs - | otherwise = ascending b (a :) xs - sequences xs = [xs] - - descending a as (b : bs) - | a `cmp` b == GT = descending b (a : as) bs - descending a as bs = (a : as) : sequences bs - - ascending a as (b : bs) - | a `cmp` b /= GT = ascending b (\ys -> as (a : ys)) bs - ascending a as bs = - let x = as [a] - in x : sequences bs - - mergeAll [x] = x - mergeAll xs = mergeAll (mergePairs xs) - - mergePairs (a : b : xs) = - let x = merge a b - in x : mergePairs xs - mergePairs xs = xs - - merge as@(a : as') bs@(b : bs') - | a `cmp` b == GT = b : merge as bs' - | otherwise = a : merge as' bs - merge [] bs = bs - merge as [] = as + where + sequences (a : b : xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a :) xs + sequences xs = [xs] + + descending a as (b : bs) + | a `cmp` b == GT = descending b (a : as) bs + descending a as bs = (a : as) : sequences bs + + ascending a as (b : bs) + | a `cmp` b /= GT = ascending b (\ys -> as (a : ys)) bs + ascending a as bs = + let x = as [a] + in x : sequences bs + + mergeAll [x] = x + mergeAll xs = mergeAll (mergePairs xs) + + mergePairs (a : b : xs) = + let x = merge a b + in x : mergePairs xs + mergePairs xs = xs + + merge as@(a : as') bs@(b : bs') + | a `cmp` b == GT = b : merge as bs' + | otherwise = a : merge as' bs + merge [] bs = bs + merge as [] = as {-# INLINEABLE sortBy #-} diff --git a/plutus-tx/src/PlutusTx/Maybe.hs b/plutus-tx/src/PlutusTx/Maybe.hs index 1fb36f8ddf6..b1f57a66fec 100644 --- a/plutus-tx/src/PlutusTx/Maybe.hs +++ b/plutus-tx/src/PlutusTx/Maybe.hs @@ -13,39 +13,36 @@ import Prelude (Maybe (..)) {- HLINT ignore -} -{-| Check if a 'Maybe' @a@ is @Just a@ - - >>> isJust Nothing - False - >>> isJust (Just "plutus") - True --} +-- | Check if a 'Maybe' @a@ is @Just a@ +-- +-- >>> isJust Nothing +-- False +-- >>> isJust (Just "plutus") +-- True isJust :: Maybe a -> Bool isJust m = case m of Just _ -> True; _ -> False {-# INLINEABLE isJust #-} -{-| Check if a 'Maybe' @a@ is @Nothing@ - - >>> isNothing Nothing - True - >>> isNothing (Just "plutus") - False --} +-- | Check if a 'Maybe' @a@ is @Nothing@ +-- +-- >>> isNothing Nothing +-- True +-- >>> isNothing (Just "plutus") +-- False isNothing :: Maybe a -> Bool isNothing m = case m of Just _ -> False; _ -> True {-# INLINEABLE isNothing #-} -{-| Plutus Tx version of 'Prelude.maybe'. - - >>> maybe "platypus" (\s -> s) (Just "plutus") - "plutus" - >>> maybe "platypus" (\s -> s) Nothing - "platypus" --} +-- | Plutus Tx version of 'Prelude.maybe'. +-- +-- >>> maybe "platypus" (\s -> s) (Just "plutus") +-- "plutus" +-- >>> maybe "platypus" (\s -> s) Nothing +-- "platypus" maybe :: b -> (a -> b) -> Maybe a -> b maybe b f m = case m of Nothing -> b - Just a -> f a + Just a -> f a {-# INLINEABLE maybe #-} -- | Plutus Tx version of 'Data.Maybe.fromMaybe' @@ -53,11 +50,10 @@ fromMaybe :: a -> Maybe a -> a fromMaybe a = maybe a id {-# INLINEABLE fromMaybe #-} -{-| Plutus Tx version of 'Data.Maybe.mapMaybe'. - - >>> mapMaybe (\i -> if i == 2 then Just '2' else Nothing) [1, 2, 3, 4] - "2" --} +-- | Plutus Tx version of 'Data.Maybe.mapMaybe'. +-- +-- >>> mapMaybe (\i -> if i == 2 then Just '2' else Nothing) [1, 2, 3, 4] +-- "2" mapMaybe :: (a -> Maybe b) -> [a] -> [b] mapMaybe p = foldr (\e xs -> maybe xs (: xs) (p e)) [] {-# INLINEABLE mapMaybe #-} diff --git a/plutus-tx/src/PlutusTx/Monoid.hs b/plutus-tx/src/PlutusTx/Monoid.hs index 273ca9d6dfb..f2c62a6efbd 100644 --- a/plutus-tx/src/PlutusTx/Monoid.hs +++ b/plutus-tx/src/PlutusTx/Monoid.hs @@ -15,7 +15,7 @@ import PlutusTx.Semigroup {- HLINT ignore -} -- | Plutus Tx version of 'Data.Monoid.Monoid'. -class (Semigroup a) => Monoid a where +class Semigroup a => Monoid a where -- | Plutus Tx version of 'Data.Monoid.mempty'. mempty :: a @@ -23,12 +23,12 @@ class (Semigroup a) => Monoid a where -- simpler representation -- | Plutus Tx version of 'Data.Monoid.mappend'. -mappend :: (Monoid a) => a -> a -> a +mappend :: Monoid a => a -> a -> a mappend = (<>) {-# INLINEABLE mappend #-} -- | Plutus Tx version of 'Data.Monoid.mconcat'. -mconcat :: (Monoid a) => [a] -> a +mconcat :: Monoid a => [a] -> a mconcat = foldr mappend mempty {-# INLINEABLE mconcat #-} @@ -44,7 +44,7 @@ instance Monoid [a] where {-# INLINEABLE mempty #-} mempty = [] -instance (Semigroup a) => Monoid (Maybe a) where +instance Semigroup a => Monoid (Maybe a) where {-# INLINEABLE mempty #-} mempty = Nothing @@ -56,7 +56,7 @@ instance (Monoid a, Monoid b) => Monoid (a, b) where {-# INLINEABLE mempty #-} mempty = (mempty, mempty) -instance (Monoid a) => Monoid (Dual a) where +instance Monoid a => Monoid (Dual a) where {-# INLINEABLE mempty #-} mempty = Dual mempty @@ -68,9 +68,9 @@ instance Monoid (First a) where {-# INLINEABLE mempty #-} mempty = First Nothing -class (Monoid a) => Group a where +class Monoid a => Group a where inv :: a -> a -gsub :: (Group a) => a -> a -> a +gsub :: Group a => a -> a -> a gsub x y = x <> inv y {-# INLINEABLE gsub #-} diff --git a/plutus-tx/src/PlutusTx/Numeric.hs b/plutus-tx/src/PlutusTx/Numeric.hs index 68452a781d3..cf42b702504 100644 --- a/plutus-tx/src/PlutusTx/Numeric.hs +++ b/plutus-tx/src/PlutusTx/Numeric.hs @@ -1,5 +1,5 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} @@ -29,8 +29,16 @@ module PlutusTx.Numeric ( import Data.Coerce (coerce) import Data.Semigroup (Product (Product), Sum (Sum)) import PlutusTx.Bool (Bool (False, True), (&&), (||)) -import PlutusTx.Builtins (Integer, addInteger, divideInteger, modInteger, multiplyInteger, - quotientInteger, remainderInteger, subtractInteger) +import PlutusTx.Builtins ( + Integer, + addInteger, + divideInteger, + modInteger, + multiplyInteger, + quotientInteger, + remainderInteger, + subtractInteger, + ) import PlutusTx.Monoid (Group, Monoid (mempty), gsub) import PlutusTx.Ord (Ord ((<))) import PlutusTx.Semigroup (Semigroup ((<>))) @@ -43,29 +51,29 @@ class AdditiveSemigroup a where (+) :: a -> a -> a -- | A 'Monoid' that it is sensible to describe using addition and zero. -class (AdditiveSemigroup a) => AdditiveMonoid a where +class AdditiveSemigroup a => AdditiveMonoid a where zero :: a -- | A 'Group' that it is sensible to describe using addition, zero, and subtraction. -class (AdditiveMonoid a) => AdditiveGroup a where +class AdditiveMonoid a => AdditiveGroup a where (-) :: a -> a -> a -negate :: (AdditiveGroup a) => a -> a +negate :: AdditiveGroup a => a -> a negate x = zero - x {-# INLINEABLE negate #-} -- | A newtype wrapper to derive 'Additive' classes via. newtype Additive a = Additive a -instance (Semigroup a) => AdditiveSemigroup (Additive a) where +instance Semigroup a => AdditiveSemigroup (Additive a) where {-# INLINEABLE (+) #-} (+) = coerce ((<>) :: a -> a -> a) -instance (Monoid a) => AdditiveMonoid (Additive a) where +instance Monoid a => AdditiveMonoid (Additive a) where {-# INLINEABLE zero #-} zero = Additive mempty -instance (Group a) => AdditiveGroup (Additive a) where +instance Group a => AdditiveGroup (Additive a) where {-# INLINEABLE (-) #-} (-) = coerce (gsub :: a -> a -> a) @@ -74,7 +82,7 @@ class MultiplicativeSemigroup a where (*) :: a -> a -> a -- | A 'Semigroup' that it is sensible to describe using multiplication and one. -class (MultiplicativeSemigroup a) => MultiplicativeMonoid a where +class MultiplicativeSemigroup a => MultiplicativeMonoid a where one :: a -- TODO: multiplicative group? I haven't added any since for e.g. integers division @@ -83,11 +91,11 @@ class (MultiplicativeSemigroup a) => MultiplicativeMonoid a where -- | A newtype wrapper to derive 'Multiplicative' classes via. newtype Multiplicative a = Multiplicative a -instance (Semigroup a) => MultiplicativeSemigroup (Multiplicative a) where +instance Semigroup a => MultiplicativeSemigroup (Multiplicative a) where {-# INLINEABLE (*) #-} (*) = coerce ((<>) :: a -> a -> a) -instance (Monoid a) => MultiplicativeMonoid (Multiplicative a) where +instance Monoid a => MultiplicativeMonoid (Multiplicative a) where {-# INLINEABLE one #-} one = Multiplicative mempty @@ -137,19 +145,19 @@ instance MultiplicativeMonoid Bool where class (Ring s, AdditiveGroup v) => Module s v | v -> s where scale :: s -> v -> v -instance (AdditiveSemigroup a) => Semigroup (Sum a) where +instance AdditiveSemigroup a => Semigroup (Sum a) where {-# INLINEABLE (<>) #-} (<>) = coerce ((+) :: a -> a -> a) -instance (AdditiveMonoid a) => Monoid (Sum a) where +instance AdditiveMonoid a => Monoid (Sum a) where {-# INLINEABLE mempty #-} mempty = Sum zero -instance (MultiplicativeSemigroup a) => Semigroup (Product a) where +instance MultiplicativeSemigroup a => Semigroup (Product a) where {-# INLINEABLE (<>) #-} (<>) = coerce ((*) :: a -> a -> a) -instance (MultiplicativeMonoid a) => Monoid (Product a) where +instance MultiplicativeMonoid a => Monoid (Product a) where {-# INLINEABLE mempty #-} mempty = Product one diff --git a/plutus-tx/src/PlutusTx/Optimize/Inline.hs b/plutus-tx/src/PlutusTx/Optimize/Inline.hs index 1a2421a3e54..b073949ad25 100644 --- a/plutus-tx/src/PlutusTx/Optimize/Inline.hs +++ b/plutus-tx/src/PlutusTx/Optimize/Inline.hs @@ -2,11 +2,10 @@ module PlutusTx.Optimize.Inline (inline) where import Prelude -{-| Like @GHC.Magic.Inline@, this function can be used to perform callsite inlining. - -@inline f@ or @inline (f x1 ... xn)@ inlines @f@, as long as @f@'s unfolding is available, -and @f@ is not recursive. --} +-- | Like @GHC.Magic.Inline@, this function can be used to perform callsite inlining. +-- +-- @inline f@ or @inline (f x1 ... xn)@ inlines @f@, as long as @f@'s unfolding is available, +-- and @f@ is not recursive. inline :: a -> a inline = id {-# OPAQUE inline #-} diff --git a/plutus-tx/src/PlutusTx/Optimize/SpaceTime.hs b/plutus-tx/src/PlutusTx/Optimize/SpaceTime.hs index 52bfaf0c6a4..22bd4c71b19 100644 --- a/plutus-tx/src/PlutusTx/Optimize/SpaceTime.hs +++ b/plutus-tx/src/PlutusTx/Optimize/SpaceTime.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE TemplateHaskell #-} -- | Utilities for space-time tradeoff, such as recursion unrolling. @@ -9,76 +9,72 @@ import Prelude import Language.Haskell.TH.Syntax qualified as TH import PlutusTx.Function (fix) -{-| Given @n@, and the step function for a recursive function, peel @n@ layers -off of the recursion. - -For example @peel 3 (\self -> [[| \case [] -> 0; _ : ys -> 1 + self ys||])@ -yields the equivalence of the following function: - -@ - lengthPeeled :: [a] -> a - lengthPeeled xs = - case xs of -- first recursion step - [] -> 0 - _ : ys -> 1 + - case ys of -- second recursion step - [] -> 0 - _ : zs -> 1 + - case zs of -- third recursion step - [] -> 0 - _ : ws -> 1 + - ( fix \self qs -> -- rest of recursion steps in a tight loop - case qs of - [] -> 0 - _ : ts -> 1 + self ts - ) ws -@ --} -peel - :: forall a b - . Int - -- ^ How many recursion steps to move outside of the recursion loop. - -> (TH.Code TH.Q (a -> b) -> TH.Code TH.Q (a -> b)) - {- ^ Function that given a continuation splice returns - a splice representing a single recursion step calling this continuation. - -} - -> TH.Code TH.Q (a -> b) +-- | Given @n@, and the step function for a recursive function, peel @n@ layers +-- off of the recursion. +-- +-- For example @peel 3 (\self -> [[| \case [] -> 0; _ : ys -> 1 + self ys||])@ +-- yields the equivalence of the following function: +-- +-- @ +-- lengthPeeled :: [a] -> a +-- lengthPeeled xs = +-- case xs of -- first recursion step +-- [] -> 0 +-- _ : ys -> 1 + +-- case ys of -- second recursion step +-- [] -> 0 +-- _ : zs -> 1 + +-- case zs of -- third recursion step +-- [] -> 0 +-- _ : ws -> 1 + +-- ( fix \self qs -> -- rest of recursion steps in a tight loop +-- case qs of +-- [] -> 0 +-- _ : ts -> 1 + self ts +-- ) ws +-- @ +peel :: + forall a b. + -- | How many recursion steps to move outside of the recursion loop. + Int -> + -- | Function that given a continuation splice returns + -- a splice representing a single recursion step calling this continuation. + (TH.Code TH.Q (a -> b) -> TH.Code TH.Q (a -> b)) -> + TH.Code TH.Q (a -> b) peel 0 f = [||fix \self -> $$(f [||self||])||] peel n f | n > 0 = f (peel (n - 1) f) | otherwise = error $ "PlutusTx.Optimize.SpaceTime.peel: negative n: " <> show n -{-| Given @n@, and the step function for a recursive function, - unroll recursion @n@ layers at a time - -For example @unroll 3 (\self -> [|| \case [] -> 0; _ : ys -> 1 + self ys ||])@ -yields the equivalence of the following function: - -@ - lengthUnrolled :: [a] -> a - lengthUnrolled = - fix \self xs -> -- beginning of the recursion "loop" - case xs of -- first recursion step - [] -> 0 - _ : ys -> 1 + - case ys of -- second recursion step - [] -> 0 - _ : zs -> 1 + - case zs of -- third recursion step - [] -> 0 - _ : ws -> 1 + self ws -- end of the "loop" - -@ --} -unroll - :: forall a b - . Int - -- ^ How many recursion steps to perform inside the recursion loop. - -> (TH.Code TH.Q (a -> b) -> TH.Code TH.Q (a -> b)) - {- ^ Function that given a continuation splice returns - a splice representing a single recursion step calling this continuation. - -} - -> TH.Code TH.Q (a -> b) +-- | Given @n@, and the step function for a recursive function, +-- unroll recursion @n@ layers at a time +-- +-- For example @unroll 3 (\self -> [|| \case [] -> 0; _ : ys -> 1 + self ys ||])@ +-- yields the equivalence of the following function: +-- +-- @ +-- lengthUnrolled :: [a] -> a +-- lengthUnrolled = +-- fix \self xs -> -- beginning of the recursion "loop" +-- case xs of -- first recursion step +-- [] -> 0 +-- _ : ys -> 1 + +-- case ys of -- second recursion step +-- [] -> 0 +-- _ : zs -> 1 + +-- case zs of -- third recursion step +-- [] -> 0 +-- _ : ws -> 1 + self ws -- end of the "loop" +-- +-- @ +unroll :: + forall a b. + -- | How many recursion steps to perform inside the recursion loop. + Int -> + -- | Function that given a continuation splice returns + -- a splice representing a single recursion step calling this continuation. + (TH.Code TH.Q (a -> b) -> TH.Code TH.Q (a -> b)) -> + TH.Code TH.Q (a -> b) unroll n f = [||fix \self -> $$(nTimes n f [||self||])||] -- | Apply a function @n@ times to a given value. diff --git a/plutus-tx/src/PlutusTx/Ord.hs b/plutus-tx/src/PlutusTx/Ord.hs index 7140d761ade..b2fcc736cb0 100644 --- a/plutus-tx/src/PlutusTx/Ord.hs +++ b/plutus-tx/src/PlutusTx/Ord.hs @@ -21,12 +21,11 @@ infix 4 <, <=, >, >= -- Copied from the GHC definition -{-| The 'Ord' class is used for totally ordered datatypes. - -Minimal complete definition: either 'compare' or '<='. -Using 'compare' can be more efficient for complex types. --} -class (Eq a) => Ord a where +-- | The 'Ord' class is used for totally ordered datatypes. +-- +-- Minimal complete definition: either 'compare' or '<='. +-- Using 'compare' can be more efficient for complex types. +class Eq a => Ord a where compare :: a -> a -> Ordering (<), (<=), (>), (>=) :: a -> a -> Bool max, min :: a -> a -> a @@ -65,7 +64,7 @@ instance Eq Ordering where EQ == EQ = True GT == GT = True LT == LT = True - _ == _ = False + _ == _ = False instance Ord Builtins.Integer where {-# INLINEABLE (<) #-} @@ -87,7 +86,7 @@ instance Ord Builtins.BuiltinByteString where {-# INLINEABLE (>=) #-} (>=) = Builtins.greaterThanEqualsByteString -instance (Ord a) => Ord [a] where +instance Ord a => Ord [a] where {-# INLINEABLE compare #-} compare [] [] = EQ compare [] (_ : _) = LT @@ -95,30 +94,30 @@ instance (Ord a) => Ord [a] where compare (x : xs) (y : ys) = case compare x y of EQ -> compare xs ys - c -> c + c -> c instance Ord Bool where {-# INLINEABLE compare #-} compare b1 b2 = case b1 of False -> case b2 of False -> EQ - True -> LT + True -> LT True -> case b2 of False -> GT - True -> EQ + True -> EQ -instance (Ord a) => Ord (Maybe a) where +instance Ord a => Ord (Maybe a) where {-# INLINEABLE compare #-} compare (Just a1) (Just a2) = compare a1 a2 - compare Nothing (Just _) = LT - compare (Just _) Nothing = GT - compare Nothing Nothing = EQ + compare Nothing (Just _) = LT + compare (Just _) Nothing = GT + compare Nothing Nothing = EQ instance (Ord a, Ord b) => Ord (Either a b) where {-# INLINEABLE compare #-} - compare (Left a1) (Left a2) = compare a1 a2 - compare (Left _) (Right _) = LT - compare (Right _) (Left _) = GT + compare (Left a1) (Left a2) = compare a1 a2 + compare (Left _) (Right _) = LT + compare (Right _) (Left _) = GT compare (Right b1) (Right b2) = compare b1 b2 instance Ord () where @@ -130,7 +129,7 @@ instance (Ord a, Ord b) => Ord (a, b) where compare (a, b) (a', b') = case compare a a' of EQ -> compare b b' - c -> c + c -> c instance (Ord a, Ord b) => Ord (These a b) where {-# INLINEABLE compare #-} @@ -139,7 +138,7 @@ instance (Ord a, Ord b) => Ord (These a b) where compare (These a b) (These a' b') = case compare a a' of EQ -> compare b b' - c -> c + c -> c compare (This _) _ = LT compare (That _) (This _) = GT compare (That _) (These _ _) = LT diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index 07af099c83b..d3e85d36b7e 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/plutus-tx/src/PlutusTx/Prelude.hs @@ -7,15 +7,14 @@ {-# OPTIONS_GHC -fmax-simplifier-iterations=0 #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-| The PlutusTx Prelude is a replacement for the Haskell Prelude that works -better with Plutus Tx. You should use it if you're writing code that -will be compiled with the Plutus Tx compiler. - -@ - :set -XNoImplicitPrelude - import PlutusTx.Prelude -@ --} +-- | The PlutusTx Prelude is a replacement for the Haskell Prelude that works +-- better with Plutus Tx. You should use it if you're writing code that +-- will be compiled with the Plutus Tx compiler. +-- +-- @ +-- :set -XNoImplicitPrelude +-- import PlutusTx.Prelude +-- @ module PlutusTx.Prelude ( -- * Classes module Eq, @@ -168,24 +167,68 @@ import PlutusCore.Data (Data (..)) import PlutusTx.Applicative as Applicative import PlutusTx.Base as Base import PlutusTx.Bool as Bool -import PlutusTx.Builtins (BuiltinBLS12_381_G1_Element, BuiltinBLS12_381_G2_Element, - BuiltinBLS12_381_MlResult, BuiltinByteString, BuiltinByteStringUtf8 (..), - BuiltinData, BuiltinString, Integer, appendByteString, appendString, - blake2b_224, blake2b_256, bls12_381_G1_add, bls12_381_G1_compress, - bls12_381_G1_compressed_generator, bls12_381_G1_compressed_zero, - bls12_381_G1_equals, bls12_381_G1_hashToGroup, bls12_381_G1_neg, - bls12_381_G1_scalarMul, bls12_381_G1_uncompress, bls12_381_G2_add, - bls12_381_G2_compress, bls12_381_G2_compressed_generator, - bls12_381_G2_compressed_zero, bls12_381_G2_equals, - bls12_381_G2_hashToGroup, bls12_381_G2_neg, bls12_381_G2_scalarMul, - bls12_381_G2_uncompress, bls12_381_finalVerify, bls12_381_millerLoop, - bls12_381_mulMlResult, byteStringToInteger, consByteString, decodeUtf8, - emptyByteString, emptyString, encodeUtf8, equalsByteString, equalsString, - error, fromBuiltin, fromOpaque, greaterThanByteString, indexByteString, - integerToByteString, keccak_256, lengthOfByteString, lessThanByteString, - ripemd_160, sha2_256, sha3_256, sliceByteString, toBuiltin, toOpaque, - trace, verifyEcdsaSecp256k1Signature, verifyEd25519Signature, - verifySchnorrSecp256k1Signature) +import PlutusTx.Builtins ( + BuiltinBLS12_381_G1_Element, + BuiltinBLS12_381_G2_Element, + BuiltinBLS12_381_MlResult, + BuiltinByteString, + BuiltinByteStringUtf8 (..), + BuiltinData, + BuiltinString, + Integer, + appendByteString, + appendString, + blake2b_224, + blake2b_256, + bls12_381_G1_add, + bls12_381_G1_compress, + bls12_381_G1_compressed_generator, + bls12_381_G1_compressed_zero, + bls12_381_G1_equals, + bls12_381_G1_hashToGroup, + bls12_381_G1_neg, + bls12_381_G1_scalarMul, + bls12_381_G1_uncompress, + bls12_381_G2_add, + bls12_381_G2_compress, + bls12_381_G2_compressed_generator, + bls12_381_G2_compressed_zero, + bls12_381_G2_equals, + bls12_381_G2_hashToGroup, + bls12_381_G2_neg, + bls12_381_G2_scalarMul, + bls12_381_G2_uncompress, + bls12_381_finalVerify, + bls12_381_millerLoop, + bls12_381_mulMlResult, + byteStringToInteger, + consByteString, + decodeUtf8, + emptyByteString, + emptyString, + encodeUtf8, + equalsByteString, + equalsString, + error, + fromBuiltin, + fromOpaque, + greaterThanByteString, + indexByteString, + integerToByteString, + keccak_256, + lengthOfByteString, + lessThanByteString, + ripemd_160, + sha2_256, + sha3_256, + sliceByteString, + toBuiltin, + toOpaque, + trace, + verifyEcdsaSecp256k1Signature, + verifyEd25519Signature, + verifySchnorrSecp256k1Signature, + ) import PlutusTx.Builtins qualified as Builtins import PlutusTx.Builtins.Internal qualified as BI @@ -215,20 +258,18 @@ check :: Bool -> BI.BuiltinUnit check b = if b then BI.unitval else traceError checkHasFailedError {-# INLINEABLE check #-} -{-| Integer division, rounding downwards - - >>> divide (-41) 5 - -9 --} +-- | Integer division, rounding downwards +-- +-- >>> divide (-41) 5 +-- -9 divide :: Integer -> Integer -> Integer divide = Builtins.divideInteger {-# INLINEABLE divide #-} -{-| Integer remainder, always positive for a positive divisor - - >>> modulo (-41) 5 - 4 --} +-- | Integer remainder, always positive for a positive divisor +-- +-- >>> modulo (-41) 5 +-- 4 modulo :: Integer -> Integer -> Integer modulo = Builtins.modInteger {-# INLINEABLE modulo #-} @@ -238,20 +279,18 @@ expMod :: Integer -> Integer -> Integer -> Integer expMod = Builtins.expModInteger {-# INLINEABLE expMod #-} -{-| Integer division, rouding towards zero - - >>> quotient (-41) 5 - -8 --} +-- | Integer division, rouding towards zero +-- +-- >>> quotient (-41) 5 +-- -8 {-# INLINEABLE quotient #-} quotient :: Integer -> Integer -> Integer quotient = Builtins.quotientInteger -{-| Integer remainder, same sign as dividend - - >>> remainder (-41) 5 - -1 --} +-- | Integer remainder, same sign as dividend +-- +-- >>> remainder (-41) 5 +-- -1 remainder :: Integer -> Integer -> Integer remainder = Builtins.remainderInteger {-# INLINEABLE remainder #-} diff --git a/plutus-tx/src/PlutusTx/Ratio.hs b/plutus-tx/src/PlutusTx/Ratio.hs index 7b648687c58..10164453cf6 100644 --- a/plutus-tx/src/PlutusTx/Ratio.hs +++ b/plutus-tx/src/PlutusTx/Ratio.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} module PlutusTx.Ratio ( @@ -58,17 +58,16 @@ import GHC.Generics import GHC.Real qualified as Ratio import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), HasSchemaDefinition) +import Prettyprinter (Pretty (..), (<+>)) import Prelude (Ord (..), Show, (*)) import Prelude qualified as Haskell -import Prettyprinter (Pretty (..), (<+>)) - -{-| Represents an arbitrary-precision ratio. -The following two invariants are maintained: - -1. The denominator is greater than zero. -2. The numerator and denominator are coprime. --} +-- | Represents an arbitrary-precision ratio. +-- +-- The following two invariants are maintained: +-- +-- 1. The denominator is greater than zero. +-- 2. The numerator and denominator are coprime. data Rational = Rational Integer Integer deriving stock (Haskell.Eq, Show, Generic) @@ -149,8 +148,8 @@ instance HasBlueprintDefinition Rational where type Unroll Rational = '[Rational, Integer] instance - (HasSchemaDefinition Integer referencedTypes) - => HasBlueprintSchema Rational referencedTypes + HasSchemaDefinition Integer referencedTypes => + HasBlueprintSchema Rational referencedTypes where schema = schema @(Integer, Integer) @@ -193,15 +192,14 @@ instance FromJSON Rational where d <- obj .: "denominator" case ratio n d of Haskell.Nothing -> Haskell.fail "Zero denominator is invalid." - Haskell.Just r -> Haskell.pure r - -{-| Makes a 'Rational' from a numerator and a denominator. + Haskell.Just r -> Haskell.pure r -= Important note - -If given a zero denominator, this function will error. If you don't mind a -size increase, and care about safety, use 'ratio' instead. --} +-- | Makes a 'Rational' from a numerator and a denominator. +-- +-- = Important note +-- +-- If given a zero denominator, this function will error. If you don't mind a +-- size increase, and care about safety, use 'ratio' instead. unsafeRatio :: Integer -> Integer -> Rational unsafeRatio n d | d P.== P.zero = P.traceError P.ratioHasZeroDenominatorError @@ -213,9 +211,8 @@ unsafeRatio n d (d `Builtins.quotientInteger` gcd') {-# INLINEABLE unsafeRatio #-} -{-| Safely constructs a 'Rational' from a numerator and a denominator. Returns -'Nothing' if given a zero denominator. --} +-- | Safely constructs a 'Rational' from a numerator and a denominator. Returns +-- 'Nothing' if given a zero denominator. ratio :: Integer -> Integer -> P.Maybe Rational ratio n d | d P.== P.zero = P.Nothing @@ -228,33 +225,30 @@ ratio n d (d `Builtins.quotientInteger` gcd') {-# INLINEABLE ratio #-} -{-| Converts a 'Rational' to a GHC 'Ratio.Rational', preserving value. Does not -work on-chain. --} +-- | Converts a 'Rational' to a GHC 'Ratio.Rational', preserving value. Does not +-- work on-chain. toGHC :: Rational -> Ratio.Rational toGHC (Rational n d) = n Ratio.% d -{-| Returns the numerator of its argument. - -= Note - -It is /not/ true in general that @'numerator' '<$>' 'ratio' x y = x@; this -will only hold if @x@ and @y@ are coprime. This is due to 'Rational' -normalizing the numerator and denominator. --} +-- | Returns the numerator of its argument. +-- +-- = Note +-- +-- It is /not/ true in general that @'numerator' '<$>' 'ratio' x y = x@; this +-- will only hold if @x@ and @y@ are coprime. This is due to 'Rational' +-- normalizing the numerator and denominator. numerator :: Rational -> Integer numerator (Rational n _) = n {-# INLINEABLE numerator #-} -{-| Returns the denominator of its argument. This will always be greater than, -or equal to, 1, although the type does not describe this. - -= Note - -It is /not/ true in general that @'denominator' '<$>' 'ratio' x y = y@; this -will only hold if @x@ and @y@ are coprime. This is due to 'Rational' -normalizing the numerator and denominator. --} +-- | Returns the denominator of its argument. This will always be greater than, +-- or equal to, 1, although the type does not describe this. +-- +-- = Note +-- +-- It is /not/ true in general that @'denominator' '<$>' 'ratio' x y = y@; this +-- will only hold if @x@ and @y@ are coprime. This is due to 'Rational' +-- normalizing the numerator and denominator. denominator :: Rational -> Integer denominator (Rational _ d) = d {-# INLINEABLE denominator #-} @@ -273,38 +267,35 @@ fromInteger num = Rational num P.one fromGHC :: Ratio.Rational -> Rational fromGHC r = unsafeRatio (Ratio.numerator r) (Ratio.denominator r) -{-| Produces the additive inverse of its argument. - -= Note - -This is specialized for 'Rational'; use this instead of the generic version -of this function, as it is significantly smaller on-chain. --} +-- | Produces the additive inverse of its argument. +-- +-- = Note +-- +-- This is specialized for 'Rational'; use this instead of the generic version +-- of this function, as it is significantly smaller on-chain. negate :: Rational -> Rational negate (Rational n d) = Rational (P.negate n) d {-# INLINEABLE negate #-} -{-| Returns the absolute value of its argument. - -= Note - -This is specialized for 'Rational'; use this instead of the generic version -in @PlutusTx.Numeric@, as said generic version produces much larger on-chain -code than the specialized version here. --} +-- | Returns the absolute value of its argument. +-- +-- = Note +-- +-- This is specialized for 'Rational'; use this instead of the generic version +-- in @PlutusTx.Numeric@, as said generic version produces much larger on-chain +-- code than the specialized version here. abs :: Rational -> Rational abs rat@(Rational n d) | n P.< P.zero = Rational (P.negate n) d | P.True = rat {-# INLINEABLE abs #-} -{-| @'properFraction' r@ returns the pair @(n, f)@, such that all of the -following hold: - -* @'fromInteger' n 'P.+' f = r@; -* @n@ and @f@ both have the same sign as @r@; and -* @'abs' f 'P.<' 'P.one'@. --} +-- | @'properFraction' r@ returns the pair @(n, f)@, such that all of the +-- following hold: +-- +-- * @'fromInteger' n 'P.+' f = r@; +-- * @n@ and @f@ both have the same sign as @r@; and +-- * @'abs' f 'P.<' 'P.one'@. properFraction :: Rational -> (Integer, Rational) properFraction (Rational n d) = ( n `Builtins.quotientInteger` d @@ -312,14 +303,13 @@ properFraction (Rational n d) = ) {-# INLINEABLE properFraction #-} -{-| Gives the reciprocal of the argument; specifically, for @r 'P./=' -'P.zero'@, @r 'P.*' 'recip' r = 'P.one'@. - -= Important note - -The reciprocal of zero is mathematically undefined; thus, @'recip' 'P.zero'@ -will error. Use with care. --} +-- | Gives the reciprocal of the argument; specifically, for @r 'P./=' +-- 'P.zero'@, @r 'P.*' 'recip' r = 'P.one'@. +-- +-- = Important note +-- +-- The reciprocal of zero is mathematically undefined; thus, @'recip' 'P.zero'@ +-- will error. Use with care. recip :: Rational -> Rational recip (Rational n d) | n P.== P.zero = P.traceError P.reciprocalOfZeroError @@ -327,17 +317,15 @@ recip (Rational n d) | P.True = Rational d n {-# INLINEABLE recip #-} -{-| Returns the whole-number part of its argument, dropping any leftover -fractional part. More precisely, @'truncate' r = n@ where @(n, _) = -'properFraction' r@, but is much more efficient. --} +-- | Returns the whole-number part of its argument, dropping any leftover +-- fractional part. More precisely, @'truncate' r = n@ where @(n, _) = +-- 'properFraction' r@, but is much more efficient. truncate :: Rational -> Integer truncate (Rational n d) = n `Builtins.quotientInteger` d {-# INLINEABLE truncate #-} -{-| @'round' r@ returns the nearest 'Integer' value to @r@. If @r@ is -equidistant between two values, the even value will be given. --} +-- | @'round' r@ returns the nearest 'Integer' value to @r@. If @r@ is +-- equidistant between two values, the even value will be given. round :: Rational -> Integer round x = let (n, r) = properFraction x @@ -354,16 +342,15 @@ round x = -- From GHC.Real -{-| @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which -every common factor of @x@ and @y@ is also a factor; for example -@'gcd' 4 2 = 2@, @'gcd' (-4) 6 = 2@, @'gcd' 0 4@ = @4@. @'gcd' 0 0@ = @0@. --} +-- | @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which +-- every common factor of @x@ and @y@ is also a factor; for example +-- @'gcd' 4 2 = 2@, @'gcd' (-4) 6 = 2@, @'gcd' 0 4@ = @4@. @'gcd' 0 0@ = @0@. gcd :: Integer -> Integer -> Integer gcd a b = gcd' (P.abs a) (P.abs b) - where - gcd' a' b' - | b' P.== P.zero = a' - | P.True = gcd' b' (a' `Builtins.remainderInteger` b') + where + gcd' a' b' + | b' P.== P.zero = a' + | P.True = gcd' b' (a' `Builtins.remainderInteger` b') {-# INLINEABLE gcd #-} -- Helpers diff --git a/plutus-tx/src/PlutusTx/Semigroup.hs b/plutus-tx/src/PlutusTx/Semigroup.hs index 680791e6438..95131ec9614 100644 --- a/plutus-tx/src/PlutusTx/Semigroup.hs +++ b/plutus-tx/src/PlutusTx/Semigroup.hs @@ -41,7 +41,7 @@ instance (Semigroup a, Semigroup b) => Semigroup (a, b) where {-# INLINEABLE (<>) #-} (a1, b1) <> (a2, b2) = (a1 <> a2, b1 <> b2) -instance (Semigroup a) => Semigroup (Maybe a) where +instance Semigroup a => Semigroup (Maybe a) where Just a1 <> Just a2 = Just (a1 <> a2) Just a1 <> Nothing = Just a1 Nothing <> Just a2 = Just a2 @@ -55,7 +55,7 @@ instance Semigroup Ordering where instance Semigroup () where _ <> _ = () -instance (Semigroup a) => Semigroup (Dual a) where +instance Semigroup a => Semigroup (Dual a) where {-# INLINEABLE (<>) #-} Dual a1 <> Dual a2 = Dual (a2 <> a1) @@ -66,7 +66,7 @@ instance Semigroup (Endo a) where instance Semigroup (First a) where {-# INLINEABLE (<>) #-} First Nothing <> b = b - a <> _ = a + a <> _ = a newtype Max a = Max {getMax :: a} @@ -74,7 +74,7 @@ instance Functor Max where {-# INLINEABLE fmap #-} fmap = coerce -instance (Ord a) => Semigroup (Max a) where +instance Ord a => Semigroup (Max a) where {-# INLINEABLE (<>) #-} (<>) = coerce (max :: a -> a -> a) @@ -84,6 +84,6 @@ instance Functor Min where {-# INLINEABLE fmap #-} fmap = coerce -instance (Ord a) => Semigroup (Min a) where +instance Ord a => Semigroup (Min a) where {-# INLINEABLE (<>) #-} (<>) = coerce (min :: a -> a -> a) diff --git a/plutus-tx/src/PlutusTx/Show.hs b/plutus-tx/src/PlutusTx/Show.hs index 4aa4fa214be..1eafcfd5459 100644 --- a/plutus-tx/src/PlutusTx/Show.hs +++ b/plutus-tx/src/PlutusTx/Show.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} module PlutusTx.Show ( @@ -33,61 +33,61 @@ instance Show Builtins.Integer where if n < 0 then showString "-" . showsPrec p (negate n) else foldr alg id (toDigits n) - where - alg :: Builtins.Integer -> ShowS -> ShowS - alg digit acc = - showString - ( if - | digit == 0 -> "0" - | digit == 1 -> "1" - | digit == 2 -> "2" - | digit == 3 -> "3" - | digit == 4 -> "4" - | digit == 5 -> "5" - | digit == 6 -> "6" - | digit == 7 -> "7" - | digit == 8 -> "8" - | digit == 9 -> "9" - | otherwise -> "" - ) - . acc + where + alg :: Builtins.Integer -> ShowS -> ShowS + alg digit acc = + showString + ( if + | digit == 0 -> "0" + | digit == 1 -> "1" + | digit == 2 -> "2" + | digit == 3 -> "3" + | digit == 4 -> "4" + | digit == 5 -> "5" + | digit == 6 -> "6" + | digit == 7 -> "7" + | digit == 8 -> "8" + | digit == 9 -> "9" + | otherwise -> "" + ) + . acc -- | Convert a non-negative integer to individual digits. toDigits :: Builtins.Integer -> [Builtins.Integer] toDigits = go [] - where - go acc n = case n `quotRem` 10 of - (q, r) -> - if q == 0 - then r : acc - else go (r : acc) q + where + go acc n = case n `quotRem` 10 of + (q, r) -> + if q == 0 + then r : acc + else go (r : acc) q {-# INLINEABLE toDigits #-} instance Show Builtins.BuiltinByteString where {-# INLINEABLE showsPrec #-} -- Base16-encode the ByteString and show the result. showsPrec _ s = foldr alg id (enumFromTo 0 (len - 1)) - where - len = Builtins.lengthOfByteString s + where + len = Builtins.lengthOfByteString s - showWord8 :: Builtins.Integer -> ShowS - showWord8 x = - toHex (x `Builtins.divideInteger` 16) - . toHex (x `Builtins.modInteger` 16) + showWord8 :: Builtins.Integer -> ShowS + showWord8 x = + toHex (x `Builtins.divideInteger` 16) + . toHex (x `Builtins.modInteger` 16) - toHex :: Integer -> ShowS - toHex x = - if - | x <= 9 -> showsPrec 0 x - | x == 10 -> showString "a" - | x == 11 -> showString "b" - | x == 12 -> showString "c" - | x == 13 -> showString "d" - | x == 14 -> showString "e" - | x == 15 -> showString "f" - | otherwise -> showString "" - alg :: Builtins.Integer -> ShowS -> ShowS - alg i acc = showWord8 (Builtins.indexByteString s i) . acc + toHex :: Integer -> ShowS + toHex x = + if + | x <= 9 -> showsPrec 0 x + | x == 10 -> showString "a" + | x == 11 -> showString "b" + | x == 12 -> showString "c" + | x == 13 -> showString "d" + | x == 14 -> showString "e" + | x == 15 -> showString "f" + | otherwise -> showString "" + alg :: Builtins.Integer -> ShowS -> ShowS + alg i acc = showWord8 (Builtins.indexByteString s i) . acc instance Show Builtins.BuiltinString where {-# INLINEABLE showsPrec #-} @@ -116,7 +116,7 @@ instance Show () where -- are often erased anyway. -- -- Same for the `Show (a, b)` instance. -instance (Show a) => Show [a] where +instance Show a => Show [a] where {-# INLINEABLE showsPrec #-} showsPrec _ = showList (showsPrec 0) @@ -128,9 +128,9 @@ showList showElem = \case . showElem x . foldr alg id xs . showString "]" - where - alg :: a -> ShowS -> ShowS - alg a acc = showString "," . showElem a . acc + where + alg :: a -> ShowS -> ShowS + alg a acc = showString "," . showElem a . acc {-# INLINEABLE showList #-} deriveShow ''(,) diff --git a/plutus-tx/src/PlutusTx/Show/TH.hs b/plutus-tx/src/PlutusTx/Show/TH.hs index 9350b1dfcfd..197c85708b2 100644 --- a/plutus-tx/src/PlutusTx/Show/TH.hs +++ b/plutus-tx/src/PlutusTx/Show/TH.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module PlutusTx.Show.TH where @@ -18,9 +18,8 @@ import Language.Haskell.TH.Datatype qualified as TH import Prelude (pure, (+), (<$>), (<>)) import Prelude qualified as Haskell -{-| Conversion of values to `BuiltinString`s. Unlike @GHC.Show.Show@, there is no - @showList@ method, because there is no `Show` instance for `Data.String.String`. --} +-- | Conversion of values to `BuiltinString`s. Unlike @GHC.Show.Show@, there is no +-- @showList@ method, because there is no `Show` instance for `Data.String.String`. class Show a where {-# MINIMAL showsPrec | show #-} @@ -32,16 +31,15 @@ class Show a where show :: a -> BuiltinString show x = concatBuiltinStrings (showsPrec 0 x []) -{-| Currently the only way to concatenate `BuiltinString`s is `appendString`, whose cost - is linear in the total length of the two strings. A naive concatenation of multiple - `BuiltinString`s costs @O(n^2)@ in the worst case, where @n@ is the total length. By - collecting the `BuiltinString`s in a list and concatenating them in the end, the cost - can be reduced to @O(n*logn)@. If we add a @concatStrings@ builtin function in the future, - the cost can be further reduced to @O(n)@. - - Like `GHC.Show.ShowS`, the purpose of the function type here is to turn list concatenation - into function composition. --} +-- | Currently the only way to concatenate `BuiltinString`s is `appendString`, whose cost +-- is linear in the total length of the two strings. A naive concatenation of multiple +-- `BuiltinString`s costs @O(n^2)@ in the worst case, where @n@ is the total length. By +-- collecting the `BuiltinString`s in a list and concatenating them in the end, the cost +-- can be reduced to @O(n*logn)@. If we add a @concatStrings@ builtin function in the future, +-- the cost can be further reduced to @O(n)@. +-- +-- Like `GHC.Show.ShowS`, the purpose of the function type here is to turn list concatenation +-- into function composition. type ShowS = [BuiltinString] -> [BuiltinString] showString :: BuiltinString -> ShowS @@ -105,9 +103,9 @@ deriveShowsPrec cons = , -- `showsPrec` must be inlinable for the plugin to inline it TH.pragInlD 'showsPrec TH.Inlinable TH.FunLike TH.AllPhases ] - where - clause = TH.clause [] body [] - body = TH.normalB $ deriveShowsPrecBody cons + where + clause = TH.clause [] body [] + body = TH.normalB $ deriveShowsPrecBody cons deriveShowsPrecBody :: [TH.ConstructorInfo] -> TH.Q TH.Exp deriveShowsPrecBody cons = do @@ -179,9 +177,9 @@ deriveMatchForCon p = \case mappendArgs, namedArgs :: TH.Q TH.Exp mappendArgs = Haskell.foldr1 alg showArgExps - where - alg :: TH.Q TH.Exp -> TH.Q TH.Exp -> TH.Q TH.Exp - alg argExp acc = [|$argExp . showSpace . $acc|] + where + alg :: TH.Q TH.Exp -> TH.Q TH.Exp -> TH.Q TH.Exp + alg argExp acc = [|$argExp . showSpace . $acc|] namedArgs = [| showString @@ -223,19 +221,19 @@ deriveMatchForCon p = \case let showArgExps :: [TH.Q TH.Exp] -- The `dropEnd` drops the last comma showArgExps = dropEnd 1 $ Haskell.foldMap (uncurry f) (Haskell.zip argNames args) - where - f :: TH.Name -> TH.Name -> [TH.Q TH.Exp] - f argName arg = - let argNameBase = TH.nameBase argName - infixRec = - Haskell.showParen - (isSym argNameBase) - (Haskell.showString argNameBase) - "" - in [ TH.varE 'showString `TH.appE` TH.stringE (infixRec <> " = ") - , deriveShowExpForArg 0 arg - , TH.varE 'showCommaSpace - ] + where + f :: TH.Name -> TH.Name -> [TH.Q TH.Exp] + f argName arg = + let argNameBase = TH.nameBase argName + infixRec = + Haskell.showParen + (isSym argNameBase) + (Haskell.showString argNameBase) + "" + in [ TH.varE 'showString `TH.appE` TH.stringE (infixRec <> " = ") + , deriveShowExpForArg 0 arg + , TH.varE 'showCommaSpace + ] braceCommaArgExps = (TH.varE 'showString `TH.appE` TH.stringE "{") : showArgExps mappendArgs = Haskell.foldr diff --git a/plutus-tx/src/PlutusTx/Sqrt.hs b/plutus-tx/src/PlutusTx/Sqrt.hs index 4c1c4ef0e6d..2e8fb4e5918 100644 --- a/plutus-tx/src/PlutusTx/Sqrt.hs +++ b/plutus-tx/src/PlutusTx/Sqrt.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} @@ -24,21 +24,18 @@ import Prelude qualified as Haskell -- | Integer square-root representation, discarding imaginary integers. data Sqrt - = {-| The number was negative, so we don't even attempt to compute it; - just note that the result would be imaginary. - -} + = -- | The number was negative, so we don't even attempt to compute it; + -- just note that the result would be imaginary. Imaginary | -- | An exact integer result. The 'rsqrt' of 4 is 'Exactly 2'. Exactly Integer - | {-| The Integer component (i.e. the floor) of a non-integral result. The - 'rsqrt 2' is 'Approximately 1'. - -} + | -- | The Integer component (i.e. the floor) of a non-integral result. The + -- 'rsqrt 2' is 'Approximately 1'. Approximately Integer deriving stock (Haskell.Show, Haskell.Eq) -{-| Calculates the sqrt of a ratio of integers. As x / 0 is undefined, -calling this function with `d=0` results in an error. --} +-- | Calculates the sqrt of a ratio of integers. As x / 0 is undefined, +-- calling this function with `d=0` results in an error. rsqrt :: Rational -> Sqrt rsqrt r | n * d < 0 = Imaginary @@ -47,20 +44,20 @@ rsqrt r | n < d = Approximately 0 | n < 0 = rsqrt $ unsafeRatio (negate n) (negate d) | otherwise = go 1 $ 1 + divide n d - where - n = numerator r - d = denominator r - go :: Integer -> Integer -> Sqrt - go l u - | l * l * d == n = Exactly l - | u == (l + 1) = Approximately l - | otherwise = - let - m = divide (l + u) 2 - in - if m * m * d <= n - then go m u - else go l m + where + n = numerator r + d = denominator r + go :: Integer -> Integer -> Sqrt + go l u + | l * l * d == n = Exactly l + | u == (l + 1) = Approximately l + | otherwise = + let + m = divide (l + u) 2 + in + if m * m * d <= n + then go m u + else go l m {-# INLINEABLE rsqrt #-} -- | Calculates the integer-component of the sqrt of 'n'. diff --git a/plutus-tx/src/PlutusTx/These.hs b/plutus-tx/src/PlutusTx/These.hs index 40000283173..0566b740811 100644 --- a/plutus-tx/src/PlutusTx/These.hs +++ b/plutus-tx/src/PlutusTx/These.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} @@ -14,9 +14,8 @@ import GHC.Generics (Generic) import PlutusTx.Blueprint.Definition (HasBlueprintDefinition) import Prelude qualified as Haskell -{-| A 'These' @a@ @b@ is either an @a@, or a @b@ or an @a@ and a @b@. -Plutus version of 'Data.These'. --} +-- | A 'These' @a@ @b@ is either an @a@, or a @b@ or an @a@ and a @b@. +-- Plutus version of 'Data.These'. data These a b = This a | That b | These a b deriving stock (Generic, Haskell.Eq, Haskell.Show) deriving anyclass (HasBlueprintDefinition) diff --git a/plutus-tx/src/PlutusTx/Trace.hs b/plutus-tx/src/PlutusTx/Trace.hs index 9116b8a2040..4e8e51b06be 100644 --- a/plutus-tx/src/PlutusTx/Trace.hs +++ b/plutus-tx/src/PlutusTx/Trace.hs @@ -26,9 +26,8 @@ traceIfTrue :: Builtins.BuiltinString -> Bool -> Bool traceIfTrue str a = if a then trace str True else False {-# INLINEABLE traceIfTrue #-} -{-| Emit one of two 'BuiltinString' depending on whether or not the argument -evaluates to 'True' or 'False'. --} +-- | Emit one of two 'BuiltinString' depending on whether or not the argument +-- evaluates to 'True' or 'False'. traceBool :: BuiltinString -> BuiltinString -> Bool -> Bool traceBool trueLabel falseLabel c = if c then trace trueLabel True else trace falseLabel False {-# INLINEABLE traceBool #-} diff --git a/plutus-tx/src/PlutusTx/Traversable.hs b/plutus-tx/src/PlutusTx/Traversable.hs index ab2bc19a950..c4bdc1792b9 100644 --- a/plutus-tx/src/PlutusTx/Traversable.hs +++ b/plutus-tx/src/PlutusTx/Traversable.hs @@ -18,7 +18,7 @@ import PlutusTx.Monoid (Monoid) -- | Plutus Tx version of 'Data.Traversable.Traversable'. class (Functor t, Foldable t) => Traversable t where -- | Plutus Tx version of 'Data.Traversable.traverse'. - traverse :: (Applicative f) => (a -> f b) -> t a -> f (t b) + traverse :: Applicative f => (a -> f b) -> t a -> f (t b) -- All the other methods are deliberately omitted, -- to make this a one-method class which has a simpler representation @@ -26,18 +26,18 @@ class (Functor t, Foldable t) => Traversable t where instance Traversable [] where {-# INLINEABLE traverse #-} traverse f = go - where - go [] = pure [] - go (x : xs) = liftA2 (:) (f x) (go xs) + where + go [] = pure [] + go (x : xs) = liftA2 (:) (f x) (go xs) instance Traversable Maybe where {-# INLINEABLE traverse #-} - traverse _ Nothing = pure Nothing + traverse _ Nothing = pure Nothing traverse f (Just a) = Just <$> f a instance Traversable (Either c) where {-# INLINEABLE traverse #-} - traverse _ (Left a) = pure (Left a) + traverse _ (Left a) = pure (Left a) traverse f (Right a) = Right <$> f a instance Traversable ((,) c) where @@ -73,17 +73,17 @@ for = flip traverse {-# INLINE for #-} -- | Plutus Tx version of 'Data.Traversable.fmapDefault'. -fmapDefault - :: forall t a b - . (Traversable t) - => (a -> b) -> t a -> t b +fmapDefault :: + forall t a b. + Traversable t => + (a -> b) -> t a -> t b fmapDefault = coerce (traverse :: (a -> Identity b) -> t a -> Identity (t b)) {-# INLINE fmapDefault #-} -- | Plutus Tx version of 'Data.Traversable.foldMapDefault'. -foldMapDefault - :: forall t m a - . (Traversable t, Monoid m) - => (a -> m) -> t a -> m +foldMapDefault :: + forall t m a. + (Traversable t, Monoid m) => + (a -> m) -> t a -> m foldMapDefault = coerce (traverse :: (a -> Const m ()) -> t a -> Const m (t ())) {-# INLINE foldMapDefault #-} diff --git a/plutus-tx/test/Blueprint/Definition/Spec.hs b/plutus-tx/test/Blueprint/Definition/Spec.hs index 1d3fbc9f3a5..d8520488bef 100644 --- a/plutus-tx/test/Blueprint/Definition/Spec.hs +++ b/plutus-tx/test/Blueprint/Definition/Spec.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Blueprint.Definition.Spec where @@ -44,27 +44,27 @@ atLeastAsManyDefinitionsAsTypes :: Assertion atLeastAsManyDefinitionsAsTypes = (length (Map.keys definitions) >= 3) @? "Not enough schema definitions: < 3" - where - definitions = definitionsToMap (deriveDefinitions @[Fixture.T1, Fixture.T2, Integer]) (const ()) + where + definitions = definitionsToMap (deriveDefinitions @[Fixture.T1, Fixture.T2, Integer]) (const ()) allReferencedDefinitionsAreDefined :: Assertion allReferencedDefinitionsAreDefined = (referencedIds `isSubsetOf` definedIds) @? "Not all referenced schema definitions are defined" - where - referencedIds = - Set.fromList - [ ref - | schemas <- universe (Map.elems definitions) - , SomeSchema (SchemaDefinitionRef ref) <- schemas - ] - definedIds = Set.fromList (Map.keys definitions) + where + referencedIds = + Set.fromList + [ ref + | schemas <- universe (Map.elems definitions) + , SomeSchema (SchemaDefinitionRef ref) <- schemas + ] + definedIds = Set.fromList (Map.keys definitions) - definitions :: Map DefinitionId SomeSchema - definitions = - -- Here T2 depends on T1 (and not vice-versa) but we intentionally provide them out of order - -- to prove that any order is valid. - definitionsToMap (deriveDefinitions @[Fixture.T1, Fixture.T2, Integer]) SomeSchema + definitions :: Map DefinitionId SomeSchema + definitions = + -- Here T2 depends on T1 (and not vice-versa) but we intentionally provide them out of order + -- to prove that any order is valid. + definitionsToMap (deriveDefinitions @[Fixture.T1, Fixture.T2, Integer]) SomeSchema data SomeSchema where SomeSchema :: Schema xs -> SomeSchema diff --git a/plutus-tx/test/Blueprint/Spec.hs b/plutus-tx/test/Blueprint/Spec.hs index aa35ff74c58..1ad49074f2a 100644 --- a/plutus-tx/test/Blueprint/Spec.hs +++ b/plutus-tx/test/Blueprint/Spec.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Blueprint.Spec where @@ -24,8 +24,13 @@ import Data.Typeable (Typeable, (:~:) (Refl)) import GHC.Generics (Generic) import PlutusTx.AsData qualified as PlutusTx import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) -import PlutusTx.Blueprint.Definition (Definitions, HasBlueprintDefinition, UnrollAll, Unrolled, - definitionsFor) +import PlutusTx.Blueprint.Definition ( + Definitions, + HasBlueprintDefinition, + UnrollAll, + Unrolled, + definitionsFor, + ) import PlutusTx.Blueprint.Definition.Id (definitionIdFromTypeK) import PlutusTx.Blueprint.Definition.Unroll (definitionId) import PlutusTx.Blueprint.Schema (Schema (..)) @@ -70,7 +75,7 @@ type Phantom :: forall k. k -> Type data Phantom p = MkPhantom deriving stock instance Generic (Phantom p) -instance (Typeable p) => HasBlueprintDefinition (Phantom (p :: k)) where +instance Typeable p => HasBlueprintDefinition (Phantom (p :: k)) where definitionId = definitionIdFromTypeK @(Type -> Type) @Phantom <> definitionIdFromTypeK @k @p @@ -122,8 +127,8 @@ testUnrollNestedLists = Refl testUnrollPair :: Unrolled (Integer, Bool) :~: [(Integer, Bool), Integer, Bool] testUnrollPair = Refl -testUnrollBuiltinPair - :: Unrolled (BuiltinPair Integer Bool) +testUnrollBuiltinPair :: + Unrolled (BuiltinPair Integer Bool) :~: [ BuiltinPair Integer Bool , Integer , Bool @@ -136,8 +141,8 @@ testUnrollMaybe = Refl testPhantom :: Unrolled (Phantom Bool) :~: '[Phantom Bool] testPhantom = Refl -testUnrollBuiltinList - :: Unrolled (BuiltinList (BuiltinPair Bool BuiltinUnit)) +testUnrollBuiltinList :: + Unrolled (BuiltinList (BuiltinPair Bool BuiltinUnit)) :~: [ BuiltinList (BuiltinPair Bool BuiltinUnit) , BuiltinUnit , Bool diff --git a/plutus-tx/test/Rational/Laws/Construction.hs b/plutus-tx/test/Rational/Laws/Construction.hs index f20ae784250..d0ec76069d7 100644 --- a/plutus-tx/test/Rational/Laws/Construction.hs +++ b/plutus-tx/test/Rational/Laws/Construction.hs @@ -1,6 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Rational.Laws.Construction (constructionLaws) where @@ -8,11 +8,16 @@ import Hedgehog (Gen, Property, assert, cover, property, (===)) import Hedgehog.Gen qualified as Gen import PlutusTx.Prelude qualified as Plutus import PlutusTx.Ratio qualified as Ratio -import Prelude -import Rational.Laws.Helpers (forAllWithPP, genInteger, genIntegerPos, normalAndEquivalentToMaybe, - testCoverProperty) +import Rational.Laws.Helpers ( + forAllWithPP, + genInteger, + genIntegerPos, + normalAndEquivalentToMaybe, + testCoverProperty, + ) import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testPropertyNamed) +import Prelude constructionLaws :: [TestTree] constructionLaws = @@ -63,27 +68,27 @@ propRatioSign = property $ do let r = Ratio.ratio n d let signIndicator = Plutus.compare <$> r <*> pure Plutus.zero case (signum n, signum d) of - (0, _) -> signIndicator === Just Plutus.EQ + (0, _) -> signIndicator === Just Plutus.EQ (-1, -1) -> signIndicator === Just Plutus.GT - (1, 1) -> signIndicator === Just Plutus.GT - _ -> signIndicator === Just Plutus.LT - where - go :: Gen (Plutus.Integer, Plutus.Integer) - go = Gen.choice [zeroNum, sameSign, diffSign] - zeroNum :: Gen (Plutus.Integer, Plutus.Integer) - zeroNum = (0,) <$> Gen.filter (/= Plutus.zero) genInteger - sameSign :: Gen (Plutus.Integer, Plutus.Integer) - sameSign = do - gen <- Gen.element [genIntegerPos, negate <$> genIntegerPos] - (,) <$> gen <*> gen - diffSign :: Gen (Plutus.Integer, Plutus.Integer) - diffSign = do - (genN, genD) <- - Gen.element - [ (genIntegerPos, negate <$> genIntegerPos) - , (negate <$> genIntegerPos, genIntegerPos) - ] - (,) <$> genN <*> genD + (1, 1) -> signIndicator === Just Plutus.GT + _ -> signIndicator === Just Plutus.LT + where + go :: Gen (Plutus.Integer, Plutus.Integer) + go = Gen.choice [zeroNum, sameSign, diffSign] + zeroNum :: Gen (Plutus.Integer, Plutus.Integer) + zeroNum = (0,) <$> Gen.filter (/= Plutus.zero) genInteger + sameSign :: Gen (Plutus.Integer, Plutus.Integer) + sameSign = do + gen <- Gen.element [genIntegerPos, negate <$> genIntegerPos] + (,) <$> gen <*> gen + diffSign :: Gen (Plutus.Integer, Plutus.Integer) + diffSign = do + (genN, genD) <- + Gen.element + [ (genIntegerPos, negate <$> genIntegerPos) + , (negate <$> genIntegerPos, genIntegerPos) + ] + (,) <$> genN <*> genD propConstructionAgreement :: Property propConstructionAgreement = property $ do diff --git a/plutus-tx/test/Rational/Laws/Helpers.hs b/plutus-tx/test/Rational/Laws/Helpers.hs index 30bfb883a54..76a3f61365c 100644 --- a/plutus-tx/test/Rational/Laws/Helpers.hs +++ b/plutus-tx/test/Rational/Laws/Helpers.hs @@ -1,6 +1,6 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- We need Arg Rational instance {-# OPTIONS_GHC -Wno-orphans #-} @@ -22,17 +22,28 @@ import Data.Functor.Contravariant (contramap) import Data.Kind (Type) import Data.Maybe (isJust, isNothing) import GHC.Exts (fromString) -import Hedgehog (Gen, MonadTest, Property, PropertyT, assert, cover, failure, forAllWith, property, - success, (===)) +import Hedgehog ( + Gen, + MonadTest, + Property, + PropertyT, + assert, + cover, + failure, + forAllWith, + property, + success, + (===), + ) import Hedgehog.Function (Arg (build), CoGen, vary, via) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import PlutusTx.Prelude qualified as Plutus import PlutusTx.Ratio qualified as Ratio -import Prelude import Test.Tasty (TestTree, localOption) import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit), testPropertyNamed) import Text.Show.Pretty (ppShow) +import Prelude -- This is a hack to avoid coverage issues. -- @@ -56,13 +67,13 @@ import Text.Show.Pretty (ppShow) -- reflexive, and that the type of the generated values is either large or -- infinite. If one or both of these don't hold, use of this function will have -- the _opposite_ effect, as it will skew the test outcomes. -testEntangled - :: forall (a :: Type) - . (Show a) - => String - -> Gen a - -> (a -> a -> PropertyT IO ()) - -> TestTree +testEntangled :: + forall (a :: Type). + Show a => + String -> + Gen a -> + (a -> a -> PropertyT IO ()) -> + TestTree testEntangled name gen cb = localOption coverLimit . testPropertyNamed name (fromString name) . property $ do (x, my) <- forAllWith ppEntangled ((,) <$> gen <*> maybe' gen) @@ -70,7 +81,7 @@ testEntangled name gen cb = cover 45 "possibly different" (isJust my) case my of Nothing -> cb x x - Just y -> cb x y + Just y -> cb x y -- This is the same as 'testEntangled', but for three values instead of two. -- More precisely, this ensures that, given a generator and function argument, @@ -78,20 +89,20 @@ testEntangled name gen cb = -- of the same value, rather than three independently-generated values. -- -- All the caveats of 'testEntangled' also apply to this function. -testEntangled3 - :: forall (a :: Type) - . (Show a) - => String - -> Gen a - -> (a -> a -> a -> PropertyT IO ()) - -> TestTree +testEntangled3 :: + forall (a :: Type). + Show a => + String -> + Gen a -> + (a -> a -> a -> PropertyT IO ()) -> + TestTree testEntangled3 name gen cb = localOption coverLimit . testPropertyNamed name (fromString name) . property $ do (x, myz) <- forAllWith ppEntangled3 ((,) <$> gen <*> maybe' ((,) <$> gen <*> gen)) cover 45 "identical" (isNothing myz) cover 45 "possibly different" (isJust myz) case myz of - Nothing -> cb x x x + Nothing -> cb x x x Just (y, z) -> cb x y z -- Hedgehog treats coverage as an absolute minimum: more precisely, given N @@ -140,10 +151,10 @@ genInteger = Gen.integral . Range.linearFrom 0 (-100) $ 100 genIntegerPos :: Gen Integer genIntegerPos = Gen.integral . Range.linearFrom 100 1 $ 200 -forAllWithPP - :: forall (a :: Type) (m :: Type -> Type) - . (Show a, Monad m) - => Gen a -> PropertyT m a +forAllWithPP :: + forall (a :: Type) (m :: Type -> Type). + (Show a, Monad m) => + Gen a -> PropertyT m a forAllWithPP = forAllWith ppShow -- Rationals are required to maintain several invariants. We could write code to @@ -151,10 +162,10 @@ forAllWithPP = forAllWith ppShow -- -- This function is thus equivalent to === for Rationals, but with the added -- check that the first argument maintains the invariants it's supposed to. -normalAndEquivalentTo - :: forall (m :: Type -> Type) - . (MonadTest m) - => Plutus.Rational -> Plutus.Rational -> m () +normalAndEquivalentTo :: + forall (m :: Type -> Type). + MonadTest m => + Plutus.Rational -> Plutus.Rational -> m () normalAndEquivalentTo actual expected = do let num = Ratio.numerator actual let den = Ratio.denominator actual @@ -163,10 +174,10 @@ normalAndEquivalentTo actual expected = do actual === expected -- 'normalAndEquivalentTo' lifted to 'Maybe'. -normalAndEquivalentToMaybe - :: forall (m :: Type -> Type) - . (MonadTest m) - => Maybe Plutus.Rational -> Maybe Plutus.Rational -> m () +normalAndEquivalentToMaybe :: + forall (m :: Type -> Type). + MonadTest m => + Maybe Plutus.Rational -> Maybe Plutus.Rational -> m () normalAndEquivalentToMaybe actual expected = case (actual, expected) of (Nothing, Nothing) -> success (Just actual', Just _) -> do @@ -186,15 +197,15 @@ normalAndEquivalentToMaybe actual expected = case (actual, expected) of coverLimit :: HedgehogTestLimit coverLimit = HedgehogTestLimit . Just $ 8000 -ppEntangled :: forall (a :: Type). (Show a) => (a, Maybe a) -> String +ppEntangled :: forall (a :: Type). Show a => (a, Maybe a) -> String ppEntangled = \case (x, Nothing) -> ppShow (x, x) (x, Just y) -> ppShow (x, y) -ppEntangled3 - :: forall (a :: Type) - . (Show a) - => (a, Maybe (a, a)) -> String +ppEntangled3 :: + forall (a :: Type). + Show a => + (a, Maybe (a, a)) -> String ppEntangled3 = \case (x, Nothing) -> ppShow (x, x, x) (x, Just (y, z)) -> ppShow (x, y, z) diff --git a/plutus-tx/test/Rational/Laws/Other.hs b/plutus-tx/test/Rational/Laws/Other.hs index b4e369f6276..c3d0dbdbc90 100644 --- a/plutus-tx/test/Rational/Laws/Other.hs +++ b/plutus-tx/test/Rational/Laws/Other.hs @@ -1,6 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Rational.Laws.Other (otherLaws) where @@ -9,11 +9,16 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import PlutusTx.Prelude qualified as Plutus import PlutusTx.Ratio qualified as Ratio -import Prelude -import Rational.Laws.Helpers (forAllWithPP, genInteger, genIntegerPos, genRational, - testCoverProperty) +import Rational.Laws.Helpers ( + forAllWithPP, + genInteger, + genIntegerPos, + genRational, + testCoverProperty, + ) import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testPropertyNamed) +import Prelude otherLaws :: [TestTree] otherLaws = @@ -98,23 +103,23 @@ propProperFracSigns = property $ do Plutus.LT -> do Plutus.compare n Plutus.zero /== Plutus.GT Plutus.compare n Plutus.zero /== Plutus.GT - where - go :: Gen Plutus.Rational - go = Gen.choice [zeroNum, sameSign, diffSign] - zeroNum :: Gen Plutus.Rational - zeroNum = Ratio.unsafeRatio Plutus.zero <$> Gen.filter (/= Plutus.zero) genInteger - sameSign :: Gen Plutus.Rational - sameSign = do - gen <- Gen.element [genIntegerPos, negate <$> genIntegerPos] - Ratio.unsafeRatio <$> gen <*> gen - diffSign :: Gen Plutus.Rational - diffSign = do - (genN, genD) <- - Gen.element - [ (genIntegerPos, negate <$> genIntegerPos) - , (negate <$> genIntegerPos, genIntegerPos) - ] - Ratio.unsafeRatio <$> genN <*> genD + where + go :: Gen Plutus.Rational + go = Gen.choice [zeroNum, sameSign, diffSign] + zeroNum :: Gen Plutus.Rational + zeroNum = Ratio.unsafeRatio Plutus.zero <$> Gen.filter (/= Plutus.zero) genInteger + sameSign :: Gen Plutus.Rational + sameSign = do + gen <- Gen.element [genIntegerPos, negate <$> genIntegerPos] + Ratio.unsafeRatio <$> gen <*> gen + diffSign :: Gen Plutus.Rational + diffSign = do + (genN, genD) <- + Gen.element + [ (genIntegerPos, negate <$> genIntegerPos) + , (negate <$> genIntegerPos, genIntegerPos) + ] + Ratio.unsafeRatio <$> genN <*> genD propProperFracAbs :: Property propProperFracAbs = property $ do @@ -136,19 +141,19 @@ propRoundHalf = property $ do let rounded = Ratio.round r case (signum n, even n) of (-1, False) -> rounded === n Plutus.- Plutus.one - (-1, True) -> rounded === n - (0, _) -> rounded === Plutus.zero - (1, False) -> rounded === n Plutus.+ Plutus.one - _ -> rounded === n - where - go :: Gen (Integer, Plutus.Rational) - go = do - n <- genInteger - f <- case signum n of - (-1) -> pure . Ratio.negate $ Ratio.half - 0 -> Gen.element [Ratio.half, Ratio.negate Ratio.half] - _ -> pure Ratio.half - pure (n, f) + (-1, True) -> rounded === n + (0, _) -> rounded === Plutus.zero + (1, False) -> rounded === n Plutus.+ Plutus.one + _ -> rounded === n + where + go :: Gen (Integer, Plutus.Rational) + go = do + n <- genInteger + f <- case signum n of + (-1) -> pure . Ratio.negate $ Ratio.half + 0 -> Gen.element [Ratio.half, Ratio.negate Ratio.half] + _ -> pure Ratio.half + pure (n, f) propRoundLow :: Property propRoundLow = property $ do @@ -157,16 +162,16 @@ propRoundLow = property $ do let rounded = Ratio.round r let truncated = Ratio.truncate r rounded === truncated - where - go :: Gen (Integer, Plutus.Rational) - go = do - num <- Gen.integral . Range.constant 1 $ 135 - let f = Ratio.unsafeRatio num 271 - n <- genInteger - case signum n of - (-1) -> pure (n, Ratio.negate f) - 0 -> (n,) <$> Gen.element [f, Ratio.negate f] - _ -> pure (n, f) + where + go :: Gen (Integer, Plutus.Rational) + go = do + num <- Gen.integral . Range.constant 1 $ 135 + let f = Ratio.unsafeRatio num 271 + n <- genInteger + case signum n of + (-1) -> pure (n, Ratio.negate f) + 0 -> (n,) <$> Gen.element [f, Ratio.negate f] + _ -> pure (n, f) propRoundHigh :: Property propRoundHigh = property $ do @@ -175,13 +180,13 @@ propRoundHigh = property $ do let rounded = Ratio.round r let truncated = Ratio.truncate r Plutus.abs rounded === Plutus.abs truncated Plutus.+ Plutus.one - where - go :: Gen (Integer, Plutus.Rational) - go = do - num <- Gen.integral . Range.constant 136 $ 270 - let f = Ratio.unsafeRatio num 271 - n <- genInteger - case signum n of - (-1) -> pure (n, Ratio.negate f) - 0 -> (n,) <$> Gen.element [f, Ratio.negate f] - _ -> pure (n, f) + where + go :: Gen (Integer, Plutus.Rational) + go = do + num <- Gen.integral . Range.constant 136 $ 270 + let f = Ratio.unsafeRatio num 271 + n <- genInteger + case signum n of + (-1) -> pure (n, Ratio.negate f) + 0 -> (n,) <$> Gen.element [f, Ratio.negate f] + _ -> pure (n, f) diff --git a/plutus-tx/test/Show/Spec.hs b/plutus-tx/test/Show/Spec.hs index ac13a3ba86d..e38a35c4ce4 100644 --- a/plutus-tx/test/Show/Spec.hs +++ b/plutus-tx/test/Show/Spec.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Show.Spec where @@ -16,11 +16,11 @@ import Data.Text qualified as Text import Hedgehog import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import Prelude hiding (Show (..)) import System.FilePath import Test.Tasty import Test.Tasty.Extras import Test.Tasty.Hedgehog +import Prelude hiding (Show (..)) toHaskellString :: BuiltinString -> String toHaskellString (BI.BuiltinString t) = Text.unpack t @@ -37,7 +37,7 @@ showByteStringBase16 = property $ do builtinBytestring = BI.BuiltinByteString bytestring toHaskellString (show builtinBytestring) === Char8.unpack hex -goldenShow :: forall a. (Show a) => TestName -> a -> TestNested +goldenShow :: forall a. Show a => TestName -> a -> TestNested goldenShow name x = do path <- ask let fp = foldr () (name ++ ".golden.show") path diff --git a/plutus-tx/test/Spec.hs b/plutus-tx/test/Spec.hs index c96cbf08fca..fcf8ef36aa9 100644 --- a/plutus-tx/test/Spec.hs +++ b/plutus-tx/test/Spec.hs @@ -1,7 +1,7 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Main (main) where @@ -25,12 +25,12 @@ import PlutusTx.Numeric (negate) import PlutusTx.Prelude (dropByteString, one, takeByteString) import PlutusTx.Ratio (Rational, denominator, numerator, recip, unsafeRatio) import PlutusTx.Sqrt (Sqrt (Approximately, Exactly, Imaginary), isqrt, rsqrt) -import Prelude hiding (Enum (..), Rational, negate, recip) import Rational.Laws (lawsTests) import Show.Spec qualified import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.Hedgehog (testPropertyNamed) import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) +import Test.Tasty.Hedgehog (testPropertyNamed) +import Prelude hiding (Enum (..), Rational, negate, recip) main :: IO () main = defaultMain tests @@ -112,10 +112,10 @@ isqrtRoundTrip = property $ do let positiveInteger = Gen.integral (Range.linear 0 100000) x' <- forAll positiveInteger tripping x' sq (decodeExact . isqrt) - where - sq x = x ^ (2 :: Integer) - decodeExact (Exactly x) = Right x - decodeExact s = Left s + where + sq x = x ^ (2 :: Integer) + decodeExact (Exactly x) = Right x + decodeExact s = Left s serdeTests :: TestTree serdeTests = @@ -141,7 +141,7 @@ dataRoundTrip = property $ do sixtyFourByteInteger :: Integer sixtyFourByteInteger = 2 ^ ((64 :: Integer) * 8) -genData :: (MonadGen m) => m Data +genData :: MonadGen m => m Data genData = let st = Gen.subterm genData id constrIndex = fromIntegral <$> Gen.integral @_ @Word64 Range.linearBounded @@ -204,13 +204,13 @@ reciprocalFailsZeroNumerator = do -- the result should be 1 if there was an exception res @?= one -genPositiveRational :: (Monad m) => PropertyT m Rational +genPositiveRational :: Monad m => PropertyT m Rational genPositiveRational = do a <- forAll . Gen.integral $ Range.linear 1 100000 b <- forAll . Gen.integral $ Range.linear 1 100000 return (unsafeRatio a b) -genNegativeRational :: (Monad m) => PropertyT m Rational +genNegativeRational :: Monad m => PropertyT m Rational genNegativeRational = negate <$> genPositiveRational -- If x and y are positive rational numbers and x < y then 1/y < 1/x @@ -339,24 +339,24 @@ enumFromThenToTests = , testCase "enumFromThenTo () () () == [()*]" $ enumFromThenTo () () () @?=* [(), () .. ()] ] - where - {- Check (approximately) that two possibly infinite lists are equal. We can get infinite lists from - `enumFromThenTo`, both legitimately and because of implementation errors (which are exactly - what we're testing for here). If we just use @?= then (a) it won't terminate if we give it - two equal infinite lists, and (b) if it fails and one of the lists is infinite then it'll try - to generate an infinite error message, again leading to non-termination. To deal with this, - if an argument has more than 1000 elements then we assume it's infinite and just include an - initial segment in any error message, and when we're comparing two such "infinite" lists we - just compare the first 1000 elements. The only infinite lists that enumFromThenTo can - generate are of the form [x,x,x,...], so this is definitely a safe strategy in this context. - -} - l1 @?=* l2 = - case (possiblyInfinite l1, possiblyInfinite l2) of - (False, False) -> l1 @?= l2 - (True, False) -> failWith (showInit l1) (show l2) - (False, True) -> failWith (show l1) (showInit l2) - (True, True) -> unless (take 1000 l1 == take 1000 l2) (failWith (showInit l1) (showInit l2)) - where - possiblyInfinite l = drop 1000 l /= [] - showInit l = "[" ++ intercalate "," (fmap show (take 5 l)) ++ ",...]" - failWith expected actual = assertFailure ("expected: " ++ expected ++ "\n but got: " ++ actual) + where + {- Check (approximately) that two possibly infinite lists are equal. We can get infinite lists from + `enumFromThenTo`, both legitimately and because of implementation errors (which are exactly + what we're testing for here). If we just use @?= then (a) it won't terminate if we give it + two equal infinite lists, and (b) if it fails and one of the lists is infinite then it'll try + to generate an infinite error message, again leading to non-termination. To deal with this, + if an argument has more than 1000 elements then we assume it's infinite and just include an + initial segment in any error message, and when we're comparing two such "infinite" lists we + just compare the first 1000 elements. The only infinite lists that enumFromThenTo can + generate are of the form [x,x,x,...], so this is definitely a safe strategy in this context. + -} + l1 @?=* l2 = + case (possiblyInfinite l1, possiblyInfinite l2) of + (False, False) -> l1 @?= l2 + (True, False) -> failWith (showInit l1) (show l2) + (False, True) -> failWith (show l1) (showInit l2) + (True, True) -> unless (take 1000 l1 == take 1000 l2) (failWith (showInit l1) (showInit l2)) + where + possiblyInfinite l = drop 1000 l /= [] + showInit l = "[" ++ intercalate "," (fmap show (take 5 l)) ++ ",...]" + failWith expected actual = assertFailure ("expected: " ++ expected ++ "\n but got: " ++ actual) diff --git a/plutus-tx/testlib/Hedgehog/Laws/Common.hs b/plutus-tx/testlib/Hedgehog/Laws/Common.hs index 312ba00c2bc..8e7ac562365 100644 --- a/plutus-tx/testlib/Hedgehog/Laws/Common.hs +++ b/plutus-tx/testlib/Hedgehog/Laws/Common.hs @@ -37,7 +37,7 @@ prop_unit g op unit = property $ do cover 10 "different" $ x /= unit x `op` unit Hedgehog.=== x -prop_reflexive :: (Show a) => Hedgehog.Gen a -> (a -> a -> Bool) -> Property +prop_reflexive :: Show a => Hedgehog.Gen a -> (a -> a -> Bool) -> Property prop_reflexive g op = property $ do x <- forAll g x `op` x Hedgehog.=== True diff --git a/plutus-tx/testlib/PlutusTx/Test/Golden.hs b/plutus-tx/testlib/PlutusTx/Test/Golden.hs index dd22601b83f..7a01972acb1 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Golden.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Golden.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module PlutusTx.Test.Golden ( -- * TH CodGen @@ -48,12 +48,32 @@ import PlutusCore qualified as PLC import PlutusCore.Evaluation.Machine.ExBudget qualified as PLC import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) import PlutusCore.Flat (Flat) -import PlutusCore.Pretty (Doc, Pretty (pretty), PrettyBy (prettyBy), PrettyConfigClassic, - PrettyConfigName, PrettyUni, Render (render), prettyClassicSimple, - prettyPlcClassicSimple, prettyReadable, prettyReadableSimple) -import PlutusCore.Test (TestNested, ToUPlc (..), goldenAstSize, goldenTPlc, goldenUPlc, - goldenUPlcReadable, nestedGoldenVsDoc, nestedGoldenVsDocM, ppCatch, rethrow, - runUPlcBudget) +import PlutusCore.Pretty ( + Doc, + Pretty (pretty), + PrettyBy (prettyBy), + PrettyConfigClassic, + PrettyConfigName, + PrettyUni, + Render (render), + prettyClassicSimple, + prettyPlcClassicSimple, + prettyReadable, + prettyReadableSimple, + ) +import PlutusCore.Test ( + TestNested, + ToUPlc (..), + goldenAstSize, + goldenTPlc, + goldenUPlc, + goldenUPlcReadable, + nestedGoldenVsDoc, + nestedGoldenVsDocM, + ppCatch, + rethrow, + runUPlcBudget, + ) import PlutusIR.Core.Type (progTerm) import PlutusIR.Test () import PlutusTx.Code (CompiledCode, CompiledCodeIn (..), countAstNodes, getPir, getPirNoAnn) @@ -67,7 +87,7 @@ import Text.Printf (printf) import UntypedPlutusCore qualified as UPLC -- Value assertion tests -goldenCodeGen :: (TH.Ppr a) => TestName -> TH.Q a -> TH.ExpQ +goldenCodeGen :: TH.Ppr a => TestName -> TH.Q a -> TH.ExpQ goldenCodeGen name code = do c <- code [|nestedGoldenVsDoc name ".th" $(TH.stringE $ TH.pprint c)|] @@ -83,28 +103,28 @@ goldenBudget name compiledCode = do , prettyCodeSize compiledCode ] -goldenBundle - :: TestName - -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a - -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun b - -> TestNested +goldenBundle :: + TestName -> + CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a -> + CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun b -> + TestNested goldenBundle name x y = do goldenPirReadable name x goldenUPlcReadable name x goldenEvalCekCatchBudget name y -goldenBundle' - :: TestName - -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a - -> TestNested +goldenBundle' :: + TestName -> + CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a -> + TestNested goldenBundle' name x = goldenBundle name x x -- | Does not print uniques. -goldenPir - :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) - => TestName - -> CompiledCodeIn uni fun a - -> TestNested +goldenPir :: + (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => + TestName -> + CompiledCodeIn uni fun a -> + TestNested goldenPir name value = nestedGoldenVsDoc name ".pir" . maybe @@ -113,11 +133,11 @@ goldenPir name value = $ getPirNoAnn value -- | Does not print uniques. -goldenPirReadable - :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) - => TestName - -> CompiledCodeIn uni fun a - -> TestNested +goldenPirReadable :: + (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => + TestName -> + CompiledCodeIn uni fun a -> + TestNested goldenPirReadable name value = nestedGoldenVsDoc name ".pir" . maybe @@ -125,41 +145,40 @@ goldenPirReadable name value = (prettyReadableSimple . view progTerm) $ getPirNoAnn value -{-| Prints uniques. This should be used sparingly: a simple change to a script or a -compiler pass may change all uniques, making it difficult to see the actual -change if all uniques are printed. It is nonetheless useful sometimes. --} -goldenPirReadableU - :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) - => TestName - -> CompiledCodeIn uni fun a - -> TestNested +-- | Prints uniques. This should be used sparingly: a simple change to a script or a +-- compiler pass may change all uniques, making it difficult to see the actual +-- change if all uniques are printed. It is nonetheless useful sometimes. +goldenPirReadableU :: + (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => + TestName -> + CompiledCodeIn uni fun a -> + TestNested goldenPirReadableU name value = nestedGoldenVsDoc name ".pir" . maybe "PIR not found in CompiledCode" (prettyReadable . view progTerm) $ getPirNoAnn value -goldenPirBy - :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) - => PrettyConfigClassic PrettyConfigName - -> TestName - -> CompiledCodeIn uni fun a - -> TestNested +goldenPirBy :: + (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => + PrettyConfigClassic PrettyConfigName -> + TestName -> + CompiledCodeIn uni fun a -> + TestNested goldenPirBy config name value = nestedGoldenVsDoc name ".pir" $ prettyBy config $ getPir value -goldenEvalCek - :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) - => TestName - -> a - -> TestNested +goldenEvalCek :: + ToUPlc a PLC.DefaultUni PLC.DefaultFun => + TestName -> + a -> + TestNested goldenEvalCek name value = nestedGoldenVsDocM name ".eval" $ prettyPlcClassicSimple <$> rethrow (runPlcCek value) -goldenEvalCekCatch - :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) - => TestName -> a -> TestNested +goldenEvalCekCatch :: + ToUPlc a PLC.DefaultUni PLC.DefaultFun => + TestName -> a -> TestNested goldenEvalCekCatch name value = nestedGoldenVsDocM name ".eval" $ either (pretty . show) prettyPlcClassicSimple @@ -178,9 +197,9 @@ goldenEvalCekCatchBudget name compiledCode = ] pure (render @Text contents) -goldenEvalCekLog - :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) - => TestName -> a -> TestNested +goldenEvalCekLog :: + ToUPlc a PLC.DefaultUni PLC.DefaultFun => + TestName -> a -> TestNested goldenEvalCekLog name value = nestedGoldenVsDocM name ".eval" $ prettyPlcClassicSimple . view _1 <$> rethrow (runPlcCekTrace value) @@ -193,27 +212,26 @@ prettyBudget (PLC.ExBudget (ExCPU cpu) (ExMemory mem)) = , fill 10 "Memory:" <+> prettyIntRightAligned (fromSatInt @Int mem) ] -{-| Pretty-print compiled code size - -Given a UPLC program, there are two quantification of "size": AST Size and Flat Size. -AST Size measures AST nodes of the given UPLC program. Flat Size measures the number -of bytes when the given program serialized into bytestring using binary flat encoding format. - -Cost of storing smart contract onchain is partially determined by the Flat size. So it -is useful to have Flat size measurement in case we adopt new or introduce optimizations -to the flat encoding format. --} +-- | Pretty-print compiled code size +-- +-- Given a UPLC program, there are two quantification of "size": AST Size and Flat Size. +-- AST Size measures AST nodes of the given UPLC program. Flat Size measures the number +-- of bytes when the given program serialized into bytestring using binary flat encoding format. +-- +-- Cost of storing smart contract onchain is partially determined by the Flat size. So it +-- is useful to have Flat size measurement in case we adopt new or introduce optimizations +-- to the flat encoding format. prettyCodeSize :: CompiledCodeIn PLC.DefaultUni PLC.DefaultFun a -> Doc ann prettyCodeSize compiledCode = vsep [ fill 10 "AST Size:" <+> prettyIntRightAligned astSize , fill 10 "Flat Size:" <+> prettyIntRightAligned flatSize ] - where - astSize = countAstNodes compiledCode - flatSize = countFlatBytes compiledCode + where + astSize = countAstNodes compiledCode + flatSize = countFlatBytes compiledCode -prettyIntRightAligned :: (Integral i) => i -> Doc ann +prettyIntRightAligned :: Integral i => i -> Doc ann prettyIntRightAligned = pretty @String . printf "%19s" @@ -223,6 +241,6 @@ prettyIntRightAligned = . reverse . show @Integer . fromIntegral - where - chunksOf _ [] = [] - chunksOf n xs = take n xs : chunksOf n (drop n xs) + where + chunksOf _ [] = [] + chunksOf n xs = take n xs : chunksOf n (drop n xs) diff --git a/plutus-tx/testlib/PlutusTx/Test/Orphans.hs b/plutus-tx/testlib/PlutusTx/Test/Orphans.hs index b8dc98bb470..c3b7f4d2d7e 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Orphans.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Orphans.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module PlutusTx.Test.Orphans where @@ -25,8 +25,8 @@ import PlutusCore.Flat (Flat) import Test.Tasty.Extras () instance - (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => ToUPlc (CompiledCodeIn uni fun a) uni fun + (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => + ToUPlc (CompiledCodeIn uni fun a) uni fun where toUPlc compiledCode = toUPlc =<< catchAll (getPlcNoAnn compiledCode) @@ -43,8 +43,8 @@ instance , Default (PLC.CostingPart uni fun) , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) - ) - => ToTPlc (CompiledCodeIn uni fun a) uni fun + ) => + ToTPlc (CompiledCodeIn uni fun a) uni fun where toTPlc compiledCode = catchAll (getPir compiledCode) >>= \case diff --git a/plutus-tx/testlib/PlutusTx/Test/Run/Code.hs b/plutus-tx/testlib/PlutusTx/Test/Run/Code.hs index 7ef2513ad23..1d85e0d3463 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Run/Code.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Run/Code.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module PlutusTx.Test.Run.Code ( module Eval, @@ -25,27 +25,26 @@ import Test.Tasty (TestName) import Test.Tasty.HUnit (Assertion, assertFailure, testCase) import UntypedPlutusCore (DefaultUni) -{-| Evaluate 'CompiledCode' and check that the result matches a given Haskell value - (perhaps obtained by running the Haskell code that the term was compiled - from). We evaluate the lifted Haskell value as well, because lifting may - produce reducible terms. The function is polymorphic in the comparison - operator so that we can use it with both HUnit Assertions and QuickCheck - Properties. --} -evaluationResultMatchesHaskell - :: (Tx.Lift DefaultUni hask) - => CompiledCode a - -> (forall r. (Eq r, Show r) => r -> r -> k) - -> hask - -> k +-- | Evaluate 'CompiledCode' and check that the result matches a given Haskell value +-- (perhaps obtained by running the Haskell code that the term was compiled +-- from). We evaluate the lifted Haskell value as well, because lifting may +-- produce reducible terms. The function is polymorphic in the comparison +-- operator so that we can use it with both HUnit Assertions and QuickCheck +-- Properties. +evaluationResultMatchesHaskell :: + Tx.Lift DefaultUni hask => + CompiledCode a -> + (forall r. (Eq r, Show r) => r -> r -> k) -> + hask -> + k evaluationResultMatchesHaskell actual = cekResultMatchesHaskellValue (compiledCodeToTerm actual) assertEvaluatesSuccessfully :: CompiledCode a -> Assertion assertEvaluatesSuccessfully code = do case evaluateCompiledCode code of - EvalResult{evalResult = Right _} -> pure () - EvalResult{evalResult = Left err, evalResultTraces} -> + EvalResult {evalResult = Right _} -> pure () + EvalResult {evalResult = Left err, evalResultTraces} -> assertFailure $ Text.unpack $ Text.unlines @@ -58,8 +57,8 @@ assertEvaluatesSuccessfully code = do assertEvaluatesWithError :: CompiledCode a -> Assertion assertEvaluatesWithError code = do case evaluateCompiledCode code of - EvalResult{evalResult = Left _} -> pure () - EvalResult{evalResult = Right _, evalResultTraces} -> + EvalResult {evalResult = Left _} -> pure () + EvalResult {evalResult = Right _, evalResultTraces} -> assertFailure $ Text.unpack $ Text.unlines diff --git a/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs b/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs index 4a6931d0734..efb0dfe1237 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module PlutusTx.Test.Run.Uplc where @@ -26,13 +26,13 @@ import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC type Term = UPLC.Term PLC.Name DefaultUni DefaultFun () -runPlcCek - :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) - => a - -> ExceptT - SomeException - IO - (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) +runPlcCek :: + ToUPlc a PLC.DefaultUni PLC.DefaultFun => + a -> + ExceptT + SomeException + IO + (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) runPlcCek val = do term <- toUPlc val fromRightM (throwError . SomeException) $ @@ -40,16 +40,16 @@ runPlcCek val = do PLC.defaultCekParametersForTesting (term ^. UPLC.progTerm) -runPlcCekTrace - :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) - => a - -> ExceptT - SomeException - IO - ( [Text] - , UPLC.CekExTally PLC.DefaultFun - , UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () - ) +runPlcCekTrace :: + ToUPlc a PLC.DefaultUni PLC.DefaultFun => + a -> + ExceptT + SomeException + IO + ( [Text] + , UPLC.CekExTally PLC.DefaultFun + , UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () + ) runPlcCekTrace value = do term <- toUPlc value let UPLC.CekReport (UPLC.cekResultToEither -> result) (UPLC.TallyingSt tally _) logOut = @@ -61,13 +61,13 @@ runPlcCekTrace value = do res <- fromRightM (throwError . SomeException) result pure (logOut, tally, res) -runPlcCekBudget - :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) - => a - -> ExceptT - SomeException - IO - (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun (), PLC.ExBudget) +runPlcCekBudget :: + ToUPlc a PLC.DefaultUni PLC.DefaultFun => + a -> + ExceptT + SomeException + IO + (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun (), PLC.ExBudget) runPlcCekBudget val = do term <- toUPlc val fromRightM (throwError . SomeException) $ do diff --git a/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs b/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs index cff57760cf9..14a202c331e 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module PlutusTx.Test.Util.Apply ( CompiledCodeFuncToHaskType, FinalType, unsafeApplyCodeN, applyCodeN, - ) where +) where import Prelude @@ -30,62 +30,68 @@ type family FinalType t where FinalType a = a class CompiledCodeFuncToHask t r uni fun where - applyCodeN' - :: (Either String (CompiledCodeIn uni fun (FinalType t)) -> r) - -> Either String (CompiledCodeIn uni fun t) - -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun t) r + applyCodeN' :: + (Either String (CompiledCodeIn uni fun (FinalType t)) -> r) -> + Either String (CompiledCodeIn uni fun t) -> + CompiledCodeFuncToHaskType (CompiledCodeIn uni fun t) r -instance {-# OVERLAPPING #-} ( PLC.Everywhere uni Flat - , PLC.Everywhere uni PrettyConst - , PLC.Closed uni - , Flat fun - , Pretty fun - , PrettyBy RenderContext (PLC.SomeTypeIn uni) - , CompiledCodeFuncToHask b r uni fun - , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun (a -> b)) r - ~ (CompiledCodeIn uni fun a -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r) - ) => - CompiledCodeFuncToHask (a -> b) r uni fun where +instance + {-# OVERLAPPING #-} + ( PLC.Everywhere uni Flat + , PLC.Everywhere uni PrettyConst + , PLC.Closed uni + , Flat fun + , Pretty fun + , PrettyBy RenderContext (PLC.SomeTypeIn uni) + , CompiledCodeFuncToHask b r uni fun + , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun (a -> b)) r + ~ (CompiledCodeIn uni fun a -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r) + ) => + CompiledCodeFuncToHask (a -> b) r uni fun + where applyCodeN' cont f a = applyCodeN' @b @r cont $ f >>= flip applyCode a instance ( FinalType a ~ a , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) r ~ r - ) => CompiledCodeFuncToHask a r uni fun where + ) => + CompiledCodeFuncToHask a r uni fun + where applyCodeN' = ($) -{- | Transform 'CompiledCode' function into a function in "Hask". This helps applying -arguments to already built script in a type safe manner. Example: -```hs -foo :: CompiledCode (Integer -> () -> Bool) -bar :: CompiledCode Integer -baz :: CompiledCode () - -applyCodeN foo bar baz :: Either String (CompiledCode Bool) -``` --} -applyCodeN - :: forall uni fun a - . CompiledCodeFuncToHask a (Either String (CompiledCodeIn uni fun (FinalType a))) uni fun - => CompiledCodeIn uni fun a - -> CompiledCodeFuncToHaskType - (CompiledCodeIn uni fun a) - (Either String (CompiledCodeIn uni fun (FinalType a))) +-- | Transform 'CompiledCode' function into a function in "Hask". This helps applying +-- arguments to already built script in a type safe manner. Example: +-- ```hs +-- foo :: CompiledCode (Integer -> () -> Bool) +-- bar :: CompiledCode Integer +-- baz :: CompiledCode () +-- +-- applyCodeN foo bar baz :: Either String (CompiledCode Bool) +-- ``` +applyCodeN :: + forall uni fun a. + CompiledCodeFuncToHask a (Either String (CompiledCodeIn uni fun (FinalType a))) uni fun => + CompiledCodeIn uni fun a -> + CompiledCodeFuncToHaskType + (CompiledCodeIn uni fun a) + (Either String (CompiledCodeIn uni fun (FinalType a))) applyCodeN = applyCodeN' - @a @(Either String (CompiledCodeIn uni fun (FinalType a))) + @a + @(Either String (CompiledCodeIn uni fun (FinalType a))) id . pure -- | Same as 'applyCodeN' but is partial instead of returning `Either String`. -unsafeApplyCodeN - :: forall uni fun a - . CompiledCodeFuncToHask a (CompiledCodeIn uni fun (FinalType a)) uni fun - => CompiledCodeIn uni fun a - -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) (CompiledCodeIn uni fun (FinalType a)) +unsafeApplyCodeN :: + forall uni fun a. + CompiledCodeFuncToHask a (CompiledCodeIn uni fun (FinalType a)) uni fun => + CompiledCodeIn uni fun a -> + CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) (CompiledCodeIn uni fun (FinalType a)) unsafeApplyCodeN = applyCodeN' - @a @(CompiledCodeIn uni fun (FinalType a)) + @a + @(CompiledCodeIn uni fun (FinalType a)) (either error id) . pure diff --git a/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs b/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs index a47083f930a..fdb4cf6ad2c 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} module PlutusTx.Test.Util.Compiled ( Program, @@ -30,20 +30,19 @@ import UntypedPlutusCore.Evaluation.Machine.Cek as Cek type Term = UPLC.Term PLC.NamedDeBruijn DefaultUni DefaultFun () type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun () -{-| The size of a 'CompiledCodeIn' as measured in Flat bytes. - -This function serialises the code to 'ByteString' and counts the number -of bytes. It uses the same serialisation format as used by the ledger: -CBOR(Flat(StripNames(Strip Annotations(UPLC)))) - -Caveat: the 'SerialisedCode' constructor of the 'CompiledCode' type -already contains a PLC program as 'ByteString', but it isn't the same byte -representation as the one produced by 'serialiseCompiledCode' function: -in uses the 'NamedDeBruijn' representation, which also stores names. -On the mainnet we don't serialise names, only DeBruijn indices, so this function -re-serialises the code to get the size in bytes that we would actually -use on the mainnet. --} +-- | The size of a 'CompiledCodeIn' as measured in Flat bytes. +-- +-- This function serialises the code to 'ByteString' and counts the number +-- of bytes. It uses the same serialisation format as used by the ledger: +-- CBOR(Flat(StripNames(Strip Annotations(UPLC)))) +-- +-- Caveat: the 'SerialisedCode' constructor of the 'CompiledCode' type +-- already contains a PLC program as 'ByteString', but it isn't the same byte +-- representation as the one produced by 'serialiseCompiledCode' function: +-- in uses the 'NamedDeBruijn' representation, which also stores names. +-- On the mainnet we don't serialise names, only DeBruijn indices, so this function +-- re-serialises the code to get the size in bytes that we would actually +-- use on the mainnet. countFlatBytes :: CompiledCode ann -> Integer countFlatBytes = fromIntegral @@ -55,55 +54,52 @@ countFlatBytes = . toAnonDeBruijnProg . getPlcNoAnn -{-| Given a DeBruijn-named term, give every variable the name "v". If we later - call unDeBruijn, that will rename the variables to things like "v123", where - 123 is the relevant de Bruijn index. --} -toNamedDeBruijnTerm - :: UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () - -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () +-- | Given a DeBruijn-named term, give every variable the name "v". If we later +-- call unDeBruijn, that will rename the variables to things like "v123", where +-- 123 is the relevant de Bruijn index. +toNamedDeBruijnTerm :: + UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () -> + UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () toNamedDeBruijnTerm = UPLC.termMapNames UPLC.fakeNameDeBruijn -- | Remove the textual names from a NamedDeBruijn term toAnonDeBruijnTerm :: Term -> UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () toAnonDeBruijnTerm = UPLC.termMapNames UPLC.unNameDeBruijn -toAnonDeBruijnProg - :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () +toAnonDeBruijnProg :: + UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () -> + UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () toAnonDeBruijnProg (UPLC.Program () ver body) = UPLC.Program () ver $ toAnonDeBruijnTerm body -{-| Just extract the body of a program wrapped in a 'CompiledCodeIn'. -We use this a lot. --} +-- | Just extract the body of a program wrapped in a 'CompiledCodeIn'. +-- We use this a lot. compiledCodeToTerm :: Tx.CompiledCodeIn DefaultUni DefaultFun a -> Term compiledCodeToTerm code = let UPLC.Program _ _ body = Tx.getPlcNoAnn code in body -{-| Evaluate a PLC term and check that the result matches a given Haskell value - (perhaps obtained by running the Haskell code that the term was compiled - from). We evaluate the lifted Haskell value as well, because lifting may - produce reducible terms. The function is polymorphic in the comparison - operator so that we can use it with both HUnit Assertions and QuickCheck - Properties. --} -cekResultMatchesHaskellValue - :: (Tx.Lift DefaultUni hask) - => Term - -> (forall r. (Eq r, Show r) => r -> r -> k) - -> hask - -> k +-- | Evaluate a PLC term and check that the result matches a given Haskell value +-- (perhaps obtained by running the Haskell code that the term was compiled +-- from). We evaluate the lifted Haskell value as well, because lifting may +-- produce reducible terms. The function is polymorphic in the comparison +-- operator so that we can use it with both HUnit Assertions and QuickCheck +-- Properties. +cekResultMatchesHaskellValue :: + Tx.Lift DefaultUni hask => + Term -> + (forall r. (Eq r, Show r) => r -> r -> k) -> + hask -> + k cekResultMatchesHaskellValue actual matches expected = matches (unsafeRunTermCek actual) (unsafeRunTermCek (compiledCodeToTerm (Tx.liftCodeDef expected))) - where - unsafeRunTermCek :: Term -> EvaluationResult Term - unsafeRunTermCek = - unsafeSplitStructuralOperational - . Cek.cekResultToEither - . _cekReportResult - . runCekDeBruijn - PLC.defaultCekParametersForTesting - Cek.restrictingEnormous - Cek.noEmitter + where + unsafeRunTermCek :: Term -> EvaluationResult Term + unsafeRunTermCek = + unsafeSplitStructuralOperational + . Cek.cekResultToEither + . _cekReportResult + . runCekDeBruijn + PLC.defaultCekParametersForTesting + Cek.restrictingEnormous + Cek.noEmitter