From a47be0edc32543993f2bc362173757e0903c7122 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Tue, 16 Jun 2026 13:00:23 +0100 Subject: [PATCH 01/13] Add Plinth parsed-AST deriving plugin to plutus-tx-plugin MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Ports the PlinthPlugin parsed-result plugin (from the ghc-plinth standalone effort) into plutus-tx-plugin. It expands data declarations written with `deriving … via PlinthPlugin` into AsData pattern synonyms, Optics prisms, and Match functions at parse time, alongside the existing core Plinth.Plugin. The modules carry CPP shims so they build on both GHC 9.6 and 9.12 (the versions plutus supports). PlinthPlugin and PlinthPlugin.Via (the `data Via = PlinthPlugin` sentinel) are exposed; the rest are internal. The version banner now reads Paths_plutus_tx_plugin. Co-Authored-By: Claude Opus 4.8 --- .../20260616_plinth_deriving_plugin.md | 6 + plutus-tx-plugin/plutus-tx-plugin.cabal | 19 + plutus-tx-plugin/src/PlinthPlugin.hs | 348 +++++++++++++ .../src/PlinthPlugin/Constant/Module.hs | 53 ++ .../src/PlinthPlugin/Generator/AsData.hs | 472 ++++++++++++++++++ .../src/PlinthPlugin/Generator/Common.hs | 364 ++++++++++++++ .../src/PlinthPlugin/Generator/FromData.hs | 128 +++++ .../src/PlinthPlugin/Generator/Match.hs | 307 ++++++++++++ .../src/PlinthPlugin/Generator/Optics.hs | 213 ++++++++ plutus-tx-plugin/src/PlinthPlugin/Hs.hs | 386 ++++++++++++++ plutus-tx-plugin/src/PlinthPlugin/Hsc.hs | 49 ++ plutus-tx-plugin/src/PlinthPlugin/Options.hs | 39 ++ .../src/PlinthPlugin/Type/Config.hs | 27 + .../src/PlinthPlugin/Type/Constructor.hs | 39 ++ .../src/PlinthPlugin/Type/Field.hs | 37 ++ .../src/PlinthPlugin/Type/Flag.hs | 32 ++ .../src/PlinthPlugin/Type/Type.hs | 56 +++ plutus-tx-plugin/src/PlinthPlugin/Via.hs | 15 + 18 files changed, 2590 insertions(+) create mode 100644 plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md create mode 100644 plutus-tx-plugin/src/PlinthPlugin.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Constant/Module.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Hs.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Hsc.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Options.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Type/Constructor.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Type/Field.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs create mode 100644 plutus-tx-plugin/src/PlinthPlugin/Via.hs diff --git a/plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md b/plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md new file mode 100644 index 00000000000..ea92a66c445 --- /dev/null +++ b/plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md @@ -0,0 +1,6 @@ +### Added + +- Added the Plinth parsed-AST deriving plugin (`PlinthPlugin`). It generates + `AsData` pattern synonyms, `Optics` prisms, and `Match` functions from data + declarations written with `deriving … via PlinthPlugin`. The sentinel lives + in `PlinthPlugin.Via` (`data Via = PlinthPlugin`). diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index ab359f994da..082a32a6107 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -56,11 +56,28 @@ library hs-source-dirs: src exposed-modules: Plinth.Plugin + PlinthPlugin + PlinthPlugin.Via PlutusTx.Compiler.Error PlutusTx.Options PlutusTx.Plugin.Common other-modules: + Paths_plutus_tx_plugin + PlinthPlugin.Constant.Module + PlinthPlugin.Generator.AsData + PlinthPlugin.Generator.Common + PlinthPlugin.Generator.FromData + PlinthPlugin.Generator.Match + PlinthPlugin.Generator.Optics + PlinthPlugin.Hs + PlinthPlugin.Hsc + PlinthPlugin.Options + PlinthPlugin.Type.Config + PlinthPlugin.Type.Constructor + PlinthPlugin.Type.Field + PlinthPlugin.Type.Flag + PlinthPlugin.Type.Type PlutusTx.Compiler.Binders PlutusTx.Compiler.Builtins PlutusTx.Compiler.Compat @@ -77,6 +94,8 @@ library PlutusTx.Plugin.Boilerplate PlutusTx.Plugin.Unsupported + autogen-modules: Paths_plutus_tx_plugin + build-depends: , array , base >=4.9 && <5 diff --git a/plutus-tx-plugin/src/PlinthPlugin.hs b/plutus-tx-plugin/src/PlinthPlugin.hs new file mode 100644 index 00000000000..1440be7fc61 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin.hs @@ -0,0 +1,348 @@ +module PlinthPlugin + ( plugin, + ) +where + +import qualified Control.Monad as Monad +import qualified Control.Monad.IO.Class as IO +import qualified Data.Bifunctor as Bifunctor +import qualified Data.Maybe as Maybe +import qualified Data.Version as Version +import qualified PlinthPlugin.Generator.AsData as AsData +import qualified PlinthPlugin.Generator.Match as Match +import qualified PlinthPlugin.Generator.Optics as Optics +import qualified PlinthPlugin.Generator.Common as Common +import GHC.Hs +import qualified PlinthPlugin.Hsc as Hsc +import qualified PlinthPlugin.Options as Options +import qualified PlinthPlugin.Type.Config as Config +import qualified PlinthPlugin.Type.Flag as Flag +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc +import qualified Paths_plutus_tx_plugin as This +import qualified System.Console.GetOpt as Console + +-- | The compiler plugin. When built into the Plinth GHC binary this is +-- registered as a static plugin and is active for every compilation without +-- requiring a @-fplugin=PlinthPlugin@ pragma. +-- +-- Once active, you can derive instances like this: +-- +-- > data Shape = Point | Circle Integer Integer +-- > deriving AsData via PlinthPlugin +-- > deriving Optics via PlinthPlugin +plugin :: Ghc.Plugin +plugin = + Ghc.defaultPlugin + { Ghc.parsedResultAction = parsedResultAction, + Ghc.pluginRecompile = Ghc.purePlugin + } + +parsedResultAction :: + [Ghc.CommandLineOption] -> + Ghc.ModSummary -> + Ghc.ParsedResult -> + Ghc.Hsc Ghc.ParsedResult +parsedResultAction commandLineOptions modSummary (Ghc.ParsedResult hsParsedModule msgs) = do + let lHsModule1 = Ghc.hpm_module hsParsedModule + srcSpan = Ghc.getLoc lHsModule1 + + flags <- Options.parse Flag.options commandLineOptions srcSpan + let config = Config.fromFlags flags + + Monad.when (Config.help config) + . Hsc.throwError srcSpan + . Ghc.vcat + . fmap Ghc.text + . lines + $ Console.usageInfo ("PlinthPlugin version " <> version) Flag.options + Monad.when (Config.version config) . Hsc.throwError srcSpan $ + Ghc.text version + + let moduleName = Ghc.moduleName $ Ghc.ms_mod modSummary + lHsModule2 <- handleLHsModule config moduleName lHsModule1 + + let newHsParsedModule = hsParsedModule { Ghc.hpm_module = lHsModule2 } + pure $ Ghc.ParsedResult newHsParsedModule msgs + +version :: String +version = Version.showVersion This.version + +type LHsModule = Ghc.Located (Ghc.HsModule Ghc.GhcPs) + +handleLHsModule :: + Config.Config -> + Ghc.ModuleName -> + LHsModule -> + Ghc.Hsc LHsModule +handleLHsModule config moduleName lHsModule = do + hsModule <- handleHsModule config moduleName $ Ghc.unLoc lHsModule + pure $ Ghc.L (Ghc.getLoc lHsModule) hsModule + +handleHsModule :: + Config.Config -> + Ghc.ModuleName -> + Ghc.HsModule Ghc.GhcPs -> + Ghc.Hsc (Ghc.HsModule Ghc.GhcPs) +handleHsModule config moduleName hsModule = do + (lImportDecls, lHsDecls) <- + handleLHsDecls config moduleName $ + Ghc.hsmodDecls hsModule + pure + hsModule + { Ghc.hsmodImports = Ghc.hsmodImports hsModule <> lImportDecls, + Ghc.hsmodDecls = lHsDecls + } + +handleLHsDecls :: + Config.Config -> + Ghc.ModuleName -> + [Ghc.LHsDecl Ghc.GhcPs] -> + Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) +handleLHsDecls config moduleName lHsDecls = do + tuples <- mapM (handleLHsDecl config moduleName) lHsDecls + pure . Bifunctor.bimap mconcat mconcat $ unzip tuples + +handleLHsDecl :: + Config.Config -> + Ghc.ModuleName -> + Ghc.LHsDecl Ghc.GhcPs -> + Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) +handleLHsDecl config moduleName lHsDecl = case Ghc.unLoc lHsDecl of + Ghc.TyClD xTyClD tyClDecl1 -> do + (mTyClDecl2, (lImportDecls, lHsDecls)) <- handleTyClDecl config moduleName tyClDecl1 + case mTyClDecl2 of + Nothing -> + pure (lImportDecls, lHsDecls) + Just tyClDecl2 -> + let newDecl = Ghc.L (Ghc.getLoc lHsDecl) (Ghc.TyClD xTyClD tyClDecl2) + in pure (lImportDecls, newDecl : lHsDecls) + _ -> pure ([], [lHsDecl]) + +handleTyClDecl :: + Config.Config -> + Ghc.ModuleName -> + Ghc.TyClDecl Ghc.GhcPs -> + Ghc.Hsc + ( Maybe (Ghc.TyClDecl Ghc.GhcPs), + ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) + ) +handleTyClDecl config moduleName tyClDecl = case tyClDecl of + Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity tcdDataDefn -> do + (mHsDataDefn, (lImportDecls, lHsDecls)) <- + handleHsDataDefn + config + moduleName + tcdLName + tcdTyVars + tcdDataDefn + pure + ( fmap (Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity) mHsDataDefn, + (lImportDecls, lHsDecls) + ) + _ -> pure (Just tyClDecl, ([], [])) + +handleHsDataDefn :: + Config.Config -> + Ghc.ModuleName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + Ghc.HsDataDefn Ghc.GhcPs -> + Ghc.Hsc + ( Maybe (Ghc.HsDataDefn Ghc.GhcPs), + ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) + ) +handleHsDataDefn config moduleName lIdP lHsQTyVars hsDataDefn = + case hsDataDefn of + Ghc.HsDataDefn dd_ext dd_ctxt dd_cType dd_kindSig dd_cons dd_derivs -> + do + let consList = case dd_cons of + Ghc.DataTypeCons _ cs -> cs + Ghc.NewTypeCon c -> [c] + + (mHsDeriving, (lImportDecls, lHsDecls)) <- + handleHsDeriving + config + moduleName + lIdP + lHsQTyVars + consList + dd_derivs + + pure + ( fmap + (\hsDeriving -> Ghc.HsDataDefn dd_ext dd_ctxt dd_cType dd_kindSig dd_cons hsDeriving) + mHsDeriving, + (lImportDecls, lHsDecls) + ) + +handleHsDeriving :: + Config.Config -> + Ghc.ModuleName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + [Ghc.LConDecl Ghc.GhcPs] -> + Ghc.HsDeriving Ghc.GhcPs -> + Ghc.Hsc + ( Maybe (Ghc.HsDeriving Ghc.GhcPs), + ( [Ghc.LImportDecl Ghc.GhcPs], + [Ghc.LHsDecl Ghc.GhcPs] + ) + ) +handleHsDeriving config moduleName lIdP lHsQTyVars lConDecls hsDeriving = do + (dropOriginal, lHsDerivingClauses, (lImportDecls, lHsDecls)) <- + handleLHsDerivingClauses config moduleName lIdP lHsQTyVars lConDecls hsDeriving + pure + ( if dropOriginal then Nothing else Just lHsDerivingClauses, + (lImportDecls, lHsDecls) + ) + +handleLHsDerivingClauses :: + Config.Config -> + Ghc.ModuleName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + [Ghc.LConDecl Ghc.GhcPs] -> + Ghc.HsDeriving Ghc.GhcPs -> + Ghc.Hsc + ( Bool, + [Ghc.LHsDerivingClause Ghc.GhcPs], + ( [Ghc.LImportDecl Ghc.GhcPs], + [Ghc.LHsDecl Ghc.GhcPs] + ) + ) +handleLHsDerivingClauses config moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses = + do + tuples <- + mapM + (handleLHsDerivingClause config moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses) + lHsDerivingClauses + let (mClauses, dropFlags, extras) = unzip3 tuples + taggedExtras = zip dropFlags extras + orderedExtras = + fmap snd (filter fst taggedExtras) + <> fmap snd (filter (not . fst) taggedExtras) + pure + ( or dropFlags, + Maybe.catMaybes mClauses, + Bifunctor.bimap mconcat mconcat $ unzip orderedExtras + ) + +handleLHsDerivingClause :: + Config.Config -> + Ghc.ModuleName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + [Ghc.LConDecl Ghc.GhcPs] -> + Ghc.HsDeriving Ghc.GhcPs -> + Ghc.LHsDerivingClause Ghc.GhcPs -> + Ghc.Hsc + ( Maybe (Ghc.LHsDerivingClause Ghc.GhcPs), + Bool, + ( [Ghc.LImportDecl Ghc.GhcPs], + [Ghc.LHsDecl Ghc.GhcPs] + ) + ) +handleLHsDerivingClause config moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses lHsDerivingClause = + case Ghc.unLoc lHsDerivingClause of + Ghc.HsDerivingClause _ deriv_clause_strategy deriv_clause_tys + | Just options <- Common.parseDerivingStrategy deriv_clause_strategy -> do + let nonPlinthPluginClauses = filter + ( \c -> case Ghc.unLoc c of + Ghc.HsDerivingClause _ s _ -> + Maybe.isNothing (Common.parseDerivingStrategy s) + ) + lHsDerivingClauses + (dropOriginal, lImportDecls, lHsDecls) <- + handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options nonPlinthPluginClauses + . toLHsSigTypes + $ Ghc.unLoc deriv_clause_tys + pure (Nothing, dropOriginal, (lImportDecls, lHsDecls)) + _ -> pure (Just lHsDerivingClause, False, ([], [])) + +toLHsSigTypes :: Ghc.DerivClauseTys Ghc.GhcPs -> [Ghc.LHsSigType Ghc.GhcPs] +toLHsSigTypes derivClauseTys = case derivClauseTys of + Ghc.DctSingle _ lHsSigType -> [lHsSigType] + Ghc.DctMulti _ lHsSigTypes -> lHsSigTypes + +handleLHsSigTypes :: + Config.Config -> + Ghc.ModuleName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + [Ghc.LConDecl Ghc.GhcPs] -> + [String] -> + Ghc.HsDeriving Ghc.GhcPs -> + [Ghc.LHsSigType Ghc.GhcPs] -> + Ghc.Hsc + ( Bool, + [Ghc.LImportDecl Ghc.GhcPs], + [Ghc.LHsDecl Ghc.GhcPs] + ) +handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options lHsDerivingClauses lHsSigTypes = + do + tuples <- + mapM + (handleLHsSigType config moduleName lIdP lHsQTyVars lConDecls options lHsDerivingClauses) + lHsSigTypes + let (dropFlags, importLists, declLists) = unzip3 tuples + pure (or dropFlags, mconcat importLists, mconcat declLists) + +handleLHsSigType :: + Config.Config -> + Ghc.ModuleName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + [Ghc.LConDecl Ghc.GhcPs] -> + [String] -> + Ghc.HsDeriving Ghc.GhcPs -> + Ghc.LHsSigType Ghc.GhcPs -> + Ghc.Hsc + ( Bool, + [Ghc.LImportDecl Ghc.GhcPs], + [Ghc.LHsDecl Ghc.GhcPs] + ) +handleLHsSigType config moduleName lIdP lHsQTyVars lConDecls options lHsDerivingClauses lHsSigType = + do + let srcSpan = Ghc.getLocA lHsSigType + (dropOriginal, lImportDecls, lHsDecls) <- case getGenerator lHsSigType of + Just generate -> + generate lHsDerivingClauses moduleName lIdP lHsQTyVars lConDecls options srcSpan + Nothing -> Hsc.throwError srcSpan $ Ghc.text "unsupported type class" + + verbose <- isVerbose config + Monad.when verbose $ do + IO.liftIO $ do + putStrLn $ replicate 80 '-' + mapM_ (putStrLn . Ghc.showPprUnsafe . Ghc.ppr) lImportDecls + mapM_ (putStrLn . Ghc.showPprUnsafe . Ghc.ppr) lHsDecls + + pure (dropOriginal, lImportDecls, lHsDecls) + +isVerbose :: Config.Config -> Ghc.Hsc Bool +isVerbose config = do + dynFlags <- Ghc.getDynFlags + pure $ Config.verbose config || Ghc.dopt Ghc.Opt_D_dump_deriv dynFlags + +getGenerator :: Ghc.LHsSigType Ghc.GhcPs -> Maybe (Ghc.HsDeriving Ghc.GhcPs -> Common.Generator) +getGenerator lHsSigType = do + className <- getClassName lHsSigType + lookup className generators + +generators :: [(String, Ghc.HsDeriving Ghc.GhcPs -> Common.Generator)] +generators = + [ ("AsData", AsData.generate), + ("Match", Match.generate), + ("Optics", Optics.generate) + ] + +getClassName :: Ghc.LHsSigType Ghc.GhcPs -> Maybe String +getClassName lHsSigType = do + lHsType <- case Ghc.unLoc lHsSigType of + Ghc.HsSig _ _ x -> Just x + lIdP <- case Ghc.unLoc lHsType of + Ghc.HsTyVar _ _ x -> Just x + _ -> Nothing + case Ghc.unLoc lIdP of + Ghc.Unqual x -> Just $ Ghc.occNameString x + _ -> Nothing diff --git a/plutus-tx-plugin/src/PlinthPlugin/Constant/Module.hs b/plutus-tx-plugin/src/PlinthPlugin/Constant/Module.hs new file mode 100644 index 00000000000..c4a87512106 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Constant/Module.hs @@ -0,0 +1,53 @@ +module PlinthPlugin.Constant.Module + ( controlApplicative, + controlLens, + dataAeson, + dataHashMapStrictInsOrd, + dataMaybe, + dataMonoid, + dataProxy, + dataString, + dataSwagger, + plutusTx, + plutusTxBuiltins, + testQuickCheck, + ) +where + +import qualified GHC.Unit.Module as Ghc + +controlApplicative :: Ghc.ModuleName +controlApplicative = Ghc.mkModuleName "Control.Applicative" + +controlLens :: Ghc.ModuleName +controlLens = Ghc.mkModuleName "Control.Lens" + +dataAeson :: Ghc.ModuleName +dataAeson = Ghc.mkModuleName "Data.Aeson" + +dataHashMapStrictInsOrd :: Ghc.ModuleName +dataHashMapStrictInsOrd = Ghc.mkModuleName "Data.HashMap.Strict.InsOrd" + +dataMaybe :: Ghc.ModuleName +dataMaybe = Ghc.mkModuleName "Data.Maybe" + +dataMonoid :: Ghc.ModuleName +dataMonoid = Ghc.mkModuleName "Data.Monoid" + +dataProxy :: Ghc.ModuleName +dataProxy = Ghc.mkModuleName "Data.Proxy" + +dataString :: Ghc.ModuleName +dataString = Ghc.mkModuleName "Data.String" + +dataSwagger :: Ghc.ModuleName +dataSwagger = Ghc.mkModuleName "Data.Swagger" + +plutusTx :: Ghc.ModuleName +plutusTx = Ghc.mkModuleName "PlutusTx" + +plutusTxBuiltins :: Ghc.ModuleName +plutusTxBuiltins = Ghc.mkModuleName "PlutusTx.Builtins" + +testQuickCheck :: Ghc.ModuleName +testQuickCheck = Ghc.mkModuleName "Test.QuickCheck" diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs new file mode 100644 index 00000000000..e44e3923ff9 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE CPP #-} + +module PlinthPlugin.Generator.AsData + ( generate, + ) +where + +import qualified Data.List as List +import qualified PlinthPlugin.Constant.Module as Module +import qualified PlinthPlugin.Generator.Common as Common +import qualified PlinthPlugin.Hs as Hs +import qualified PlinthPlugin.Hsc as Hsc +import qualified PlinthPlugin.Type.Constructor as Constructor +import qualified PlinthPlugin.Type.Field as Field +import qualified PlinthPlugin.Type.Type as Type +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc +import qualified GHC.Types.Fixity as Ghc +import qualified GHC.Types.SourceText as Ghc + +-- | Replaces the original data declaration with a newtype backed by +-- 'BuiltinData', generates bidirectional pattern synonyms for each +-- constructor, and derives 'ToData'/'FromData' via GND. +-- +-- Given: +-- +-- > data Example a = Ex1 Integer | Ex2 a a +-- > deriving AsData via PlinthPlugin +-- +-- Generates: +-- +-- > newtype Example a = Example_BD PlutusTx.Builtins.BuiltinData +-- > deriving newtype (PlutusTx.ToData, PlutusTx.FromData) +-- > +-- > pattern Ex1 :: Integer -> Example a +-- > pattern Ex1 x0_ <- +-- > Example_BD ((\d_ -> PlutusTx.unsafeFromBuiltinData +-- > (PlutusTx.headBuiltinList (PlutusTx.sndPair (PlutusTx.unsafeDataAsConstr d_)))) -> x0_) +-- > where Ex1 x0_ = Example_BD (PlutusTx.mkConstr 0 [PlutusTx.toBuiltinData x0_]) +-- > +-- > pattern Ex2 :: a -> a -> Example a +-- > pattern Ex2 x0_ x1_ <- +-- > Example_BD ((\d_ -> let args_ = PlutusTx.sndPair (PlutusTx.unsafeDataAsConstr d_) +-- > in (PlutusTx.unsafeFromBuiltinData (PlutusTx.headBuiltinList args_), +-- > ...)) -> (x0_, x1_)) +-- > where Ex2 x0_ x1_ = Example_BD (PlutusTx.mkConstr 1 [...]) +-- > +-- > {-# COMPLETE Ex1, Ex2 #-} +generate :: Ghc.HsDeriving Ghc.GhcPs -> Common.Generator +generate remainingDerivs _moduleName lIdP lHsQTyVars lConDecls _options srcSpan = do + type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan + let constructors = Type.constructors type_ + when (null constructors) $ + Hsc.throwError srcSpan $ Ghc.text "AsData requires at least one constructor" + + plutusTx <- Common.makeRandomModule Module.plutusTx + plutusTxBuiltins <- Common.makeRandomModule Module.plutusTxBuiltins + + let lImportDecls = + Hs.importDecls + srcSpan + [ (Module.plutusTx, plutusTx), + (Module.plutusTxBuiltins, plutusTxBuiltins) + ] + + newtypeDecl = + makeNewtypeDecl srcSpan type_ plutusTx plutusTxBuiltins remainingDerivs + + completeDecl = + makeCompleteDecl srcSpan constructors + + patSynDecls <- + mapM + (\(idx, con) -> makePatSynDecl srcSpan type_ con idx plutusTx plutusTxBuiltins) + (zip [0 ..] constructors) + + pure (True, lImportDecls, newtypeDecl : patSynDecls <> [completeDecl]) + +when :: Applicative f => Bool -> f () -> f () +when True action = action +when False _ = pure () + +-- | The internal constructor name for the newtype. +internalConName :: Type.Type -> Ghc.OccName +internalConName type_ = + Ghc.mkDataOcc $ + Ghc.occNameString (Ghc.rdrNameOcc (Type.name type_)) <> "_BD" + +-- | Generate: @newtype Example a = Example_BD BuiltinData@ +-- @ deriving newtype (ToData, FromData)@ +makeNewtypeDecl :: + Ghc.SrcSpan -> + Type.Type -> + Ghc.ModuleName -> + Ghc.ModuleName -> + Ghc.HsDeriving Ghc.GhcPs -> + Ghc.LHsDecl Ghc.GhcPs +makeNewtypeDecl srcSpan type_ plutusTx plutusTxBuiltins remainingDerivs = + let tyName = Ghc.rdrNameOcc $ Type.name type_ + lTypeName = Ghc.noLocA $ Ghc.mkRdrUnqual tyName + lConName = Ghc.noLocA $ Ghc.mkRdrUnqual (internalConName type_) + + builtinDataTy = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsTyVar + Ghc.noAnn + Ghc.NotPromoted + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.Qual plutusTxBuiltins (Ghc.mkTcOcc "BuiltinData")) + + conDecl = + Ghc.noLocA $ + Ghc.ConDeclH98 + { Ghc.con_ext = Ghc.noAnn, + Ghc.con_name = lConName, + Ghc.con_forall = False, + Ghc.con_ex_tvs = [], + Ghc.con_mb_cxt = Nothing, + Ghc.con_args = + Ghc.PrefixCon + [] + [Ghc.HsScaled Hs.unrestrictedArrow builtinDataTy], + Ghc.con_doc = Nothing + } + + -- deriving newtype (ToData, FromData) plus any remaining clauses + gndClause = makeGndClause srcSpan plutusTx + derivs = gndClause : remainingDerivs + + dataDefn = + Ghc.HsDataDefn +#if __GLASGOW_HASKELL__ >= 910 + { Ghc.dd_ext = Ghc.noAnn, +#else + { Ghc.dd_ext = Ghc.noExtField, +#endif + Ghc.dd_ctxt = Nothing, + Ghc.dd_cType = Nothing, + Ghc.dd_kindSig = Nothing, + Ghc.dd_cons = Ghc.NewTypeCon conDecl, + Ghc.dd_derivs = derivs + } + + -- Preserve type variables from the original type + tyVars = mkTyVars srcSpan (Type.variables type_) + + tyClDecl = + Ghc.DataDecl +#if __GLASGOW_HASKELL__ >= 910 + { Ghc.tcdDExt = Ghc.noExtField, +#else + { Ghc.tcdDExt = Ghc.noAnn, +#endif + Ghc.tcdLName = lTypeName, + Ghc.tcdTyVars = tyVars, + Ghc.tcdFixity = Ghc.Prefix, + Ghc.tcdDataDefn = dataDefn + } + in Ghc.noLocA (Ghc.TyClD Ghc.noExtField tyClDecl) + +-- | Build @deriving newtype (PlutusTx.ToData, PlutusTx.FromData)@. +makeGndClause :: + Ghc.SrcSpan -> + Ghc.ModuleName -> + Ghc.LHsDerivingClause Ghc.GhcPs +makeGndClause srcSpan plutusTx = + let strategy = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.NewtypeStrategy Ghc.noAnn + + mkCls occ = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsSig + Ghc.noExtField + Ghc.mkHsOuterImplicit + ( Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsTyVar + Ghc.noAnn + Ghc.NotPromoted + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.Qual plutusTx occ) + ) + + tys = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.DctMulti Ghc.noExtField [mkCls (Ghc.mkClsOcc "ToData"), mkCls (Ghc.mkClsOcc "FromData"), mkCls (Ghc.mkClsOcc "UnsafeFromData")] + in Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsDerivingClause Ghc.noAnn (Just strategy) tys + +-- | Build @{-# COMPLETE Ex1, Ex2 #-}@. +makeCompleteDecl :: + Ghc.SrcSpan -> + [Constructor.Constructor] -> + Ghc.LHsDecl Ghc.GhcPs +makeCompleteDecl srcSpan constructors = + let conNames = + fmap + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) . Ghc.mkRdrUnqual . Ghc.rdrNameOcc . Constructor.name) + constructors + in Ghc.noLocA . Ghc.SigD Ghc.noExtField $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.CompleteMatchSig + ((Ghc.noAnn, Nothing, Ghc.noAnn), Ghc.NoSourceText) + conNames + Nothing +#else + Ghc.CompleteMatchSig + (Ghc.noAnn, Ghc.NoSourceText) + (Ghc.L srcSpan conNames) + Nothing +#endif + +-- | Generate the bidirectional pattern synonym for one constructor. +makePatSynDecl :: + Ghc.SrcSpan -> + Type.Type -> + Constructor.Constructor -> + Integer -> + Ghc.ModuleName -> + Ghc.ModuleName -> + Ghc.Hsc (Ghc.LHsDecl Ghc.GhcPs) +makePatSynDecl srcSpan type_ constructor idx plutusTx plutusTxBuiltins = do + let fields = Constructor.fields constructor + arity = length fields + + vars <- mapM (\_ -> Common.makeRandomVariable srcSpan "x_") fields + dVar <- Common.makeRandomVariable srcSpan "d_" + tagVar <- Common.makeRandomVariable srcSpan "tag_" + argsVar <- Common.makeRandomVariable srcSpan "args_" + + let conRdrName = Constructor.name constructor + lConName = Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.mkRdrUnqual (Ghc.rdrNameOcc conRdrName) + internalCon = Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.mkRdrUnqual (internalConName type_) + + -- The "where" (builder) body: + -- Example_BD (mkConstr idx [toBuiltinData (x0_ :: T0), ...]) + encodeArgs = + fmap + ( \(v, field) -> + Hs.app + srcSpan + (Hs.qualVar srcSpan plutusTx (Ghc.mkVarOcc "toBuiltinData")) + -- type annotation so GHC can resolve ToData instance + (Hs.par srcSpan $ typeAnnotate srcSpan (Field.type_ field) (Hs.var srcSpan v)) + ) + (zip vars fields) + + builderBody = + Hs.app + srcSpan + ( Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsVar Ghc.noExtField internalCon + ) + ( Hs.par srcSpan $ + Hs.app + srcSpan + ( Hs.app + srcSpan + (Hs.qualVar srcSpan plutusTxBuiltins (Ghc.mkVarOcc "mkConstr")) + (intLit srcSpan idx) + ) + (Hs.explicitList srcSpan encodeArgs) + ) + + -- The match (destructor) pattern uses a view pattern: + -- Example_BD (viewFn -> matchPat) + viewFn = makeViewFn srcSpan fields idx dVar tagVar argsVar plutusTx plutusTxBuiltins + matchPat = makeMatchPat srcSpan arity vars + + matchPat' = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ConPat + Ghc.noAnn + internalCon + ( Ghc.PrefixCon + [] + [ Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ViewPat Ghc.noAnn viewFn matchPat + ] + ) + + -- pattern synonym args + patArgs = Ghc.PrefixCon [] vars + + -- The explicit bidirectional direction + builderMatch = + Hs.funMatch + srcSpan + lConName + (fmap (Hs.varPat srcSpan) vars) + (Common.makeGRHSs srcSpan builderBody) + + patSynBind = + Ghc.PatSynBind Ghc.noExtField $ + Ghc.PSB + { Ghc.psb_ext = Ghc.noAnn, + Ghc.psb_id = lConName, + Ghc.psb_args = patArgs, + Ghc.psb_def = matchPat', + Ghc.psb_dir = Ghc.ExplicitBidirectional $ + Hs.mg (Ghc.L srcSpan [builderMatch]) + } + + pure $ + Ghc.noLocA $ + Ghc.ValD Ghc.noExtField patSynBind + +-- | Wrap an expression with a type annotation: @(expr :: ty)@. +typeAnnotate :: + Ghc.SrcSpan -> + Ghc.HsType Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs +typeAnnotate srcSpan ty expr = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ExprWithTySig + Ghc.noAnn + expr + ( Ghc.HsWC Ghc.noExtField $ + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsSig + Ghc.noExtField + Ghc.mkHsOuterImplicit + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) ty) + ) + +-- | Build the view function for deconstruction. +-- +-- Always checks the constructor tag; returns @Maybe@ so GHC can try the +-- next pattern alternative if the tag doesn't match: +-- +-- @\d_ -> let tag_ = fst (unsafeDataAsConstr d_) +-- args_ = snd (unsafeDataAsConstr d_) +-- in if tag_ == idx then Just \ else Nothing@ +-- +-- @\@ is @()@ for nullary constructors, @(x :: T)@ for arity-1, +-- or a tuple for higher arities. +makeViewFn :: + Ghc.SrcSpan -> + [Field.Field] -> + Integer -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.ModuleName -> + Ghc.ModuleName -> + Ghc.LHsExpr Ghc.GhcPs +makeViewFn srcSpan fields idx dVar tagVar argsVar plutusTx plutusTxBuiltins = + let ptx = Hs.qualVar srcSpan plutusTx + blt = Hs.qualVar srcSpan plutusTxBuiltins + arity = length fields + + -- fst / snd (unsafeDataAsConstr d_) + constrExpr = + Hs.app srcSpan + (blt (Ghc.mkVarOcc "unsafeDataAsConstr")) + (Hs.var srcSpan dVar) + + getFst = Hs.app srcSpan (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "fst"))) (Hs.par srcSpan constrExpr) + getSnd = Hs.app srcSpan (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "snd"))) (Hs.par srcSpan constrExpr) + + -- helper: 0-arg let binding var = rhs + mkLetFun var rhs = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.FunBind Ghc.noExtField var + (Hs.mg (Ghc.L srcSpan [Hs.funMatch srcSpan var [] (Common.makeGRHSs srcSpan rhs)])) + + tagBind = mkLetFun tagVar getFst + argsBind = mkLetFun argsVar getSnd + + -- head (tail^n argsVar) + nthElem n = + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "head"))) + ( Hs.par srcSpan $ + iterate + ( \e -> + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "tail"))) + (Hs.par srcSpan e) + ) + (Hs.var srcSpan argsVar) + !! n + ) + + -- (unsafeFromBuiltinData e) :: fieldType + decode fieldType e = + typeAnnotate srcSpan fieldType $ + Hs.app srcSpan + (ptx (Ghc.mkVarOcc "unsafeFromBuiltinData")) + (Hs.par srcSpan e) + + -- value to wrap in Just + inner = case arity of + 0 -> + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ExplicitTuple Ghc.noAnn [] Ghc.Boxed + 1 -> + decode (Field.type_ (head fields)) (nthElem 0) + _ -> + let elems = fmap (\(n, f) -> decode (Field.type_ f) (nthElem n)) (zip [0 ..] fields) + in Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ExplicitTuple Ghc.noAnn (fmap Hs.tupArg elems) Ghc.Boxed + + justInner = + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Just"))) + (Hs.par srcSpan inner) + + nothingExpr = + Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Nothing")) + + -- tagVar == idx + cond = + Hs.opApp srcSpan + (Hs.var srcSpan tagVar) + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "=="))) + (intLit srcSpan idx) + + ifExpr = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsIf Ghc.noAnn cond justInner nothingExpr + + -- omit argsBind for nullary constructors (avoid unused-variable warning) + letBinds = if arity == 0 then [tagBind] else [tagBind, argsBind] + + body = + Hs.letE srcSpan (Hs.valLocalBinds letBinds) ifExpr + in Hs.lam srcSpan . Hs.mg $ + Ghc.L srcSpan + [ Hs.match srcSpan + [Hs.varPat srcSpan dVar] + (Common.makeGRHSs srcSpan body) + ] + +-- | Build the match pattern for the view result. +-- Always wrapped in @Just@: nullary → @Just ()@, arity 1 → @Just x0_@, +-- arity n → @Just (x0_, x1_, ...)@ +makeMatchPat :: + Ghc.SrcSpan -> + Int -> + [Ghc.LIdP Ghc.GhcPs] -> + Ghc.LPat Ghc.GhcPs +makeMatchPat srcSpan arity vars = + let inner = case arity of + 0 -> + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.TuplePat Ghc.noAnn [] Ghc.Boxed + 1 -> + Hs.varPat srcSpan (head vars) + _ -> + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.TuplePat Ghc.noAnn (fmap (Hs.varPat srcSpan) vars) Ghc.Boxed + in Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ConPat Ghc.noAnn + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.mkRdrUnqual (Ghc.mkDataOcc "Just"))) + (Ghc.PrefixCon [] [inner]) + +-- | Rebuild 'LHsQTyVars' from the type variable 'RdrName's. +mkTyVars :: Ghc.SrcSpan -> [Ghc.IdP Ghc.GhcPs] -> Ghc.LHsQTyVars Ghc.GhcPs +mkTyVars srcSpan vars = + Ghc.HsQTvs Ghc.noExtField (fmap (Hs.userTyVar srcSpan) vars) + +-- | Integer overloaded literal. +intLit :: Ghc.SrcSpan -> Integer -> Ghc.LHsExpr Ghc.GhcPs +intLit s n = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsOverLit Ghc.noExtField $ +#else + Ghc.HsOverLit Ghc.noAnn $ +#endif + Ghc.OverLit Ghc.noExtField (Ghc.HsIntegral (Ghc.IL Ghc.NoSourceText False n)) + diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs new file mode 100644 index 00000000000..cc8b594c839 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE CPP #-} + +module PlinthPlugin.Generator.Common + ( Generator, + applyAll, + fieldNameOptions, + makeGRHSs, + makeInstanceDeclaration, + makeLHsBind, + makeRandomModule, + makeRandomVariable, + parseDerivingStrategy, + ) +where + +import qualified Control.Monad.IO.Class as IO +import qualified Data.Char as Char +import qualified Data.IORef as IORef +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import qualified PlinthPlugin.Hs as Hs +import qualified PlinthPlugin.Hsc as Hsc +import qualified PlinthPlugin.Type.Constructor as Constructor +import qualified PlinthPlugin.Type.Field as Field +import qualified PlinthPlugin.Type.Type as Type +import qualified GHC.Data.Bag as Ghc +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc +import qualified GHC.Types.Fixity as Ghc +import qualified System.Console.GetOpt as Console +import qualified System.IO.Unsafe as Unsafe +import qualified Text.Printf as Printf + +-- | The 'Bool' indicates whether the original declaration should be dropped +-- (replaced by the generated declarations). Most generators return 'False'. +type Generator = + Ghc.ModuleName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + [Ghc.LConDecl Ghc.GhcPs] -> + [String] -> + Ghc.SrcSpan -> + Ghc.Hsc + (Bool, [Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) + +fieldNameOptions :: + Ghc.SrcSpan -> [Console.OptDescr (String -> Ghc.Hsc String)] +fieldNameOptions srcSpan = + [ Console.Option [] ["kebab"] (Console.NoArg $ pure . kebab) "", + Console.Option [] ["camel"] (Console.NoArg $ pure . lower) "", + Console.Option [] ["snake"] (Console.NoArg $ pure . snake) "", + Console.Option [] ["prefix", "strip"] (Console.ReqArg (stripPrefix srcSpan) "PREFIX") "", + Console.Option [] ["suffix"] (Console.ReqArg (stripSuffix srcSpan) "SUFFIX") "", + Console.Option [] ["title"] (Console.NoArg $ pure . upper) "", + Console.Option [] ["rename"] (Console.ReqArg (rename srcSpan) "OLD:NEW") "" + ] + +stripPrefix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String +stripPrefix srcSpan prefix s1 = case List.stripPrefix prefix s1 of + Nothing -> + Hsc.throwError srcSpan + . Ghc.text + $ show prefix + <> " is not a prefix of " + <> show s1 + Just s2 -> pure s2 + +stripSuffix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String +stripSuffix srcSpan suffix s1 = case Text.stripSuffix (Text.pack suffix) (Text.pack s1) of + Nothing -> + Hsc.throwError srcSpan + . Ghc.text + $ show suffix + <> " is not a suffix of " + <> show s1 + Just s2 -> pure $ Text.unpack s2 + +rename :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String +rename loc arg str = + case Text.splitOn (Text.singleton ':') $ Text.pack arg of + [old, new] + | not (Text.null old || Text.null new) -> + pure $ + if Text.pack str == old + then Text.unpack new + else str + _ -> Hsc.throwError loc . Ghc.text $ show arg <> " is invalid" + +-- | Applies all the monadic functions in order beginning with some starting +-- value. +applyAll :: Monad m => [a -> m a] -> a -> m a +applyAll fs x = case fs of + [] -> pure x + f : gs -> do + y <- f x + applyAll gs y + +-- | Converts the first character into upper case. +upper :: String -> String +upper = overFirst Char.toUpper + +-- | Converts the first character into lower case. +lower :: String -> String +lower = overFirst Char.toLower + +overFirst :: (a -> a) -> [a] -> [a] +overFirst f xs = case xs of + x : ys -> f x : ys + _ -> xs + +-- | Converts the string into kebab case. +-- +-- >>> kebab "DoReMi" +-- "do-re-mi" +kebab :: String -> String +kebab = camelTo '-' + +-- | Converts the string into snake case. +-- +-- >>> snake "DoReMi" +-- "do_re_mi" +snake :: String -> String +snake = camelTo '_' + +camelTo :: Char -> String -> String +camelTo char = + let go wasUpper string = case string of + "" -> "" + first : rest -> + if Char.isUpper first + then + if wasUpper + then Char.toLower first : go True rest + else char : Char.toLower first : go True rest + else first : go False rest + in go True + +makeLHsType :: + Ghc.SrcSpan -> + Ghc.ModuleName -> + Ghc.OccName -> + Type.Type -> + Ghc.LHsType Ghc.GhcPs +makeLHsType srcSpan moduleName className = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) + . Ghc.HsAppTy + Ghc.noExtField + ( Ghc.L (Ghc.noAnnSrcSpan srcSpan) + . Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted + . Ghc.L (Ghc.noAnnSrcSpan srcSpan) + $ Ghc.Qual moduleName className + ) + . toLHsType srcSpan + +toLHsType :: Ghc.SrcSpan -> Type.Type -> Ghc.LHsType Ghc.GhcPs +toLHsType srcSpan type_ = + let ext :: Ghc.NoExtField + ext = Ghc.noExtField + + -- A bare type variable, used as a type. Each location wrapper is a + -- fresh expression so its annotation type is inferred per-position + -- (a shared @loc@ binding monomorphises to the wrong annotation). + tv :: Ghc.IdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs + tv n = Hs.tyVar srcSpan (Ghc.L (Ghc.noAnnSrcSpan srcSpan) n) + + initial :: Ghc.LHsType Ghc.GhcPs + initial = tv (Type.name type_) + + combine :: + Ghc.LHsType Ghc.GhcPs -> Ghc.IdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs + combine x v = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.HsAppTy ext x (tv v)) + + bare :: Ghc.LHsType Ghc.GhcPs + bare = List.foldl' combine initial $ Type.variables type_ + in case Type.variables type_ of + [] -> bare + _ -> Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.HsParTy Ghc.noAnn bare + +makeHsContext :: + Ghc.SrcSpan -> + Ghc.ModuleName -> + Ghc.OccName -> + Type.Type -> + [Ghc.LHsType Ghc.GhcPs] +makeHsContext srcSpan moduleName className = + fmap + ( Ghc.L (Ghc.noAnnSrcSpan srcSpan) + . Ghc.HsAppTy + Ghc.noExtField + ( Ghc.L (Ghc.noAnnSrcSpan srcSpan) + . Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted + . Ghc.L (Ghc.noAnnSrcSpan srcSpan) + $ Ghc.Qual moduleName className + ) + . Ghc.L (Ghc.noAnnSrcSpan srcSpan) + . Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted + . Ghc.L (Ghc.noAnnSrcSpan srcSpan) + . Ghc.Unqual + ) + . List.nub + . Maybe.mapMaybe + ( \field -> case Field.type_ field of + Ghc.HsTyVar _ _ lRdrName -> case Ghc.unLoc lRdrName of + Ghc.Unqual occName | Ghc.isTvOcc occName -> Just occName + _ -> Nothing + _ -> Nothing + ) + . concatMap Constructor.fields + . Type.constructors + +makeHsImplicitBndrs :: + Ghc.SrcSpan -> + Type.Type -> + Ghc.ModuleName -> + Ghc.OccName -> + Ghc.LHsSigType Ghc.GhcPs +makeHsImplicitBndrs srcSpan type_ moduleName className = + let withoutContext = makeLHsType srcSpan moduleName className type_ + context = makeHsContext srcSpan moduleName className type_ + withContext = + if null context + then withoutContext + else + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsQualTy Ghc.noExtField (Ghc.L (Ghc.noAnnSrcSpan srcSpan) context) withoutContext + in Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit withContext + +-- | Makes a random variable name using the given prefix. +makeRandomVariable :: Ghc.SrcSpan -> String -> Ghc.Hsc (Ghc.LIdP Ghc.GhcPs) +makeRandomVariable srcSpan prefix = do + n <- bumpCounter + pure . Ghc.L (Ghc.noAnnSrcSpan srcSpan) . Ghc.Unqual . Ghc.mkVarOcc $ + Printf.printf + "%s%d" + prefix + n + +-- | Makes a random module name. This will convert any periods to underscores +-- and add a unique suffix. +-- +-- >>> makeRandomModule "Data.Aeson" +-- "Data_Aeson_1" +makeRandomModule :: Ghc.ModuleName -> Ghc.Hsc Ghc.ModuleName +makeRandomModule moduleName = do + n <- bumpCounter + pure . Ghc.mkModuleName $ + Printf.printf + "%s_%d" + (underscoreAll moduleName) + n + +underscoreAll :: Ghc.ModuleName -> String +underscoreAll = fmap underscoreOne . Ghc.moduleNameString + +underscoreOne :: Char -> Char +underscoreOne c = case c of + '.' -> '_' + _ -> c + +makeInstanceDeclaration :: + Ghc.SrcSpan -> + Type.Type -> + Ghc.ModuleName -> + Ghc.OccName -> + [Ghc.LHsBind Ghc.GhcPs] -> + Ghc.LHsDecl Ghc.GhcPs +makeInstanceDeclaration srcSpan type_ moduleName occName lHsBinds = + let hsImplicitBndrs = makeHsImplicitBndrs srcSpan type_ moduleName occName + in makeLHsDecl srcSpan hsImplicitBndrs lHsBinds + +makeLHsDecl :: + Ghc.SrcSpan -> + Ghc.LHsSigType Ghc.GhcPs -> + [Ghc.LHsBind Ghc.GhcPs] -> + Ghc.LHsDecl Ghc.GhcPs +makeLHsDecl srcSpan hsImplicitBndrs lHsBinds = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) + . Ghc.InstD Ghc.noExtField + . Ghc.ClsInstD Ghc.noExtField + $ Ghc.ClsInstDecl +#if __GLASGOW_HASKELL__ >= 910 + (Nothing, Ghc.noAnn, Ghc.NoAnnSortKey) + hsImplicitBndrs + lHsBinds +#else + (Ghc.noAnn, Ghc.NoAnnSortKey) + hsImplicitBndrs + (Ghc.listToBag lHsBinds) +#endif + [] [] [] Nothing + +makeLHsBind :: + Ghc.SrcSpan -> + Ghc.OccName -> + [Ghc.LPat Ghc.GhcPs] -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsBind Ghc.GhcPs +makeLHsBind srcSpan occName pats = + Hs.funBind srcSpan occName . makeMatchGroup srcSpan occName pats + +makeMatchGroup :: + Ghc.SrcSpan -> + Ghc.OccName -> + [Ghc.LPat Ghc.GhcPs] -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +makeMatchGroup srcSpan occName lPats hsExpr = + Hs.mg + ( Ghc.L srcSpan + [ Hs.funMatch + srcSpan + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.Unqual occName)) + lPats + (makeGRHSs srcSpan hsExpr) + ] + ) + +makeGRHSs :: + Ghc.SrcSpan -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +makeGRHSs srcSpan hsExpr = + Ghc.GRHSs Ghc.emptyComments [Hs.grhs srcSpan hsExpr] $ + Ghc.EmptyLocalBinds Ghc.noExtField + +bumpCounter :: IO.MonadIO m => m Word +bumpCounter = IO.liftIO . IORef.atomicModifyIORef' counterRef $ \n -> (n + 1, n) + +counterRef :: IORef.IORef Word +counterRef = Unsafe.unsafePerformIO $ IORef.newIORef 0 +{-# NOINLINE counterRef #-} + + + +-- | This plugin only fires on specific deriving strategies. In particular it +-- looks for clauses like this: +-- +-- > deriving C via PlinthPlugin +-- +-- where @PlinthPlugin@ is the promoted constructor of @data Via = PlinthPlugin@. +-- Using a real constructor (rather than a @Symbol@ string literal) means the +-- name must be in scope and well-kinded, so when the plugin is not loaded GHC +-- reports a clean type error instead of a confusing one. +-- +-- This function is responsible for analyzing a deriving strategy to determine +-- if the plugin should fire or not. +parseDerivingStrategy :: + Maybe (Ghc.LDerivStrategy Ghc.GhcPs) -> Maybe [String] +parseDerivingStrategy mLDerivStrategy = do + lDerivStrategy <- mLDerivStrategy + lHsSigType <- case Ghc.unLoc lDerivStrategy of + Ghc.ViaStrategy (Ghc.XViaStrategyPs _ x) -> Just $ Ghc.unLoc x + _ -> Nothing + lHsType <- case lHsSigType of + Ghc.HsSig _ _ x -> Just x + rdrName <- case Ghc.unLoc lHsType of + Ghc.HsTyVar _ _ x -> Just $ Ghc.unLoc x + _ -> Nothing + case Ghc.occNameString $ Ghc.rdrNameOcc rdrName of + "PlinthPlugin" -> Just [] + _ -> Nothing + diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs new file mode 100644 index 00000000000..7017df9ccc5 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs @@ -0,0 +1,128 @@ +module PlinthPlugin.Generator.FromData + ( generate, + ) +where + +import qualified Data.List as List +import qualified PlinthPlugin.Constant.Module as Module +import qualified PlinthPlugin.Generator.Common as Common +import qualified PlinthPlugin.Hs as Hs +import qualified PlinthPlugin.Hsc as Hsc +import qualified PlinthPlugin.Options as Options +import qualified PlinthPlugin.Type.Constructor as Constructor +import qualified PlinthPlugin.Type.Field as Field +import qualified PlinthPlugin.Type.Type as Type +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc + +generate :: Common.Generator +generate _moduleName _lIdP _lHsQTyVars _lConDecls _options _srcSpan = + pure (False, [], []) +-- generate :: Common.Generator +-- generate moduleName lIdP lHsQTyVars lConDecls options srcSpan = do +-- type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan +-- constructor <- case Type.constructors type_ of +-- [x] -> pure x +-- _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor" +-- modifyFieldName <- +-- Common.applyAll +-- <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan + +-- fields <- +-- mapM (fromField srcSpan modifyFieldName) +-- . List.sortOn Field.name +-- . concatMap Constructor.fields +-- $ Type.constructors type_ + +-- applicative <- Common.makeRandomModule Module.controlApplicative +-- aeson <- Common.makeRandomModule Module.dataAeson +-- string <- Common.makeRandomModule Module.dataString +-- object <- Common.makeRandomVariable srcSpan "object_" +-- let lImportDecls = +-- Hs.importDecls +-- srcSpan +-- [ (Module.controlApplicative, applicative), +-- (Module.dataAeson, aeson), +-- (Module.dataString, string) +-- ] + +-- bindStmts = +-- fmap +-- ( \(field, (name, var)) -> +-- Hs.bindStmt srcSpan (Hs.varPat srcSpan var) +-- . Hs.opApp +-- srcSpan +-- (Hs.var srcSpan object) +-- ( Hs.qualVar srcSpan aeson +-- . Ghc.mkVarOcc +-- $ if Field.isOptional field then ".:?" else ".:" +-- ) +-- . Hs.app srcSpan (Hs.qualVar srcSpan string $ Ghc.mkVarOcc "fromString") +-- . Hs.lit srcSpan +-- $ Hs.string name +-- ) +-- fields + +-- lastStmt = +-- Hs.lastStmt srcSpan +-- . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure") +-- . Hs.recordCon srcSpan (Ghc.reLocA . Ghc.L srcSpan $ Constructor.name constructor) +-- . Hs.recFields +-- $ fmap +-- ( \(field, (_, var)) -> +-- Hs.recField +-- srcSpan +-- (Hs.fieldOcc srcSpan . Hs.unqual srcSpan $ Field.name field) +-- $ Hs.var srcSpan var +-- ) +-- fields + +-- lHsBind = +-- Common.makeLHsBind srcSpan (Ghc.mkVarOcc "parseJSON") [] +-- . Hs.app +-- srcSpan +-- ( Hs.app +-- srcSpan +-- (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "withObject") +-- . Hs.lit srcSpan +-- . Hs.string +-- $ Type.qualifiedName moduleName type_ +-- ) +-- . Hs.par srcSpan +-- . Hs.lam srcSpan +-- . Hs.mg +-- $ Ghc.L +-- srcSpan +-- [ Hs.match srcSpan Ghc.LambdaExpr [Hs.varPat srcSpan object] $ +-- Hs.grhss +-- srcSpan +-- [ Hs.grhs srcSpan +-- . Hs.doExpr srcSpan +-- $ bindStmts +-- <> [lastStmt] +-- ] +-- ] + +-- lHsDecl = +-- Common.makeInstanceDeclaration +-- srcSpan +-- type_ +-- aeson +-- (Ghc.mkClsOcc "FromJSON") +-- [lHsBind] + +-- pure (lImportDecls, [lHsDecl]) + +fromField :: + Ghc.SrcSpan -> + (String -> Ghc.Hsc String) -> + Field.Field -> + Ghc.Hsc (Field.Field, (String, Ghc.LIdP Ghc.GhcPs)) +fromField srcSpan modifyFieldName field = do + let fieldName = Field.name field + name <- modifyFieldName $ Ghc.occNameString fieldName + var <- + Common.makeRandomVariable srcSpan . (<> "_") $ + Ghc.occNameString + fieldName + pure (field, (name, var)) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs new file mode 100644 index 00000000000..390a060002a --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs @@ -0,0 +1,307 @@ +module PlinthPlugin.Generator.Match + ( generate, + ) +where + +import qualified Data.List as List +import qualified PlinthPlugin.Constant.Module as Module +import qualified PlinthPlugin.Generator.Common as Common +import qualified PlinthPlugin.Hs as Hs +import qualified PlinthPlugin.Hsc as Hsc +import qualified PlinthPlugin.Type.Constructor as Constructor +import qualified PlinthPlugin.Type.Field as Field +import qualified PlinthPlugin.Type.Type as Type +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc +import qualified GHC.Types.Fixity as Ghc +import qualified GHC.Types.SourceText as Ghc + +-- | Generates a CPS-style destructor function for 'AsData' sum types. +-- +-- Given: +-- +-- > data Example a = Ex1 Integer | Ex2 a a +-- > deriving (AsData, Match) via PlinthPlugin +-- +-- Generates: +-- +-- > matchExample :: Example a -> (Integer -> r_N) -> (a -> a -> r_N) -> r_N +-- > matchExample (Example_BD d_) f_0 f_1 = +-- > let tag_ = fst (PlutusTx.Builtins.unsafeDataAsConstr d_) +-- > args_ = snd (PlutusTx.Builtins.unsafeDataAsConstr d_) +-- > in if tag_ == 0 +-- > then f_0 ((PlutusTx.unsafeFromBuiltinData (head args_)) :: Integer) +-- > else f_1 ((PlutusTx.unsafeFromBuiltinData (head args_)) :: a) +-- > ((PlutusTx.unsafeFromBuiltinData (head (tail args_))) :: a) +-- +-- For a single-constructor type, the tag check is omitted entirely: +-- +-- > data Address = Address Credential (Maybe StakingCredential) +-- > deriving (AsData, Match) via PlinthPlugin +-- +-- Generates: +-- +-- > matchAddress :: Address -> (Credential -> Maybe StakingCredential -> r_N) -> r_N +-- > matchAddress (Address_BD d_) f_ = +-- > let args_ = snd (PlutusTx.Builtins.unsafeDataAsConstr d_) +-- > in f_ ((PlutusTx.unsafeFromBuiltinData (head args_)) :: Credential) +-- > ((PlutusTx.unsafeFromBuiltinData (head (tail args_))) :: Maybe StakingCredential) +generate :: Ghc.HsDeriving Ghc.GhcPs -> Common.Generator +generate _ _moduleName lIdP lHsQTyVars lConDecls _options srcSpan = do + type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan + let constructors = Type.constructors type_ + when (null constructors) $ + Hsc.throwError srcSpan $ Ghc.text "Match requires at least one constructor" + + plutusTx <- Common.makeRandomModule Module.plutusTx + plutusTxBuiltins <- Common.makeRandomModule Module.plutusTxBuiltins + + let lImportDecls = + Hs.importDecls + srcSpan + [ (Module.plutusTx, plutusTx), + (Module.plutusTxBuiltins, plutusTxBuiltins) + ] + + decls <- makeMatchDecls srcSpan type_ constructors plutusTx plutusTxBuiltins + pure (False, lImportDecls, decls) + +when :: Applicative f => Bool -> f () -> f () +when True action = action +when False _ = pure () + +-- | The internal BD constructor name (same convention as 'AsData'). +internalConName :: Type.Type -> Ghc.OccName +internalConName type_ = + Ghc.mkDataOcc $ + Ghc.occNameString (Ghc.rdrNameOcc (Type.name type_)) <> "_BD" + +-- | @"match" <> TypeName@, e.g. @matchExample@. +matchFunOcc :: Type.Type -> Ghc.OccName +matchFunOcc type_ = + Ghc.mkVarOcc $ + "match" <> Ghc.occNameString (Ghc.rdrNameOcc (Type.name type_)) + +makeMatchDecls :: + Ghc.SrcSpan -> + Type.Type -> + [Constructor.Constructor] -> + Ghc.ModuleName -> + Ghc.ModuleName -> + Ghc.Hsc [Ghc.LHsDecl Ghc.GhcPs] +makeMatchDecls srcSpan type_ constructors plutusTx plutusTxBuiltins = do + let funOcc = matchFunOcc type_ + funId = Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.Unqual funOcc) + internalCon = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.mkRdrUnqual (internalConName type_) + + dVar <- Common.makeRandomVariable srcSpan "d_" + tagVar <- Common.makeRandomVariable srcSpan "tag_" + argsVar <- Common.makeRandomVariable srcSpan "args_" + contVars <- mapM (\_ -> Common.makeRandomVariable srcSpan "f_") constructors + rVar <- Common.makeRandomVariable srcSpan "r_" + + let sigDecl = makeSigDecl srcSpan type_ constructors funId rVar + valDecl = + makeValDecl + srcSpan + constructors + funOcc + dVar + tagVar + argsVar + internalCon + contVars + plutusTx + plutusTxBuiltins + + pure [sigDecl, valDecl] + +-- | Build the type signature. +-- +-- @matchExample :: Example a -> (Integer -> r_N) -> (a -> a -> r_N) -> r_N@ +makeSigDecl :: + Ghc.SrcSpan -> + Type.Type -> + [Constructor.Constructor] -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsDecl Ghc.GhcPs +makeSigDecl srcSpan type_ constructors funId rVar = + let loc = Ghc.noAnnSrcSpan srcSpan + + rTy = Ghc.L loc $ Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted rVar + + -- A -> B -> ... -> r for a constructor's fields + mkContTy fields = + foldr + (\field acc -> Hs.funTy srcSpan (Ghc.L loc (Field.type_ field)) acc) + rTy + fields + + -- Wrap in parens unless nullary (just r) + mkContTyPar fields = case fields of + [] -> rTy + _ -> Ghc.L loc $ Ghc.HsParTy Ghc.noAnn (mkContTy fields) + + outerTy = mkOuterTy srcSpan type_ + contTys = fmap (mkContTyPar . Constructor.fields) constructors + + -- TypeName vars -> cont0 -> ... -> r + fullTy = + foldr + (\argTy acc -> Hs.funTy srcSpan argTy acc) + rTy + (outerTy : contTys) + in Ghc.noLocA $ Ghc.SigD Ghc.noExtField $ + Ghc.TypeSig Ghc.noAnn [funId] $ + Ghc.HsWC Ghc.noExtField $ + Ghc.L loc $ + Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit fullTy + +-- | @TypeName a b ...@ as an 'LHsType', parenthesised when there are type vars. +mkOuterTy :: Ghc.SrcSpan -> Type.Type -> Ghc.LHsType Ghc.GhcPs +mkOuterTy srcSpan type_ = + let -- Fresh location wrappers per position (a shared @loc@ monomorphises + -- to the wrong annotation type under GHC ≥ 9.10). + tv n = Hs.tyVar srcSpan (Ghc.L (Ghc.noAnnSrcSpan srcSpan) n) + initial = tv (Type.name type_) + applied = + List.foldl' + ( \acc v -> + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsAppTy Ghc.noExtField acc (tv v) + ) + initial + (Type.variables type_) + in case Type.variables type_ of + [] -> applied + _ -> Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.HsParTy Ghc.noAnn applied + +-- | Build the function value declaration. +makeValDecl :: + Ghc.SrcSpan -> + [Constructor.Constructor] -> + Ghc.OccName -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.LIdP Ghc.GhcPs -> + [Ghc.LIdP Ghc.GhcPs] -> + Ghc.ModuleName -> + Ghc.ModuleName -> + Ghc.LHsDecl Ghc.GhcPs +makeValDecl srcSpan constructors funOcc dVar tagVar argsVar internalCon contVars plutusTx plutusTxBuiltins = + let ptx = Hs.qualVar srcSpan plutusTx + blt = Hs.qualVar srcSpan plutusTxBuiltins + + -- head (tail^n args_) + nthElem n = + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "head"))) + ( Hs.par srcSpan $ + iterate + ( \e -> + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "tail"))) + (Hs.par srcSpan e) + ) + (Hs.var srcSpan argsVar) + !! n + ) + + -- (unsafeFromBuiltinData (head/tail^n args_)) :: FieldType + decodeField n field = + typeAnnotate srcSpan (Field.type_ field) $ + Hs.app srcSpan + (ptx (Ghc.mkVarOcc "unsafeFromBuiltinData")) + (Hs.par srcSpan (nthElem n)) + + -- f_ decoded_field_0 decoded_field_1 ... + applyFn fVar fields = + List.foldl' + (Hs.app srcSpan) + (Hs.var srcSpan fVar) + (zipWith decodeField [0 ..] fields) + + -- Nested if-else dispatch; last constructor falls through without a tag check + makeDispatch [] _ = error "Match.makeDispatch: empty list" + makeDispatch [(fVar, con)] _ = applyFn fVar (Constructor.fields con) + makeDispatch ((fVar, con) : rest) (idx : idxs) = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsIf Ghc.noAnn + ( Hs.opApp srcSpan + (Hs.var srcSpan tagVar) + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "=="))) + (intLit srcSpan idx) + ) + (applyFn fVar (Constructor.fields con)) + (makeDispatch rest idxs) + makeDispatch _ [] = error "Match.makeDispatch: ran out of indices" + + needsTag = length constructors > 1 + needsArgs = any (not . null . Constructor.fields) constructors + + constrExpr = + Hs.app srcSpan + (blt (Ghc.mkVarOcc "unsafeDataAsConstr")) + (Hs.var srcSpan dVar) + + getFst = Hs.app srcSpan (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "fst"))) (Hs.par srcSpan constrExpr) + getSnd = Hs.app srcSpan (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "snd"))) (Hs.par srcSpan constrExpr) + + mkLetFun var rhs = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.FunBind Ghc.noExtField var + (Hs.mg (Ghc.L srcSpan [Hs.funMatch srcSpan var [] (Common.makeGRHSs srcSpan rhs)])) + + tagBind = mkLetFun tagVar getFst + argsBind = mkLetFun argsVar getSnd + + letBinds = + (if needsTag then [tagBind] else []) + <> (if needsArgs then [argsBind] else []) + + innerBody = case constructors of + [con] -> applyFn (head contVars) (Constructor.fields con) + _ -> makeDispatch (zip contVars constructors) [0 ..] + + body = + if null letBinds + then innerBody + else + Hs.letE srcSpan (Hs.valLocalBinds letBinds) innerBody + + -- (TypeName_BD d_) or (TypeName_BD _) when d_ is unused + innerPat = + if null letBinds + then Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.WildPat Ghc.noExtField + else Hs.varPat srcSpan dVar + + dPat = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ConPat Ghc.noAnn internalCon (Ghc.PrefixCon [] [innerPat]) + + allPats = dPat : fmap (Hs.varPat srcSpan) contVars + + in Ghc.noLocA $ Ghc.ValD Ghc.noExtField $ + Ghc.unLoc (Common.makeLHsBind srcSpan funOcc allPats body) + +-- | Wrap an expression with a type annotation: @(expr :: ty)@. +typeAnnotate :: + Ghc.SrcSpan -> + Ghc.HsType Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs +typeAnnotate srcSpan ty expr = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ExprWithTySig Ghc.noAnn expr $ + Ghc.HsWC Ghc.noExtField $ + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) ty) + +-- | Integer overloaded literal. +intLit :: Ghc.SrcSpan -> Integer -> Ghc.LHsExpr Ghc.GhcPs +intLit = Hs.intLit diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs new file mode 100644 index 00000000000..c1915d9dd4d --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs @@ -0,0 +1,213 @@ +module PlinthPlugin.Generator.Optics + ( generate, + ) +where + +import qualified Data.List as List +import qualified PlinthPlugin.Constant.Module as Module +import qualified PlinthPlugin.Generator.Common as Common +import qualified PlinthPlugin.Hs as Hs +import qualified PlinthPlugin.Type.Constructor as Constructor +import qualified PlinthPlugin.Type.Field as Field +import qualified PlinthPlugin.Type.Type as Type +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc +import qualified GHC.Types.Fixity as Ghc +import qualified GHC.Types.SourceText as Ghc + +-- | For each constructor generates a 'Prism'' binding. For example: +-- +-- > data Shape = Point | Circle Integer | Rectangle Integer Integer +-- > deriving Optics via PlinthPlugin +-- +-- Produces: +-- +-- > _Point :: Prism' Shape () +-- > _Circle :: Prism' Shape Integer +-- > _Rectangle :: Prism' Shape (Integer, Integer) +generate :: Ghc.HsDeriving Ghc.GhcPs -> Common.Generator +generate _ _moduleName lIdP lHsQTyVars lConDecls _options srcSpan = do + type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan + lens <- Common.makeRandomModule Module.controlLens + let lImportDecls = Hs.importDecls srcSpan [(Module.controlLens, lens)] + decls <- mapM (makePrismDecls srcSpan type_ lens) (Type.constructors type_) + pure (False, lImportDecls, concat decls) + +-- | Generates the signature and binding for one prism. +makePrismDecls :: + Ghc.SrcSpan -> + Type.Type -> + Ghc.ModuleName -> + Constructor.Constructor -> + Ghc.Hsc [Ghc.LHsDecl Ghc.GhcPs] +makePrismDecls srcSpan type_ lens constructor = do + let fields = Constructor.fields constructor + arity = length fields + conOcc = Ghc.rdrNameOcc (Constructor.name constructor) + prismOcc = Ghc.mkVarOcc ("_" <> Ghc.occNameString conOcc) + prismId = Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.Unqual prismOcc) + lConId = Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.mkRdrUnqual conOcc) + + vars <- mapM (\_ -> Common.makeRandomVariable srcSpan "x_") fields + scrutVar <- Common.makeRandomVariable srcSpan "x_" + + let -- Focus type: () / T / (T0, T1, ...) + fieldTys = fmap (\f -> Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Field.type_ f)) fields + focusTy = case arity of + 0 -> unitTy srcSpan + 1 -> head fieldTys + _ -> Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.HsTupleTy Ghc.noAnn Ghc.HsBoxedOrConstraintTuple fieldTys + + -- Outer type: TypeName a b ... + outerTy = mkOuterTy srcSpan type_ + + -- Prism' OuterTy FocusTy + prismTy = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsAppTy Ghc.noExtField + ( Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsAppTy Ghc.noExtField + ( Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted + (Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.Qual lens (Ghc.mkTcOcc "Prism'")) + ) + outerTy + ) + focusTy + + -- _ConName :: Prism' OuterTy FocusTy + sigDecl = + Ghc.noLocA $ Ghc.SigD Ghc.noExtField $ + Ghc.TypeSig Ghc.noAnn [prismId] $ + Ghc.HsWC Ghc.noExtField $ + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit prismTy + + -- _ConName = lens.prism' builder matcher + prismExpr = + Hs.app srcSpan + ( Hs.app srcSpan + (Hs.qualVar srcSpan lens (Ghc.mkVarOcc "prism'")) + (Hs.par srcSpan $ mkBuilder srcSpan lConId vars arity) + ) + (Hs.par srcSpan $ mkMatcher srcSpan lConId vars scrutVar arity) + + valDecl = + Ghc.noLocA $ Ghc.ValD Ghc.noExtField $ + Ghc.FunBind Ghc.noExtField prismId + (Hs.mg (Ghc.L srcSpan [Hs.funMatch srcSpan prismId [] (Common.makeGRHSs srcSpan prismExpr)])) + + pure [sigDecl, valDecl] + +-- | Builder function: converts the focus type back to the sum type. +-- +-- * Nullary: @const ConName@ +-- * Unary: @ConName@ +-- * Multi: @\(x0, x1, ...) -> ConName x0 x1 ...@ +mkBuilder :: + Ghc.SrcSpan -> + Ghc.LIdP Ghc.GhcPs -> + [Ghc.LIdP Ghc.GhcPs] -> + Int -> + Ghc.LHsExpr Ghc.GhcPs +mkBuilder srcSpan lConId vars arity = case arity of + 0 -> + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "const"))) + (Hs.var srcSpan lConId) + 1 -> + Hs.var srcSpan lConId + _ -> + let tuplePat = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.TuplePat Ghc.noAnn (fmap (Hs.varPat srcSpan) vars) Ghc.Boxed + body = List.foldl' (Hs.app srcSpan) (Hs.var srcSpan lConId) (fmap (Hs.var srcSpan) vars) + in Hs.lam srcSpan . Hs.mg $ + Ghc.L srcSpan + [Hs.match srcSpan [tuplePat] (Common.makeGRHSs srcSpan body)] + +-- | Matcher function: converts the sum type to @Maybe@ focus. +-- +-- @\x -> case x of { ConName x0 x1 ... -> Just (x0, x1, ...); _ -> Nothing }@ +mkMatcher :: + Ghc.SrcSpan -> + Ghc.LIdP Ghc.GhcPs -> + [Ghc.LIdP Ghc.GhcPs] -> + Ghc.LIdP Ghc.GhcPs -> + Int -> + Ghc.LHsExpr Ghc.GhcPs +mkMatcher srcSpan lConId vars scrutVar arity = + let successResult = case arity of + 0 -> + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Just"))) + (unitExpr srcSpan) + 1 -> + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Just"))) + (Hs.par srcSpan $ Hs.var srcSpan (head vars)) + _ -> + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Just"))) + ( Hs.par srcSpan $ + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ExplicitTuple Ghc.noAnn (fmap (Hs.tupArg . Hs.var srcSpan) vars) Ghc.Boxed + ) + + conPat = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ConPat Ghc.noAnn lConId (Ghc.PrefixCon [] (fmap (Hs.varPat srcSpan) vars)) + + wildPat = Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.WildPat Ghc.noExtField + + nothingExpr = Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Nothing")) + + conMatch = + Hs.caseMatch srcSpan [conPat] (Common.makeGRHSs srcSpan successResult) + + wildMatch = + Hs.caseMatch srcSpan [wildPat] (Common.makeGRHSs srcSpan nothingExpr) + + caseExpr = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsCase Ghc.noAnn + (Hs.var srcSpan scrutVar) + (Hs.mg (Ghc.L srcSpan [conMatch, wildMatch])) + in Hs.lam srcSpan . Hs.mg $ + Ghc.L srcSpan + [ Hs.match srcSpan + [Hs.varPat srcSpan scrutVar] + (Common.makeGRHSs srcSpan caseExpr) + ] + +-- | Build @TypeName a b ...@ as an 'LHsType', parenthesised when there are +-- type variables (so it can be applied to the focus type without ambiguity). +mkOuterTy :: Ghc.SrcSpan -> Type.Type -> Ghc.LHsType Ghc.GhcPs +mkOuterTy srcSpan type_ = + let -- Each location wrapper is a fresh expression so its annotation type is + -- inferred per-position (a shared @loc@ monomorphises to the wrong one). + tv n = Hs.tyVar srcSpan (Ghc.L (Ghc.noAnnSrcSpan srcSpan) n) + initial = tv (Type.name type_) + applied = + List.foldl' + ( \acc v -> + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsAppTy Ghc.noExtField acc (tv v) + ) + initial + (Type.variables type_) + in case Type.variables type_ of + [] -> applied + _ -> Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.HsParTy Ghc.noAnn applied + +-- | The unit type @()@ at the type level. +unitTy :: Ghc.SrcSpan -> Ghc.LHsType Ghc.GhcPs +unitTy srcSpan = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsTupleTy Ghc.noAnn Ghc.HsBoxedOrConstraintTuple [] + +-- | The unit expression @()@. +unitExpr :: Ghc.SrcSpan -> Ghc.LHsExpr Ghc.GhcPs +unitExpr srcSpan = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ExplicitTuple Ghc.noAnn [] Ghc.Boxed diff --git a/plutus-tx-plugin/src/PlinthPlugin/Hs.hs b/plutus-tx-plugin/src/PlinthPlugin/Hs.hs new file mode 100644 index 00000000000..cff567934c8 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Hs.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE CPP #-} + +module PlinthPlugin.Hs + ( app, + bindStmt, + doExpr, + explicitList, + explicitTuple, + fieldOcc, + caseMatch, + funBind, + funMatch, + funTy, + grhs, + grhss, + importDecls, + intLit, + lam, + lastStmt, + letE, + lit, + match, + mg, + opApp, + par, + qual, + qualTyVar, + qualVar, + recField, + recFields, + recordCon, + string, + tupArg, + tyVar, + unqual, + unrestrictedArrow, + userTyVar, + valLocalBinds, + var, + varPat, + ) +where + +#if __GLASGOW_HASKELL__ < 912 +import qualified GHC.Data.Bag as Ghc +#endif +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc +import qualified GHC.Types.Fixity as Ghc +import qualified GHC.Types.SourceText as Ghc + +app :: + Ghc.SrcSpan -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs +app s f x = Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsApp Ghc.noExtField f x +#else + Ghc.HsApp Ghc.noAnn f x +#endif + +bindStmt :: + Ghc.SrcSpan -> + Ghc.LPat Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LStmt Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +bindStmt s p e = + Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.BindStmt Ghc.noAnn p e + +doExpr :: Ghc.SrcSpan -> [Ghc.ExprLStmt Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs +doExpr s stmts = + Ghc.L (Ghc.noAnnSrcSpan s) $ + Ghc.HsDo Ghc.noAnn (Ghc.DoExpr Nothing) (Ghc.L (Ghc.noAnnSrcSpan s) stmts) + +explicitList :: + Ghc.SrcSpan -> [Ghc.LHsExpr Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs +explicitList s xs = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.ExplicitList Ghc.noAnn xs + +explicitTuple :: + Ghc.SrcSpan -> [Ghc.HsTupArg Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs +explicitTuple s xs = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.ExplicitTuple Ghc.noAnn xs Ghc.Boxed + +fieldOcc :: Ghc.SrcSpan -> Ghc.RdrName -> Ghc.LFieldOcc Ghc.GhcPs +fieldOcc s r = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.FieldOcc + { Ghc.foExt = Ghc.noExtField + , Ghc.foLabel = Ghc.L (Ghc.noAnnSrcSpan s) r + } + +funBind :: + Ghc.SrcSpan -> + Ghc.OccName -> + Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> + Ghc.LHsBind Ghc.GhcPs +funBind s f g = + Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.FunBind Ghc.noExtField (unqual s f) g + +grhs :: + Ghc.SrcSpan -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LGRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +grhs s e = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.GRHS Ghc.noAnn [] e + +grhss :: + Ghc.SrcSpan -> + [Ghc.LGRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)] -> + Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +grhss _ xs = + Ghc.GRHSs Ghc.emptyComments xs $ Ghc.EmptyLocalBinds Ghc.noExtField + +importDecl :: + Ghc.SrcSpan -> + Ghc.ModuleName -> + Ghc.ModuleName -> + Ghc.LImportDecl Ghc.GhcPs +importDecl s m n = + Ghc.L (Ghc.noAnnSrcSpan s) $ + Ghc.ImportDecl + { Ghc.ideclExt = Ghc.XImportDeclPass + { Ghc.ideclAnn = Ghc.noAnn + , Ghc.ideclSourceText = Ghc.NoSourceText + , Ghc.ideclImplicit = False + } + , Ghc.ideclName = Ghc.L (Ghc.noAnnSrcSpan s) m + , Ghc.ideclPkgQual = Ghc.NoRawPkgQual + , Ghc.ideclSource = Ghc.NotBoot + , Ghc.ideclSafe = False + , Ghc.ideclQualified = Ghc.QualifiedPre + , Ghc.ideclAs = Just $ Ghc.L (Ghc.noAnnSrcSpan s) n + , Ghc.ideclImportList = Nothing + } + +importDecls :: + Ghc.SrcSpan -> + [(Ghc.ModuleName, Ghc.ModuleName)] -> + [Ghc.LImportDecl Ghc.GhcPs] +importDecls = fmap . uncurry . importDecl + +lam :: + Ghc.SrcSpan -> + Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> + Ghc.LHsExpr Ghc.GhcPs +lam s mg_ = Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsLam Ghc.noAnn Ghc.LamSingle mg_ +#else + Ghc.HsLam Ghc.noExtField mg_ +#endif + +lastStmt :: + Ghc.SrcSpan -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LStmt Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +lastStmt s e = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.LastStmt Ghc.noExtField e Nothing noSyntaxExpr + +lit :: Ghc.SrcSpan -> Ghc.HsLit Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs +lit s l = Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsLit Ghc.noExtField l +#else + Ghc.HsLit Ghc.noAnn l +#endif + +noSyntaxExpr :: Ghc.SyntaxExpr Ghc.GhcPs +noSyntaxExpr = Ghc.noSyntaxExpr + +-- | Build a lambda match. The match context is always a (single) lambda, +-- so it is baked in rather than passed by the caller; this also avoids a +-- CPP-divergent context type in the signature. +match :: + Ghc.SrcSpan -> + [Ghc.LPat Ghc.GhcPs] -> + Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> + Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +match s ps g = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.Match Ghc.noExtField (Ghc.LamAlt Ghc.LamSingle) (Ghc.L (Ghc.noAnnSrcSpan s) ps) g +#else + Ghc.Match Ghc.noAnn Ghc.LambdaExpr ps g +#endif + +-- | A prefix-function ('FunRhs') match with located patterns. @FunRhs@ gained +-- an annotation field and @m_pats@ became located in GHC 9.10. +funMatch :: + Ghc.SrcSpan -> + Ghc.LIdP Ghc.GhcPs -> + [Ghc.LPat Ghc.GhcPs] -> + Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> + Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +funMatch s v ps g = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.Match Ghc.noExtField (Ghc.FunRhs v Ghc.Prefix Ghc.NoSrcStrict Ghc.noAnn) (Ghc.L (Ghc.noAnnSrcSpan s) ps) g +#else + Ghc.Match Ghc.noAnn (Ghc.FunRhs v Ghc.Prefix Ghc.NoSrcStrict) ps g +#endif + +-- | A @case@ alternative ('CaseAlt') match with located patterns. +caseMatch :: + Ghc.SrcSpan -> + [Ghc.LPat Ghc.GhcPs] -> + Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> + Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +caseMatch s ps g = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.Match Ghc.noExtField Ghc.CaseAlt (Ghc.L (Ghc.noAnnSrcSpan s) ps) g +#else + Ghc.Match Ghc.noAnn Ghc.CaseAlt ps g +#endif + +-- | A @let ... in ...@ expression. The @let@/@in@ tokens moved into the +-- extension field in GHC 9.10. +letE :: + Ghc.SrcSpan -> + Ghc.HsLocalBinds Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs +letE s binds body = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsLet Ghc.noAnn binds body +#else + Ghc.HsLet Ghc.noAnn Ghc.noHsTok binds Ghc.noHsTok body +#endif + +-- | A function type @a -> b@ (unrestricted arrow). The @HsFunTy@ extension +-- field became 'Ghc.NoExtField' in GHC 9.10. +funTy :: + Ghc.SrcSpan -> + Ghc.LHsType Ghc.GhcPs -> + Ghc.LHsType Ghc.GhcPs -> + Ghc.LHsType Ghc.GhcPs +funTy s a b = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsFunTy Ghc.noExtField unrestrictedArrow a b +#else + Ghc.HsFunTy Ghc.noAnn unrestrictedArrow a b +#endif + +-- | An integer overloaded literal. The @HsOverLit@ extension field became +-- 'Ghc.NoExtField' in GHC 9.10. +intLit :: Ghc.SrcSpan -> Integer -> Ghc.LHsExpr Ghc.GhcPs +intLit s n = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsOverLit Ghc.noExtField $ +#else + Ghc.HsOverLit Ghc.noAnn $ +#endif + Ghc.OverLit Ghc.noExtField (Ghc.HsIntegral (Ghc.IL Ghc.NoSourceText False n)) + +-- | The unrestricted function arrow @->@. Its token representation moved +-- into an annotation in GHC 9.10. +unrestrictedArrow :: Ghc.HsArrow Ghc.GhcPs +#if __GLASGOW_HASKELL__ >= 910 +unrestrictedArrow = Ghc.HsUnrestrictedArrow Ghc.noAnn +#else +unrestrictedArrow = Ghc.HsUnrestrictedArrow Ghc.noHsUniTok +#endif + +-- | Value local-bindings from a list of binds. @LHsBinds@ became a plain +-- list (was a @Bag@) in GHC 9.12. +valLocalBinds :: [Ghc.LHsBind Ghc.GhcPs] -> Ghc.HsLocalBinds Ghc.GhcPs +valLocalBinds binds = + Ghc.HsValBinds Ghc.noAnn $ + Ghc.ValBinds + Ghc.NoAnnSortKey +#if __GLASGOW_HASKELL__ >= 912 + binds +#else + (Ghc.listToBag binds) +#endif + [] + +-- | A user type-variable binder with no kind annotation. The binder layout +-- changed to @HsTvb@/@HsBndrVar@ in GHC 9.10, and the binder visibility flag +-- (@HsBndrVis@) replaced the unit flag for these binders. +userTyVar :: + Ghc.SrcSpan -> + Ghc.IdP Ghc.GhcPs -> +#if __GLASGOW_HASKELL__ >= 910 + Ghc.LHsTyVarBndr (Ghc.HsBndrVis Ghc.GhcPs) Ghc.GhcPs +#else + Ghc.LHsTyVarBndr () Ghc.GhcPs +#endif +userTyVar s v = + Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsTvb Ghc.noAnn (Ghc.HsBndrRequired Ghc.noExtField) (Ghc.HsBndrVar Ghc.noExtField (Ghc.L (Ghc.noAnnSrcSpan s) v)) (Ghc.HsBndrNoKind Ghc.noExtField) +#else + Ghc.UserTyVar Ghc.noAnn () (Ghc.L (Ghc.noAnnSrcSpan s) v) +#endif + +mg :: + Ghc.Located [Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)] -> + Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +mg ms = + Ghc.MG +#if __GLASGOW_HASKELL__ >= 910 + (Ghc.Generated Ghc.OtherExpansion Ghc.SkipPmc) +#else + Ghc.Generated +#endif + (Ghc.noLocA (Ghc.unLoc ms)) + +opApp :: + Ghc.SrcSpan -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs +opApp s l o r = Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.OpApp Ghc.noExtField l o r +#else + Ghc.OpApp Ghc.noAnn l o r +#endif + +par :: Ghc.SrcSpan -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs +par s e = Ghc.L (Ghc.noAnnSrcSpan s) $ +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsPar Ghc.noAnn e +#else + Ghc.HsPar Ghc.noAnn Ghc.noHsTok e Ghc.noHsTok +#endif + +qual :: Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LIdP Ghc.GhcPs +qual s m n = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.mkRdrQual m n + +qualTyVar :: + Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LHsType Ghc.GhcPs +qualTyVar s m = tyVar s . qual s m + +qualVar :: + Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LHsExpr Ghc.GhcPs +qualVar s m = var s . qual s m + +recFields :: + [Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)] -> + Ghc.HsRecFields Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +recFields fs = +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsRecFields Ghc.noExtField fs Nothing +#else + Ghc.HsRecFields fs Nothing +#endif + +recField :: + Ghc.SrcSpan -> + Ghc.LFieldOcc Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs -> + Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) +recField s f e = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.HsFieldBind Ghc.noAnn f e False + +recordCon :: + Ghc.SrcSpan -> + Ghc.LIdP Ghc.GhcPs -> + Ghc.HsRecordBinds Ghc.GhcPs -> + Ghc.LHsExpr Ghc.GhcPs +recordCon s c fs = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.RecordCon Ghc.noAnn c fs + +string :: String -> Ghc.HsLit Ghc.GhcPs +string = Ghc.HsString Ghc.NoSourceText . Ghc.mkFastString + +tupArg :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.HsTupArg Ghc.GhcPs +#if __GLASGOW_HASKELL__ >= 910 +tupArg = Ghc.Present Ghc.noExtField +#else +tupArg = Ghc.Present Ghc.noAnn +#endif + +tyVar :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs +tyVar s x = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted x + +unqual :: Ghc.SrcSpan -> Ghc.OccName -> Ghc.LIdP Ghc.GhcPs +unqual s n = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.mkRdrUnqual n + +var :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs +var s x = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.HsVar Ghc.noExtField x + +varPat :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LPat Ghc.GhcPs +varPat s x = Ghc.L (Ghc.noAnnSrcSpan s) $ Ghc.VarPat Ghc.noExtField x diff --git a/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs b/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs new file mode 100644 index 00000000000..6cf24357669 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} + +module PlinthPlugin.Hsc + ( addWarning, + throwError, + ) +where + +import qualified Control.Monad.IO.Class as IO +import qualified GHC as Ghc +import qualified GHC.Data.Bag as Ghc +import qualified GHC.Driver.Config.Diagnostic as Ghc +import qualified GHC.Driver.Errors as Ghc +import qualified GHC.Driver.Errors.Types as Ghc +import qualified GHC.Plugins as Ghc +import qualified GHC.Types.Error as Ghc +import qualified GHC.Utils.Error as Ghc +import qualified GHC.Utils.Logger as Ghc + +-- | Adds a warning +addWarning :: Ghc.SrcSpan -> Ghc.SDoc -> Ghc.Hsc () +addWarning srcSpan msgDoc = do + logger <- Ghc.getLogger + IO.liftIO $ Ghc.logMsg + logger + Ghc.MCOutput + srcSpan + msgDoc + +-- | Throws an error +throwError :: Ghc.SrcSpan -> Ghc.SDoc -> Ghc.Hsc a +throwError srcSpan msgDoc = do + dynFlags <- Ghc.getDynFlags + let diagOpts = Ghc.initDiagOpts dynFlags + -- 1. Create the plain diagnostic + innerDiag = Ghc.mkPlainDiagnostic Ghc.WarningWithoutFlag [] msgDoc + + -- 2. Use the 'GhcUnknownMessage' wrapper with a 'Simple' constructor + -- This bypasses the need for phase-specific types like DsMessage. +#if __GLASGOW_HASKELL__ >= 910 + diagnostic = Ghc.GhcUnknownMessage (Ghc.UnknownDiagnostic (const Ghc.NoDiagnosticOpts) innerDiag) +#else + diagnostic = Ghc.GhcUnknownMessage (Ghc.UnknownDiagnostic innerDiag) +#endif + + -- 3. Create the envelope + msg = Ghc.mkPlainMsgEnvelope diagOpts srcSpan diagnostic + + Ghc.throwErrors $ Ghc.mkMessages (Ghc.unitBag msg) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Options.hs b/plutus-tx-plugin/src/PlinthPlugin/Options.hs new file mode 100644 index 00000000000..79a3600d28a --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Options.hs @@ -0,0 +1,39 @@ +module PlinthPlugin.Options + ( parse, + ) +where + +import qualified Control.Monad as Monad +import qualified PlinthPlugin.Hsc as Hsc +import qualified GHC.Plugins as Ghc +import qualified System.Console.GetOpt as Console + +-- | Parses command line options. Adds warnings and throws errors as +-- appropriate. Returns the list of parsed options. +parse :: [Console.OptDescr a] -> [String] -> Ghc.SrcSpan -> Ghc.Hsc [a] +parse optDescrs strings srcSpan = do + let (xs, args, opts, errs) = Console.getOpt' Console.Permute optDescrs strings + Monad.forM_ opts $ + Hsc.addWarning srcSpan + . Ghc.text + . mappend "unknown option: " + . quote + Monad.forM_ args $ + Hsc.addWarning srcSpan + . Ghc.text + . mappend "unexpected argument: " + . quote + Monad.unless (null errs) + . Hsc.throwError srcSpan + . Ghc.vcat + . fmap Ghc.text + . lines + $ mconcat errs + pure xs + +-- | Quotes a string using GHC's weird quoting format. +-- +-- >>> quote "thing" +-- "`thing'" +quote :: String -> String +quote string = "`" <> string <> "'" diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs new file mode 100644 index 00000000000..968f4fb6902 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs @@ -0,0 +1,27 @@ +module PlinthPlugin.Type.Config + ( Config (..), + fromFlags, + ) +where + +import qualified Data.List as List +import qualified PlinthPlugin.Type.Flag as Flag + +data Config = Config + { help :: Bool, + verbose :: Bool, + version :: Bool + } + deriving (Eq, Show) + +initial :: Config +initial = Config {help = False, verbose = False, version = False} + +fromFlags :: Foldable t => t Flag.Flag -> Config +fromFlags = List.foldl' applyFlag initial + +applyFlag :: Config -> Flag.Flag -> Config +applyFlag config flag = case flag of + Flag.Help -> config {help = True} + Flag.Verbose -> config {verbose = True} + Flag.Version -> config {version = True} diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Constructor.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Constructor.hs new file mode 100644 index 00000000000..da36a38466c --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Constructor.hs @@ -0,0 +1,39 @@ +module PlinthPlugin.Type.Constructor + ( Constructor (..), + make, + ) +where + +import qualified Control.Monad as Monad +import qualified Data.List as List +import qualified PlinthPlugin.Hsc as Hsc +import qualified PlinthPlugin.Type.Field as Field +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc + +data Constructor = Constructor + { name :: Ghc.IdP Ghc.GhcPs, + fields :: [Field.Field] + } + +make :: Ghc.SrcSpan -> Ghc.LConDecl Ghc.GhcPs -> Ghc.Hsc Constructor +make srcSpan lConDecl = do + (lIdP, hsConDeclDetails) <- case Ghc.unLoc lConDecl of + Ghc.ConDeclH98 _ x _ _ _ y _ -> pure (x, y) + _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported LConDecl" + theFields <- case hsConDeclDetails of + Ghc.RecCon lConDeclFields -> + fmap concat . Monad.forM (Ghc.unLoc lConDeclFields) $ \lConDeclField -> do + (lFieldOccs, lHsType) <- case Ghc.unLoc lConDeclField of + Ghc.ConDeclField _ x y _ -> pure (x, y) + mapM (Field.make srcSpan lHsType) lFieldOccs + Ghc.PrefixCon _ scaledTypes -> + pure $ List.zipWith + (\i (Ghc.HsScaled _ lHsType) -> Field.Field + { Field.name = Ghc.mkVarOcc ("_field" <> show (i :: Int)), + Field.type_ = Ghc.unLoc lHsType + }) + [0 ..] + scaledTypes + _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported HsConDeclDetails" + pure Constructor {name = Ghc.unLoc lIdP, fields = theFields} diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Field.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Field.hs new file mode 100644 index 00000000000..322354cd55b --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Field.hs @@ -0,0 +1,37 @@ +module PlinthPlugin.Type.Field + ( Field (..), + make, + isOptional, + ) +where + +import qualified PlinthPlugin.Hsc as Hsc +import qualified GHC.Hs as Ghc +import qualified GHC.Plugins as Ghc + +data Field = Field + { name :: Ghc.OccName, + type_ :: Ghc.HsType Ghc.GhcPs + } + +make :: + Ghc.SrcSpan -> + Ghc.LHsType Ghc.GhcPs -> + Ghc.LFieldOcc Ghc.GhcPs -> + Ghc.Hsc Field +make srcSpan lHsType lFieldOcc = do + lRdrName <- case Ghc.unLoc lFieldOcc of + Ghc.FieldOcc _ x -> pure x + occName <- case Ghc.unLoc lRdrName of + Ghc.Unqual x -> pure x + _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported RdrName" + pure Field {name = occName, type_ = Ghc.unLoc lHsType} + +isOptional :: Field -> Bool +isOptional field = case type_ field of + Ghc.HsAppTy _ lHsType _ -> case Ghc.unLoc lHsType of + Ghc.HsTyVar _ _ lIdP -> case Ghc.unLoc lIdP of + Ghc.Unqual occName -> Ghc.occNameString occName == "Maybe" + _ -> False + _ -> False + _ -> False diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs new file mode 100644 index 00000000000..6ac4e6c4d82 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs @@ -0,0 +1,32 @@ +module PlinthPlugin.Type.Flag + ( Flag (..), + options, + ) +where + +import qualified System.Console.GetOpt as Console + +data Flag + = Help + | Verbose + | Version + deriving (Eq, Show) + +options :: [Console.OptDescr Flag] +options = + [ Console.Option + ['h', '?'] + ["help"] + (Console.NoArg Help) + "shows this help message and exits", + Console.Option + ['v'] + ["version"] + (Console.NoArg Version) + "shows the version number and exits", + Console.Option + [] + ["verbose"] + (Console.NoArg Verbose) + "outputs derived instances" + ] diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs new file mode 100644 index 00000000000..d122012542f --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} + +module PlinthPlugin.Type.Type + ( Type (..), + make, + qualifiedName, + ) +where + +import qualified Control.Monad as Monad +import qualified PlinthPlugin.Hsc as Hsc +import qualified PlinthPlugin.Type.Constructor as Constructor +import qualified GHC.Hs as Ghc +import qualified GHC.Hs.Type as Ghc +import qualified GHC.Plugins as Ghc +import qualified Language.Haskell.Syntax.Type as Syntax + +data Type = Type + { name :: Ghc.IdP Ghc.GhcPs, + variables :: [Ghc.IdP Ghc.GhcPs], + constructors :: [Constructor.Constructor] + } + +make :: + Ghc.LIdP Ghc.GhcPs -> + Ghc.LHsQTyVars Ghc.GhcPs -> + [Ghc.LConDecl Ghc.GhcPs] -> + Ghc.SrcSpan -> + Ghc.Hsc Type +make lIdP lHsQTyVars lConDecls srcSpan = do + lHsTyVarBndrs <- case lHsQTyVars of + Ghc.HsQTvs _ hsq_explicit -> pure hsq_explicit + theVariables <- Monad.forM lHsTyVarBndrs $ \lHsTyVarBndr -> + case Ghc.unLoc lHsTyVarBndr of +#if __GLASGOW_HASKELL__ >= 910 + Ghc.HsTvb _ _ (Ghc.HsBndrVar _ (Ghc.L _ var)) _ -> pure var +#else + Ghc.UserTyVar _ _ (Ghc.L _ var) -> pure var + Ghc.KindedTyVar _ _ (Ghc.L _ var) _ -> pure var +#endif + _ -> Hsc.throwError srcSpan $ Ghc.text "unknown type variable binder" + theConstructors <- mapM (Constructor.make srcSpan) lConDecls + pure + Type + { name = Ghc.unLoc lIdP, + variables = theVariables, + constructors = theConstructors + } + +qualifiedName :: Ghc.ModuleName -> Type -> String +qualifiedName moduleName type_ = + mconcat + [ Ghc.moduleNameString moduleName, + ".", + Ghc.occNameString . Ghc.rdrNameOcc $ name type_ + ] diff --git a/plutus-tx-plugin/src/PlinthPlugin/Via.hs b/plutus-tx-plugin/src/PlinthPlugin/Via.hs new file mode 100644 index 00000000000..e5c4a12caa8 --- /dev/null +++ b/plutus-tx-plugin/src/PlinthPlugin/Via.hs @@ -0,0 +1,15 @@ +-- | The @DerivingVia@ sentinel type recognised by the Plinth plugin. +module PlinthPlugin.Via (Via (..)) where + +-- | Used as a @DerivingVia@ target to activate the plugin, e.g. +-- +-- > data Foo = Foo Integer Integer +-- > deriving AsData via PlinthPlugin +-- +-- The constructor is promoted to a type (so the use site needs @DataKinds@). +-- +-- When the plugin is active the deriving clause is rewritten away at parse +-- time, so @PlinthPlugin@ never actually has to be in scope. Defining it as a +-- real, well-kinded constructor means that when the plugin is /not/ loaded GHC +-- reports a clean type error instead of a confusing one. +data Via = PlinthPlugin From 9305ef851b62b9e1f91adcf97b2b7a823239e414 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Tue, 16 Jun 2026 14:17:03 +0100 Subject: [PATCH 02/13] Conform PlinthPlugin modules to plutus -Wall -Werror The vendored plinth-plugin suppressed these warnings in its own cabal; plutus-tx-plugin builds with -Wall -Werror, so: remove unused imports (CPP-guarding Bag, still needed by the 9.6 makeLHsDecl branch), give the Config/Flag derivings explicit 'stock' strategies, suppress -Wx-partial on the three generators (the head calls are non-empty by construction), and drop the unwired FromData stub. Co-Authored-By: Claude Opus 4.8 --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 - plutus-tx-plugin/src/PlinthPlugin.hs | 1 - .../src/PlinthPlugin/Generator/AsData.hs | 4 +- .../src/PlinthPlugin/Generator/Common.hs | 3 +- .../src/PlinthPlugin/Generator/FromData.hs | 128 ------------------ .../src/PlinthPlugin/Generator/Match.hs | 5 +- .../src/PlinthPlugin/Generator/Optics.hs | 6 +- plutus-tx-plugin/src/PlinthPlugin/Hsc.hs | 1 - .../src/PlinthPlugin/Type/Config.hs | 2 +- .../src/PlinthPlugin/Type/Flag.hs | 2 +- .../src/PlinthPlugin/Type/Type.hs | 2 - 11 files changed, 14 insertions(+), 141 deletions(-) delete mode 100644 plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 082a32a6107..52f9c87f55e 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -67,7 +67,6 @@ library PlinthPlugin.Constant.Module PlinthPlugin.Generator.AsData PlinthPlugin.Generator.Common - PlinthPlugin.Generator.FromData PlinthPlugin.Generator.Match PlinthPlugin.Generator.Optics PlinthPlugin.Hs diff --git a/plutus-tx-plugin/src/PlinthPlugin.hs b/plutus-tx-plugin/src/PlinthPlugin.hs index 1440be7fc61..e8c7752d4f7 100644 --- a/plutus-tx-plugin/src/PlinthPlugin.hs +++ b/plutus-tx-plugin/src/PlinthPlugin.hs @@ -12,7 +12,6 @@ import qualified PlinthPlugin.Generator.AsData as AsData import qualified PlinthPlugin.Generator.Match as Match import qualified PlinthPlugin.Generator.Optics as Optics import qualified PlinthPlugin.Generator.Common as Common -import GHC.Hs import qualified PlinthPlugin.Hsc as Hsc import qualified PlinthPlugin.Options as Options import qualified PlinthPlugin.Type.Config as Config diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs index e44e3923ff9..bdabdb706f9 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs @@ -1,11 +1,13 @@ {-# LANGUAGE CPP #-} +-- The 'head' calls below are on lists that are non-empty by construction +-- (guarded by the surrounding arity/constructor-count matches). +{-# OPTIONS_GHC -Wno-x-partial #-} module PlinthPlugin.Generator.AsData ( generate, ) where -import qualified Data.List as List import qualified PlinthPlugin.Constant.Module as Module import qualified PlinthPlugin.Generator.Common as Common import qualified PlinthPlugin.Hs as Hs diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs index cc8b594c839..b38140c4762 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs @@ -24,10 +24,11 @@ import qualified PlinthPlugin.Hsc as Hsc import qualified PlinthPlugin.Type.Constructor as Constructor import qualified PlinthPlugin.Type.Field as Field import qualified PlinthPlugin.Type.Type as Type +#if __GLASGOW_HASKELL__ < 910 import qualified GHC.Data.Bag as Ghc +#endif import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc -import qualified GHC.Types.Fixity as Ghc import qualified System.Console.GetOpt as Console import qualified System.IO.Unsafe as Unsafe import qualified Text.Printf as Printf diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs deleted file mode 100644 index 7017df9ccc5..00000000000 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/FromData.hs +++ /dev/null @@ -1,128 +0,0 @@ -module PlinthPlugin.Generator.FromData - ( generate, - ) -where - -import qualified Data.List as List -import qualified PlinthPlugin.Constant.Module as Module -import qualified PlinthPlugin.Generator.Common as Common -import qualified PlinthPlugin.Hs as Hs -import qualified PlinthPlugin.Hsc as Hsc -import qualified PlinthPlugin.Options as Options -import qualified PlinthPlugin.Type.Constructor as Constructor -import qualified PlinthPlugin.Type.Field as Field -import qualified PlinthPlugin.Type.Type as Type -import qualified GHC.Hs as Ghc -import qualified GHC.Plugins as Ghc - -generate :: Common.Generator -generate _moduleName _lIdP _lHsQTyVars _lConDecls _options _srcSpan = - pure (False, [], []) --- generate :: Common.Generator --- generate moduleName lIdP lHsQTyVars lConDecls options srcSpan = do --- type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan --- constructor <- case Type.constructors type_ of --- [x] -> pure x --- _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor" --- modifyFieldName <- --- Common.applyAll --- <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan - --- fields <- --- mapM (fromField srcSpan modifyFieldName) --- . List.sortOn Field.name --- . concatMap Constructor.fields --- $ Type.constructors type_ - --- applicative <- Common.makeRandomModule Module.controlApplicative --- aeson <- Common.makeRandomModule Module.dataAeson --- string <- Common.makeRandomModule Module.dataString --- object <- Common.makeRandomVariable srcSpan "object_" --- let lImportDecls = --- Hs.importDecls --- srcSpan --- [ (Module.controlApplicative, applicative), --- (Module.dataAeson, aeson), --- (Module.dataString, string) --- ] - --- bindStmts = --- fmap --- ( \(field, (name, var)) -> --- Hs.bindStmt srcSpan (Hs.varPat srcSpan var) --- . Hs.opApp --- srcSpan --- (Hs.var srcSpan object) --- ( Hs.qualVar srcSpan aeson --- . Ghc.mkVarOcc --- $ if Field.isOptional field then ".:?" else ".:" --- ) --- . Hs.app srcSpan (Hs.qualVar srcSpan string $ Ghc.mkVarOcc "fromString") --- . Hs.lit srcSpan --- $ Hs.string name --- ) --- fields - --- lastStmt = --- Hs.lastStmt srcSpan --- . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure") --- . Hs.recordCon srcSpan (Ghc.reLocA . Ghc.L srcSpan $ Constructor.name constructor) --- . Hs.recFields --- $ fmap --- ( \(field, (_, var)) -> --- Hs.recField --- srcSpan --- (Hs.fieldOcc srcSpan . Hs.unqual srcSpan $ Field.name field) --- $ Hs.var srcSpan var --- ) --- fields - --- lHsBind = --- Common.makeLHsBind srcSpan (Ghc.mkVarOcc "parseJSON") [] --- . Hs.app --- srcSpan --- ( Hs.app --- srcSpan --- (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "withObject") --- . Hs.lit srcSpan --- . Hs.string --- $ Type.qualifiedName moduleName type_ --- ) --- . Hs.par srcSpan --- . Hs.lam srcSpan --- . Hs.mg --- $ Ghc.L --- srcSpan --- [ Hs.match srcSpan Ghc.LambdaExpr [Hs.varPat srcSpan object] $ --- Hs.grhss --- srcSpan --- [ Hs.grhs srcSpan --- . Hs.doExpr srcSpan --- $ bindStmts --- <> [lastStmt] --- ] --- ] - --- lHsDecl = --- Common.makeInstanceDeclaration --- srcSpan --- type_ --- aeson --- (Ghc.mkClsOcc "FromJSON") --- [lHsBind] - --- pure (lImportDecls, [lHsDecl]) - -fromField :: - Ghc.SrcSpan -> - (String -> Ghc.Hsc String) -> - Field.Field -> - Ghc.Hsc (Field.Field, (String, Ghc.LIdP Ghc.GhcPs)) -fromField srcSpan modifyFieldName field = do - let fieldName = Field.name field - name <- modifyFieldName $ Ghc.occNameString fieldName - var <- - Common.makeRandomVariable srcSpan . (<> "_") $ - Ghc.occNameString - fieldName - pure (field, (name, var)) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs index 390a060002a..faed5c40d82 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs @@ -1,3 +1,6 @@ +-- The 'head' call below is on a list that is non-empty by construction. +{-# OPTIONS_GHC -Wno-x-partial #-} + module PlinthPlugin.Generator.Match ( generate, ) @@ -13,8 +16,6 @@ import qualified PlinthPlugin.Type.Field as Field import qualified PlinthPlugin.Type.Type as Type import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc -import qualified GHC.Types.Fixity as Ghc -import qualified GHC.Types.SourceText as Ghc -- | Generates a CPS-style destructor function for 'AsData' sum types. -- diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs index c1915d9dd4d..4e8c22f0187 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs @@ -1,3 +1,7 @@ +-- The 'head' calls below are on lists that are non-empty by construction +-- (guarded by the surrounding arity matches). +{-# OPTIONS_GHC -Wno-x-partial #-} + module PlinthPlugin.Generator.Optics ( generate, ) @@ -12,8 +16,6 @@ import qualified PlinthPlugin.Type.Field as Field import qualified PlinthPlugin.Type.Type as Type import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc -import qualified GHC.Types.Fixity as Ghc -import qualified GHC.Types.SourceText as Ghc -- | For each constructor generates a 'Prism'' binding. For example: -- diff --git a/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs b/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs index 6cf24357669..f0ff16ecbc5 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs @@ -10,7 +10,6 @@ import qualified Control.Monad.IO.Class as IO import qualified GHC as Ghc import qualified GHC.Data.Bag as Ghc import qualified GHC.Driver.Config.Diagnostic as Ghc -import qualified GHC.Driver.Errors as Ghc import qualified GHC.Driver.Errors.Types as Ghc import qualified GHC.Plugins as Ghc import qualified GHC.Types.Error as Ghc diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs index 968f4fb6902..f34d7f702e4 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs @@ -12,7 +12,7 @@ data Config = Config verbose :: Bool, version :: Bool } - deriving (Eq, Show) + deriving stock (Eq, Show) initial :: Config initial = Config {help = False, verbose = False, version = False} diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs index 6ac4e6c4d82..a3004272be7 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs @@ -10,7 +10,7 @@ data Flag = Help | Verbose | Version - deriving (Eq, Show) + deriving stock (Eq, Show) options :: [Console.OptDescr Flag] options = diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs index d122012542f..9aa154b50b6 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs @@ -11,9 +11,7 @@ import qualified Control.Monad as Monad import qualified PlinthPlugin.Hsc as Hsc import qualified PlinthPlugin.Type.Constructor as Constructor import qualified GHC.Hs as Ghc -import qualified GHC.Hs.Type as Ghc import qualified GHC.Plugins as Ghc -import qualified Language.Haskell.Syntax.Type as Syntax data Type = Type { name :: Ghc.IdP Ghc.GhcPs, From e954cb9e25a91b2abbb100afc13d1827be9686ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Tue, 16 Jun 2026 15:01:10 +0100 Subject: [PATCH 03/13] Make -Wno-x-partial pragma 9.6-safe -Wx-partial does not exist before GHC 9.8, so the bare -Wno-x-partial pragma tripped -Werror=unrecognised-warning-flags on the 9.6 build. Pair it with -Wno-unrecognised-warning-flags so the unknown flag is a no-op on 9.6. Co-Authored-By: Claude Opus 4.8 --- plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs | 3 ++- plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs | 3 ++- plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs | 3 ++- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs index bdabdb706f9..6804e4ddfa4 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} -- The 'head' calls below are on lists that are non-empty by construction -- (guarded by the surrounding arity/constructor-count matches). -{-# OPTIONS_GHC -Wno-x-partial #-} +-- (-Wx-partial does not exist before GHC 9.8, hence -Wno-unrecognised-warning-flags) +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} module PlinthPlugin.Generator.AsData ( generate, diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs index faed5c40d82..659098a96dc 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs @@ -1,5 +1,6 @@ -- The 'head' call below is on a list that is non-empty by construction. -{-# OPTIONS_GHC -Wno-x-partial #-} +-- (-Wx-partial does not exist before GHC 9.8, hence -Wno-unrecognised-warning-flags) +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} module PlinthPlugin.Generator.Match ( generate, diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs b/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs index 4e8c22f0187..66c103f1641 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs @@ -1,6 +1,7 @@ -- The 'head' calls below are on lists that are non-empty by construction -- (guarded by the surrounding arity matches). -{-# OPTIONS_GHC -Wno-x-partial #-} +-- (-Wx-partial does not exist before GHC 9.8, hence -Wno-unrecognised-warning-flags) +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} module PlinthPlugin.Generator.Optics ( generate, From 924eddebe5bf5288ea45579df202a378c2f8b302 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Tue, 16 Jun 2026 15:39:36 +0100 Subject: [PATCH 04/13] Fix 9.6 overlapping-patterns + unused Hsc import in Type.Type On GHC 9.6, UserTyVar/KindedTyVar already exhaust HsTyVarBndr, so the catch-all tripped -Werror=overlapping-patterns; move it into the >=9.10 branch (where it covers HsBndrWildCard). That leaves PlinthPlugin.Hsc unused on 9.6, so CPP-guard its import too. Verified locally with plutus's -Wall -Werror set on both GHC 9.6.7 and 9.12.2. Co-Authored-By: Claude Opus 4.8 --- plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs b/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs index 9aa154b50b6..52f40bb092a 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs +++ b/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs @@ -8,7 +8,9 @@ module PlinthPlugin.Type.Type where import qualified Control.Monad as Monad +#if __GLASGOW_HASKELL__ >= 910 import qualified PlinthPlugin.Hsc as Hsc +#endif import qualified PlinthPlugin.Type.Constructor as Constructor import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc @@ -32,11 +34,12 @@ make lIdP lHsQTyVars lConDecls srcSpan = do case Ghc.unLoc lHsTyVarBndr of #if __GLASGOW_HASKELL__ >= 910 Ghc.HsTvb _ _ (Ghc.HsBndrVar _ (Ghc.L _ var)) _ -> pure var + -- HsBndrWildCard and the XTyVarBndr extension constructor + _ -> Hsc.throwError srcSpan $ Ghc.text "unknown type variable binder" #else Ghc.UserTyVar _ _ (Ghc.L _ var) -> pure var Ghc.KindedTyVar _ _ (Ghc.L _ var) _ -> pure var #endif - _ -> Hsc.throwError srcSpan $ Ghc.text "unknown type variable binder" theConstructors <- mapM (Constructor.make srcSpan) lConDecls pure Type From e08071f8c7e3466395dd1423b3097498b00217b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Tue, 16 Jun 2026 16:51:25 +0100 Subject: [PATCH 05/13] Add activation test for the PlinthPlugin deriving plugin Adds AsData.Spec to frontend-plugin-tests: a module compiled with -fplugin PlinthPlugin that derives 'AsData via PlinthPlugin' and uses the generated Circle/Rectangle pattern synonyms. If the plugin does not fire, the deriving clause survives to the renamer and the module fails to compile, so compilation itself proves the plugin works; the HUnit case additionally exercises the generated synonyms at runtime. Co-Authored-By: Claude Opus 4.8 --- plutus-tx-plugin/plutus-tx-plugin.cabal | 2 + .../test-frontend-plugin/AsData/Spec.hs | 47 +++++++++++++++++++ plutus-tx-plugin/test-frontend-plugin/Spec.hs | 17 ++++--- 3 files changed, 60 insertions(+), 6 deletions(-) create mode 100644 plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 52f9c87f55e..26b9d08bca4 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -260,6 +260,7 @@ test-suite frontend-plugin-tests hs-source-dirs: test-frontend-plugin main-is: Spec.hs other-modules: + AsData.Spec Inlineable.Lib Inlineable.Spec NoStrict.Spec @@ -272,6 +273,7 @@ test-suite frontend-plugin-tests , plutus-tx-plugin ^>=1.65 , plutus-tx:plutus-tx-testlib , tasty + , tasty-hunit ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs new file mode 100644 index 00000000000..b72cadb232c --- /dev/null +++ b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -fplugin PlinthPlugin #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-| Activation test for the @PlinthPlugin@ parsed-AST deriving plugin. + +This module is compiled with @-fplugin PlinthPlugin@. The plugin must rewrite +the @deriving AsData via PlinthPlugin@ clause below into a @BuiltinData@-backed +newtype plus bidirectional pattern synonyms @Circle@/@Rectangle@ (and inject +the @PlutusTx.*@ imports the generated code uses). + +If the plugin does /not/ fire, the deriving clause survives to the renamer — +where @AsData@ is not a real class and the @Circle@ synonym does not exist — so +this module fails to compile. Thus successful compilation /is/ the test. +-} +module AsData.Spec (tests) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +data Shape + = Circle Integer + | Rectangle Integer Integer + deriving AsData via PlinthPlugin + +-- | These reference both plugin-generated pattern synonyms (so neither is +-- flagged unused under @-Werror@). The trailing wildcard makes each match +-- total and non-overlapping regardless of the generated @COMPLETE@ pragma, +-- so they do not trip @-Werror@ on incomplete/overlapping patterns either. +isCircle :: Shape -> Bool +isCircle (Circle _) = True +isCircle _ = False + +isRectangle :: Shape -> Bool +isRectangle (Rectangle _ _) = True +isRectangle _ = False + +tests :: TestTree +tests = + testGroup + "AsData via PlinthPlugin" + [ testCase "plugin fires; generated synonyms construct and match" $ do + isCircle (Circle 1) @?= True + isRectangle (Circle 1) @?= False + isRectangle (Rectangle 2 3) @?= True + ] diff --git a/plutus-tx-plugin/test-frontend-plugin/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/Spec.hs index fe60ec3ad25..a2a2b13d63b 100644 --- a/plutus-tx-plugin/test-frontend-plugin/Spec.hs +++ b/plutus-tx-plugin/test-frontend-plugin/Spec.hs @@ -1,10 +1,11 @@ module Main (main) where +import AsData.Spec qualified as AsData import Inlineable.Spec qualified as Inlineable import NoStrict.Spec qualified as NoStrict import Strict.Spec qualified as Strict -import Test.Tasty (TestTree, defaultMain) +import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Extras (runTestNested) main :: IO () @@ -12,9 +13,13 @@ main = defaultMain tests tests :: TestTree tests = - runTestNested - ["test-frontend-plugin"] - [ Strict.tests - , NoStrict.tests - , Inlineable.tests + testGroup + "frontend-plugin-tests" + [ runTestNested + ["test-frontend-plugin"] + [ Strict.tests + , NoStrict.tests + , Inlineable.tests + ] + , AsData.tests ] From b8faa4dd68931121939f1915dc6b176f2fd9dd57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Tue, 16 Jun 2026 17:27:26 +0100 Subject: [PATCH 06/13] Suppress generated-code warnings in the PlinthPlugin test The AsData-generated code uses head/tail and emits pattern synonyms without signatures, tripping -Werror=x-partial and -Werror=missing-pattern-synonym-signatures. These are inherent to the plugin output, so suppress them on the test module (the plugin firing is confirmed by the generated code compiling at all). Co-Authored-By: Claude Opus 4.8 --- plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs index b72cadb232c..18b896d5bf1 100644 --- a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs +++ b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs @@ -1,4 +1,10 @@ {-# OPTIONS_GHC -fplugin PlinthPlugin #-} +-- The plugin-generated code uses 'head'/'tail' internally and emits pattern +-- synonyms without top-level signatures; suppress those warnings here (the +-- -Wno-unrecognised-warning-flags keeps -Wno-x-partial harmless pre-GHC 9.8). +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} +{-# OPTIONS_GHC -Wno-x-partial #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} From 067f419c803d2e565dae0a0680f35a274a3302bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Thu, 18 Jun 2026 14:17:44 +0100 Subject: [PATCH 07/13] Fold the Plinth deriving pass into Plinth.Plugin; move to PlutusTx.Plugin.Deriving Per review (hsyl20): instead of shipping a standalone PlinthPlugin that users must enable with a second -fplugin, wire the parsed-AST deriving pass into the existing Plinth.Plugin as its parsedResultAction. Any module compiled with the Plinth plugin now gets 'deriving via Plinth' automatically. Also: move the modules from PlinthPlugin.* to PlutusTx.Plugin.Deriving.*, and rename the deriving-via sentinel to a bare 'data Plinth' (PlutusTx.Plugin.Deriving.Via) so it reads 'deriving AsData via Plinth' with no DataKinds. The standalone 'plugin' value and its CLI/help/version handling are dropped. Co-Authored-By: Claude Opus 4.8 --- .../20260616_plinth_deriving_plugin.md | 10 ++- plutus-tx-plugin/plutus-tx-plugin.cabal | 30 +++---- plutus-tx-plugin/src/Plinth/Plugin.hs | 3 + plutus-tx-plugin/src/PlinthPlugin/Via.hs | 15 ---- .../Plugin/Deriving.hs} | 81 ++++++------------- .../Plugin/Deriving}/Constant/Module.hs | 2 +- .../Plugin/Deriving}/Generator/AsData.hs | 18 ++--- .../Plugin/Deriving}/Generator/Common.hs | 23 +++--- .../Plugin/Deriving}/Generator/Match.hs | 20 ++--- .../Plugin/Deriving}/Generator/Optics.hs | 16 ++-- .../Plugin/Deriving}/Hs.hs | 2 +- .../Plugin/Deriving}/Hsc.hs | 2 +- .../Plugin/Deriving}/Options.hs | 4 +- .../Plugin/Deriving}/Type/Config.hs | 4 +- .../Plugin/Deriving}/Type/Constructor.hs | 6 +- .../Plugin/Deriving}/Type/Field.hs | 4 +- .../Plugin/Deriving}/Type/Flag.hs | 2 +- .../Plugin/Deriving}/Type/Type.hs | 6 +- .../src/PlutusTx/Plugin/Deriving/Via.hs | 15 ++++ .../test-frontend-plugin/AsData/Spec.hs | 21 ++--- 20 files changed, 131 insertions(+), 153 deletions(-) delete mode 100644 plutus-tx-plugin/src/PlinthPlugin/Via.hs rename plutus-tx-plugin/src/{PlinthPlugin.hs => PlutusTx/Plugin/Deriving.hs} (82%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Constant/Module.hs (96%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Generator/AsData.hs (97%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Generator/Common.hs (94%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Generator/Match.hs (95%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Generator/Optics.hs (94%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Hs.hs (99%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Hsc.hs (97%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Options.hs (91%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Type/Config.hs (84%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Type/Constructor.hs (91%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Type/Field.hs (90%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Type/Flag.hs (93%) rename plutus-tx-plugin/src/{PlinthPlugin => PlutusTx/Plugin/Deriving}/Type/Type.hs (89%) create mode 100644 plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Via.hs diff --git a/plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md b/plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md index ea92a66c445..8d527cd8b19 100644 --- a/plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md +++ b/plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md @@ -1,6 +1,8 @@ ### Added -- Added the Plinth parsed-AST deriving plugin (`PlinthPlugin`). It generates - `AsData` pattern synonyms, `Optics` prisms, and `Match` functions from data - declarations written with `deriving … via PlinthPlugin`. The sentinel lives - in `PlinthPlugin.Via` (`data Via = PlinthPlugin`). +- The Plinth plugin now expands `deriving … via Plinth` clauses at parse time, + generating `AsData` pattern synonyms, `Optics` prisms, and `Match` functions + from data declarations. The pass is wired into `Plinth.Plugin`, so any module + compiled with the Plinth plugin gets it automatically — no extra `-fplugin`. + The implementation lives under `PlutusTx.Plugin.Deriving.*`, and the + deriving-via sentinel type is `Plinth` (`PlutusTx.Plugin.Deriving.Via`). diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 26b9d08bca4..6be01aa5b0d 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -56,27 +56,27 @@ library hs-source-dirs: src exposed-modules: Plinth.Plugin - PlinthPlugin - PlinthPlugin.Via + PlutusTx.Plugin.Deriving.Via PlutusTx.Compiler.Error PlutusTx.Options PlutusTx.Plugin.Common other-modules: Paths_plutus_tx_plugin - PlinthPlugin.Constant.Module - PlinthPlugin.Generator.AsData - PlinthPlugin.Generator.Common - PlinthPlugin.Generator.Match - PlinthPlugin.Generator.Optics - PlinthPlugin.Hs - PlinthPlugin.Hsc - PlinthPlugin.Options - PlinthPlugin.Type.Config - PlinthPlugin.Type.Constructor - PlinthPlugin.Type.Field - PlinthPlugin.Type.Flag - PlinthPlugin.Type.Type + PlutusTx.Plugin.Deriving + PlutusTx.Plugin.Deriving.Constant.Module + PlutusTx.Plugin.Deriving.Generator.AsData + PlutusTx.Plugin.Deriving.Generator.Common + PlutusTx.Plugin.Deriving.Generator.Match + PlutusTx.Plugin.Deriving.Generator.Optics + PlutusTx.Plugin.Deriving.Hs + PlutusTx.Plugin.Deriving.Hsc + PlutusTx.Plugin.Deriving.Options + PlutusTx.Plugin.Deriving.Type.Config + PlutusTx.Plugin.Deriving.Type.Constructor + PlutusTx.Plugin.Deriving.Type.Field + PlutusTx.Plugin.Deriving.Type.Flag + PlutusTx.Plugin.Deriving.Type.Type PlutusTx.Compiler.Binders PlutusTx.Compiler.Builtins PlutusTx.Compiler.Compat diff --git a/plutus-tx-plugin/src/Plinth/Plugin.hs b/plutus-tx-plugin/src/Plinth/Plugin.hs index 528b90a15f7..1a1e8adf601 100644 --- a/plutus-tx-plugin/src/Plinth/Plugin.hs +++ b/plutus-tx-plugin/src/Plinth/Plugin.hs @@ -5,6 +5,7 @@ module Plinth.Plugin (plugin, plinthc) where import PlutusTx.Options import PlutusTx.Plugin.Boilerplate import PlutusTx.Plugin.Common +import PlutusTx.Plugin.Deriving qualified as Deriving import PlutusTx.Plugin.Unsupported import PlutusTx.Plugin.Utils @@ -18,6 +19,8 @@ plugin :: GHC.Plugin plugin = GHC.defaultPlugin { GHC.driverPlugin = addFlagsAndExts + , -- Expand @deriving … via Plinth@ clauses at parse time. + GHC.parsedResultAction = Deriving.parsedResultAction , GHC.typeCheckResultAction = \cliOpts _modSummary env -> do opts <- case parsePluginOptions (removeBoilerplateOpts cliOpts) of Success o -> pure o diff --git a/plutus-tx-plugin/src/PlinthPlugin/Via.hs b/plutus-tx-plugin/src/PlinthPlugin/Via.hs deleted file mode 100644 index e5c4a12caa8..00000000000 --- a/plutus-tx-plugin/src/PlinthPlugin/Via.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | The @DerivingVia@ sentinel type recognised by the Plinth plugin. -module PlinthPlugin.Via (Via (..)) where - --- | Used as a @DerivingVia@ target to activate the plugin, e.g. --- --- > data Foo = Foo Integer Integer --- > deriving AsData via PlinthPlugin --- --- The constructor is promoted to a type (so the use site needs @DataKinds@). --- --- When the plugin is active the deriving clause is rewritten away at parse --- time, so @PlinthPlugin@ never actually has to be in scope. Defining it as a --- real, well-kinded constructor means that when the plugin is /not/ loaded GHC --- reports a clean type error instead of a confusing one. -data Via = PlinthPlugin diff --git a/plutus-tx-plugin/src/PlinthPlugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs similarity index 82% rename from plutus-tx-plugin/src/PlinthPlugin.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs index e8c7752d4f7..77c61f9c259 100644 --- a/plutus-tx-plugin/src/PlinthPlugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs @@ -1,5 +1,14 @@ -module PlinthPlugin - ( plugin, +-- | The Plinth @deriving via@ pass. This is /not/ a standalone plugin: it is +-- wired into 'Plinth.Plugin.plugin' as its @parsedResultAction@, so that any +-- module compiled with the Plinth plugin can write +-- +-- > data Shape = Point | Circle Integer Integer +-- > deriving AsData via Plinth +-- > deriving Optics via Plinth +-- +-- without enabling a second plugin. +module PlutusTx.Plugin.Deriving + ( parsedResultAction, ) where @@ -7,65 +16,27 @@ import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as IO import qualified Data.Bifunctor as Bifunctor import qualified Data.Maybe as Maybe -import qualified Data.Version as Version -import qualified PlinthPlugin.Generator.AsData as AsData -import qualified PlinthPlugin.Generator.Match as Match -import qualified PlinthPlugin.Generator.Optics as Optics -import qualified PlinthPlugin.Generator.Common as Common -import qualified PlinthPlugin.Hsc as Hsc -import qualified PlinthPlugin.Options as Options -import qualified PlinthPlugin.Type.Config as Config -import qualified PlinthPlugin.Type.Flag as Flag +import qualified PlutusTx.Plugin.Deriving.Generator.AsData as AsData +import qualified PlutusTx.Plugin.Deriving.Generator.Match as Match +import qualified PlutusTx.Plugin.Deriving.Generator.Optics as Optics +import qualified PlutusTx.Plugin.Deriving.Generator.Common as Common +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Type.Config as Config import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc -import qualified Paths_plutus_tx_plugin as This -import qualified System.Console.GetOpt as Console - --- | The compiler plugin. When built into the Plinth GHC binary this is --- registered as a static plugin and is active for every compilation without --- requiring a @-fplugin=PlinthPlugin@ pragma. --- --- Once active, you can derive instances like this: --- --- > data Shape = Point | Circle Integer Integer --- > deriving AsData via PlinthPlugin --- > deriving Optics via PlinthPlugin -plugin :: Ghc.Plugin -plugin = - Ghc.defaultPlugin - { Ghc.parsedResultAction = parsedResultAction, - Ghc.pluginRecompile = Ghc.purePlugin - } +-- | The @parsedResultAction@ hook: rewrite @deriving … via Plinth@ clauses in +-- the freshly-parsed module into the generated declarations. parsedResultAction :: [Ghc.CommandLineOption] -> Ghc.ModSummary -> Ghc.ParsedResult -> Ghc.Hsc Ghc.ParsedResult -parsedResultAction commandLineOptions modSummary (Ghc.ParsedResult hsParsedModule msgs) = do - let lHsModule1 = Ghc.hpm_module hsParsedModule - srcSpan = Ghc.getLoc lHsModule1 - - flags <- Options.parse Flag.options commandLineOptions srcSpan - let config = Config.fromFlags flags - - Monad.when (Config.help config) - . Hsc.throwError srcSpan - . Ghc.vcat - . fmap Ghc.text - . lines - $ Console.usageInfo ("PlinthPlugin version " <> version) Flag.options - Monad.when (Config.version config) . Hsc.throwError srcSpan $ - Ghc.text version - - let moduleName = Ghc.moduleName $ Ghc.ms_mod modSummary - lHsModule2 <- handleLHsModule config moduleName lHsModule1 - - let newHsParsedModule = hsParsedModule { Ghc.hpm_module = lHsModule2 } - pure $ Ghc.ParsedResult newHsParsedModule msgs - -version :: String -version = Version.showVersion This.version +parsedResultAction _commandLineOptions modSummary (Ghc.ParsedResult hsParsedModule msgs) = do + let config = Config.fromFlags [] + moduleName = Ghc.moduleName $ Ghc.ms_mod modSummary + lHsModule2 <- handleLHsModule config moduleName (Ghc.hpm_module hsParsedModule) + pure $ Ghc.ParsedResult hsParsedModule {Ghc.hpm_module = lHsModule2} msgs type LHsModule = Ghc.Located (Ghc.HsModule Ghc.GhcPs) @@ -246,14 +217,14 @@ handleLHsDerivingClause config moduleName lIdP lHsQTyVars lConDecls lHsDerivingC case Ghc.unLoc lHsDerivingClause of Ghc.HsDerivingClause _ deriv_clause_strategy deriv_clause_tys | Just options <- Common.parseDerivingStrategy deriv_clause_strategy -> do - let nonPlinthPluginClauses = filter + let nonPlinthClauses = filter ( \c -> case Ghc.unLoc c of Ghc.HsDerivingClause _ s _ -> Maybe.isNothing (Common.parseDerivingStrategy s) ) lHsDerivingClauses (dropOriginal, lImportDecls, lHsDecls) <- - handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options nonPlinthPluginClauses + handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options nonPlinthClauses . toLHsSigTypes $ Ghc.unLoc deriv_clause_tys pure (Nothing, dropOriginal, (lImportDecls, lHsDecls)) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Constant/Module.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Constant/Module.hs similarity index 96% rename from plutus-tx-plugin/src/PlinthPlugin/Constant/Module.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Constant/Module.hs index c4a87512106..a1b8b61eb77 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Constant/Module.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Constant/Module.hs @@ -1,4 +1,4 @@ -module PlinthPlugin.Constant.Module +module PlutusTx.Plugin.Deriving.Constant.Module ( controlApplicative, controlLens, dataAeson, diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs similarity index 97% rename from plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs index 6804e4ddfa4..b682dc2ea5a 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/AsData.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs @@ -4,18 +4,18 @@ -- (-Wx-partial does not exist before GHC 9.8, hence -Wno-unrecognised-warning-flags) {-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} -module PlinthPlugin.Generator.AsData +module PlutusTx.Plugin.Deriving.Generator.AsData ( generate, ) where -import qualified PlinthPlugin.Constant.Module as Module -import qualified PlinthPlugin.Generator.Common as Common -import qualified PlinthPlugin.Hs as Hs -import qualified PlinthPlugin.Hsc as Hsc -import qualified PlinthPlugin.Type.Constructor as Constructor -import qualified PlinthPlugin.Type.Field as Field -import qualified PlinthPlugin.Type.Type as Type +import qualified PlutusTx.Plugin.Deriving.Constant.Module as Module +import qualified PlutusTx.Plugin.Deriving.Generator.Common as Common +import qualified PlutusTx.Plugin.Deriving.Hs as Hs +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Type.Constructor as Constructor +import qualified PlutusTx.Plugin.Deriving.Type.Field as Field +import qualified PlutusTx.Plugin.Deriving.Type.Type as Type import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc import qualified GHC.Types.Fixity as Ghc @@ -28,7 +28,7 @@ import qualified GHC.Types.SourceText as Ghc -- Given: -- -- > data Example a = Ex1 Integer | Ex2 a a --- > deriving AsData via PlinthPlugin +-- > deriving AsData via Plinth -- -- Generates: -- diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Common.hs similarity index 94% rename from plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Common.hs index b38140c4762..b48a532f303 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Common.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Common.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module PlinthPlugin.Generator.Common +module PlutusTx.Plugin.Deriving.Generator.Common ( Generator, applyAll, fieldNameOptions, @@ -19,11 +19,11 @@ import qualified Data.IORef as IORef import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Text as Text -import qualified PlinthPlugin.Hs as Hs -import qualified PlinthPlugin.Hsc as Hsc -import qualified PlinthPlugin.Type.Constructor as Constructor -import qualified PlinthPlugin.Type.Field as Field -import qualified PlinthPlugin.Type.Type as Type +import qualified PlutusTx.Plugin.Deriving.Hs as Hs +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Type.Constructor as Constructor +import qualified PlutusTx.Plugin.Deriving.Type.Field as Field +import qualified PlutusTx.Plugin.Deriving.Type.Type as Type #if __GLASGOW_HASKELL__ < 910 import qualified GHC.Data.Bag as Ghc #endif @@ -338,12 +338,11 @@ counterRef = Unsafe.unsafePerformIO $ IORef.newIORef 0 -- | This plugin only fires on specific deriving strategies. In particular it -- looks for clauses like this: -- --- > deriving C via PlinthPlugin +-- > deriving C via Plinth -- --- where @PlinthPlugin@ is the promoted constructor of @data Via = PlinthPlugin@. --- Using a real constructor (rather than a @Symbol@ string literal) means the --- name must be in scope and well-kinded, so when the plugin is not loaded GHC --- reports a clean type error instead of a confusing one. +-- where @Plinth@ is the sentinel type @data Plinth@. Using a real type (rather +-- than a @Symbol@ string literal) means the name must be in scope, so when the +-- plugin is not loaded GHC reports a clean error instead of a confusing one. -- -- This function is responsible for analyzing a deriving strategy to determine -- if the plugin should fire or not. @@ -360,6 +359,6 @@ parseDerivingStrategy mLDerivStrategy = do Ghc.HsTyVar _ _ x -> Just $ Ghc.unLoc x _ -> Nothing case Ghc.occNameString $ Ghc.rdrNameOcc rdrName of - "PlinthPlugin" -> Just [] + "Plinth" -> Just [] _ -> Nothing diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs similarity index 95% rename from plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs index 659098a96dc..0cdb4e2b105 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Match.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs @@ -2,19 +2,19 @@ -- (-Wx-partial does not exist before GHC 9.8, hence -Wno-unrecognised-warning-flags) {-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} -module PlinthPlugin.Generator.Match +module PlutusTx.Plugin.Deriving.Generator.Match ( generate, ) where import qualified Data.List as List -import qualified PlinthPlugin.Constant.Module as Module -import qualified PlinthPlugin.Generator.Common as Common -import qualified PlinthPlugin.Hs as Hs -import qualified PlinthPlugin.Hsc as Hsc -import qualified PlinthPlugin.Type.Constructor as Constructor -import qualified PlinthPlugin.Type.Field as Field -import qualified PlinthPlugin.Type.Type as Type +import qualified PlutusTx.Plugin.Deriving.Constant.Module as Module +import qualified PlutusTx.Plugin.Deriving.Generator.Common as Common +import qualified PlutusTx.Plugin.Deriving.Hs as Hs +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Type.Constructor as Constructor +import qualified PlutusTx.Plugin.Deriving.Type.Field as Field +import qualified PlutusTx.Plugin.Deriving.Type.Type as Type import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc @@ -23,7 +23,7 @@ import qualified GHC.Plugins as Ghc -- Given: -- -- > data Example a = Ex1 Integer | Ex2 a a --- > deriving (AsData, Match) via PlinthPlugin +-- > deriving (AsData, Match) via Plinth -- -- Generates: -- @@ -39,7 +39,7 @@ import qualified GHC.Plugins as Ghc -- For a single-constructor type, the tag check is omitted entirely: -- -- > data Address = Address Credential (Maybe StakingCredential) --- > deriving (AsData, Match) via PlinthPlugin +-- > deriving (AsData, Match) via Plinth -- -- Generates: -- diff --git a/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Optics.hs similarity index 94% rename from plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Optics.hs index 66c103f1641..0f27b964820 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Generator/Optics.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Optics.hs @@ -3,25 +3,25 @@ -- (-Wx-partial does not exist before GHC 9.8, hence -Wno-unrecognised-warning-flags) {-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} -module PlinthPlugin.Generator.Optics +module PlutusTx.Plugin.Deriving.Generator.Optics ( generate, ) where import qualified Data.List as List -import qualified PlinthPlugin.Constant.Module as Module -import qualified PlinthPlugin.Generator.Common as Common -import qualified PlinthPlugin.Hs as Hs -import qualified PlinthPlugin.Type.Constructor as Constructor -import qualified PlinthPlugin.Type.Field as Field -import qualified PlinthPlugin.Type.Type as Type +import qualified PlutusTx.Plugin.Deriving.Constant.Module as Module +import qualified PlutusTx.Plugin.Deriving.Generator.Common as Common +import qualified PlutusTx.Plugin.Deriving.Hs as Hs +import qualified PlutusTx.Plugin.Deriving.Type.Constructor as Constructor +import qualified PlutusTx.Plugin.Deriving.Type.Field as Field +import qualified PlutusTx.Plugin.Deriving.Type.Type as Type import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc -- | For each constructor generates a 'Prism'' binding. For example: -- -- > data Shape = Point | Circle Integer | Rectangle Integer Integer --- > deriving Optics via PlinthPlugin +-- > deriving Optics via Plinth -- -- Produces: -- diff --git a/plutus-tx-plugin/src/PlinthPlugin/Hs.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Hs.hs similarity index 99% rename from plutus-tx-plugin/src/PlinthPlugin/Hs.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Hs.hs index cff567934c8..b57f6992138 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Hs.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Hs.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module PlinthPlugin.Hs +module PlutusTx.Plugin.Deriving.Hs ( app, bindStmt, doExpr, diff --git a/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Hsc.hs similarity index 97% rename from plutus-tx-plugin/src/PlinthPlugin/Hsc.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Hsc.hs index f0ff16ecbc5..f2e5f8ae027 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Hsc.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Hsc.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module PlinthPlugin.Hsc +module PlutusTx.Plugin.Deriving.Hsc ( addWarning, throwError, ) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Options.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Options.hs similarity index 91% rename from plutus-tx-plugin/src/PlinthPlugin/Options.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Options.hs index 79a3600d28a..48f8471b8c6 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Options.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Options.hs @@ -1,10 +1,10 @@ -module PlinthPlugin.Options +module PlutusTx.Plugin.Deriving.Options ( parse, ) where import qualified Control.Monad as Monad -import qualified PlinthPlugin.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc import qualified GHC.Plugins as Ghc import qualified System.Console.GetOpt as Console diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Config.hs similarity index 84% rename from plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Config.hs index f34d7f702e4..4f5b5cafa95 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Config.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Config.hs @@ -1,11 +1,11 @@ -module PlinthPlugin.Type.Config +module PlutusTx.Plugin.Deriving.Type.Config ( Config (..), fromFlags, ) where import qualified Data.List as List -import qualified PlinthPlugin.Type.Flag as Flag +import qualified PlutusTx.Plugin.Deriving.Type.Flag as Flag data Config = Config { help :: Bool, diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Constructor.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Constructor.hs similarity index 91% rename from plutus-tx-plugin/src/PlinthPlugin/Type/Constructor.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Constructor.hs index da36a38466c..6866f36d938 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Constructor.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Constructor.hs @@ -1,4 +1,4 @@ -module PlinthPlugin.Type.Constructor +module PlutusTx.Plugin.Deriving.Type.Constructor ( Constructor (..), make, ) @@ -6,8 +6,8 @@ where import qualified Control.Monad as Monad import qualified Data.List as List -import qualified PlinthPlugin.Hsc as Hsc -import qualified PlinthPlugin.Type.Field as Field +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Type.Field as Field import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Field.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Field.hs similarity index 90% rename from plutus-tx-plugin/src/PlinthPlugin/Type/Field.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Field.hs index 322354cd55b..5828a7501f7 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Field.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Field.hs @@ -1,11 +1,11 @@ -module PlinthPlugin.Type.Field +module PlutusTx.Plugin.Deriving.Type.Field ( Field (..), make, isOptional, ) where -import qualified PlinthPlugin.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Flag.hs similarity index 93% rename from plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Flag.hs index a3004272be7..ac60f561c4b 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Flag.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Flag.hs @@ -1,4 +1,4 @@ -module PlinthPlugin.Type.Flag +module PlutusTx.Plugin.Deriving.Type.Flag ( Flag (..), options, ) diff --git a/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Type.hs similarity index 89% rename from plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs rename to plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Type.hs index 52f40bb092a..966a8e8b71a 100644 --- a/plutus-tx-plugin/src/PlinthPlugin/Type/Type.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Type.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module PlinthPlugin.Type.Type +module PlutusTx.Plugin.Deriving.Type.Type ( Type (..), make, qualifiedName, @@ -9,9 +9,9 @@ where import qualified Control.Monad as Monad #if __GLASGOW_HASKELL__ >= 910 -import qualified PlinthPlugin.Hsc as Hsc +import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc #endif -import qualified PlinthPlugin.Type.Constructor as Constructor +import qualified PlutusTx.Plugin.Deriving.Type.Constructor as Constructor import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Via.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Via.hs new file mode 100644 index 00000000000..31776a55e6e --- /dev/null +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Via.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyDataDecls #-} + +-- | The @DerivingVia@ sentinel type recognised by the Plinth deriving plugin. +module PlutusTx.Plugin.Deriving.Via (Plinth) where + +-- | Used as a @DerivingVia@ target to activate the deriving plugin, e.g. +-- +-- > data Foo = Foo Integer Integer +-- > deriving AsData via Plinth +-- +-- When the plugin is active the deriving clause is rewritten away at parse +-- time, so @Plinth@ never actually has to be in scope. Defining it as a real +-- type means that when the plugin is /not/ loaded GHC reports a clean error +-- instead of a confusing one. +data Plinth diff --git a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs index 18b896d5bf1..a59af8df187 100644 --- a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs +++ b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -fplugin PlinthPlugin #-} +{-# OPTIONS_GHC -fplugin Plinth.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:datatypes=BuiltinCasing #-} -- The plugin-generated code uses 'head'/'tail' internally and emits pattern -- synonyms without top-level signatures; suppress those warnings here (the -- -Wno-unrecognised-warning-flags keeps -Wno-x-partial harmless pre-GHC 9.8). @@ -9,14 +11,15 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-| Activation test for the @PlinthPlugin@ parsed-AST deriving plugin. +{-| Activation test for the Plinth @deriving via@ pass. -This module is compiled with @-fplugin PlinthPlugin@. The plugin must rewrite -the @deriving AsData via PlinthPlugin@ clause below into a @BuiltinData@-backed -newtype plus bidirectional pattern synonyms @Circle@/@Rectangle@ (and inject -the @PlutusTx.*@ imports the generated code uses). +This module is compiled with the Plinth plugin (@-fplugin Plinth.Plugin@), into +which the deriving pass is wired. The plugin must rewrite the +@deriving AsData via Plinth@ clause below into a @BuiltinData@-backed newtype +plus bidirectional pattern synonyms @Circle@/@Rectangle@ (and inject the +@PlutusTx.*@ imports the generated code uses). -If the plugin does /not/ fire, the deriving clause survives to the renamer — +If the deriving pass does /not/ fire, the clause survives to the renamer — where @AsData@ is not a real class and the @Circle@ synonym does not exist — so this module fails to compile. Thus successful compilation /is/ the test. -} @@ -28,7 +31,7 @@ import Test.Tasty.HUnit (testCase, (@?=)) data Shape = Circle Integer | Rectangle Integer Integer - deriving AsData via PlinthPlugin + deriving AsData via Plinth -- | These reference both plugin-generated pattern synonyms (so neither is -- flagged unused under @-Werror@). The trailing wildcard makes each match @@ -45,7 +48,7 @@ isRectangle _ = False tests :: TestTree tests = testGroup - "AsData via PlinthPlugin" + "AsData via Plinth" [ testCase "plugin fires; generated synonyms construct and match" $ do isCircle (Circle 1) @?= True isRectangle (Circle 1) @?= False From a43cf5940c4ab115ff17b0d0d09e0bea078b102b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Thu, 18 Jun 2026 14:56:08 +0100 Subject: [PATCH 08/13] Simplify deriving pass per review: Bool matcher, drop Config/Flag/Options Addresses two review comments: - parseDerivingStrategy returned Maybe [String] but the options channel is always empty now, so it becomes isPlinthVia :: ... -> Bool, and the [String] options are removed from the Generator type and the handle* plumbing. - The CLI/help/version handling pulled in the Paths_ module plus Config, Flag and Options modules for no real benefit. The pass always uses defaults now, so those three modules are deleted and the config threading removed; verbose dumping is driven solely by -ddump-deriv. Co-Authored-By: Claude Opus 4.8 --- plutus-tx-plugin/plutus-tx-plugin.cabal | 3 - .../src/PlutusTx/Plugin/Deriving.hs | 74 ++++++++----------- .../Plugin/Deriving/Generator/AsData.hs | 2 +- .../Plugin/Deriving/Generator/Common.hs | 13 ++-- .../Plugin/Deriving/Generator/Match.hs | 2 +- .../Plugin/Deriving/Generator/Optics.hs | 2 +- .../src/PlutusTx/Plugin/Deriving/Options.hs | 39 ---------- .../PlutusTx/Plugin/Deriving/Type/Config.hs | 27 ------- .../src/PlutusTx/Plugin/Deriving/Type/Flag.hs | 32 -------- 9 files changed, 37 insertions(+), 157 deletions(-) delete mode 100644 plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Options.hs delete mode 100644 plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Config.hs delete mode 100644 plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Flag.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 6be01aa5b0d..979d1829ef6 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -71,11 +71,8 @@ library PlutusTx.Plugin.Deriving.Generator.Optics PlutusTx.Plugin.Deriving.Hs PlutusTx.Plugin.Deriving.Hsc - PlutusTx.Plugin.Deriving.Options - PlutusTx.Plugin.Deriving.Type.Config PlutusTx.Plugin.Deriving.Type.Constructor PlutusTx.Plugin.Deriving.Type.Field - PlutusTx.Plugin.Deriving.Type.Flag PlutusTx.Plugin.Deriving.Type.Type PlutusTx.Compiler.Binders PlutusTx.Compiler.Builtins diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs index 77c61f9c259..315b448ea96 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs @@ -21,7 +21,6 @@ import qualified PlutusTx.Plugin.Deriving.Generator.Match as Match import qualified PlutusTx.Plugin.Deriving.Generator.Optics as Optics import qualified PlutusTx.Plugin.Deriving.Generator.Common as Common import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc -import qualified PlutusTx.Plugin.Deriving.Type.Config as Config import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc @@ -33,30 +32,27 @@ parsedResultAction :: Ghc.ParsedResult -> Ghc.Hsc Ghc.ParsedResult parsedResultAction _commandLineOptions modSummary (Ghc.ParsedResult hsParsedModule msgs) = do - let config = Config.fromFlags [] - moduleName = Ghc.moduleName $ Ghc.ms_mod modSummary - lHsModule2 <- handleLHsModule config moduleName (Ghc.hpm_module hsParsedModule) + let moduleName = Ghc.moduleName $ Ghc.ms_mod modSummary + lHsModule2 <- handleLHsModule moduleName (Ghc.hpm_module hsParsedModule) pure $ Ghc.ParsedResult hsParsedModule {Ghc.hpm_module = lHsModule2} msgs type LHsModule = Ghc.Located (Ghc.HsModule Ghc.GhcPs) handleLHsModule :: - Config.Config -> Ghc.ModuleName -> LHsModule -> Ghc.Hsc LHsModule -handleLHsModule config moduleName lHsModule = do - hsModule <- handleHsModule config moduleName $ Ghc.unLoc lHsModule +handleLHsModule moduleName lHsModule = do + hsModule <- handleHsModule moduleName $ Ghc.unLoc lHsModule pure $ Ghc.L (Ghc.getLoc lHsModule) hsModule handleHsModule :: - Config.Config -> Ghc.ModuleName -> Ghc.HsModule Ghc.GhcPs -> Ghc.Hsc (Ghc.HsModule Ghc.GhcPs) -handleHsModule config moduleName hsModule = do +handleHsModule moduleName hsModule = do (lImportDecls, lHsDecls) <- - handleLHsDecls config moduleName $ + handleLHsDecls moduleName $ Ghc.hsmodDecls hsModule pure hsModule @@ -65,22 +61,20 @@ handleHsModule config moduleName hsModule = do } handleLHsDecls :: - Config.Config -> Ghc.ModuleName -> [Ghc.LHsDecl Ghc.GhcPs] -> Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) -handleLHsDecls config moduleName lHsDecls = do - tuples <- mapM (handleLHsDecl config moduleName) lHsDecls +handleLHsDecls moduleName lHsDecls = do + tuples <- mapM (handleLHsDecl moduleName) lHsDecls pure . Bifunctor.bimap mconcat mconcat $ unzip tuples handleLHsDecl :: - Config.Config -> Ghc.ModuleName -> Ghc.LHsDecl Ghc.GhcPs -> Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) -handleLHsDecl config moduleName lHsDecl = case Ghc.unLoc lHsDecl of +handleLHsDecl moduleName lHsDecl = case Ghc.unLoc lHsDecl of Ghc.TyClD xTyClD tyClDecl1 -> do - (mTyClDecl2, (lImportDecls, lHsDecls)) <- handleTyClDecl config moduleName tyClDecl1 + (mTyClDecl2, (lImportDecls, lHsDecls)) <- handleTyClDecl moduleName tyClDecl1 case mTyClDecl2 of Nothing -> pure (lImportDecls, lHsDecls) @@ -90,18 +84,16 @@ handleLHsDecl config moduleName lHsDecl = case Ghc.unLoc lHsDecl of _ -> pure ([], [lHsDecl]) handleTyClDecl :: - Config.Config -> Ghc.ModuleName -> Ghc.TyClDecl Ghc.GhcPs -> Ghc.Hsc ( Maybe (Ghc.TyClDecl Ghc.GhcPs), ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) ) -handleTyClDecl config moduleName tyClDecl = case tyClDecl of +handleTyClDecl moduleName tyClDecl = case tyClDecl of Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity tcdDataDefn -> do (mHsDataDefn, (lImportDecls, lHsDecls)) <- handleHsDataDefn - config moduleName tcdLName tcdTyVars @@ -113,7 +105,6 @@ handleTyClDecl config moduleName tyClDecl = case tyClDecl of _ -> pure (Just tyClDecl, ([], [])) handleHsDataDefn :: - Config.Config -> Ghc.ModuleName -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsQTyVars Ghc.GhcPs -> @@ -122,7 +113,7 @@ handleHsDataDefn :: ( Maybe (Ghc.HsDataDefn Ghc.GhcPs), ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) ) -handleHsDataDefn config moduleName lIdP lHsQTyVars hsDataDefn = +handleHsDataDefn moduleName lIdP lHsQTyVars hsDataDefn = case hsDataDefn of Ghc.HsDataDefn dd_ext dd_ctxt dd_cType dd_kindSig dd_cons dd_derivs -> do @@ -132,7 +123,6 @@ handleHsDataDefn config moduleName lIdP lHsQTyVars hsDataDefn = (mHsDeriving, (lImportDecls, lHsDecls)) <- handleHsDeriving - config moduleName lIdP lHsQTyVars @@ -147,7 +137,6 @@ handleHsDataDefn config moduleName lIdP lHsQTyVars hsDataDefn = ) handleHsDeriving :: - Config.Config -> Ghc.ModuleName -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsQTyVars Ghc.GhcPs -> @@ -159,16 +148,15 @@ handleHsDeriving :: [Ghc.LHsDecl Ghc.GhcPs] ) ) -handleHsDeriving config moduleName lIdP lHsQTyVars lConDecls hsDeriving = do +handleHsDeriving moduleName lIdP lHsQTyVars lConDecls hsDeriving = do (dropOriginal, lHsDerivingClauses, (lImportDecls, lHsDecls)) <- - handleLHsDerivingClauses config moduleName lIdP lHsQTyVars lConDecls hsDeriving + handleLHsDerivingClauses moduleName lIdP lHsQTyVars lConDecls hsDeriving pure ( if dropOriginal then Nothing else Just lHsDerivingClauses, (lImportDecls, lHsDecls) ) handleLHsDerivingClauses :: - Config.Config -> Ghc.ModuleName -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsQTyVars Ghc.GhcPs -> @@ -181,11 +169,11 @@ handleLHsDerivingClauses :: [Ghc.LHsDecl Ghc.GhcPs] ) ) -handleLHsDerivingClauses config moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses = +handleLHsDerivingClauses moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses = do tuples <- mapM - (handleLHsDerivingClause config moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses) + (handleLHsDerivingClause moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses) lHsDerivingClauses let (mClauses, dropFlags, extras) = unzip3 tuples taggedExtras = zip dropFlags extras @@ -199,7 +187,6 @@ handleLHsDerivingClauses config moduleName lIdP lHsQTyVars lConDecls lHsDeriving ) handleLHsDerivingClause :: - Config.Config -> Ghc.ModuleName -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsQTyVars Ghc.GhcPs -> @@ -213,18 +200,18 @@ handleLHsDerivingClause :: [Ghc.LHsDecl Ghc.GhcPs] ) ) -handleLHsDerivingClause config moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses lHsDerivingClause = +handleLHsDerivingClause moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses lHsDerivingClause = case Ghc.unLoc lHsDerivingClause of Ghc.HsDerivingClause _ deriv_clause_strategy deriv_clause_tys - | Just options <- Common.parseDerivingStrategy deriv_clause_strategy -> do + | Common.isPlinthVia deriv_clause_strategy -> do let nonPlinthClauses = filter ( \c -> case Ghc.unLoc c of Ghc.HsDerivingClause _ s _ -> - Maybe.isNothing (Common.parseDerivingStrategy s) + not (Common.isPlinthVia s) ) lHsDerivingClauses (dropOriginal, lImportDecls, lHsDecls) <- - handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options nonPlinthClauses + handleLHsSigTypes moduleName lIdP lHsQTyVars lConDecls nonPlinthClauses . toLHsSigTypes $ Ghc.unLoc deriv_clause_tys pure (Nothing, dropOriginal, (lImportDecls, lHsDecls)) @@ -236,12 +223,10 @@ toLHsSigTypes derivClauseTys = case derivClauseTys of Ghc.DctMulti _ lHsSigTypes -> lHsSigTypes handleLHsSigTypes :: - Config.Config -> Ghc.ModuleName -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsQTyVars Ghc.GhcPs -> [Ghc.LConDecl Ghc.GhcPs] -> - [String] -> Ghc.HsDeriving Ghc.GhcPs -> [Ghc.LHsSigType Ghc.GhcPs] -> Ghc.Hsc @@ -249,22 +234,20 @@ handleLHsSigTypes :: [Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs] ) -handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options lHsDerivingClauses lHsSigTypes = +handleLHsSigTypes moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses lHsSigTypes = do tuples <- mapM - (handleLHsSigType config moduleName lIdP lHsQTyVars lConDecls options lHsDerivingClauses) + (handleLHsSigType moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses) lHsSigTypes let (dropFlags, importLists, declLists) = unzip3 tuples pure (or dropFlags, mconcat importLists, mconcat declLists) handleLHsSigType :: - Config.Config -> Ghc.ModuleName -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsQTyVars Ghc.GhcPs -> [Ghc.LConDecl Ghc.GhcPs] -> - [String] -> Ghc.HsDeriving Ghc.GhcPs -> Ghc.LHsSigType Ghc.GhcPs -> Ghc.Hsc @@ -272,15 +255,15 @@ handleLHsSigType :: [Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs] ) -handleLHsSigType config moduleName lIdP lHsQTyVars lConDecls options lHsDerivingClauses lHsSigType = +handleLHsSigType moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses lHsSigType = do let srcSpan = Ghc.getLocA lHsSigType (dropOriginal, lImportDecls, lHsDecls) <- case getGenerator lHsSigType of Just generate -> - generate lHsDerivingClauses moduleName lIdP lHsQTyVars lConDecls options srcSpan + generate lHsDerivingClauses moduleName lIdP lHsQTyVars lConDecls srcSpan Nothing -> Hsc.throwError srcSpan $ Ghc.text "unsupported type class" - verbose <- isVerbose config + verbose <- isVerbose Monad.when verbose $ do IO.liftIO $ do putStrLn $ replicate 80 '-' @@ -289,10 +272,11 @@ handleLHsSigType config moduleName lIdP lHsQTyVars lConDecls options lHsDeriving pure (dropOriginal, lImportDecls, lHsDecls) -isVerbose :: Config.Config -> Ghc.Hsc Bool -isVerbose config = do +-- | Whether to dump the generated declarations, driven by @-ddump-deriv@. +isVerbose :: Ghc.Hsc Bool +isVerbose = do dynFlags <- Ghc.getDynFlags - pure $ Config.verbose config || Ghc.dopt Ghc.Opt_D_dump_deriv dynFlags + pure $ Ghc.dopt Ghc.Opt_D_dump_deriv dynFlags getGenerator :: Ghc.LHsSigType Ghc.GhcPs -> Maybe (Ghc.HsDeriving Ghc.GhcPs -> Common.Generator) getGenerator lHsSigType = do diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs index b682dc2ea5a..bcf65d56484 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs @@ -50,7 +50,7 @@ import qualified GHC.Types.SourceText as Ghc -- > -- > {-# COMPLETE Ex1, Ex2 #-} generate :: Ghc.HsDeriving Ghc.GhcPs -> Common.Generator -generate remainingDerivs _moduleName lIdP lHsQTyVars lConDecls _options srcSpan = do +generate remainingDerivs _moduleName lIdP lHsQTyVars lConDecls srcSpan = do type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan let constructors = Type.constructors type_ when (null constructors) $ diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Common.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Common.hs index b48a532f303..15e218913ec 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Common.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Common.hs @@ -9,7 +9,7 @@ module PlutusTx.Plugin.Deriving.Generator.Common makeLHsBind, makeRandomModule, makeRandomVariable, - parseDerivingStrategy, + isPlinthVia, ) where @@ -40,7 +40,6 @@ type Generator = Ghc.LIdP Ghc.GhcPs -> Ghc.LHsQTyVars Ghc.GhcPs -> [Ghc.LConDecl Ghc.GhcPs] -> - [String] -> Ghc.SrcSpan -> Ghc.Hsc (Bool, [Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs]) @@ -346,9 +345,9 @@ counterRef = Unsafe.unsafePerformIO $ IORef.newIORef 0 -- -- This function is responsible for analyzing a deriving strategy to determine -- if the plugin should fire or not. -parseDerivingStrategy :: - Maybe (Ghc.LDerivStrategy Ghc.GhcPs) -> Maybe [String] -parseDerivingStrategy mLDerivStrategy = do +isPlinthVia :: + Maybe (Ghc.LDerivStrategy Ghc.GhcPs) -> Bool +isPlinthVia mLDerivStrategy = Maybe.fromMaybe False $ do lDerivStrategy <- mLDerivStrategy lHsSigType <- case Ghc.unLoc lDerivStrategy of Ghc.ViaStrategy (Ghc.XViaStrategyPs _ x) -> Just $ Ghc.unLoc x @@ -358,7 +357,5 @@ parseDerivingStrategy mLDerivStrategy = do rdrName <- case Ghc.unLoc lHsType of Ghc.HsTyVar _ _ x -> Just $ Ghc.unLoc x _ -> Nothing - case Ghc.occNameString $ Ghc.rdrNameOcc rdrName of - "Plinth" -> Just [] - _ -> Nothing + pure $ Ghc.occNameString (Ghc.rdrNameOcc rdrName) == "Plinth" diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs index 0cdb4e2b105..3aca78f753e 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs @@ -49,7 +49,7 @@ import qualified GHC.Plugins as Ghc -- > in f_ ((PlutusTx.unsafeFromBuiltinData (head args_)) :: Credential) -- > ((PlutusTx.unsafeFromBuiltinData (head (tail args_))) :: Maybe StakingCredential) generate :: Ghc.HsDeriving Ghc.GhcPs -> Common.Generator -generate _ _moduleName lIdP lHsQTyVars lConDecls _options srcSpan = do +generate _ _moduleName lIdP lHsQTyVars lConDecls srcSpan = do type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan let constructors = Type.constructors type_ when (null constructors) $ diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Optics.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Optics.hs index 0f27b964820..6222424eba1 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Optics.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Optics.hs @@ -29,7 +29,7 @@ import qualified GHC.Plugins as Ghc -- > _Circle :: Prism' Shape Integer -- > _Rectangle :: Prism' Shape (Integer, Integer) generate :: Ghc.HsDeriving Ghc.GhcPs -> Common.Generator -generate _ _moduleName lIdP lHsQTyVars lConDecls _options srcSpan = do +generate _ _moduleName lIdP lHsQTyVars lConDecls srcSpan = do type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan lens <- Common.makeRandomModule Module.controlLens let lImportDecls = Hs.importDecls srcSpan [(Module.controlLens, lens)] diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Options.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Options.hs deleted file mode 100644 index 48f8471b8c6..00000000000 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Options.hs +++ /dev/null @@ -1,39 +0,0 @@ -module PlutusTx.Plugin.Deriving.Options - ( parse, - ) -where - -import qualified Control.Monad as Monad -import qualified PlutusTx.Plugin.Deriving.Hsc as Hsc -import qualified GHC.Plugins as Ghc -import qualified System.Console.GetOpt as Console - --- | Parses command line options. Adds warnings and throws errors as --- appropriate. Returns the list of parsed options. -parse :: [Console.OptDescr a] -> [String] -> Ghc.SrcSpan -> Ghc.Hsc [a] -parse optDescrs strings srcSpan = do - let (xs, args, opts, errs) = Console.getOpt' Console.Permute optDescrs strings - Monad.forM_ opts $ - Hsc.addWarning srcSpan - . Ghc.text - . mappend "unknown option: " - . quote - Monad.forM_ args $ - Hsc.addWarning srcSpan - . Ghc.text - . mappend "unexpected argument: " - . quote - Monad.unless (null errs) - . Hsc.throwError srcSpan - . Ghc.vcat - . fmap Ghc.text - . lines - $ mconcat errs - pure xs - --- | Quotes a string using GHC's weird quoting format. --- --- >>> quote "thing" --- "`thing'" -quote :: String -> String -quote string = "`" <> string <> "'" diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Config.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Config.hs deleted file mode 100644 index 4f5b5cafa95..00000000000 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Config.hs +++ /dev/null @@ -1,27 +0,0 @@ -module PlutusTx.Plugin.Deriving.Type.Config - ( Config (..), - fromFlags, - ) -where - -import qualified Data.List as List -import qualified PlutusTx.Plugin.Deriving.Type.Flag as Flag - -data Config = Config - { help :: Bool, - verbose :: Bool, - version :: Bool - } - deriving stock (Eq, Show) - -initial :: Config -initial = Config {help = False, verbose = False, version = False} - -fromFlags :: Foldable t => t Flag.Flag -> Config -fromFlags = List.foldl' applyFlag initial - -applyFlag :: Config -> Flag.Flag -> Config -applyFlag config flag = case flag of - Flag.Help -> config {help = True} - Flag.Verbose -> config {verbose = True} - Flag.Version -> config {version = True} diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Flag.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Flag.hs deleted file mode 100644 index ac60f561c4b..00000000000 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Type/Flag.hs +++ /dev/null @@ -1,32 +0,0 @@ -module PlutusTx.Plugin.Deriving.Type.Flag - ( Flag (..), - options, - ) -where - -import qualified System.Console.GetOpt as Console - -data Flag - = Help - | Verbose - | Version - deriving stock (Eq, Show) - -options :: [Console.OptDescr Flag] -options = - [ Console.Option - ['h', '?'] - ["help"] - (Console.NoArg Help) - "shows this help message and exits", - Console.Option - ['v'] - ["version"] - (Console.NoArg Version) - "shows the version number and exits", - Console.Option - [] - ["verbose"] - (Console.NoArg Verbose) - "outputs derived instances" - ] From a03a6ac0fd3e851400f41dd40cf08b4a9204d24f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Thu, 18 Jun 2026 16:47:52 +0100 Subject: [PATCH 09/13] Generate top-level signatures for AsData pattern synonyms Per review: emit 'pattern Con :: t0 -> ... -> T a b' signatures alongside the generated pattern synonyms, so user modules no longer need -Wno-missing-pattern-synonym-signatures (dropped from the activation test). Co-Authored-By: Claude Opus 4.8 --- .../Plugin/Deriving/Generator/AsData.hs | 28 +++++++++++++++---- .../test-frontend-plugin/AsData/Spec.hs | 7 ++--- 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs index bcf65d56484..76a61b4fe87 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs @@ -77,7 +77,7 @@ generate remainingDerivs _moduleName lIdP lHsQTyVars lConDecls srcSpan = do (\(idx, con) -> makePatSynDecl srcSpan type_ con idx plutusTx plutusTxBuiltins) (zip [0 ..] constructors) - pure (True, lImportDecls, newtypeDecl : patSynDecls <> [completeDecl]) + pure (True, lImportDecls, newtypeDecl : concat patSynDecls <> [completeDecl]) when :: Applicative f => Bool -> f () -> f () when True action = action @@ -219,7 +219,7 @@ makePatSynDecl :: Integer -> Ghc.ModuleName -> Ghc.ModuleName -> - Ghc.Hsc (Ghc.LHsDecl Ghc.GhcPs) + Ghc.Hsc [Ghc.LHsDecl Ghc.GhcPs] makePatSynDecl srcSpan type_ constructor idx plutusTx plutusTxBuiltins = do let fields = Constructor.fields constructor arity = length fields @@ -302,9 +302,27 @@ makePatSynDecl srcSpan type_ constructor idx plutusTx plutusTxBuiltins = do Hs.mg (Ghc.L srcSpan [builderMatch]) } - pure $ - Ghc.noLocA $ - Ghc.ValD Ghc.noExtField patSynBind + patSynDecl = Ghc.noLocA $ Ghc.ValD Ghc.noExtField patSynBind + + -- The top-level signature: @pattern Con :: t0 -> ... -> tn -> T a b ...@ + tv n = Hs.tyVar srcSpan (Ghc.L (Ghc.noAnnSrcSpan srcSpan) n) + resultTy = + foldl + (\acc v -> Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.HsAppTy Ghc.noExtField acc (tv v))) + (tv (Type.name type_)) + (Type.variables type_) + patSynTy = + foldr + (\f acc -> Hs.funTy srcSpan (Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Field.type_ f)) acc) + resultTy + fields + sigDecl = + Ghc.noLocA . Ghc.SigD Ghc.noExtField $ + Ghc.PatSynSig Ghc.noAnn [lConName] $ + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit patSynTy + + pure [sigDecl, patSynDecl] -- | Wrap an expression with a type annotation: @(expr :: ty)@. typeAnnotate :: diff --git a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs index a59af8df187..cd41aa7cab7 100644 --- a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs +++ b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs @@ -1,12 +1,11 @@ {-# OPTIONS_GHC -fplugin Plinth.Plugin #-} {-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:datatypes=BuiltinCasing #-} --- The plugin-generated code uses 'head'/'tail' internally and emits pattern --- synonyms without top-level signatures; suppress those warnings here (the --- -Wno-unrecognised-warning-flags keeps -Wno-x-partial harmless pre-GHC 9.8). +-- The plugin-generated code still uses 'head'/'tail' internally; suppress that +-- warning here (the -Wno-unrecognised-warning-flags keeps -Wno-x-partial +-- harmless pre-GHC 9.8, where the flag does not exist). {-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} {-# OPTIONS_GHC -Wno-x-partial #-} -{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} From 3e20137c5e456574a6345ac9ba68406f57d81f92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Thu, 18 Jun 2026 16:53:34 +0100 Subject: [PATCH 10/13] Generate explicit arg matches instead of head/tail in AsData decoders Per review: the generated view function now binds the constructor's arguments with an explicit list pattern \case args_ of { [a0, a1, ...] -> Just (decode a0, decode a1, ...); _ -> Nothing } instead of indexing with head/(tail^n). The generated code is now total, so the AsData activation test drops -Wno-x-partial entirely. Co-Authored-By: Claude Opus 4.8 --- .../Plugin/Deriving/Generator/AsData.hs | 71 +++++++++++-------- .../test-frontend-plugin/AsData/Spec.hs | 5 -- 2 files changed, 41 insertions(+), 35 deletions(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs index 76a61b4fe87..3d4e4d7c1d7 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/AsData.hs @@ -228,6 +228,7 @@ makePatSynDecl srcSpan type_ constructor idx plutusTx plutusTxBuiltins = do dVar <- Common.makeRandomVariable srcSpan "d_" tagVar <- Common.makeRandomVariable srcSpan "tag_" argsVar <- Common.makeRandomVariable srcSpan "args_" + viewVars <- mapM (\_ -> Common.makeRandomVariable srcSpan "a_") fields let conRdrName = Constructor.name constructor lConName = Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.mkRdrUnqual (Ghc.rdrNameOcc conRdrName) @@ -265,7 +266,7 @@ makePatSynDecl srcSpan type_ constructor idx plutusTx plutusTxBuiltins = do -- The match (destructor) pattern uses a view pattern: -- Example_BD (viewFn -> matchPat) - viewFn = makeViewFn srcSpan fields idx dVar tagVar argsVar plutusTx plutusTxBuiltins + viewFn = makeViewFn srcSpan fields idx dVar tagVar argsVar viewVars plutusTx plutusTxBuiltins matchPat = makeMatchPat srcSpan arity vars matchPat' = @@ -361,10 +362,11 @@ makeViewFn :: Ghc.LIdP Ghc.GhcPs -> Ghc.LIdP Ghc.GhcPs -> Ghc.LIdP Ghc.GhcPs -> + [Ghc.LIdP Ghc.GhcPs] -> Ghc.ModuleName -> Ghc.ModuleName -> Ghc.LHsExpr Ghc.GhcPs -makeViewFn srcSpan fields idx dVar tagVar argsVar plutusTx plutusTxBuiltins = +makeViewFn srcSpan fields idx dVar tagVar argsVar viewVars plutusTx plutusTxBuiltins = let ptx = Hs.qualVar srcSpan plutusTx blt = Hs.qualVar srcSpan plutusTxBuiltins arity = length fields @@ -387,21 +389,6 @@ makeViewFn srcSpan fields idx dVar tagVar argsVar plutusTx plutusTxBuiltins = tagBind = mkLetFun tagVar getFst argsBind = mkLetFun argsVar getSnd - -- head (tail^n argsVar) - nthElem n = - Hs.app srcSpan - (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "head"))) - ( Hs.par srcSpan $ - iterate - ( \e -> - Hs.app srcSpan - (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "tail"))) - (Hs.par srcSpan e) - ) - (Hs.var srcSpan argsVar) - !! n - ) - -- (unsafeFromBuiltinData e) :: fieldType decode fieldType e = typeAnnotate srcSpan fieldType $ @@ -409,26 +396,50 @@ makeViewFn srcSpan fields idx dVar tagVar argsVar plutusTx plutusTxBuiltins = (ptx (Ghc.mkVarOcc "unsafeFromBuiltinData")) (Hs.par srcSpan e) - -- value to wrap in Just - inner = case arity of - 0 -> + -- The decoded fields, sourced from the explicitly bound @viewVars@. + decoded = case zip viewVars fields of + [(v, f)] -> decode (Field.type_ f) (Hs.var srcSpan v) + vfs -> Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ - Ghc.ExplicitTuple Ghc.noAnn [] Ghc.Boxed - 1 -> - decode (Field.type_ (head fields)) (nthElem 0) - _ -> - let elems = fmap (\(n, f) -> decode (Field.type_ f) (nthElem n)) (zip [0 ..] fields) - in Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ - Ghc.ExplicitTuple Ghc.noAnn (fmap Hs.tupArg elems) Ghc.Boxed + Ghc.ExplicitTuple + Ghc.noAnn + (fmap (\(v, f) -> Hs.tupArg (decode (Field.type_ f) (Hs.var srcSpan v))) vfs) + Ghc.Boxed - justInner = + justDecoded = Hs.app srcSpan (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Just"))) - (Hs.par srcSpan inner) + (Hs.par srcSpan decoded) nothingExpr = Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Nothing")) + -- case args_ of { [a0, ...] -> Just ; _ -> Nothing } + argsListPat = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ListPat Ghc.noAnn (fmap (Hs.varPat srcSpan) viewVars) + wildPat = Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.WildPat Ghc.noExtField) + argsCase = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsCase Ghc.noAnn (Hs.var srcSpan argsVar) $ + Hs.mg $ + Ghc.L srcSpan + [ Hs.caseMatch srcSpan [argsListPat] (Common.makeGRHSs srcSpan justDecoded), + Hs.caseMatch srcSpan [wildPat] (Common.makeGRHSs srcSpan nothingExpr) + ] + + -- nullary: @Just ()@; otherwise the explicit-match case above + thenExpr = + if arity == 0 + then + Hs.app srcSpan + (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkDataOcc "Just"))) + ( Hs.par srcSpan $ + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ExplicitTuple Ghc.noAnn [] Ghc.Boxed + ) + else argsCase + -- tagVar == idx cond = Hs.opApp srcSpan @@ -438,7 +449,7 @@ makeViewFn srcSpan fields idx dVar tagVar argsVar plutusTx plutusTxBuiltins = ifExpr = Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ - Ghc.HsIf Ghc.noAnn cond justInner nothingExpr + Ghc.HsIf Ghc.noAnn cond thenExpr nothingExpr -- omit argsBind for nullary constructors (avoid unused-variable warning) letBinds = if arity == 0 then [tagBind] else [tagBind, argsBind] diff --git a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs index cd41aa7cab7..c797ddeb581 100644 --- a/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs +++ b/plutus-tx-plugin/test-frontend-plugin/AsData/Spec.hs @@ -1,11 +1,6 @@ {-# OPTIONS_GHC -fplugin Plinth.Plugin #-} {-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:datatypes=BuiltinCasing #-} --- The plugin-generated code still uses 'head'/'tail' internally; suppress that --- warning here (the -Wno-unrecognised-warning-flags keeps -Wno-x-partial --- harmless pre-GHC 9.8, where the flag does not exist). -{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} -{-# OPTIONS_GHC -Wno-x-partial #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} From 0485a83b70c1b6271e791deab8aaaae115385d4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Thu, 18 Jun 2026 17:10:02 +0100 Subject: [PATCH 11/13] Generate explicit arg matches in Match decoder; add Match activation test The Match destructor no longer uses head/(tail^n) to index the constructor's arguments; it binds them with an explicit list pattern \case args_ of { [a0, a1, ...] -> f_ (decode a0) (decode a1) ...; _ -> PlutusTx.Builtins.error () } The wildcard branch is unreachable for well-formed Data and uses the on-chain error builtin, matching the previous head/tail crash-on-malformed behaviour. Adds Match/Spec.hs (deriving (AsData, Match) via Plinth) which exercises matchShape's dispatch + field decoding at runtime, so the codegen is verified end-to-end in CI like the AsData test. Co-Authored-By: Claude Opus 4.8 --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + .../Plugin/Deriving/Generator/Match.hs | 80 +++++++++++-------- .../test-frontend-plugin/Match/Spec.hs | 40 ++++++++++ plutus-tx-plugin/test-frontend-plugin/Spec.hs | 2 + 4 files changed, 89 insertions(+), 34 deletions(-) create mode 100644 plutus-tx-plugin/test-frontend-plugin/Match/Spec.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 979d1829ef6..b49a019b01a 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -260,6 +260,7 @@ test-suite frontend-plugin-tests AsData.Spec Inlineable.Lib Inlineable.Spec + Match.Spec NoStrict.Spec Strict.Spec diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs index 3aca78f753e..2b902968a1b 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs @@ -102,6 +102,10 @@ makeMatchDecls srcSpan type_ constructors plutusTx plutusTxBuiltins = do tagVar <- Common.makeRandomVariable srcSpan "tag_" argsVar <- Common.makeRandomVariable srcSpan "args_" contVars <- mapM (\_ -> Common.makeRandomVariable srcSpan "f_") constructors + fieldVarss <- + mapM + (mapM (\_ -> Common.makeRandomVariable srcSpan "a_") . Constructor.fields) + constructors rVar <- Common.makeRandomVariable srcSpan "r_" let sigDecl = makeSigDecl srcSpan type_ constructors funId rVar @@ -115,6 +119,7 @@ makeMatchDecls srcSpan type_ constructors plutusTx plutusTxBuiltins = do argsVar internalCon contVars + fieldVarss plutusTx plutusTxBuiltins @@ -191,46 +196,54 @@ makeValDecl :: Ghc.LIdP Ghc.GhcPs -> Ghc.LIdP Ghc.GhcPs -> [Ghc.LIdP Ghc.GhcPs] -> + [[Ghc.LIdP Ghc.GhcPs]] -> Ghc.ModuleName -> Ghc.ModuleName -> Ghc.LHsDecl Ghc.GhcPs -makeValDecl srcSpan constructors funOcc dVar tagVar argsVar internalCon contVars plutusTx plutusTxBuiltins = +makeValDecl srcSpan constructors funOcc dVar tagVar argsVar internalCon contVars fieldVarss plutusTx plutusTxBuiltins = let ptx = Hs.qualVar srcSpan plutusTx blt = Hs.qualVar srcSpan plutusTxBuiltins - -- head (tail^n args_) - nthElem n = - Hs.app srcSpan - (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "head"))) - ( Hs.par srcSpan $ - iterate - ( \e -> - Hs.app srcSpan - (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "tail"))) - (Hs.par srcSpan e) - ) - (Hs.var srcSpan argsVar) - !! n - ) - - -- (unsafeFromBuiltinData (head/tail^n args_)) :: FieldType - decodeField n field = + -- (unsafeFromBuiltinData e) :: FieldType + decode field e = typeAnnotate srcSpan (Field.type_ field) $ Hs.app srcSpan (ptx (Ghc.mkVarOcc "unsafeFromBuiltinData")) - (Hs.par srcSpan (nthElem n)) - - -- f_ decoded_field_0 decoded_field_1 ... - applyFn fVar fields = - List.foldl' - (Hs.app srcSpan) - (Hs.var srcSpan fVar) - (zipWith decodeField [0 ..] fields) + (Hs.par srcSpan e) + + unitExpr = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.ExplicitTuple Ghc.noAnn [] Ghc.Boxed + + -- Apply a continuation to the decoded fields, binding them with an + -- explicit list pattern rather than head/tail: + -- @case args_ of { [a0, ...] -> f_ (decode a0) ...; _ -> error () }@. + -- The wildcard branch is unreachable for well-formed Data. + applyFn fVar fields fieldVars = case fields of + [] -> Hs.var srcSpan fVar + _ -> + let applied = + List.foldl' + (Hs.app srcSpan) + (Hs.var srcSpan fVar) + (zipWith (\f v -> decode f (Hs.var srcSpan v)) fields fieldVars) + listPat = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.ListPat Ghc.noAnn (fmap (Hs.varPat srcSpan) fieldVars) + wildPat = Ghc.L (Ghc.noAnnSrcSpan srcSpan) (Ghc.WildPat Ghc.noExtField) + errExpr = + Hs.app srcSpan (blt (Ghc.mkVarOcc "error")) (Hs.par srcSpan unitExpr) + in Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.HsCase Ghc.noAnn (Hs.var srcSpan argsVar) $ + Hs.mg $ + Ghc.L srcSpan + [ Hs.caseMatch srcSpan [listPat] (Common.makeGRHSs srcSpan applied), + Hs.caseMatch srcSpan [wildPat] (Common.makeGRHSs srcSpan errExpr) + ] -- Nested if-else dispatch; last constructor falls through without a tag check - makeDispatch [] _ = error "Match.makeDispatch: empty list" - makeDispatch [(fVar, con)] _ = applyFn fVar (Constructor.fields con) - makeDispatch ((fVar, con) : rest) (idx : idxs) = + makeDispatch [] = error "Match.makeDispatch: empty list" + makeDispatch [(_, fVar, con, fvs)] = applyFn fVar (Constructor.fields con) fvs + makeDispatch ((idx, fVar, con, fvs) : rest) = Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ Ghc.HsIf Ghc.noAnn ( Hs.opApp srcSpan @@ -238,9 +251,8 @@ makeValDecl srcSpan constructors funOcc dVar tagVar argsVar internalCon contVars (Hs.var srcSpan (Hs.unqual srcSpan (Ghc.mkVarOcc "=="))) (intLit srcSpan idx) ) - (applyFn fVar (Constructor.fields con)) - (makeDispatch rest idxs) - makeDispatch _ [] = error "Match.makeDispatch: ran out of indices" + (applyFn fVar (Constructor.fields con) fvs) + (makeDispatch rest) needsTag = length constructors > 1 needsArgs = any (not . null . Constructor.fields) constructors @@ -266,8 +278,8 @@ makeValDecl srcSpan constructors funOcc dVar tagVar argsVar internalCon contVars <> (if needsArgs then [argsBind] else []) innerBody = case constructors of - [con] -> applyFn (head contVars) (Constructor.fields con) - _ -> makeDispatch (zip contVars constructors) [0 ..] + [con] -> applyFn (head contVars) (Constructor.fields con) (head fieldVarss) + _ -> makeDispatch (List.zip4 [0 ..] contVars constructors fieldVarss) body = if null letBinds diff --git a/plutus-tx-plugin/test-frontend-plugin/Match/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/Match/Spec.hs new file mode 100644 index 00000000000..86ac2d04ca8 --- /dev/null +++ b/plutus-tx-plugin/test-frontend-plugin/Match/Spec.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -fplugin Plinth.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:datatypes=BuiltinCasing #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-| Activation test for the @Match@ generator (the CPS destructor). + +Compiled with the Plinth plugin, @deriving (AsData, Match) via Plinth@ must +produce the @Circle@/@Rectangle@ pattern synonyms /and/ a destructor + +> matchShape :: Shape -> (Integer -> r) -> (Integer -> Integer -> r) -> r + +'firstField' constructs values via the AsData synonyms and destructures them +via @matchShape@, exercising both continuations and the (now head/tail-free) +field decoding. If the plugin does not fire, @matchShape@ is undefined and this +module fails to compile. +-} +module Match.Spec (tests) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +data Shape + = Circle Integer + | Rectangle Integer Integer + deriving (AsData, Match) via Plinth + +firstField :: Shape -> Integer +firstField s = matchShape s (\r -> r) (\w _ -> w) + +tests :: TestTree +tests = + testGroup + "Match via Plinth" + [ testCase "matchShape dispatches on the tag and decodes fields" $ do + firstField (Circle 7) @?= 7 + firstField (Rectangle 3 5) @?= 3 + ] diff --git a/plutus-tx-plugin/test-frontend-plugin/Spec.hs b/plutus-tx-plugin/test-frontend-plugin/Spec.hs index a2a2b13d63b..fdece905859 100644 --- a/plutus-tx-plugin/test-frontend-plugin/Spec.hs +++ b/plutus-tx-plugin/test-frontend-plugin/Spec.hs @@ -2,6 +2,7 @@ module Main (main) where import AsData.Spec qualified as AsData import Inlineable.Spec qualified as Inlineable +import Match.Spec qualified as Match import NoStrict.Spec qualified as NoStrict import Strict.Spec qualified as Strict @@ -22,4 +23,5 @@ tests = , Inlineable.tests ] , AsData.tests + , Match.tests ] From 0cbddc38e17d82282e53c616b83f4a8ae99371dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Thu, 18 Jun 2026 17:52:16 +0100 Subject: [PATCH 12/13] Fix Match result type variable namespace (r not in scope) matchShape's result type variable was generated from a value-namespace name (makeRandomVariable), so implicit quantification in the signature did not bind it and GHC reported 'not in scope'. Rebuild it as a type-variable-namespace name. (Latent bug surfaced by the new Match activation test.) Co-Authored-By: Claude Opus 4.8 --- .../src/PlutusTx/Plugin/Deriving/Generator/Match.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs index 2b902968a1b..0a709eb81a0 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Deriving/Generator/Match.hs @@ -138,7 +138,13 @@ makeSigDecl :: makeSigDecl srcSpan type_ constructors funId rVar = let loc = Ghc.noAnnSrcSpan srcSpan - rTy = Ghc.L loc $ Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted rVar + -- @rVar@ is made in the value namespace; as the result /type/ variable + -- it must be in the type-variable namespace, else implicit + -- quantification does not bind it ("not in scope"). + rTyName = + Ghc.L (Ghc.noAnnSrcSpan srcSpan) $ + Ghc.mkRdrUnqual (Ghc.mkTyVarOcc (Ghc.occNameString (Ghc.rdrNameOcc (Ghc.unLoc rVar)))) + rTy = Ghc.L loc $ Ghc.HsTyVar Ghc.noAnn Ghc.NotPromoted rTyName -- A -> B -> ... -> r for a constructor's fields mkContTy fields = From f40105d1f215fd235279a32c3a14d5d6da0f8ce2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Fri, 19 Jun 2026 19:57:29 +0100 Subject: [PATCH 13/13] Re-trigger CI (flaky uplc-evaluator-integration-tests, SIGTERM) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit No code change. The previous run was fully green except a flaky failure in plutus-benchmark's uplc-evaluator-integration-tests, whose evaluator service exited with code -15 (SIGTERM) — unrelated to this PR. Co-Authored-By: Claude Opus 4.8