[Git][ghc/ghc][wip/D5373] Add TcHoleFitTypes and address issues
Matthías Páll Gissurarson
gitlab at gitlab.haskell.org
Thu Jun 6 16:26:32 UTC 2019
Matthías Páll Gissurarson pushed to branch wip/D5373 at Glasgow Haskell Compiler / GHC
Commits:
3559a11e by Matthías Páll Gissurarson at 2019-06-06T16:26:13Z
Add TcHoleFitTypes and address issues
- - - - -
9 changed files:
- compiler/ghc.cabal.in
- compiler/main/Plugins.hs
- compiler/typecheck/TcHoleErrors.hs
- + compiler/typecheck/TcHoleFitTypes.hs
- + compiler/typecheck/TcHoleFitTypes.hs-boot
- compiler/typecheck/TcRnDriver.hs
- compiler/typecheck/TcRnTypes.hs
- docs/users_guide/extending_ghc.rst
- testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs
Changes:
=====================================
compiler/ghc.cabal.in
=====================================
@@ -504,6 +504,7 @@ Library
TcRules
TcSimplify
TcHoleErrors
+ TcHoleFitTypes
TcErrors
TcTyClsDecls
TcTyDecls
=====================================
compiler/main/Plugins.hs
=====================================
@@ -30,6 +30,10 @@ module Plugins (
-- - access to loaded interface files with 'interfaceLoadAction'
--
, keepRenamedSource
+ -- ** Hole fit plugins
+ -- | hole fit plugins allow plugins to change the behavior of valid hole
+ -- fit suggestions
+ , HoleFitPluginR
-- * Internal
, PluginWithArgs(..), plugins, pluginRecompile'
@@ -42,8 +46,8 @@ import GhcPrelude
import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM )
import qualified TcRnTypes
-import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports
- , HoleFitPluginR )
+import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
+import TcHoleFitTypes ( HoleFitPluginR )
import HsSyn
import DynFlags
import HscTypes
@@ -173,7 +177,7 @@ instance Monoid PluginRecompile where
type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin
-type HoleFitPlugin = [CommandLineOption] -> Maybe TcRnTypes.HoleFitPluginR
+type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR
purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
purePlugin _args = return NoForceRecompile
=====================================
compiler/typecheck/TcHoleErrors.hs
=====================================
@@ -8,7 +8,7 @@ module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits
, hfIsLcl
, pprHoleFit, debugHoleFitDispConfig
- -- Re-exported from TcRnTypes
+ -- Re-exported from TcHoleFitTypes
, TypedHole (..), HoleFit (..), HoleFitCandidate (..)
, CandPlugin, FitPlugin
, HoleFitPlugin (..), HoleFitPluginR (..)
@@ -56,6 +56,9 @@ import LoadIface ( loadInterfaceForNameMaybe )
import PrelInfo (knownKeyNames)
+import TcHoleFitTypes
+
+
{-
Note [Valid hole fits include ...]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -430,13 +433,6 @@ getSortingAlg =
then BySize
else NoSorting }
-hfIsLcl :: HoleFit -> Bool
-hfIsLcl hf@(HoleFit {}) = case hfCand hf of
- IdHFCand _ -> True
- NameHFCand _ -> False
- GreHFCand gre -> gre_lcl gre
-hfIsLcl _ = False
-
-- If enabled, we go through the fits and add any associated documentation,
-- by looking it up in the module or the environment (for local fits)
addDocs :: [HoleFit] -> TcM [HoleFit]
@@ -893,7 +889,7 @@ tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates =
else return Nothing }
else return Nothing }
where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty
- hole = TyH relevantCts implics Nothing
+ hole = TyH tyHRelevantCts tyHImplics Nothing
subsDiscardMsg :: SDoc
@@ -954,7 +950,7 @@ tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $
-- the innermost (the one with the highest level) is first, so it
-- suffices to get the level of the first one (or the current level, if
-- there are no implications involved).
- innermost_lvl <- case implics of
+ innermost_lvl <- case tyHImplics of
[] -> getTcLevel
-- imp is the innermost implication
(imp:_) -> return (ic_tclvl imp)
@@ -962,15 +958,15 @@ tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $
tcSubType_NC ExprSigCtxt ty hole_ty
; traceTc "Checking hole fit {" empty
; traceTc "wanteds are: " $ ppr wanted
- ; if isEmptyWC wanted && isEmptyBag relevantCts
+ ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts
then traceTc "}" empty >> return (True, wrp)
else do { fresh_binds <- newTcEvBinds
-- The relevant constraints may contain HoleDests, so we must
-- take care to clone them as well (to avoid #15370).
- ; cloned_relevants <- mapBagM cloneWanted relevantCts
+ ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts
-- We wrap the WC in the nested implications, see
-- Note [Nested Implications]
- ; let outermost_first = reverse implics
+ ; let outermost_first = reverse tyHImplics
setWC = setWCAndBinds fresh_binds
-- We add the cloned relevants to the wanteds generated by
-- the call to tcSubType_NC, see Note [Relevant Constraints]
@@ -998,5 +994,5 @@ tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $
fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR
fromPureHFPlugin plug =
HoleFitPluginR { hfPluginInit = newTcRef ()
- , holeFitPluginR = const plug
+ , hfPluginRun = const plug
, hfPluginStop = const $ return () }
=====================================
compiler/typecheck/TcHoleFitTypes.hs
=====================================
@@ -0,0 +1,144 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module TcHoleFitTypes (
+ TypedHole (..), HoleFit (..), HoleFitCandidate (..),
+ CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),
+ hfIsLcl, pprHoleFitCand
+ ) where
+
+import GhcPrelude
+
+import TcRnTypes
+import TcType
+
+import RdrName
+
+import HsDoc
+import Id
+
+import Outputable
+import Name
+
+import Data.Function ( on )
+
+data TypedHole = TyH { tyHRelevantCts :: Cts
+ -- ^ Any relevant Cts to the hole
+ , tyHImplics :: [Implication]
+ -- ^ The nested implications of the hole with the
+ -- innermost implication first.
+ , tyHCt :: Maybe Ct
+ -- ^ The hole constraint itself, if available.
+ }
+
+instance Outputable TypedHole where
+ ppr (TyH rels implics ct)
+ = hang (text "TypedHole") 2
+ (ppr rels $+$ ppr implics $+$ ppr ct)
+
+
+-- | HoleFitCandidates are passed to hole fit plugins and then
+-- checked whether they fit a given typed-hole.
+data HoleFitCandidate = IdHFCand Id -- An id, like locals.
+ | NameHFCand Name -- A name, like built-in syntax.
+ | GreHFCand GlobalRdrElt -- A global, like imported ids.
+ deriving (Eq)
+
+instance Outputable HoleFitCandidate where
+ ppr = pprHoleFitCand
+
+pprHoleFitCand :: HoleFitCandidate -> SDoc
+pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid
+pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname
+pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre
+
+
+
+
+instance NamedThing HoleFitCandidate where
+ getName hfc = case hfc of
+ IdHFCand cid -> idName cid
+ NameHFCand cname -> cname
+ GreHFCand cgre -> gre_name cgre
+ getOccName hfc = case hfc of
+ IdHFCand cid -> occName cid
+ NameHFCand cname -> occName cname
+ GreHFCand cgre -> occName (gre_name cgre)
+
+instance HasOccName HoleFitCandidate where
+ occName = getOccName
+
+instance Ord HoleFitCandidate where
+ compare = compare `on` getName
+
+-- | HoleFit is the type we use for valid hole fits. It contains the
+-- element that was checked, the Id of that element as found by `tcLookup`,
+-- and the refinement level of the fit, which is the number of extra argument
+-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
+data HoleFit =
+ HoleFit { hfId :: Id -- ^ The elements id in the TcM
+ , hfCand :: HoleFitCandidate -- ^ The candidate that was checked.
+ , hfType :: TcType -- ^ The type of the id, possibly zonked.
+ , hfRefLvl :: Int -- ^ The number of holes in this fit.
+ , hfWrap :: [TcType] -- ^ The wrapper for the match.
+ , hfMatches :: [TcType]
+ -- ^ What the refinement variables got matched with, if anything
+ , hfDoc :: Maybe HsDocString
+ -- ^ Documentation of this HoleFit, if available.
+ }
+ | RawHoleFit SDoc
+ -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins
+ -- can inject any fit they want.
+
+-- We define an Eq and Ord instance to be able to build a graph.
+instance Eq HoleFit where
+ (==) = (==) `on` hfId
+
+instance Outputable HoleFit where
+ ppr (RawHoleFit sd) = sd
+ ppr (HoleFit _ cand ty _ _ mtchs _) =
+ hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty))
+ where name = ppr $ getName cand
+ holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs
+
+-- We compare HoleFits by their name instead of their Id, since we don't
+-- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
+-- which is used to compare Ids. When comparing, we want HoleFits with a lower
+-- refinement level to come first.
+instance Ord HoleFit where
+ compare (RawHoleFit _) (RawHoleFit _) = EQ
+ compare (RawHoleFit _) _ = LT
+ compare _ (RawHoleFit _) = GT
+ compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
+ where cmp = if hfRefLvl a == hfRefLvl b
+ then compare `on` (getName . hfCand)
+ else compare `on` hfRefLvl
+
+hfIsLcl :: HoleFit -> Bool
+hfIsLcl hf@(HoleFit {}) = case hfCand hf of
+ IdHFCand _ -> True
+ NameHFCand _ -> False
+ GreHFCand gre -> gre_lcl gre
+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/typecheck/TcHoleFitTypes.hs-boot
=====================================
@@ -0,0 +1,7 @@
+-- This boot file is in place to break the loop where:
+-- + TcRnTypes needs 'HoleFitPlugin',
+-- + which needs 'TcHoleFitTypes'
+-- + which needs 'TcRnTypes'
+module TcHoleFitTypes where
+
+data HoleFitPlugin
=====================================
compiler/typecheck/TcRnDriver.hs
=====================================
@@ -141,6 +141,8 @@ import qualified Data.Set as S
import Control.DeepSeq
import Control.Monad
+import TcHoleFitTypes ( HoleFitPluginR (..) )
+
#include "HsVersions.h"
@@ -166,7 +168,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax
(text "Renamer/typechecker"<+>brackets (ppr this_mod))
(const ()) $
initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
- withTcPlugins hsc_env $ withHfPlugins hsc_env $
+ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $
tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
@@ -1842,7 +1844,7 @@ runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
runTcInteractive hsc_env thing_inside
- = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHfPlugins hsc_env $
+ = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $
do { traceTc "setInteractiveContext" $
vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
, text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
@@ -2877,8 +2879,8 @@ getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]
getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
-withHfPlugins :: HscEnv -> TcM a -> TcM a
-withHfPlugins hsc_env m =
+withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
+withHoleFitPlugins hsc_env m =
case (getHfPlugins (hsc_dflags hsc_env)) of
[] -> m -- Common fast case
plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins
=====================================
compiler/typecheck/TcRnTypes.hs
=====================================
@@ -130,10 +130,6 @@ module TcRnTypes(
eqCanDischargeFR,
funEqCanDischarge, funEqCanDischargeF,
- -- Hole Fit Plugins
- TypedHole (..), HoleFit (..), HoleFitCandidate (..),
- CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),
-
-- Pretty printing
pprEvVarTheta,
pprEvVars, pprEvVarWithType,
@@ -202,7 +198,6 @@ import CostCentreState
import Control.Monad (ap, liftM, msum)
import qualified Control.Monad.Fail as MonadFail
import Data.Set ( Set )
-import Data.Function ( on )
import qualified Data.Set as S
import Data.List ( sort )
@@ -213,6 +208,8 @@ import Data.Maybe ( mapMaybe )
import GHCi.Message
import GHCi.RemoteTypes
+import {-# SOURCE #-} TcHoleFitTypes ( HoleFitPlugin )
+
import qualified Language.Haskell.TH as TH
-- | A 'NameShape' is a substitution on 'Name's that can be used
@@ -3919,121 +3916,3 @@ getRoleAnnots :: [Name] -> RoleAnnotEnv
getRoleAnnots bndrs role_env
= ( mapMaybe (lookupRoleAnnot role_env) bndrs
, delListFromNameEnv role_env bndrs )
-
-{-
-Hole Fit Plugins
--------------------------
--}
-
-data TypedHole = TyH { relevantCts :: Cts
- -- ^ Any relevant Cts to the hole
- , implics :: [Implication]
- -- ^ The nested implications of the hole with the
- -- innermost implication first.
- , holeCt :: Maybe Ct
- -- ^ The hole constraint itself, if available.
- }
-
-instance Outputable TypedHole where
- ppr (TyH rels implics ct)
- = hang (text "TypedHole") 2
- (ppr rels $+$ ppr implics $+$ ppr ct)
-
-
--- | HoleFitCandidates are passed to hole fit plugins and then
--- checked whether they fit a given typed-hole.
-data HoleFitCandidate = IdHFCand Id -- An id, like locals.
- | NameHFCand Name -- A name, like built-in syntax.
- | GreHFCand GlobalRdrElt -- A global, like imported ids.
- deriving (Eq)
-
-instance Outputable HoleFitCandidate where
- ppr = pprHoleFitCand
-
-pprHoleFitCand :: HoleFitCandidate -> SDoc
-pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id
-pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name
-pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre
-
-instance NamedThing HoleFitCandidate where
- getName hfc = case hfc of
- IdHFCand id -> idName id
- NameHFCand name -> name
- GreHFCand gre -> gre_name gre
- getOccName hfc = case hfc of
- IdHFCand id -> occName id
- NameHFCand name -> occName name
- GreHFCand gre -> occName (gre_name gre)
-
-instance HasOccName HoleFitCandidate where
- occName = getOccName
-
-instance Ord HoleFitCandidate where
- compare = compare `on` getName
-
--- | HoleFit is the type we use for valid hole fits. It contains the
--- element that was checked, the Id of that element as found by `tcLookup`,
--- and the refinement level of the fit, which is the number of extra argument
--- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
-data HoleFit =
- HoleFit { hfId :: Id -- ^ The elements id in the TcM
- , hfCand :: HoleFitCandidate -- ^ The candidate that was checked.
- , hfType :: TcType -- ^ The type of the id, possibly zonked.
- , hfRefLvl :: Int -- ^ The number of holes in this fit.
- , hfWrap :: [TcType] -- ^ The wrapper for the match.
- , hfMatches :: [TcType]
- -- ^ What the refinement variables got matched with, if anything
- , hfDoc :: Maybe HsDocString
- -- ^ Documentation of this HoleFit, if available.
- }
- | RawHoleFit SDoc
- -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins
- -- can inject any fit they want.
-
--- We define an Eq and Ord instance to be able to build a graph.
-instance Eq HoleFit where
- (==) = (==) `on` hfId
-
-instance Outputable HoleFit where
- ppr (RawHoleFit sd) = sd
- ppr (HoleFit _ cand ty _ _ mtchs _) =
- hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty))
- where name = ppr $ getName cand
- holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs
-
--- We compare HoleFits by their name instead of their Id, since we don't
--- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
--- which is used to compare Ids. When comparing, we want HoleFits with a lower
--- refinement level to come first.
-instance Ord HoleFit where
- compare (RawHoleFit _) (RawHoleFit _) = EQ
- compare (RawHoleFit _) _ = LT
- compare _ (RawHoleFit _) = GT
- compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
- where cmp = if hfRefLvl a == hfRefLvl b
- then compare `on` (getName . hfCand)
- else compare `on` hfRefLvl
-
-
--- | 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
- , holeFitPluginR :: TcRef s -> HoleFitPlugin
- -- ^ The function defining the plugin itself
- , hfPluginStop :: TcRef s -> TcM ()
- -- ^ Cleanup of state, guaranteed to be called even on error
- }
=====================================
docs/users_guide/extending_ghc.rst
=====================================
@@ -869,12 +869,12 @@ at error generation.
::
- data TypedHole = TyH { relevantCts :: Cts
+ data TypedHole = TyH { tyHRelevantCts :: Cts
-- ^ Any relevant Cts to the hole
- , implics :: [Implication]
+ , tyHImplics :: [Implication]
-- ^ The nested implications of the hole with the
-- innermost implication first.
- , holeCt :: Maybe Ct
+ , tyHCt :: Maybe Ct
-- ^ The hole constraint itself, if available.
}
@@ -912,7 +912,7 @@ communication between the candidate and fit plugin.
data HoleFitPluginR = forall s. HoleFitPluginR
{ hfPluginInit :: TcM (TcRef s)
-- ^ Initializes the TcRef to be passed to the plugin
- , holeFitPluginR :: TcRef s -> HoleFitPlugin
+ , hfPluginRun :: TcRef s -> HoleFitPlugin
-- ^ The function defining the plugin itself
, hfPluginStop :: TcRef s -> TcM ()
-- ^ Cleanup of state, guaranteed to be called even on error
@@ -987,7 +987,7 @@ spent on searching for valid hole fits, after which new searches are aborted.
fromModule _ = []
toHoleFitCommand :: TypedHole -> String -> Maybe String
- toHoleFitCommand TyH{holeCt = Just (CHoleCan _ h)} str
+ toHoleFitCommand TyH{tyHCt = Just (CHoleCan _ h)} str
= stripPrefix ("_" <> str) $ occNameString $ holeOcc h
toHoleFitCommand _ _ = Nothing
=====================================
testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs
=====================================
@@ -34,7 +34,7 @@ fromModule (GreHFCand gre) =
fromModule _ = []
toHoleFitCommand :: TypedHole -> String -> Maybe String
-toHoleFitCommand TyH{holeCt = Just (CHoleCan _ h)} str
+toHoleFitCommand TyH{tyHCt = Just (CHoleCan _ h)} str
= stripPrefix ("_" <> str) $ occNameString $ holeOcc h
toHoleFitCommand _ _ = Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/3559a11ee39a76b65755ba8bffd821cba776019b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/3559a11ee39a76b65755ba8bffd821cba776019b
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/20190606/66c78688/attachment-0001.html>
More information about the ghc-commits
mailing list