monoidal-plugins (empty) → 0.1.0.0

raw patch · 5 files changed

+181/−0 lines, 5 filesdep +basedep +ghc

Dependencies added: base, ghc

Files

• CHANGELOG.md +5/−0
• LICENSE +29/−0
• README.md +3/−0
• monoidal-plugins.cabal +29/−0
• src/MonoidalPlugins.hs +115/−0

@@ -0,0 +1,5 @@+# Revision history for monoidal-plugins++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,29 @@+Copyright (c) 2025, Aaron Allen+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,3 @@+# monoidal-plugins++A monoidal interface for aggregating GHC plugins

@@ -0,0 +1,29 @@+cabal-version:      3.0+name:               monoidal-plugins+version:            0.1.0.0+synopsis: A monoidal interface for aggregating GHC plugins+description: A monoidal interface for aggregating GHC plugins into a single plugin+category: Development+license:            BSD-3-Clause+license-file:       LICENSE+author:             Aaron Allen+maintainer:         aaronallen8455@gmail.com+copyright:          2025 Aaron Allen+build-type:         Simple+extra-doc-files:    CHANGELOG.md+                    README.md++source-repository head+  type: git+  location: https://github.com/aaronallen8455/monoidal-plugins++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  MonoidalPlugins+    build-depends:    base < 5,+                      ghc >= 9.6 && < 9.13+    hs-source-dirs:   src+    default-language: GHC2021

@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+module MonoidalPlugins+  ( MonoidalPlugin(..)+  , foldPlugins+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Coerce+import           Data.Foldable+import           Data.IORef+import           GHC.Driver.Plugins+#if MIN_VERSION_ghc(9,8,0)+import           GHC.Tc.Errors.Hole.Plugin+#else+import           GHC.Tc.Errors.Hole.FitTypes+#endif+import qualified GHC.Tc.Types as Tc++foldPlugins+  :: forall f. (Foldable f, Coercible (f Plugin) (f MonoidalPlugin))+  => f Plugin -> Plugin+foldPlugins = coerce . fold @f @MonoidalPlugin . coerce++newtype MonoidalPlugin = MonoidalPlugin { unMonoidalPlugin :: Plugin }++instance Semigroup MonoidalPlugin where+  MonoidalPlugin a <> MonoidalPlugin b = MonoidalPlugin Plugin+    { installCoreToDos = \opts ->+        installCoreToDos a opts >=> installCoreToDos b opts+    , tcPlugin = \opts -> coerce $+        (coerce $ tcPlugin a opts :: Maybe SGTcPlugin)+        <> coerce (tcPlugin b opts)+    , defaultingPlugin = \opts -> coerce $+        (coerce $ defaultingPlugin a opts :: Maybe SGDefaultingPlugin)+        <> coerce (defaultingPlugin b opts)+    , holeFitPlugin = \opts -> coerce $+        (coerce $ holeFitPlugin a opts :: Maybe SGHoleFitPlugin)+        <> coerce (holeFitPlugin b opts)+    , driverPlugin = \opts -> driverPlugin a opts >=> driverPlugin b opts+#if MIN_VERSION_ghc(9,10,0)+    , latePlugin = \hscEnv opts -> latePlugin a hscEnv opts >=> latePlugin b hscEnv opts+#endif+    , pluginRecompile = \opts ->+        pluginRecompile a opts <> pluginRecompile b opts+    , parsedResultAction = \opts modSum ->+        parsedResultAction a opts modSum >=> parsedResultAction b opts modSum+    , renamedResultAction = \opts gblEnv ->+        renamedResultAction a opts gblEnv >=> uncurry (renamedResultAction b opts)+    , typeCheckResultAction = \opts modSum ->+        typeCheckResultAction a opts modSum >=> typeCheckResultAction b opts modSum+    , spliceRunAction = \opts ->+        spliceRunAction a opts >=> spliceRunAction b opts+    , interfaceLoadAction = \opts ->+        interfaceLoadAction a opts >=> interfaceLoadAction b opts+    }++instance Monoid MonoidalPlugin where+  mempty = MonoidalPlugin defaultPlugin { pluginRecompile = mempty }++newtype SGHoleFitPlugin = SGHoleFitPlugin HoleFitPluginR++instance Semigroup SGHoleFitPlugin where+  SGHoleFitPlugin (HoleFitPluginR initA runA stopA)+    <> SGHoleFitPlugin (HoleFitPluginR initB runB stopB) =+    SGHoleFitPlugin HoleFitPluginR+    { hfPluginInit = do+        r1 <- initA+        r2 <- initB+        liftIO $ newIORef (r1, r2)+    , hfPluginRun = \ref ->+        HoleFitPlugin+          { candPlugin = \hole xs -> do+              (r1, r2) <- liftIO $ readIORef ref+              candPlugin (runA r1) hole xs >>= candPlugin (runB r2) hole+          , fitPlugin = \hole xs -> do+              (r1, r2) <- liftIO $ readIORef ref+              fitPlugin (runA r1) hole xs >>= fitPlugin (runB r2) hole+          }+    , hfPluginStop = \ref -> do+        (r1, r2) <- liftIO $ readIORef ref+        stopA r1+        stopB r2+    }++newtype SGDefaultingPlugin = SGDefaultingPlugin Tc.DefaultingPlugin++instance Semigroup SGDefaultingPlugin where+  SGDefaultingPlugin (Tc.DefaultingPlugin initA runA stopA)+    <> SGDefaultingPlugin (Tc.DefaultingPlugin initB runB stopB) =+    SGDefaultingPlugin Tc.DefaultingPlugin+    { Tc.dePluginInit = (,) <$> initA <*> initB+    , Tc.dePluginRun = \(s1, s2) wc -> do+        (<>) <$> runA s1 wc <*> runB s2 wc+    , Tc.dePluginStop = \(s1, s2) -> stopA s1 >> stopB s2+    }++newtype SGTcPlugin = SGTcPlugin Tc.TcPlugin++instance Semigroup SGTcPlugin where+  SGTcPlugin (Tc.TcPlugin initA solveA rewriteA stopA)+    <> SGTcPlugin (Tc.TcPlugin initB solveB rewriteB stopB) =+    SGTcPlugin Tc.TcPlugin+    { Tc.tcPluginInit = (,) <$> initA <*> initB+    , Tc.tcPluginSolve = \(s1, s2) evBinds givens wanteds -> do+        r1 <- solveA s1 evBinds givens wanteds+        r2 <- solveB s2 evBinds givens wanteds+        pure Tc.TcPluginSolveResult+          { Tc.tcPluginInsolubleCts = Tc.tcPluginInsolubleCts r1 <> Tc.tcPluginInsolubleCts r2+          , Tc.tcPluginSolvedCts = Tc.tcPluginSolvedCts r1 <> Tc.tcPluginSolvedCts r2+          , Tc.tcPluginNewCts = Tc.tcPluginNewCts r1 <> Tc.tcPluginNewCts r2+          }+    , Tc.tcPluginRewrite = \(s1, s2) -> rewriteA s1 <> rewriteB s2+    , Tc.tcPluginStop = \(s1, s2) -> stopA s1 >> stopB s2+    }