diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/effectful-plugin.cabal b/effectful-plugin.cabal --- a/effectful-plugin.cabal +++ b/effectful-plugin.cabal @@ -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 diff --git a/src/Effectful/Plugin.hs b/src/Effectful/Plugin.hs --- a/src/Effectful/Plugin.hs +++ b/src/Effectful/Plugin.hs @@ -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