mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
plugin
This commit is contained in:
parent
d886b32fe4
commit
30169352e4
3
polysemy-plugin/.gitignore
vendored
Normal file
3
polysemy-plugin/.gitignore
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
.stack-work/
|
||||
polysemy-plugin.cabal
|
||||
*~
|
3
polysemy-plugin/ChangeLog.md
Normal file
3
polysemy-plugin/ChangeLog.md
Normal file
@ -0,0 +1,3 @@
|
||||
# Changelog for polysemy-plugin
|
||||
|
||||
## Unreleased changes
|
30
polysemy-plugin/LICENSE
Normal file
30
polysemy-plugin/LICENSE
Normal file
@ -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.
|
1
polysemy-plugin/README.md
Normal file
1
polysemy-plugin/README.md
Normal file
@ -0,0 +1 @@
|
||||
# polysemy-plugin
|
2
polysemy-plugin/Setup.hs
Normal file
2
polysemy-plugin/Setup.hs
Normal file
@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
40
polysemy-plugin/package.yaml
Normal file
40
polysemy-plugin/package.yaml
Normal file
@ -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 <https://github.com/isovector/polysemy-plugin#readme>
|
||||
|
||||
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
|
79
polysemy-plugin/src/Polysemy/Plugin.hs
Normal file
79
polysemy-plugin/src/Polysemy/Plugin.hs
Normal file
@ -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))
|
||||
|
2
polysemy-plugin/test/Spec.hs
Normal file
2
polysemy-plugin/test/Spec.hs
Normal file
@ -0,0 +1,2 @@
|
||||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented"
|
@ -2,6 +2,7 @@ resolver: lts-13.0
|
||||
|
||||
packages:
|
||||
- .
|
||||
- polysemy-plugin
|
||||
|
||||
extra-deps:
|
||||
- dump-core-0.1.3.2
|
||||
|
Loading…
Reference in New Issue
Block a user