effectful-plugin 2.0.0.0 → 2.0.0.1
raw patch · 3 files changed
+103/−40 lines, 3 filesdep ~effectful-coredep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: effectful-core, ghc
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- effectful-plugin.cabal +15/−6
- src/Effectful/Plugin.hs +83/−34
CHANGELOG.md view
@@ -1,3 +1,8 @@+# effectful-plugin-2.0.0.1 (2025-08-30)+* Small optimization of checking suitable effects for unification.+* Add `timing` flag for tracking execution time of the plugin.+* Expect wanted constraints that are already solved.+ # effectful-plugin-2.0.0.0 (2025-06-09) * Drop support for GHC < 9.4. * Fix various bugs and shortcomings.
effectful-plugin.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: effectful-plugin-version: 2.0.0.0+version: 2.0.0.1 license: BSD-3-Clause license-file: LICENSE category: Control@@ -17,13 +17,17 @@ extra-source-files: CHANGELOG.md README.md -tested-with: GHC == { 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2 }+tested-with: GHC == { 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2, 9.14.1 } bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head type: git location: https://github.com/haskell-effectful/effectful.git +flag timing+ description: Show timing information+ default: False+ flag verbose description: Trace plugin execution default: False@@ -51,9 +55,7 @@ ImportQualifiedPost LambdaCase MultiParamTypeClasses- NoFieldSelectors NoStarIsType- OverloadedRecordDot PolyKinds RankNTypes RecordWildCards@@ -64,17 +66,24 @@ TypeApplications TypeFamilies TypeOperators+ UndecidableInstances + if impl(ghc >= 9.4)+ default-extensions: NoFieldSelectors+ , OverloadedRecordDot+ library import: language + if flag(timing)+ cpp-options: -DTIMING+ if flag(verbose) cpp-options: -DVERBOSE build-depends: base >= 4.16 && < 5 , containers >= 0.5- , effectful-core >= 2.5.0.0 && < 3.0.0.0- , ghc >= 9.4 && < 9.13+ , ghc >= 9.4 && < 9.15 hs-source-dirs: src
src/Effectful/Plugin.hs view
@@ -39,8 +39,15 @@ import GHC.Tc.Types.CtLoc #endif +#ifdef TIMING+import GHC.Clock+#endif+ #if __GLASGOW_HASKELL__ <= 904 type Subst = TCvSubst++isEmptySubst :: Subst -> Bool+isEmptySubst = isEmptyTCvSubst #endif data EffGiven = EffGiven@@ -74,7 +81,7 @@ data OtherWanted = OtherWanted { ty :: Type- , vars :: CoVarSet+ , vars :: TyCoVarSet } instance O.Outputable OtherWanted where@@ -85,22 +92,28 @@ ---------------------------------------- +data PluginData = PluginData+ { elemClass :: Class+ , totalTime :: !(IORef Double)+ }+ plugin :: Plugin plugin = defaultPlugin { tcPlugin = \_ -> Just TcPlugin { tcPluginInit = initPlugin , tcPluginRewrite = \_ -> emptyUFM , tcPluginSolve = disambiguateEffects- , tcPluginStop = \_ -> pure ()+ , tcPluginStop = pluginStopHook } , pluginRecompile = purePlugin } -initPlugin :: TcPluginM Class+initPlugin :: TcPluginM PluginData initPlugin = do clsMod <- lookupModule $ mkModuleName "Effectful.Internal.Effect"- cls <- tcLookupClass =<< lookupOrig clsMod (mkTcOcc ":>")- pure cls+ elemClass <- tcLookupClass =<< lookupOrig clsMod (mkTcOcc ":>")+ totalTime <- tcPluginIO $ newIORef 0+ pure PluginData{..} where lookupModule :: ModuleName -> TcPluginM Module lookupModule modName = do@@ -110,12 +123,12 @@ _ -> errorWithoutStackTrace "Please add effectful-core to the list of dependencies." disambiguateEffects- :: Class+ :: PluginData -> EvBindsVar -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult-disambiguateEffects elemCls _ allGivens allWanteds = do+disambiguateEffects pd _ allGivens allWanteds = timed pd $ do printList "Givens" allGivens printList "EffGivens" effGivens printList "OtherGivens" otherGivens@@ -126,12 +139,13 @@ solutions <- tcPluginIO $ newIORef [] forM_ effWanteds $ \wanted -> do printSingle "Wanted" wanted- case mapMaybe (maybeUnifiesWith wanted) effGivens of- [] -> printLn "No candidates"- [(given, _)] -> do+ case findCandidates wanted effGivens of+ Left given -> printSingle "Already solved by" given+ Right [] -> printLn "No candidates"+ Right [(given, _)] -> do printSingle "Single candidate found" given emitEqConstraint solutions wanted given- candidates -> do+ Right candidates -> do printList "Multiple candidates found" $ map fst candidates filterCandidates instEnvs None candidates >>= \case None -> printLn "No candidates left"@@ -145,13 +159,13 @@ (otherGivens, effGivens) = second (extendEffGivens effWanteds) . partitionEithers- . map (groupGivens elemCls)+ . map (groupGivens pd.elemClass) . filter (not . isIP) $ allGivens (otherWanteds, effWanteds) = partitionEithers- . map (groupWanteds elemCls)+ . map (groupWanteds pd.elemClass) . filter (not . isIP) $ allWanteds @@ -165,7 +179,7 @@ (given, subst) : rest -> do printSingle "Candidate" given let relevantWanteds = (`mapMaybe` otherWanteds) $ \wanted ->- if substHasAnyVar subst wanted.vars+ if substHasAnyTyVar subst wanted.vars then Just $ substTy subst wanted.ty else Nothing printList "Relevant wanteds" relevantWanteds@@ -302,16 +316,16 @@ loop :: [EffGiven] -> [Type] -> [EffGiven] loop acc = \case [] -> acc- es : rest -> loop (extractGivens es es ++ acc) rest-- extractGivens :: Type -> Type -> [EffGiven]- extractGivens fullEs es = case splitAppTys es of- (_colon, [_kind, eff, esTail]) -> EffGiven- { effCon = fst $ splitAppTys eff- , eff = eff- , es = fullEs- } : extractGivens fullEs esTail- _ -> []+ fullEs : rest ->+ let extractGivens :: Type -> [EffGiven]+ extractGivens es = case splitAppTys es of+ (_colon, [_kind, eff, esTail]) -> EffGiven+ { effCon = fst $ splitAppTys eff+ , eff = eff+ , es = fullEs+ } : extractGivens esTail+ _ -> []+ in loop (extractGivens fullEs ++ acc) rest -- | Check if a constraint in an implicit parameter. We discard all of them -- since they will not affect resolution of @:>@ constraints.@@ -341,17 +355,26 @@ unifiesWithAny :: Type -> [OtherGiven] -> Bool unifiesWithAny ty = any (isJust . tcUnifyTyNoSkolems ty . (.ty)) -substHasAnyVar :: Subst -> TyCoVarSet -> Bool-substHasAnyVar subst = uniqSetAny (`elemUFM` getTvSubstEnv subst)+substHasAnyTyVar :: Subst -> TyCoVarSet -> Bool+substHasAnyTyVar subst = uniqSetAny (`elemUFM` getTvSubstEnv subst) --- | Given a wanted constraint and a given constraint, attempt to unify them and--- give back a substitution that can be applied to the wanted to make it equal--- to the given.-maybeUnifiesWith :: EffWanted -> EffGiven -> Maybe (EffGiven, Subst)-maybeUnifiesWith wanted given =- if wanted.es `eqType` given.es && wanted.effCon `eqType` given.effCon- then (given, ) <$> tcUnifyTyNoSkolems wanted.eff given.eff- else Nothing+-- | Find givens unifiable with a wanted and give them back along with+-- appropriate substitutions.+--+-- Returns Left if the wanted is already solved by one of the givens.+findCandidates :: EffWanted -> [EffGiven] -> Either EffGiven [(EffGiven, Subst)]+findCandidates wanted = loop []+ where+ loop acc = \case+ [] -> Right acc+ given : rest ->+ if wanted.effCon `eqType` given.effCon && wanted.es `eqType` given.es+ then case tcUnifyTyNoSkolems wanted.eff given.eff of+ Just subst+ | isEmptySubst subst -> Left given+ | otherwise -> loop ((given, subst) : acc) rest+ Nothing -> loop acc rest+ else loop acc rest nubType :: [Type] -> [Type] nubType = coerce . S.toList . S.fromList @OrdType . coerce@@ -366,6 +389,32 @@ ---------------------------------------- -- Debugging++#ifdef TIMING++timed :: PluginData -> TcPluginM a -> TcPluginM a+timed pd action = do+ t1 <- tcPluginIO getMonotonicTime+ a <- action+ tcPluginIO $ do+ t2 <- getMonotonicTime+ modifyIORef' pd.totalTime (+ (t2 - t1))+ pure a++pluginStopHook :: PluginData -> TcPluginM ()+pluginStopHook pd = tcPluginIO $ do+ time <- readIORef pd.totalTime+ putStrLn $ "Execution time of effectful-plugin (seconds): " ++ show time++#else++timed :: PluginData -> TcPluginM a -> TcPluginM a+timed _ action = action++pluginStopHook :: PluginData -> TcPluginM ()+pluginStopHook _ = pure ()++#endif #ifdef VERBOSE