mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
Fix the plugin (#62)
This commit is contained in:
parent
882cd80abf
commit
feacd2a001
@ -33,6 +33,8 @@ module Polysemy.Plugin.Fundep (fundepPlugin) where
|
||||
import Class
|
||||
import CoAxiom
|
||||
import Control.Monad
|
||||
import Data.Bifunctor
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import FastString (fsLit)
|
||||
import GHC (ModuleName)
|
||||
@ -61,10 +63,10 @@ fundepPlugin = TcPlugin
|
||||
allMonadEffectConstraints :: Class -> [Ct] -> [(CtLoc, (Type, Type, Type))]
|
||||
allMonadEffectConstraints cls cts =
|
||||
[ (ctLoc cd, (effName, eff, r))
|
||||
| cd@CDictCan{cc_class = cls', cc_tyargs = [_, r, eff]} <- cts
|
||||
, cls == cls'
|
||||
, let effName = getEffName eff
|
||||
]
|
||||
| cd@CDictCan{cc_class = cls', cc_tyargs = [_, r, eff]} <- cts
|
||||
, cls == cls'
|
||||
, let effName = getEffName eff
|
||||
]
|
||||
|
||||
singleListToJust :: [a] -> Maybe a
|
||||
singleListToJust [a] = Just a
|
||||
@ -81,10 +83,6 @@ getEffName :: Type -> Type
|
||||
getEffName t = fst $ splitAppTys t
|
||||
|
||||
|
||||
-- isTyVar :: Type -> Bool
|
||||
-- isTyVar = isJust . getTyVar_maybe
|
||||
|
||||
|
||||
canUnify :: Type -> Type -> Bool
|
||||
canUnify wanted given =
|
||||
let (w, ws) = splitAppTys wanted
|
||||
@ -96,26 +94,39 @@ canUnify wanted given =
|
||||
|
||||
|
||||
mkWanted :: Bool -> CtLoc -> Type -> Type -> TcPluginM (Maybe Ct)
|
||||
mkWanted mustUnify loc wanted given = do
|
||||
mkWanted mustUnify loc wanted given =
|
||||
if (not mustUnify || canUnify wanted given)
|
||||
then do
|
||||
(ev, _) <- unsafeTcPluginTcM $ runTcSDeriveds $ newWantedEq loc Nominal wanted given
|
||||
pure $ Just (CNonCanonical ev)
|
||||
pure $ Just $ CNonCanonical ev
|
||||
else
|
||||
pure Nothing
|
||||
|
||||
thd :: (a, b, c) -> c
|
||||
thd (_, _, c) = c
|
||||
|
||||
countLength :: (a -> a -> Bool) -> [a] -> [(a, Int)]
|
||||
countLength eq as =
|
||||
let grouped = groupBy eq as
|
||||
in zipWith (curry $ bimap head length) grouped grouped
|
||||
|
||||
solveFundep :: Class -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult
|
||||
solveFundep _ _ _ [] = pure $ TcPluginOk [] []
|
||||
solveFundep effCls giv _ want = do
|
||||
let wantedEffs = allMonadEffectConstraints effCls want
|
||||
let givenEffs = snd <$> allMonadEffectConstraints effCls giv
|
||||
eqs <- forM wantedEffs $ \(loc, e@(_, eff, r)) ->
|
||||
givenEffs = snd <$> allMonadEffectConstraints effCls giv
|
||||
num_wanteds_by_r = countLength eqType $ fmap (thd . snd) wantedEffs
|
||||
must_unify r =
|
||||
let Just num_wanted = find (eqType r . fst) num_wanteds_by_r
|
||||
in snd num_wanted /= 1
|
||||
|
||||
eqs <- forM wantedEffs $ \(loc, e@(_, eff, r)) -> do
|
||||
case findMatchingEffectIfSingular e givenEffs of
|
||||
Nothing -> do
|
||||
case splitAppTys r of
|
||||
(_, [_, eff', _]) -> mkWanted False loc eff eff'
|
||||
(_, [_, eff', _]) -> mkWanted (must_unify r) loc eff eff'
|
||||
_ -> pure Nothing
|
||||
Just eff' -> mkWanted True loc eff eff'
|
||||
|
||||
return (TcPluginOk [] (catMaybes eqs))
|
||||
pure $ TcPluginOk [] $ catMaybes eqs
|
||||
|
||||
|
43
polysemy-plugin/test/ExampleSpec.hs
Normal file
43
polysemy-plugin/test/ExampleSpec.hs
Normal file
@ -0,0 +1,43 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
|
||||
|
||||
module ExampleSpec where
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Error
|
||||
import Polysemy.Input
|
||||
import Polysemy.Output
|
||||
import Polysemy.Resource
|
||||
import Test.Hspec
|
||||
|
||||
data Teletype m a where
|
||||
ReadTTY :: Teletype m String
|
||||
WriteTTY :: String -> Teletype m ()
|
||||
|
||||
makeSem ''Teletype
|
||||
|
||||
runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a
|
||||
runTeletypeIO = interpret $ \case
|
||||
ReadTTY -> sendM getLine
|
||||
WriteTTY msg -> sendM $ putStrLn msg
|
||||
|
||||
data CustomException = ThisException | ThatException deriving Show
|
||||
|
||||
program :: Members '[Teletype, Resource, Error CustomException] r => Sem r ()
|
||||
program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)
|
||||
where work = bracket (readTTY) (const $ writeTTY "exiting bracket") $ \i -> do
|
||||
writeTTY "entering bracket"
|
||||
case i of
|
||||
"explode" -> throw ThisException
|
||||
"weird stuff" -> writeTTY i >> throw ThatException
|
||||
_ -> writeTTY i >> writeTTY "no exceptions"
|
||||
|
||||
foo :: IO (Either CustomException ())
|
||||
foo = (runM .@ runResource .@@ runErrorInIO @CustomException) $ runTeletypeIO program
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "example" $ do
|
||||
it "should compile!" $ do
|
||||
True `shouldBe` True
|
||||
|
Loading…
Reference in New Issue
Block a user