[Git][ghc/ghc][wip/tc-lcl-env-refactor] 4 commits: hole fit plugins: Split definition into own module
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed May 17 08:17:28 UTC 2023
Matthew Pickering pushed to branch wip/tc-lcl-env-refactor at Glasgow Haskell Compiler / GHC
Commits:
08992bc4 by Matthew Pickering at 2023-05-17T09:13:36+01:00
hole fit plugins: Split definition into own module
The hole fit plugins are defined in terms of TcM, a type we want to
avoid depending on from `GHC.Tc.Errors.Types`. By moving it into its own
module we can remove this dependency. It also simplifies the necessary
boot file.
- - - - -
bd960d65 by Matthew Pickering at 2023-05-17T09:13:36+01:00
Move GHC.Core.Opt.CallerCC Types into separate module
This allows `GHC.Driver.DynFlags` to depend on these types without
depending on CoreM and hence the entire simplifier pipeline.
We can also remove a hs-boot file with this change.
- - - - -
38b6f624 by Matthew Pickering at 2023-05-17T09:13:36+01:00
Remove unecessary SOURCE import
- - - - -
67225975 by Matthew Pickering at 2023-05-17T09:16:48+01:00
Comment out traceZonk for now
- - - - -
18 changed files:
- compiler/GHC/Core/Opt/CallerCC.hs
- − compiler/GHC/Core/Opt/CallerCC.hs-boot
- + compiler/GHC/Core/Opt/CallerCC/Types.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Plugins.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Errors/Hole/FitTypes.hs
- − compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot
- + compiler/GHC/Tc/Errors/Hole/Plugin.hs
- + compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Zonk/Monad.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Core/Opt/CallerCC.hs
=====================================
@@ -15,14 +15,11 @@ module GHC.Core.Opt.CallerCC
, parseCallerCcFilter
) where
-import Data.Word (Word8)
import Data.Maybe
import Control.Applicative
import GHC.Utils.Monad.State.Strict
-import Data.Either
import Control.Monad
-import qualified Text.ParserCombinators.ReadP as P
import GHC.Prelude
import GHC.Utils.Outputable as Outputable
@@ -38,11 +35,8 @@ import GHC.Unit.Types
import GHC.Data.FastString
import GHC.Core
import GHC.Core.Opt.Monad
-import GHC.Utils.Panic
-import qualified GHC.Utils.Binary as B
-import Data.Char
+import GHC.Core.Opt.CallerCC.Types
-import Language.Haskell.Syntax.Module.Name
addCallerCostCentres :: ModGuts -> CoreM ModGuts
addCallerCostCentres guts = do
@@ -139,90 +133,3 @@ needsCallSiteCostCentre env i =
checkFunc =
occNameMatches (ccfFuncName ccf) (getOccName i)
-data NamePattern
- = PChar Char NamePattern
- | PWildcard NamePattern
- | PEnd
-
-instance Outputable NamePattern where
- ppr (PChar c rest) = char c <> ppr rest
- ppr (PWildcard rest) = char '*' <> ppr rest
- ppr PEnd = Outputable.empty
-
-instance B.Binary NamePattern where
- get bh = do
- tag <- B.get bh
- case tag :: Word8 of
- 0 -> PChar <$> B.get bh <*> B.get bh
- 1 -> PWildcard <$> B.get bh
- 2 -> pure PEnd
- _ -> panic "Binary(NamePattern): Invalid tag"
- put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y
- put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x
- put_ bh PEnd = B.put_ bh (2 :: Word8)
-
-occNameMatches :: NamePattern -> OccName -> Bool
-occNameMatches pat = go pat . occNameString
- where
- go :: NamePattern -> String -> Bool
- go PEnd "" = True
- go (PChar c rest) (d:s)
- = d == c && go rest s
- go (PWildcard rest) s
- = go rest s || go (PWildcard rest) (tail s)
- go _ _ = False
-
-type Parser = P.ReadP
-
-parseNamePattern :: Parser NamePattern
-parseNamePattern = pattern
- where
- pattern = star P.<++ wildcard P.<++ char P.<++ end
- star = PChar '*' <$ P.string "\\*" <*> pattern
- wildcard = do
- void $ P.char '*'
- PWildcard <$> pattern
- char = PChar <$> P.get <*> pattern
- end = PEnd <$ P.eof
-
-data CallerCcFilter
- = CallerCcFilter { ccfModuleName :: Maybe ModuleName
- , ccfFuncName :: NamePattern
- }
-
-instance Outputable CallerCcFilter where
- ppr ccf =
- maybe (char '*') ppr (ccfModuleName ccf)
- <> char '.'
- <> ppr (ccfFuncName ccf)
-
-instance B.Binary CallerCcFilter where
- get bh = CallerCcFilter <$> B.get bh <*> B.get bh
- put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y
-
-parseCallerCcFilter :: String -> Either String CallerCcFilter
-parseCallerCcFilter inp =
- case P.readP_to_S parseCallerCcFilter' inp of
- ((result, ""):_) -> Right result
- _ -> Left $ "parse error on " ++ inp
-
-parseCallerCcFilter' :: Parser CallerCcFilter
-parseCallerCcFilter' =
- CallerCcFilter
- <$> moduleFilter
- <* P.char '.'
- <*> parseNamePattern
- where
- moduleFilter :: Parser (Maybe ModuleName)
- moduleFilter =
- (Just . mkModuleName <$> moduleName)
- <|>
- (Nothing <$ P.char '*')
-
- moduleName :: Parser String
- moduleName = do
- c <- P.satisfy isUpper
- cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')
- rest <- optional $ P.char '.' >> fmap ('.':) moduleName
- return $ c : (cs ++ fromMaybe "" rest)
-
=====================================
compiler/GHC/Core/Opt/CallerCC.hs-boot deleted
=====================================
@@ -1,8 +0,0 @@
-module GHC.Core.Opt.CallerCC where
-
-import GHC.Prelude
-
--- Necessary due to import in GHC.Driver.Session.
-data CallerCcFilter
-
-parseCallerCcFilter :: String -> Either String CallerCcFilter
=====================================
compiler/GHC/Core/Opt/CallerCC/Types.hs
=====================================
@@ -0,0 +1,108 @@
+module GHC.Core.Opt.CallerCC.Types where
+
+import Data.Word (Word8)
+import Data.Maybe
+
+import Control.Applicative
+import Data.Either
+import Control.Monad
+import qualified Text.ParserCombinators.ReadP as P
+
+import GHC.Prelude
+import GHC.Utils.Outputable as Outputable
+import GHC.Types.Name hiding (varName)
+import GHC.Utils.Panic
+import qualified GHC.Utils.Binary as B
+import Data.Char
+
+import Language.Haskell.Syntax.Module.Name
+
+
+data NamePattern
+ = PChar Char NamePattern
+ | PWildcard NamePattern
+ | PEnd
+
+instance Outputable NamePattern where
+ ppr (PChar c rest) = char c <> ppr rest
+ ppr (PWildcard rest) = char '*' <> ppr rest
+ ppr PEnd = Outputable.empty
+
+instance B.Binary NamePattern where
+ get bh = do
+ tag <- B.get bh
+ case tag :: Word8 of
+ 0 -> PChar <$> B.get bh <*> B.get bh
+ 1 -> PWildcard <$> B.get bh
+ 2 -> pure PEnd
+ _ -> panic "Binary(NamePattern): Invalid tag"
+ put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y
+ put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x
+ put_ bh PEnd = B.put_ bh (2 :: Word8)
+
+occNameMatches :: NamePattern -> OccName -> Bool
+occNameMatches pat = go pat . occNameString
+ where
+ go :: NamePattern -> String -> Bool
+ go PEnd "" = True
+ go (PChar c rest) (d:s)
+ = d == c && go rest s
+ go (PWildcard rest) s
+ = go rest s || go (PWildcard rest) (tail s)
+ go _ _ = False
+
+
+
+type Parser = P.ReadP
+
+parseNamePattern :: Parser NamePattern
+parseNamePattern = pattern
+ where
+ pattern = star P.<++ wildcard P.<++ char P.<++ end
+ star = PChar '*' <$ P.string "\\*" <*> pattern
+ wildcard = do
+ void $ P.char '*'
+ PWildcard <$> pattern
+ char = PChar <$> P.get <*> pattern
+ end = PEnd <$ P.eof
+
+data CallerCcFilter
+ = CallerCcFilter { ccfModuleName :: Maybe ModuleName
+ , ccfFuncName :: NamePattern
+ }
+
+instance Outputable CallerCcFilter where
+ ppr ccf =
+ maybe (char '*') ppr (ccfModuleName ccf)
+ <> char '.'
+ <> ppr (ccfFuncName ccf)
+
+instance B.Binary CallerCcFilter where
+ get bh = CallerCcFilter <$> B.get bh <*> B.get bh
+ put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y
+
+parseCallerCcFilter :: String -> Either String CallerCcFilter
+parseCallerCcFilter inp =
+ case P.readP_to_S parseCallerCcFilter' inp of
+ ((result, ""):_) -> Right result
+ _ -> Left $ "parse error on " ++ inp
+
+parseCallerCcFilter' :: Parser CallerCcFilter
+parseCallerCcFilter' =
+ CallerCcFilter
+ <$> moduleFilter
+ <* P.char '.'
+ <*> parseNamePattern
+ where
+ moduleFilter :: Parser (Maybe ModuleName)
+ moduleFilter =
+ (Just . mkModuleName <$> moduleName)
+ <|>
+ (Nothing <$ P.char '*')
+
+ moduleName :: Parser String
+ moduleName = do
+ c <- P.satisfy isUpper
+ cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')
+ rest <- optional $ P.char '.' >> fmap ('.':) moduleName
+ return $ c : (cs ++ fromMaybe "" rest)
\ No newline at end of file
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -106,7 +106,7 @@ import qualified GHC.Types.FieldLabel as FieldLabel
import qualified GHC.Utils.Ppr.Colour as Col
import qualified GHC.Data.EnumSet as EnumSet
-import {-# SOURCE #-} GHC.Core.Opt.CallerCC
+import GHC.Core.Opt.CallerCC.Types
import Control.Monad (msum, (<=<))
import Control.Monad.Trans.Class (lift)
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -82,7 +82,7 @@ import GHC.Parser.Errors.Types (PsWarning, PsError)
import qualified GHC.Tc.Types
import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
-import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )
+import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR )
import GHC.Core.Opt.Monad ( CoreM )
import GHC.Core.Opt.Pipeline.Types ( CoreToDo )
=====================================
compiler/GHC/Plugins.hs
=====================================
@@ -55,6 +55,7 @@ module GHC.Plugins
, module GHC.Types.Unique.Supply
, module GHC.Data.FastString
, module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins
+ , module GHC.Tc.Errors.Hole.Plugin -- for hole-fit plugins
, module GHC.Unit.Module.ModGuts
, module GHC.Unit.Module.ModSummary
, module GHC.Unit.Module.ModIface
@@ -148,6 +149,7 @@ import GHC.Tc.Utils.Env ( lookupGlobal )
import GHC.Types.Name.Cache ( NameCache )
import GHC.Tc.Errors.Hole.FitTypes
+import GHC.Tc.Errors.Hole.Plugin
-- For parse result plugins
import GHC.Parser.Errors.Types ( PsWarning, PsError )
=====================================
compiler/GHC/Tc/Errors/Hole.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Tc.Errors.Hole
, sortHoleFitsBySize
- -- Re-exported from GHC.Tc.Errors.Hole.FitTypes
+ -- Re-exported from GHC.Tc.Errors.Hole.Plugin
, HoleFitPlugin (..), HoleFitPluginR (..)
)
where
@@ -78,6 +78,7 @@ import GHC.Iface.Load ( loadInterfaceForName )
import GHC.Builtin.Utils (knownKeyNames)
import GHC.Tc.Errors.Hole.FitTypes
+import GHC.Tc.Errors.Hole.Plugin
import qualified Data.Set as Set
import GHC.Types.SrcLoc
import GHC.Data.FastString (NonDetFastString(..))
=====================================
compiler/GHC/Tc/Errors/Hole/FitTypes.hs
=====================================
@@ -1,13 +1,11 @@
{-# LANGUAGE ExistentialQuantification #-}
module GHC.Tc.Errors.Hole.FitTypes (
TypedHole (..), HoleFit (..), HoleFitCandidate (..),
- CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),
hfIsLcl, pprHoleFitCand
) where
import GHC.Prelude
-import GHC.Tc.Types
import GHC.Tc.Types.Constraint
import GHC.Tc.Utils.TcType
@@ -126,25 +124,3 @@ hfIsLcl hf@(HoleFit {}) = case hfCand hf of
hfIsLcl _ = False
--- | A plugin for modifying the candidate hole fits *before* they're checked.
-type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
-
--- | A plugin for modifying hole fits *after* they've been found.
-type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
-
--- | A HoleFitPlugin is a pair of candidate and fit plugins.
-data HoleFitPlugin = HoleFitPlugin
- { candPlugin :: CandPlugin
- , fitPlugin :: FitPlugin }
-
--- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can
--- track internal state. Note the existential quantification, ensuring that
--- the state cannot be modified from outside the plugin.
-data HoleFitPluginR = forall s. HoleFitPluginR
- { hfPluginInit :: TcM (TcRef s)
- -- ^ Initializes the TcRef to be passed to the plugin
- , hfPluginRun :: TcRef s -> HoleFitPlugin
- -- ^ The function defining the plugin itself
- , hfPluginStop :: TcRef s -> TcM ()
- -- ^ Cleanup of state, guaranteed to be called even on error
- }
=====================================
compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot deleted
=====================================
@@ -1,30 +0,0 @@
--- This boot file is in place to break the loop where:
--- + GHC.Tc.Types needs 'HoleFitPlugin',
--- + which needs 'GHC.Tc.Errors.Hole.FitTypes'
--- + which needs 'GHC.Tc.Types'
-module GHC.Tc.Errors.Hole.FitTypes where
-
-import GHC.Base (Int, Maybe)
-import GHC.Types.Var (Id)
-import GHC.Types.Name (Name)
-import GHC.Types.Name.Reader (GlobalRdrElt)
-import GHC.Tc.Utils.TcType (TcType)
-import GHC.Hs.Doc (HsDocString)
-import GHC.Utils.Outputable (SDoc)
-
-data HoleFitCandidate
- = IdHFCand Id
- | NameHFCand Name
- | GreHFCand GlobalRdrElt
-
-data HoleFitPlugin
-data HoleFit =
- HoleFit { hfId :: Id
- , hfCand :: HoleFitCandidate
- , hfType :: TcType
- , hfRefLvl :: Int
- , hfWrap :: [TcType]
- , hfMatches :: [TcType]
- , hfDoc :: Maybe [HsDocString]
- }
- | RawHoleFit SDoc
=====================================
compiler/GHC/Tc/Errors/Hole/Plugin.hs
=====================================
@@ -0,0 +1,29 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module GHC.Tc.Errors.Hole.Plugin(CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..)) where
+
+import GHC.Tc.Errors.Hole.FitTypes
+import GHC.Tc.Types ( TcRef, TcM )
+
+
+-- | A plugin for modifying the candidate hole fits *before* they're checked.
+type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
+
+-- | A plugin for modifying hole fits *after* they've been found.
+type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
+
+-- | A HoleFitPlugin is a pair of candidate and fit plugins.
+data HoleFitPlugin = HoleFitPlugin
+ { candPlugin :: CandPlugin
+ , fitPlugin :: FitPlugin }
+
+-- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can
+-- track internal state. Note the existential quantification, ensuring that
+-- the state cannot be modified from outside the plugin.
+data HoleFitPluginR = forall s. HoleFitPluginR
+ { hfPluginInit :: TcM (TcRef s)
+ -- ^ Initializes the TcRef to be passed to the plugin
+ , hfPluginRun :: TcRef s -> HoleFitPlugin
+ -- ^ The function defining the plugin itself
+ , hfPluginStop :: TcRef s -> TcM ()
+ -- ^ Cleanup of state, guaranteed to be called even on error
+ }
\ No newline at end of file
=====================================
compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot
=====================================
@@ -0,0 +1,3 @@
+module GHC.Tc.Errors.Hole.Plugin where
+
+data HoleFitPlugin
\ No newline at end of file
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -76,7 +76,7 @@ import GHC.Types.Name.Set
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.TyThing
-import {-# SOURCE #-} GHC.Types.TyThing.Ppr ( pprTyThingInContext )
+import GHC.Types.TyThing.Ppr ( pprTyThingInContext )
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import GHC.Types.Var
import GHC.Types.Var.Set
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -147,7 +147,7 @@ import GHC.Prelude
import GHC.Hs
import GHC.Tc.Types.TcTyThing -- (TcIdSigInfo, TcTyThing)
-import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit)
+import GHC.Tc.Errors.Hole.FitTypes (HoleFit)
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence (EvBindsVar)
import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -55,7 +55,7 @@ import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic
-import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )
+import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) )
import GHC.Tc.Errors.Types
import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
import GHC.Tc.Gen.HsType
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -112,7 +112,7 @@ import GHC.Hs
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence
-import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )
+import {-# SOURCE #-} GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin )
import GHC.Tc.Errors.Types
import GHC.Core.Reduction ( Reduction(..) )
=====================================
compiler/GHC/Tc/Zonk/Monad.hs
=====================================
@@ -10,7 +10,7 @@ import GHC.Prelude
import GHC.Core.Type
-import GHC.Driver.Flags
+--import GHC.Driver.Flags
import GHC.Types.Var ( TcTyVar, Id, isTyCoVar )
import GHC.Types.Var.Env
@@ -298,11 +298,14 @@ writeTcRefZ :: IORef a -> a -> ZonkM ()
writeTcRefZ ref a = liftIO $ writeIORef ref a
traceZonk :: String -> SDoc -> ZonkM ()
-traceZonk herald doc = ZonkM $
+traceZonk _herald _doc = ZonkM $ return (return ())
+{-
\ ( ZonkLogEnv { le_logger = logger, le_name_ppr_ctx = ppr_ctx }) ->
do { let sty = mkDumpStyle ppr_ctx
flag = Opt_D_dump_tc_trace
title = ""
msg = hang (text herald) 2 doc
- ; logDumpFile logger sty flag title FormatText msg
+-- ; logDumpFile logger sty flag title FormatText msg
+ ; return ()
}
+ -}
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Types.Hint
import GHC.Core.FamInstEnv (FamFlavor(..))
import GHC.Core.TyCon
import GHC.Hs.Expr () -- instance Outputable
-import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
+import GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -311,6 +311,7 @@ Library
GHC.Core.Opt.Arity
GHC.Core.Opt.CallArity
GHC.Core.Opt.CallerCC
+ GHC.Core.Opt.CallerCC.Types
GHC.Core.Opt.ConstantFold
GHC.Core.Opt.CprAnal
GHC.Core.Opt.CSE
@@ -708,6 +709,7 @@ Library
GHC.Tc.Errors
GHC.Tc.Errors.Hole
GHC.Tc.Errors.Hole.FitTypes
+ GHC.Tc.Errors.Hole.Plugin
GHC.Tc.Errors.Ppr
GHC.Tc.Errors.Types
GHC.Tc.Errors.Types.PromotionErr
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b0e48ad87297472d8dacf6e6334b7d29b348fc5...672259755c94ef7bac2accfb3f52cb870f7e01b7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b0e48ad87297472d8dacf6e6334b7d29b348fc5...672259755c94ef7bac2accfb3f52cb870f7e01b7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230517/9795ef67/attachment-0001.html>
More information about the ghc-commits
mailing list