refactor: Internal module for RewriteRules, Monoid Instance

plutus-core/plutus-core.cabal

@@ -490,6 +490,7 @@ executable uplc
 library plutus-ir
   import:          lang
   visibility:      public
+  hs-source-dirs:  plutus-ir/src
   exposed-modules:
     PlutusIR
     PlutusIR.Analysis.Builtins
@@ -544,7 +545,6 @@ library plutus-ir
     PlutusIR.TypeCheck
     PlutusIR.TypeCheck.Internal
 
-  hs-source-dirs:  plutus-ir/src
   other-modules:
     PlutusIR.Analysis.Definitions
     PlutusIR.Analysis.Size
@@ -554,7 +554,7 @@ library plutus-ir
     PlutusIR.Compiler.Recursion
     PlutusIR.Normalize
     PlutusIR.Transform.RewriteRules.Common
-    PlutusIR.Transform.RewriteRules.Rules
+    PlutusIR.Transform.RewriteRules.Internal
     PlutusIR.Transform.RewriteRules.UnConstrConstrData
 
   build-depends:

plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs

@@ -27,7 +27,7 @@ import PlutusCore.Quote
 import PlutusCore.StdLib.Type qualified as Types
 import PlutusCore.TypeCheck.Internal qualified as PLC
 import PlutusCore.Version qualified as PLC
-import PlutusIR.Transform.RewriteRules.Rules
+import PlutusIR.Transform.RewriteRules.Internal (RewriteRules)
 import PlutusPrelude
 
 import Control.Monad.Error.Lens (throwing)

plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs

@@ -6,7 +6,8 @@ module PlutusIR.Transform.RewriteRules
     ( rewriteWith
     , rewritePass
     , rewritePassSC
-    , RewriteRules (..)
+    , RewriteRules
+    , unRewriteRules
     , defaultUniRewriteRules
     ) where
 
@@ -16,7 +17,7 @@ import PlutusCore.Name.Unique
 import PlutusCore.Quote
 import PlutusIR as PIR
 import PlutusIR.Analysis.VarInfo
-import PlutusIR.Transform.RewriteRules.Rules
+import PlutusIR.Transform.RewriteRules.Internal
 
 import Control.Lens
 import PlutusIR.Pass
@@ -61,11 +62,11 @@ rewriteWith :: ( Monoid a, t ~ Term tyname Name uni fun a
             => RewriteRules uni fun
             -> t
             -> m t
-rewriteWith (RewriteRules rules) t =
+rewriteWith rules t =
     -- We collect `VarsInfo` on the whole program term and pass it on as arg to each RewriteRule.
     -- This has the limitation that any variables newly-introduced by the rules would
     -- not be accounted in `VarsInfo`. This is currently fine, because we only rely on VarsInfo
     -- for isPure; isPure is safe w.r.t "open" terms.
     let vinfo = termVarInfo t
-    in transformMOf termSubterms (rules vinfo) t
+    in transformMOf termSubterms (unRewriteRules rules vinfo) t
 

plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Internal.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE RankNTypes        #-}
+
+module PlutusIR.Transform.RewriteRules.Internal
+  ( RewriteRules (..)
+  , defaultUniRewriteRules
+  ) where
+
+import PlutusCore.Default (DefaultFun, DefaultUni)
+import PlutusCore.Name.Unique (Name)
+import PlutusCore.Quote (MonadQuote)
+import PlutusIR.Analysis.VarInfo (VarsInfo)
+import PlutusIR.Core.Type qualified as PIR
+import PlutusIR.Transform.RewriteRules.CommuteFnWithConst (commuteFnWithConst)
+import PlutusIR.Transform.RewriteRules.UnConstrConstrData (unConstrConstrData)
+import PlutusPrelude (Default (..), (>=>))
+
+-- | A bundle of composed `RewriteRules`, to be passed at entrypoint of the compiler.
+newtype RewriteRules uni fun where
+  RewriteRules
+    :: { unRewriteRules
+          :: forall tyname m a
+           . (MonadQuote m, Monoid a)
+          => VarsInfo tyname Name uni a
+          -> PIR.Term tyname Name uni fun a
+          -> m (PIR.Term tyname Name uni fun a)
+       }
+    -> RewriteRules uni fun
+
+-- | The rules for the Default Universe/Builtin.
+defaultUniRewriteRules :: RewriteRules DefaultUni DefaultFun
+defaultUniRewriteRules = RewriteRules $ \varsInfo ->
+  -- The rules are composed from left to right.
+  pure . commuteFnWithConst >=> unConstrConstrData def varsInfo
+
+instance Default (RewriteRules DefaultUni DefaultFun) where
+  def = defaultUniRewriteRules
+
+instance Semigroup (RewriteRules uni fun) where
+  RewriteRules r1 <> RewriteRules r2 = RewriteRules (\varsInfo -> r1 varsInfo >=> r2 varsInfo)
+
+instance Monoid (RewriteRules uni fun) where
+  mempty = RewriteRules (const pure)