diff --git a/polysemy-plugin/.gitignore b/polysemy-plugin/.gitignore new file mode 100644 index 0000000..d608413 --- /dev/null +++ b/polysemy-plugin/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +polysemy-plugin.cabal +*~ \ No newline at end of file diff --git a/polysemy-plugin/ChangeLog.md b/polysemy-plugin/ChangeLog.md new file mode 100644 index 0000000..c179139 --- /dev/null +++ b/polysemy-plugin/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for polysemy-plugin + +## Unreleased changes diff --git a/polysemy-plugin/LICENSE b/polysemy-plugin/LICENSE new file mode 100644 index 0000000..245fbd0 --- /dev/null +++ b/polysemy-plugin/LICENSE @@ -0,0 +1,30 @@ +Copyright Sandy Maguire (c) 2019 + +All rights reserved. + +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 Sandy Maguire nor the names of other + 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 +OWNER 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. diff --git a/polysemy-plugin/README.md b/polysemy-plugin/README.md new file mode 100644 index 0000000..6241f43 --- /dev/null +++ b/polysemy-plugin/README.md @@ -0,0 +1 @@ +# polysemy-plugin diff --git a/polysemy-plugin/Setup.hs b/polysemy-plugin/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/polysemy-plugin/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/polysemy-plugin/package.yaml b/polysemy-plugin/package.yaml new file mode 100644 index 0000000..aca95d0 --- /dev/null +++ b/polysemy-plugin/package.yaml @@ -0,0 +1,40 @@ +name: polysemy-plugin +version: 0.1.0.0 +github: "isovector/polysemy-plugin" +license: BSD3 +author: "Sandy Maguire" +maintainer: "sandy@sandymaguire.me" +copyright: "2019 Sandy Maguire" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- ghc +- ghc-tcplugins-extra +- polysemy + +library: + source-dirs: src + +tests: + polysemy-plugin-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - polysemy-plugin diff --git a/polysemy-plugin/src/Polysemy/Plugin.hs b/polysemy-plugin/src/Polysemy/Plugin.hs new file mode 100644 index 0000000..8968bd3 --- /dev/null +++ b/polysemy-plugin/src/Polysemy/Plugin.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} + +module Polysemy.Plugin + ( plugin + ) where + +-- external +import GHC.TcPluginM.Extra (lookupModule, lookupName) + +-- GHC API +import FastString (fsLit) +import Module (mkModuleName) +import OccName (mkTcOcc) +import Plugins (Plugin (..), defaultPlugin +#if __GLASGOW_HASKELL__ >= 806 + , PluginRecompile(..) +#endif + ) +import TcPluginM (TcPluginM, tcLookupClass) +import TcRnTypes +import TyCoRep (Type (..)) +import Control.Monad +import Class +import Type +import Data.Maybe +import TcSMonad hiding (tcLookupClass) +import CoAxiom +import Outputable + +plugin :: Plugin +plugin = defaultPlugin + { tcPlugin = const (Just fundepPlugin) +#if __GLASGOW_HASKELL__ >= 806 + , pluginRecompile = const (return NoForceRecompile) +#endif + } + +fundepPlugin :: TcPlugin +fundepPlugin = TcPlugin + { tcPluginInit = do + md <- lookupModule (mkModuleName "Polysemy") (fsLit "polysemy") + monadEffectTcNm <- lookupName md (mkTcOcc "Member") + tcLookupClass monadEffectTcNm + , tcPluginSolve = solveFundep + , tcPluginStop = const (return ()) } + +allMonadEffectConstraints :: Class -> [Ct] -> [(CtLoc, (Type, Type, Type))] +allMonadEffectConstraints cls cts = + [ (ctLoc cd, (effName, eff, mon)) + | cd@CDictCan{cc_class = cls', cc_tyargs = [eff, mon]} <- cts + , cls == cls' + , let (effName, _) = splitAppTys eff ] + +singleListToJust :: [a] -> Maybe a +singleListToJust [a] = Just a +singleListToJust _ = Nothing + +findMatchingEffectIfSingular :: (Type, Type, Type) -> [(Type, Type, Type)] -> Maybe Type +findMatchingEffectIfSingular (effName, _, mon) ts = singleListToJust + [ eff' + | (effName', eff', mon') <- ts + , eqType effName effName' + , eqType mon mon' ] + +solveFundep :: Class -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult +solveFundep effCls giv _ want = do + pprPanic "wat" $ ppr $ giv ++ want + let wantedEffs = allMonadEffectConstraints effCls want + let givenEffs = snd <$> allMonadEffectConstraints effCls giv + eqs <- forM wantedEffs $ \(loc, e@(_, eff, _)) -> + case findMatchingEffectIfSingular e givenEffs of + Nothing -> return Nothing + Just eff' -> do + (ev, _) <- unsafeTcPluginTcM + (runTcSDeriveds (newWantedEq loc Nominal eff eff')) + return (Just (CNonCanonical ev)) + return (TcPluginOk [] (catMaybes eqs)) + diff --git a/polysemy-plugin/test/Spec.hs b/polysemy-plugin/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/polysemy-plugin/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/stack.yaml b/stack.yaml index 032d267..b9c063b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: lts-13.0 packages: - . +- polysemy-plugin extra-deps: - dump-core-0.1.3.2