Add Plinth parsed-AST deriving plugin to plutus-tx-plugin

plutus-tx-plugin/changelog.d/20260616_plinth_deriving_plugin.md

@@ -0,0 +1,8 @@
+### Added
+
+- 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`).

plutus-tx-plugin/plutus-tx-plugin.cabal

@@ -56,11 +56,24 @@ library
   hs-source-dirs:  src
   exposed-modules:
     Plinth.Plugin
+    PlutusTx.Plugin.Deriving.Via
     PlutusTx.Compiler.Error
     PlutusTx.Options
     PlutusTx.Plugin.Common
 
   other-modules:
+    Paths_plutus_tx_plugin
+    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.Type.Constructor
+    PlutusTx.Plugin.Deriving.Type.Field
+    PlutusTx.Plugin.Deriving.Type.Type
     PlutusTx.Compiler.Binders
     PlutusTx.Compiler.Builtins
     PlutusTx.Compiler.Compat
@@ -77,6 +90,8 @@ library
     PlutusTx.Plugin.Boilerplate
     PlutusTx.Plugin.Unsupported
 
+  autogen-modules:  Paths_plutus_tx_plugin
+
   build-depends:
     , array
     , base                   >=4.9   && <5
@@ -242,8 +257,10 @@ test-suite frontend-plugin-tests
   hs-source-dirs: test-frontend-plugin
   main-is:        Spec.hs
   other-modules:
+    AsData.Spec
     Inlineable.Lib
     Inlineable.Spec
+    Match.Spec
     NoStrict.Spec
     Strict.Spec
 
@@ -254,6 +271,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
 

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

plutus-tx-plugin/src/PlutusTx/Plugin/Deriving.hs

@@ -0,0 +1,302 @@
+-- | 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
+
+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 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 GHC.Hs as Ghc
+import qualified GHC.Plugins as Ghc
+
+-- | 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 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 ::
+  Ghc.ModuleName ->
+  LHsModule ->
+  Ghc.Hsc LHsModule
+handleLHsModule moduleName lHsModule = do
+  hsModule <- handleHsModule moduleName $ Ghc.unLoc lHsModule
+  pure $ Ghc.L (Ghc.getLoc lHsModule) hsModule
+
+handleHsModule ::
+  Ghc.ModuleName ->
+  Ghc.HsModule Ghc.GhcPs ->
+  Ghc.Hsc (Ghc.HsModule Ghc.GhcPs)
+handleHsModule moduleName hsModule = do
+  (lImportDecls, lHsDecls) <-
+    handleLHsDecls moduleName $
+      Ghc.hsmodDecls hsModule
+  pure
+    hsModule
+      { Ghc.hsmodImports = Ghc.hsmodImports hsModule <> lImportDecls,
+        Ghc.hsmodDecls = lHsDecls
+      }
+
+handleLHsDecls ::
+  Ghc.ModuleName ->
+  [Ghc.LHsDecl Ghc.GhcPs] ->
+  Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])
+handleLHsDecls moduleName lHsDecls = do
+  tuples <- mapM (handleLHsDecl moduleName) lHsDecls
+  pure . Bifunctor.bimap mconcat mconcat $ unzip tuples
+
+handleLHsDecl ::
+  Ghc.ModuleName ->
+  Ghc.LHsDecl Ghc.GhcPs ->
+  Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])
+handleLHsDecl moduleName lHsDecl = case Ghc.unLoc lHsDecl of
+  Ghc.TyClD xTyClD tyClDecl1 -> do
+    (mTyClDecl2, (lImportDecls, lHsDecls)) <- handleTyClDecl 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 ::
+  Ghc.ModuleName ->
+  Ghc.TyClDecl Ghc.GhcPs ->
+  Ghc.Hsc
+    ( Maybe (Ghc.TyClDecl Ghc.GhcPs),
+      ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])
+    )
+handleTyClDecl moduleName tyClDecl = case tyClDecl of
+  Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity tcdDataDefn -> do
+    (mHsDataDefn, (lImportDecls, lHsDecls)) <-
+      handleHsDataDefn
+        moduleName
+        tcdLName
+        tcdTyVars
+        tcdDataDefn
+    pure
+      ( fmap (Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity) mHsDataDefn,
+        (lImportDecls, lHsDecls)
+      )
+  _ -> pure (Just tyClDecl, ([], []))
+
+handleHsDataDefn ::
+  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 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
+            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 ::
+  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 moduleName lIdP lHsQTyVars lConDecls hsDeriving = do
+  (dropOriginal, lHsDerivingClauses, (lImportDecls, lHsDecls)) <-
+    handleLHsDerivingClauses moduleName lIdP lHsQTyVars lConDecls hsDeriving
+  pure
+    ( if dropOriginal then Nothing else Just lHsDerivingClauses,
+      (lImportDecls, lHsDecls)
+    )
+
+handleLHsDerivingClauses ::
+  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 moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses =
+  do
+    tuples <-
+      mapM
+        (handleLHsDerivingClause 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 ::
+  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 moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses lHsDerivingClause =
+  case Ghc.unLoc lHsDerivingClause of
+    Ghc.HsDerivingClause _ deriv_clause_strategy deriv_clause_tys
+      | Common.isPlinthVia deriv_clause_strategy -> do
+          let nonPlinthClauses = filter
+                ( \c -> case Ghc.unLoc c of
+                    Ghc.HsDerivingClause _ s _ ->
+                      not (Common.isPlinthVia s)
+                )
+                lHsDerivingClauses
+          (dropOriginal, lImportDecls, lHsDecls) <-
+            handleLHsSigTypes moduleName lIdP lHsQTyVars lConDecls nonPlinthClauses
+              . 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 ::
+  Ghc.ModuleName ->
+  Ghc.LIdP Ghc.GhcPs ->
+  Ghc.LHsQTyVars Ghc.GhcPs ->
+  [Ghc.LConDecl Ghc.GhcPs] ->
+  Ghc.HsDeriving Ghc.GhcPs ->
+  [Ghc.LHsSigType Ghc.GhcPs] ->
+  Ghc.Hsc
+    ( Bool,
+      [Ghc.LImportDecl Ghc.GhcPs],
+      [Ghc.LHsDecl Ghc.GhcPs]
+    )
+handleLHsSigTypes moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses lHsSigTypes =
+  do
+    tuples <-
+      mapM
+        (handleLHsSigType moduleName lIdP lHsQTyVars lConDecls lHsDerivingClauses)
+        lHsSigTypes
+    let (dropFlags, importLists, declLists) = unzip3 tuples
+    pure (or dropFlags, mconcat importLists, mconcat declLists)
+
+handleLHsSigType ::
+  Ghc.ModuleName ->
+  Ghc.LIdP Ghc.GhcPs ->
+  Ghc.LHsQTyVars Ghc.GhcPs ->
+  [Ghc.LConDecl Ghc.GhcPs] ->
+  Ghc.HsDeriving Ghc.GhcPs ->
+  Ghc.LHsSigType Ghc.GhcPs ->
+  Ghc.Hsc
+    ( Bool,
+      [Ghc.LImportDecl Ghc.GhcPs],
+      [Ghc.LHsDecl Ghc.GhcPs]
+    )
+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 srcSpan
+      Nothing -> Hsc.throwError srcSpan $ Ghc.text "unsupported type class"
+
+    verbose <- isVerbose
+    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)
+
+-- | Whether to dump the generated declarations, driven by @-ddump-deriv@.
+isVerbose :: Ghc.Hsc Bool
+isVerbose = do
+  dynFlags <- Ghc.getDynFlags
+  pure $ 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