never executed always true always false
1 {-# LANGUAGE ExistentialQuantification #-}
2 module GHC.Tc.Errors.Hole.FitTypes (
3 TypedHole (..), HoleFit (..), HoleFitCandidate (..),
4 CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),
5 hfIsLcl, pprHoleFitCand
6 ) where
7
8 import GHC.Prelude
9
10 import GHC.Tc.Types
11 import GHC.Tc.Types.Constraint
12 import GHC.Tc.Utils.TcType
13
14 import GHC.Types.Name.Reader
15
16 import GHC.Hs.Doc
17 import GHC.Types.Id
18
19 import GHC.Utils.Outputable
20 import GHC.Types.Name
21
22 import Data.Function ( on )
23
24 data TypedHole = TypedHole { th_relevant_cts :: Cts
25 -- ^ Any relevant Cts to the hole
26 , th_implics :: [Implication]
27 -- ^ The nested implications of the hole with the
28 -- innermost implication first.
29 , th_hole :: Maybe Hole
30 -- ^ The hole itself, if available. Only for debugging.
31 }
32
33 instance Outputable TypedHole where
34 ppr (TypedHole { th_relevant_cts = rels
35 , th_implics = implics
36 , th_hole = hole })
37 = hang (text "TypedHole") 2
38 (ppr rels $+$ ppr implics $+$ ppr hole)
39
40 -- | HoleFitCandidates are passed to hole fit plugins and then
41 -- checked whether they fit a given typed-hole.
42 data HoleFitCandidate = IdHFCand Id -- An id, like locals.
43 | NameHFCand Name -- A name, like built-in syntax.
44 | GreHFCand GlobalRdrElt -- A global, like imported ids.
45
46 instance Eq HoleFitCandidate where
47 IdHFCand i1 == IdHFCand i2 = i1 == i2
48 NameHFCand n1 == NameHFCand n2 = n1 == n2
49 GreHFCand gre1 == GreHFCand gre2 = gre_name gre1 == gre_name gre2
50 _ == _ = False
51
52 instance Outputable HoleFitCandidate where
53 ppr = pprHoleFitCand
54
55 pprHoleFitCand :: HoleFitCandidate -> SDoc
56 pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid
57 pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname
58 pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre
59
60 instance NamedThing HoleFitCandidate where
61 getName hfc = case hfc of
62 IdHFCand cid -> idName cid
63 NameHFCand cname -> cname
64 GreHFCand cgre -> greMangledName cgre
65 getOccName hfc = case hfc of
66 IdHFCand cid -> occName cid
67 NameHFCand cname -> occName cname
68 GreHFCand cgre -> occName (greMangledName cgre)
69
70 instance HasOccName HoleFitCandidate where
71 occName = getOccName
72
73 instance Ord HoleFitCandidate where
74 compare = compare `on` getName
75
76 -- | HoleFit is the type we use for valid hole fits. It contains the
77 -- element that was checked, the Id of that element as found by `tcLookup`,
78 -- and the refinement level of the fit, which is the number of extra argument
79 -- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
80 data HoleFit =
81 HoleFit { hfId :: Id -- ^ The elements id in the TcM
82 , hfCand :: HoleFitCandidate -- ^ The candidate that was checked.
83 , hfType :: TcType -- ^ The type of the id, possibly zonked.
84 , hfRefLvl :: Int -- ^ The number of holes in this fit.
85 , hfWrap :: [TcType] -- ^ The wrapper for the match.
86 , hfMatches :: [TcType]
87 -- ^ What the refinement variables got matched with, if anything
88 , hfDoc :: Maybe HsDocString
89 -- ^ Documentation of this HoleFit, if available.
90 }
91 | RawHoleFit SDoc
92 -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins
93 -- can inject any fit they want.
94
95 -- We define an Eq and Ord instance to be able to build a graph.
96 instance Eq HoleFit where
97 (==) = (==) `on` hfId
98
99 instance Outputable HoleFit where
100 ppr (RawHoleFit sd) = sd
101 ppr (HoleFit _ cand ty _ _ mtchs _) =
102 hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty))
103 where name = ppr $ getName cand
104 holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs
105
106 -- We compare HoleFits by their name instead of their Id, since we don't
107 -- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
108 -- which is used to compare Ids. When comparing, we want HoleFits with a lower
109 -- refinement level to come first.
110 instance Ord HoleFit where
111 compare (RawHoleFit _) (RawHoleFit _) = EQ
112 compare (RawHoleFit _) _ = LT
113 compare _ (RawHoleFit _) = GT
114 compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
115 where cmp = if hfRefLvl a == hfRefLvl b
116 then compare `on` (getName . hfCand)
117 else compare `on` hfRefLvl
118
119 hfIsLcl :: HoleFit -> Bool
120 hfIsLcl hf@(HoleFit {}) = case hfCand hf of
121 IdHFCand _ -> True
122 NameHFCand _ -> False
123 GreHFCand gre -> gre_lcl gre
124 hfIsLcl _ = False
125
126
127 -- | A plugin for modifying the candidate hole fits *before* they're checked.
128 type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
129
130 -- | A plugin for modifying hole fits *after* they've been found.
131 type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
132
133 -- | A HoleFitPlugin is a pair of candidate and fit plugins.
134 data HoleFitPlugin = HoleFitPlugin
135 { candPlugin :: CandPlugin
136 , fitPlugin :: FitPlugin }
137
138 -- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can
139 -- track internal state. Note the existential quantification, ensuring that
140 -- the state cannot be modified from outside the plugin.
141 data HoleFitPluginR = forall s. HoleFitPluginR
142 { hfPluginInit :: TcM (TcRef s)
143 -- ^ Initializes the TcRef to be passed to the plugin
144 , hfPluginRun :: TcRef s -> HoleFitPlugin
145 -- ^ The function defining the plugin itself
146 , hfPluginStop :: TcRef s -> TcM ()
147 -- ^ Cleanup of state, guaranteed to be called even on error
148 }