From 35eca34c669e01d0ca2c812b5186c0d2c7c36da0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Matth=C3=ADas=20P=C3=A1ll=20Gissurarson?=
<pallm@chalmers.se>
Date: Thu, 23 May 2019 12:46:32 +0200
Subject: [PATCH] Move HoleFitPlugin definitions and instances to TcRnTypes
---
compiler/typecheck/TcHoleErrors.hs | 45 ++++-----------
compiler/typecheck/TcRnTypes.hs | 88 +++++++++++++++++++++---------
2 files changed, 74 insertions(+), 59 deletions(-)
diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs
index 70d1df3dea7..1dd7e9abdce 100644
--- a/compiler/typecheck/TcHoleErrors.hs
+++ b/compiler/typecheck/TcHoleErrors.hs
@@ -3,7 +3,10 @@
module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits
, tcCheckHoleFit, tcSubsumes
, withoutUnification
- , fromPurePlugin
+ , fromPureHFPlugin
+ -- Re-exports for convenience
+ , hfName, hfIsLcl
+ , pprHoleFit, debugHoleFitDispConfig
-- Re-exported from TcRnTypes
, TypedHole (..), HoleFit (..), HoleFitCandidate (..)
@@ -40,7 +43,6 @@ import Control.Arrow ( (&&&) )
import Control.Monad ( filterM, replicateM, foldM )
import Data.List ( partition, sort, sortOn, nubBy )
import Data.Graph ( graphFromEdges, topSort )
-import Data.Function ( on )
import TcSimplify ( simpl_top, runTcSDeriveds )
@@ -428,7 +430,6 @@ getSortingAlg =
then BySize
else NoSorting }
-
hfName :: HoleFit -> Maybe Name
hfName hf@(HoleFit {}) = Just $ case hfCand hf of
IdHFCand id -> idName id
@@ -443,27 +444,6 @@ hfIsLcl hf@(HoleFit {}) = case hfCand hf of
GreHFCand gre -> gre_lcl gre
hfIsLcl _ = False
-
--- We define an Eq and Ord instance to be able to build a graph.
-instance Eq HoleFit where
- (==) = (==) `on` hfId
-
--- 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` hfName
- else compare `on` hfRefLvl
-
-instance Outputable HoleFit where
- ppr = pprHoleFit debugHoleFitDispConfig
-
-- 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]
@@ -952,16 +932,6 @@ tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b
where dummyHole = TyH emptyBag [] Nothing
-
-
-
-
-fromPurePlugin :: HoleFitPlugin -> HoleFitPluginR
-fromPurePlugin plug =
- HoleFitPluginR { hfPluginInit = newTcRef ()
- , holeFitPluginR = const plug
- , hfPluginStop = const $ return () }
-
-- | A tcSubsumes which takes into account relevant constraints, to fix trac
-- #14273. This makes sure that when checking whether a type fits the hole,
-- the type has to be subsumed by type of the hole as well as fulfill all
@@ -1022,3 +992,10 @@ tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $
setWCAndBinds binds imp wc
= WC { wc_simple = emptyBag
, wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }
+
+-- | Maps a plugin that needs no state to one with an empty one.
+fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR
+fromPureHFPlugin plug =
+ HoleFitPluginR { hfPluginInit = newTcRef ()
+ , holeFitPluginR = const plug
+ , hfPluginStop = const $ return () }
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 30a9a2c7edc..cdce595b51c 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -202,6 +202,7 @@ 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 )
@@ -3942,27 +3943,14 @@ instance Outputable TypedHole where
= hang (text "TypedHole") 2
(ppr rels $+$ ppr implics $+$ ppr ct)
--- | 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]
-
-data HoleFitPlugin = HoleFitPlugin
- { candPlugin :: CandPlugin
- , fitPlugin :: FitPlugin }
-
-data HoleFitPluginR = forall s. HoleFitPluginR
- { hfPluginInit :: TcM (TcRef s)
- , holeFitPluginR :: TcRef s -> HoleFitPlugin
- , hfPluginStop :: TcRef s -> TcM () }
--- | HoleFitCandidates are passed to the filter and checked whether they can be
--- made to fit.
+-- | 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
@@ -3977,20 +3965,70 @@ instance HasOccName HoleFitCandidate where
NameHFCand name -> occName name
GreHFCand gre -> occName (gre_name gre)
+instance Ord HoleFitCandidate where
+ compare = compare `on` occName
+
-- | 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.
+ 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 $ occName 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` 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 allows plugins to use an internal TcRef for tracking state.
+data HoleFitPluginR = forall s. HoleFitPluginR
+ { hfPluginInit :: TcM (TcRef s)
+ -- ^ Initializes the TcRef to be passed to the plugin
+ , holeFitPluginR :: TcRef s -> HoleFitPlugin
+ -- ^
+ , hfPluginStop :: TcRef s -> TcM ()
+ -- ^ Cleanup of state, guaranteed to be called even on error.
+ }
--
GitLab