From 4f27880a760859075efd5cd699e714c9bec6644e Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Sat, 17 Aug 2024 06:57:58 -0700 Subject: [PATCH] Remove PyF from plutus-tx-plugin (#6420) --- plutus-tx-plugin/plutus-tx-plugin.cabal | 3 +- plutus-tx-plugin/src/PlutusTx/Options.hs | 559 ++++++++++++----------- 2 files changed, 283 insertions(+), 279 deletions(-) diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index b37c82d7de0..458ace078ae 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -79,7 +79,7 @@ library build-depends: , array - , base >=4.9 && <5 + , base >=4.9 && <5 , bytestring , containers , either @@ -90,7 +90,6 @@ library , plutus-core:{plutus-core, plutus-ir} ^>=1.32 , plutus-tx ^>=1.32 , prettyprinter - , PyF >=0.11.1.0 , template-haskell , text , uniplate diff --git a/plutus-tx-plugin/src/PlutusTx/Options.hs b/plutus-tx-plugin/src/PlutusTx/Options.hs index 203dd15d980..4111f0e0a04 100644 --- a/plutus-tx-plugin/src/PlutusTx/Options.hs +++ b/plutus-tx-plugin/src/PlutusTx/Options.hs @@ -33,46 +33,45 @@ import Data.Text qualified as Text import Data.Type.Equality import GHC.Plugins qualified as GHC import Prettyprinter -import PyF (fmt) 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 - , _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 - , _posInlineConstants :: Bool - -- | Whether to try and retain the logging behaviour of the program. - , _posPreserveLogging :: Bool - , -- Setting to `True` defines `trace` as `\_ a -> a` instead of the builtin version. - -- Which effectively ignores the trace text. - _posRemoveTrace :: Bool - , _posDumpCompilationTrace :: Bool - } + { _posPlcTargetVersion :: PLC.Version + , _posDoTypecheck :: Bool + , _posDeferErrors :: Bool + , _posConservativeOpts :: Bool + , _posContextLevel :: Int + , _posDumpPir :: Bool + , _posDumpPlc :: Bool + , _posDumpUPlc :: Bool + , _posOptimize :: Bool + , _posPedantic :: Bool + , _posVerbosity :: Verbosity + , _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 + , _posInlineConstants :: 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 + } makeLenses ''PluginOptions @@ -84,186 +83,192 @@ 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 => - PluginOption - { poTypeRep :: TypeRep a - -- ^ `TypeRep` used for pretty printing the option. - , 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 - -- ^ A description of the option. - , poImplications :: [Implication a] - -- ^ Implications of this option being set to a particular value. - -- An option should not imply itself. - } + (Pretty a) => + PluginOption + { poTypeRep :: TypeRep a + -- ^ `TypeRep` used for pretty printing the option. + , 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 + -- ^ A description of the option. + , poImplications :: [Implication a] + -- ^ Implications of this option being set to a particular value. + -- An option should not imply itself. + } data ParseError - = CannotParseValue !OptionKey !OptionValue !SomeTypeRep - | UnexpectedValue !OptionKey !OptionValue - | MissingValue !OptionKey - | UnrecognisedOption !OptionKey ![OptionKey] - deriving stock (Show) + = CannotParseValue !OptionKey !OptionValue !SomeTypeRep + | UnexpectedValue !OptionKey !OptionValue + | MissingValue !OptionKey + | UnrecognisedOption !OptionKey ![OptionKey] + deriving stock (Show) newtype ParseErrors = ParseErrors (NonEmpty ParseError) - deriving newtype (Semigroup) + deriving newtype (Semigroup) instance Show ParseErrors where - show (ParseErrors errs) = - [fmt| - PlutusTx.Plugin: failed to parse options: - {Text.intercalate "\n" (fmap renderParseError (toList errs))} - |] + show (ParseErrors errs) = + "PlutusTx.Plugin: failed to parse options:\n" + <> Text.unpack (Text.intercalate "\n" (fmap renderParseError (toList errs))) instance Exception ParseErrors renderParseError :: ParseError -> Text renderParseError = \case - CannotParseValue k v tr -> - [fmt|Cannot parse value {v} for option {k} into type {show tr}.|] - UnexpectedValue k v -> - [fmt|Option {k} is a flag and does not take a value, but was given {v}.|] - MissingValue k -> - [fmt|Option {k} needs a value.|] - UnrecognisedOption k suggs -> - [fmt|Unrecognised option: {k}.|] <> case suggs of - [] -> "" - _ -> [fmt|\nDid you mean one of:\n{Text.intercalate "\n" suggs}|] + CannotParseValue k v tr -> + "Cannot parse value " + <> Text.pack (show v) + <> " for option " + <> Text.pack (show k) + <> " into type " + <> Text.pack (show tr) + UnexpectedValue k v -> + "Option " + <> Text.pack (show k) + <> " is a flag and does not take a value, but was given " + <> Text.pack (show v) + MissingValue k -> + "Option " <> Text.pack (show k) <> " needs a value" + UnrecognisedOption k suggs -> + "Unrecognised option: " <> Text.pack (show k) <> "." <> case suggs of + [] -> "" + _ -> "\nDid you mean one of:\n" <> Text.intercalate "\n" suggs -- | Definition of plugin options. pluginOptions :: Map OptionKey PluginOption pluginOptions = - Map.fromList - [ let k = "target-version" - desc = "The target Plutus Core language version" - in (k, PluginOption typeRep (plcParserOption PLC.version k) posPlcTargetVersion desc []) - , let k = "typecheck" - desc = "Perform type checking during compilation." - in (k, PluginOption typeRep (setTrue k) posDoTypecheck desc []) - , let k = "defer-errors" - desc = - "If a compilation error happens and this option is turned on, \ - \the compilation error is suppressed and the original Haskell \ - \expression is replaced with a runtime-error expression." - in (k, PluginOption typeRep (setTrue k) posDeferErrors desc []) - , let k = "conservative-optimisation" - desc = - "When conservative optimisation is used, only the optimisations that \ - \never make the program worse (in terms of cost or size) are employed. \ - \Implies `no-relaxed-float-in`, `no-inline-constants`, and \ - \`preserve-logging`." - in ( k - , PluginOption - typeRep - (setTrue k) - posConservativeOpts - desc - -- conservative-optimisation implies no-relaxed-floatin, and vice versa - -- similarly, it implies preserving logging - [ Implication (== True) posRelaxedFloatin False - , Implication (== True) posPreserveLogging True - , Implication (== True) posCaseOfCaseConservative True - , Implication (== True) posInlineConstants False - , Implication (== False) posRelaxedFloatin True - , Implication (== False) posPreserveLogging False - , Implication (== False) posCaseOfCaseConservative False - , Implication (== False) posInlineConstants True - ] - ) - , let k = "context-level" - desc = "Set context level for error messages." - in (k, PluginOption typeRep (readOption k) posContextLevel desc []) - , let k = "dump-pir" - desc = "Dump Plutus IR" - in (k, PluginOption typeRep (setTrue k) posDumpPir desc []) - , let k = "dump-tplc" - desc = "Dump Typed Plutus Core" - in (k, PluginOption typeRep (setTrue k) posDumpPlc desc []) - , let k = "dump-uplc" - desc = "Dump Untyped Plutus Core" - in (k, PluginOption typeRep (setTrue k) posDumpUPlc desc []) - , let k = "inline-constants" - desc = - "Always inline constants. Inlining constants always reduces script \ - \costs slightly, but may increase script sizes if a large constant \ - \is used more than once. Implied by `no-conservative-optimisation`." - in (k, PluginOption typeRep (setTrue k) posInlineConstants desc []) - , let k = "optimize" - desc = "Run optimization passes such as simplification and floating let-bindings." - in (k, PluginOption typeRep (setTrue k) posOptimize desc []) - , let k = "pedantic" - desc = "Run type checker after each compilation pass" - in (k, PluginOption typeRep (setTrue k) posPedantic desc []) - , let k = "verbosity" - desc = "Set logging verbosity level (0=Quiet, 1=Verbose, 2=Debug)" - toVerbosity v - | v <= 0 = Quiet - | v == 1 = Verbose - | otherwise = Debug - in ( k - , PluginOption - typeRep - (fromReadOption @Int k (Success . toVerbosity)) - posVerbosity - desc - [] - ) - , let k = "max-simplifier-iterations-pir" - desc = "Set the max iterations for the PIR simplifier" - in (k, PluginOption typeRep (readOption k) posMaxSimplifierIterationsPir desc []) - , let k = "max-simplifier-iterations-uplc" - desc = "Set the max iterations for the UPLC simplifier" - in (k, PluginOption typeRep (readOption k) posMaxSimplifierIterationsUPlc desc []) - , let k = "max-cse-iterations" - desc = "Set the max iterations for CSE" - in (k, PluginOption typeRep (readOption k) posMaxCseIterations desc []) - , let k = "simplifier-unwrap-cancel" - desc = "Run a simplification pass that cancels unwrap/wrap pairs" - in (k, PluginOption typeRep (setTrue k) posDoSimplifierUnwrapCancel desc []) - , let k = "simplifier-beta" - desc = "Run a simplification pass that performs beta transformations" - in (k, PluginOption typeRep (setTrue k) posDoSimplifierBeta desc []) - , let k = "simplifier-inline" - desc = "Run a simplification pass that performs inlining" - in (k, PluginOption typeRep (setTrue k) posDoSimplifierInline desc []) - , let k = "strictify-bindings" - desc = "Run a simplification pass that makes bindings stricter" - in (k, PluginOption typeRep (setTrue k) posDoSimplifierStrictifyBindings desc []) - , let k = "simplifier-remove-dead-bindings" - desc = "Run a simplification pass that removes dead bindings" - in (k, PluginOption typeRep (setTrue k) posDoSimplifierRemoveDeadBindings desc []) - , let k = "profile-all" - desc = "Set profiling options to All, which adds tracing when entering and exiting a term." - in (k, PluginOption typeRep (flag (const All) k) posProfile desc []) - , let k = "coverage-all" - desc = "Add all available coverage annotations in the trace output" - in (k, PluginOption typeRep (setTrue k) posCoverageAll desc []) - , let k = "coverage-location" - desc = "Add location coverage annotations in the trace output" - in (k, PluginOption typeRep (setTrue k) posCoverageLocation desc []) - , let k = "coverage-boolean" - desc = "Add boolean coverage annotations in the trace output" - in (k, PluginOption typeRep (setTrue k) posCoverageBoolean desc []) - , let k = "relaxed-float-in" - desc = - "Use a more aggressive float-in pass, which often leads to reduced costs \ - \but may occasionally lead to slightly increased costs. Implied by \ - \`no-conservative-optimisation`." - in (k, PluginOption typeRep (setTrue k) posRelaxedFloatin desc []) - , let k = "preserve-logging" - desc = - "Turn off optimisations that may alter (i.e., add, remove or change the \ - \order of) trace messages. Implied by `conservative-optimisation`." - in (k, PluginOption typeRep (setTrue k) posPreserveLogging desc []) - , let k = "remove-trace" - desc = "Eliminate calls to `trace` from Plutus Core" - in (k, PluginOption typeRep (setTrue k) posRemoveTrace desc []) - , let k = "dump-compilation-trace" - desc = "Dump compilation trace for debugging" - in (k, PluginOption typeRep (setTrue k) posDumpCompilationTrace desc []) - ] + Map.fromList + [ let k = "target-version" + desc = "The target Plutus Core language version" + in (k, PluginOption typeRep (plcParserOption PLC.version k) posPlcTargetVersion desc []) + , let k = "typecheck" + desc = "Perform type checking during compilation." + in (k, PluginOption typeRep (setTrue k) posDoTypecheck desc []) + , let k = "defer-errors" + desc = + "If a compilation error happens and this option is turned on, \ + \the compilation error is suppressed and the original Haskell \ + \expression is replaced with a runtime-error expression." + in (k, PluginOption typeRep (setTrue k) posDeferErrors desc []) + , let k = "conservative-optimisation" + desc = + "When conservative optimisation is used, only the optimisations that \ + \never make the program worse (in terms of cost or size) are employed. \ + \Implies `no-relaxed-float-in`, `no-inline-constants`, and \ + \`preserve-logging`." + in ( k + , PluginOption + typeRep + (setTrue k) + posConservativeOpts + desc + -- conservative-optimisation implies no-relaxed-floatin, and vice versa + -- similarly, it implies preserving logging + [ Implication (== True) posRelaxedFloatin False + , Implication (== True) posPreserveLogging True + , Implication (== True) posCaseOfCaseConservative True + , Implication (== True) posInlineConstants False + , Implication (== False) posRelaxedFloatin True + , Implication (== False) posPreserveLogging False + , Implication (== False) posCaseOfCaseConservative False + , Implication (== False) posInlineConstants True + ] + ) + , let k = "context-level" + desc = "Set context level for error messages." + in (k, PluginOption typeRep (readOption k) posContextLevel desc []) + , let k = "dump-pir" + desc = "Dump Plutus IR" + in (k, PluginOption typeRep (setTrue k) posDumpPir desc []) + , let k = "dump-tplc" + desc = "Dump Typed Plutus Core" + in (k, PluginOption typeRep (setTrue k) posDumpPlc desc []) + , let k = "dump-uplc" + desc = "Dump Untyped Plutus Core" + in (k, PluginOption typeRep (setTrue k) posDumpUPlc desc []) + , let k = "inline-constants" + desc = + "Always inline constants. Inlining constants always reduces script \ + \costs slightly, but may increase script sizes if a large constant \ + \is used more than once. Implied by `no-conservative-optimisation`." + in (k, PluginOption typeRep (setTrue k) posInlineConstants desc []) + , let k = "optimize" + desc = "Run optimization passes such as simplification and floating let-bindings." + in (k, PluginOption typeRep (setTrue k) posOptimize desc []) + , let k = "pedantic" + desc = "Run type checker after each compilation pass" + in (k, PluginOption typeRep (setTrue k) posPedantic desc []) + , let k = "verbosity" + desc = "Set logging verbosity level (0=Quiet, 1=Verbose, 2=Debug)" + toVerbosity v + | v <= 0 = Quiet + | v == 1 = Verbose + | otherwise = Debug + in ( k + , PluginOption + typeRep + (fromReadOption @Int k (Success . toVerbosity)) + posVerbosity + desc + [] + ) + , let k = "max-simplifier-iterations-pir" + desc = "Set the max iterations for the PIR simplifier" + in (k, PluginOption typeRep (readOption k) posMaxSimplifierIterationsPir desc []) + , let k = "max-simplifier-iterations-uplc" + desc = "Set the max iterations for the UPLC simplifier" + in (k, PluginOption typeRep (readOption k) posMaxSimplifierIterationsUPlc desc []) + , let k = "max-cse-iterations" + desc = "Set the max iterations for CSE" + in (k, PluginOption typeRep (readOption k) posMaxCseIterations desc []) + , let k = "simplifier-unwrap-cancel" + desc = "Run a simplification pass that cancels unwrap/wrap pairs" + in (k, PluginOption typeRep (setTrue k) posDoSimplifierUnwrapCancel desc []) + , let k = "simplifier-beta" + desc = "Run a simplification pass that performs beta transformations" + in (k, PluginOption typeRep (setTrue k) posDoSimplifierBeta desc []) + , let k = "simplifier-inline" + desc = "Run a simplification pass that performs inlining" + in (k, PluginOption typeRep (setTrue k) posDoSimplifierInline desc []) + , let k = "strictify-bindings" + desc = "Run a simplification pass that makes bindings stricter" + in (k, PluginOption typeRep (setTrue k) posDoSimplifierStrictifyBindings desc []) + , let k = "simplifier-remove-dead-bindings" + desc = "Run a simplification pass that removes dead bindings" + in (k, PluginOption typeRep (setTrue k) posDoSimplifierRemoveDeadBindings desc []) + , let k = "profile-all" + desc = "Set profiling options to All, which adds tracing when entering and exiting a term." + in (k, PluginOption typeRep (flag (const All) k) posProfile desc []) + , let k = "coverage-all" + desc = "Add all available coverage annotations in the trace output" + in (k, PluginOption typeRep (setTrue k) posCoverageAll desc []) + , let k = "coverage-location" + desc = "Add location coverage annotations in the trace output" + in (k, PluginOption typeRep (setTrue k) posCoverageLocation desc []) + , let k = "coverage-boolean" + desc = "Add boolean coverage annotations in the trace output" + in (k, PluginOption typeRep (setTrue k) posCoverageBoolean desc []) + , let k = "relaxed-float-in" + desc = + "Use a more aggressive float-in pass, which often leads to reduced costs \ + \but may occasionally lead to slightly increased costs. Implied by \ + \`no-conservative-optimisation`." + in (k, PluginOption typeRep (setTrue k) posRelaxedFloatin desc []) + , let k = "preserve-logging" + desc = + "Turn off optimisations that may alter (i.e., add, remove or change the \ + \order of) trace messages. Implied by `conservative-optimisation`." + in (k, PluginOption typeRep (setTrue k) posPreserveLogging desc []) + , let k = "remove-trace" + desc = "Eliminate calls to `trace` from Plutus Core" + in (k, PluginOption typeRep (setTrue k) posRemoveTrace desc []) + , let k = "dump-compilation-trace" + desc = "Dump compilation trace for debugging" + in (k, PluginOption typeRep (setTrue k) posDumpCompilationTrace desc []) + ] flag :: (a -> a) -> OptionKey -> Maybe OptionValue -> Validation ParseError (a -> a) flag f k = maybe (Success f) (Failure . UnexpectedValue k) @@ -273,105 +278,105 @@ 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 - -- TODO: use the error - Left (_e :: PLC.ParserErrorBundle) -> Failure $ CannotParseValue k t (someTypeRep (Proxy @Int)) - Nothing -> Failure $ MissingValue k + Just t -> case PLC.runQuoteT $ PLC.parse p "none" t of + 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 k = \case - Just v - | Just i <- readMaybe (Text.unpack v) -> Success $ const i - | otherwise -> Failure $ CannotParseValue k v (someTypeRep (Proxy @Int)) - Nothing -> Failure $ MissingValue k + Just v + | Just i <- readMaybe (Text.unpack v) -> Success $ const i + | otherwise -> Failure $ CannotParseValue k v (someTypeRep (Proxy @Int)) + 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) + (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 - | otherwise -> Failure $ CannotParseValue k v (someTypeRep (Proxy @Int)) - Nothing -> Failure $ MissingValue k + Just v + | Just i <- readMaybe (Text.unpack v) -> const <$> f i + | otherwise -> Failure $ CannotParseValue k v (someTypeRep (Proxy @Int)) + Nothing -> Failure $ MissingValue k defaultPluginOptions :: PluginOptions defaultPluginOptions = - PluginOptions - { _posPlcTargetVersion = PLC.plcVersion110 - , _posDoTypecheck = True - , _posDeferErrors = False - , _posConservativeOpts = False - , _posContextLevel = 1 - , _posDumpPir = False - , _posDumpPlc = False - , _posDumpUPlc = False - , _posOptimize = True - , _posPedantic = False - , _posVerbosity = Quiet - , _posMaxSimplifierIterationsPir = view PIR.coMaxSimplifierIterations PIR.defaultCompilationOpts - , _posMaxSimplifierIterationsUPlc = view UPLC.soMaxSimplifierIterations UPLC.defaultSimplifyOpts - , _posMaxCseIterations = view UPLC.soMaxCseIterations UPLC.defaultSimplifyOpts - , _posDoSimplifierUnwrapCancel = True - , _posDoSimplifierBeta = True - , _posDoSimplifierInline = True - , _posDoSimplifierEvaluateBuiltins = True - , _posDoSimplifierStrictifyBindings = True - , _posDoSimplifierRemoveDeadBindings = True - , _posProfile = None - , _posCoverageAll = False - , _posCoverageLocation = False - , _posCoverageBoolean = False - , _posRelaxedFloatin = True - , _posCaseOfCaseConservative = False - , _posInlineConstants = True - , _posPreserveLogging = False - , _posRemoveTrace = False - , _posDumpCompilationTrace = False - } + PluginOptions + { _posPlcTargetVersion = PLC.plcVersion110 + , _posDoTypecheck = True + , _posDeferErrors = False + , _posConservativeOpts = False + , _posContextLevel = 1 + , _posDumpPir = False + , _posDumpPlc = False + , _posDumpUPlc = False + , _posOptimize = True + , _posPedantic = False + , _posVerbosity = Quiet + , _posMaxSimplifierIterationsPir = view PIR.coMaxSimplifierIterations PIR.defaultCompilationOpts + , _posMaxSimplifierIterationsUPlc = view UPLC.soMaxSimplifierIterations UPLC.defaultSimplifyOpts + , _posMaxCseIterations = view UPLC.soMaxCseIterations UPLC.defaultSimplifyOpts + , _posDoSimplifierUnwrapCancel = True + , _posDoSimplifierBeta = True + , _posDoSimplifierInline = True + , _posDoSimplifierEvaluateBuiltins = True + , _posDoSimplifierStrictifyBindings = True + , _posDoSimplifierRemoveDeadBindings = True + , _posProfile = None + , _posCoverageAll = False + , _posCoverageLocation = False + , _posCoverageBoolean = False + , _posRelaxedFloatin = True + , _posCaseOfCaseConservative = False + , _posInlineConstants = True + , _posPreserveLogging = False + , _posRemoveTrace = False + , _posDumpCompilationTrace = False + } processOne :: - OptionKey -> - Maybe OptionValue -> - Validation ParseError (PluginOptions -> PluginOptions) + 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 - -- For each boolean option there is a "no-" version for disabling it. - | Just key' <- Text.stripPrefix "no-" key - , Just (PluginOption tr f field _ impls) <- Map.lookup key' pluginOptions - , Just Refl <- testEquality tr (typeRep @Bool) = - fmap (applyImplications field impls) . over field . (not .) <$> f val - | otherwise = - let suggs = - Text.pack - <$> GHC.fuzzyMatch (Text.unpack key) (Text.unpack <$> Map.keys pluginOptions) - in Failure (UnrecognisedOption key suggs) + | Just (PluginOption _ f field _ impls) <- Map.lookup key pluginOptions = + fmap (applyImplications field impls) . over field <$> f val + -- For each boolean option there is a "no-" version for disabling it. + | Just key' <- Text.stripPrefix "no-" key + , Just (PluginOption tr f field _ impls) <- Map.lookup key' pluginOptions + , Just Refl <- testEquality tr (typeRep @Bool) = + fmap (applyImplications field impls) . over field . (not .) <$> f val + | otherwise = + let suggs = + Text.pack + <$> GHC.fuzzyMatch (Text.unpack key) (Text.unpack <$> Map.keys pluginOptions) + in Failure (UnrecognisedOption key suggs) applyImplications :: Lens' PluginOptions a -> [Implication a] -> PluginOptions -> PluginOptions applyImplications field = - foldr - -- The value of `field` implies the value of `field'`. - ( \(Implication f field' val) acc -> - acc . (\opts -> if f (opts ^. field) then opts & field' .~ val else opts) - ) - id + foldr + -- The value of `field` implies the value of `field'`. + ( \(Implication f field' val) acc -> + acc . (\opts -> if f (opts ^. field) then opts & field' .~ val else opts) + ) + id processAll :: - [(OptionKey, Maybe OptionValue)] -> - Validation ParseErrors [PluginOptions -> PluginOptions] + [(OptionKey, Maybe OptionValue)] -> + Validation ParseErrors [PluginOptions -> PluginOptions] processAll = traverse $ first (ParseErrors . pure) . uncurry processOne toKeyValue :: GHC.CommandLineOption -> (OptionKey, Maybe OptionValue) toKeyValue opt = case List.elemIndex '=' opt of - Nothing -> (Text.pack opt, Nothing) - Just idx -> - let (lhs, rhs) = splitAt idx opt - in (Text.pack lhs, Just (Text.pack (drop 1 rhs))) + Nothing -> (Text.pack opt, Nothing) + Just idx -> + 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"