Expression/command ambiguity resolution
[ghc.git] / compiler / hieFile / HieUtils.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2 {-# LANGUAGE TupleSections #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 module HieUtils where
6
7 import GhcPrelude
8
9 import CoreMap
10 import DynFlags ( DynFlags )
11 import FastString ( FastString, mkFastString )
12 import IfaceType
13 import Name hiding (varName)
14 import Outputable ( renderWithStyle, ppr, defaultUserStyle )
15 import SrcLoc
16 import ToIface
17 import TyCon
18 import TyCoRep
19 import Type
20 import Var
21 import VarEnv
22
23 import HieTypes
24
25 import qualified Data.Map as M
26 import qualified Data.Set as S
27 import qualified Data.IntMap.Strict as IM
28 import qualified Data.Array as A
29 import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) )
30 import Data.Maybe ( maybeToList )
31 import Data.Monoid
32 import Data.Traversable ( for )
33 import Control.Monad.Trans.State.Strict hiding (get)
34
35
36 generateReferencesMap
37 :: Foldable f
38 => f (HieAST a)
39 -> M.Map Identifier [(Span, IdentifierDetails a)]
40 generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
41 where
42 go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
43 where
44 this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
45
46 renderHieType :: DynFlags -> HieTypeFix -> String
47 renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty
48 where sty = defaultUserStyle df
49
50 resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
51 resolveVisibility kind ty_args
52 = go (mkEmptyTCvSubst in_scope) kind ty_args
53 where
54 in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
55
56 go _ _ [] = []
57 go env ty ts
58 | Just ty' <- coreView ty
59 = go env ty' ts
60 go env (ForAllTy (Bndr tv vis) res) (t:ts)
61 | isVisibleArgFlag vis = (True , t) : ts'
62 | otherwise = (False, t) : ts'
63 where
64 ts' = go (extendTvSubst env tv t) res ts
65
66 go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps
67 = (True,t) : (go env res ts)
68
69 go env (TyVarTy tv) ts
70 | Just ki <- lookupTyVar env tv = go env ki ts
71 go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded
72
73 foldType :: (HieType a -> a) -> HieTypeFix -> a
74 foldType f (Roll t) = f $ fmap (foldType f) t
75
76 hieTypeToIface :: HieTypeFix -> IfaceType
77 hieTypeToIface = foldType go
78 where
79 go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
80 go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
81 go (HLitTy l) = IfaceLitTy l
82 go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
83 in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
84 go (HFunTy a b) = IfaceFunTy VisArg a b
85 go (HQualTy pred b) = IfaceFunTy InvisArg pred b
86 go (HCastTy a) = a
87 go HCoercionTy = IfaceTyVar "<coercion type>"
88 go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
89
90 -- This isn't fully faithful - we can't produce the 'Inferred' case
91 hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
92 hieToIfaceArgs (HieArgs xs) = go' xs
93 where
94 go' [] = IA_Nil
95 go' ((True ,x):xs) = IA_Arg x Required $ go' xs
96 go' ((False,x):xs) = IA_Arg x Specified $ go' xs
97
98 data HieTypeState
99 = HTS
100 { tyMap :: !(TypeMap TypeIndex)
101 , htyTable :: !(IM.IntMap HieTypeFlat)
102 , freshIndex :: !TypeIndex
103 }
104
105 initialHTS :: HieTypeState
106 initialHTS = HTS emptyTypeMap IM.empty 0
107
108 freshTypeIndex :: State HieTypeState TypeIndex
109 freshTypeIndex = do
110 index <- gets freshIndex
111 modify' $ \hts -> hts { freshIndex = index+1 }
112 return index
113
114 compressTypes
115 :: HieASTs Type
116 -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
117 compressTypes asts = (a, arr)
118 where
119 (a, (HTS _ m i)) = flip runState initialHTS $
120 for asts $ \typ -> do
121 i <- getTypeIndex typ
122 return i
123 arr = A.array (0,i-1) (IM.toList m)
124
125 recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
126 recoverFullType i m = go i
127 where
128 go i = Roll $ fmap go (m A.! i)
129
130 getTypeIndex :: Type -> State HieTypeState TypeIndex
131 getTypeIndex t
132 | otherwise = do
133 tm <- gets tyMap
134 case lookupTypeMap tm t of
135 Just i -> return i
136 Nothing -> do
137 ht <- go t
138 extendHTS t ht
139 where
140 extendHTS t ht = do
141 i <- freshTypeIndex
142 modify' $ \(HTS tm tt fi) ->
143 HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi
144 return i
145
146 go (TyVarTy v) = return $ HTyVarTy $ varName v
147 go ty@(AppTy _ _) = do
148 let (head,args) = splitAppTys ty
149 visArgs = HieArgs $ resolveVisibility (typeKind head) args
150 ai <- getTypeIndex head
151 argsi <- mapM getTypeIndex visArgs
152 return $ HAppTy ai argsi
153 go (TyConApp f xs) = do
154 let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs
155 is <- mapM getTypeIndex visArgs
156 return $ HTyConApp (toIfaceTyCon f) is
157 go (ForAllTy (Bndr v a) t) = do
158 k <- getTypeIndex (varType v)
159 i <- getTypeIndex t
160 return $ HForAllTy ((varName v,k),a) i
161 go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do
162 ai <- getTypeIndex a
163 bi <- getTypeIndex b
164 return $ case af of
165 InvisArg -> HQualTy ai bi
166 VisArg -> HFunTy ai bi
167 go (LitTy a) = return $ HLitTy $ toIfaceTyLit a
168 go (CastTy t _) = do
169 i <- getTypeIndex t
170 return $ HCastTy i
171 go (CoercionTy _) = return HCoercionTy
172
173 resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)
174 resolveTyVarScopes asts = M.map go asts
175 where
176 go ast = resolveTyVarScopeLocal ast asts
177
178 resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a
179 resolveTyVarScopeLocal ast asts = go ast
180 where
181 resolveNameScope dets = dets{identInfo =
182 S.map resolveScope (identInfo dets)}
183 resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =
184 TyVarBind sc $ ResolvedScopes
185 [ LocalScope binding
186 | name <- names
187 , Just binding <- [getNameBinding name asts]
188 ]
189 resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =
190 TyVarBind sc $ ResolvedScopes
191 [ LocalScope binding
192 | name <- names
193 , Just binding <- [getNameBindingInClass name sp asts]
194 ]
195 resolveScope scope = scope
196 go (Node info span children) = Node info' span $ map go children
197 where
198 info' = info { nodeIdentifiers = idents }
199 idents = M.map resolveNameScope $ nodeIdentifiers info
200
201 getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
202 getNameBinding n asts = do
203 (_,msp) <- getNameScopeAndBinding n asts
204 msp
205
206 getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]
207 getNameScope n asts = do
208 (scopes,_) <- getNameScopeAndBinding n asts
209 return scopes
210
211 getNameBindingInClass
212 :: Name
213 -> Span
214 -> M.Map FastString (HieAST a)
215 -> Maybe Span
216 getNameBindingInClass n sp asts = do
217 ast <- M.lookup (srcSpanFile sp) asts
218 getFirst $ foldMap First $ do
219 child <- flattenAst ast
220 dets <- maybeToList
221 $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
222 let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
223 return (getFirst binding)
224
225 getNameScopeAndBinding
226 :: Name
227 -> M.Map FastString (HieAST a)
228 -> Maybe ([Scope], Maybe Span)
229 getNameScopeAndBinding n asts = case nameSrcSpan n of
230 RealSrcSpan sp -> do -- @Maybe
231 ast <- M.lookup (srcSpanFile sp) asts
232 defNode <- selectLargestContainedBy sp ast
233 getFirst $ foldMap First $ do -- @[]
234 node <- flattenAst defNode
235 dets <- maybeToList
236 $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node
237 scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
238 let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
239 return $ Just (scopes, getFirst binding)
240 _ -> Nothing
241
242 getScopeFromContext :: ContextInfo -> Maybe [Scope]
243 getScopeFromContext (ValBind _ sc _) = Just [sc]
244 getScopeFromContext (PatternBind a b _) = Just [a, b]
245 getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
246 getScopeFromContext (Decl _ _) = Just [ModuleScope]
247 getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
248 getScopeFromContext (TyVarBind a _) = Just [a]
249 getScopeFromContext _ = Nothing
250
251 getBindSiteFromContext :: ContextInfo -> Maybe Span
252 getBindSiteFromContext (ValBind _ _ sp) = sp
253 getBindSiteFromContext (PatternBind _ _ sp) = sp
254 getBindSiteFromContext _ = Nothing
255
256 flattenAst :: HieAST a -> [HieAST a]
257 flattenAst n =
258 n : concatMap flattenAst (nodeChildren n)
259
260 smallestContainingSatisfying
261 :: Span
262 -> (HieAST a -> Bool)
263 -> HieAST a
264 -> Maybe (HieAST a)
265 smallestContainingSatisfying sp cond node
266 | nodeSpan node `containsSpan` sp = getFirst $ mconcat
267 [ foldMap (First . smallestContainingSatisfying sp cond) $
268 nodeChildren node
269 , First $ if cond node then Just node else Nothing
270 ]
271 | sp `containsSpan` nodeSpan node = Nothing
272 | otherwise = Nothing
273
274 selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)
275 selectLargestContainedBy sp node
276 | sp `containsSpan` nodeSpan node = Just node
277 | nodeSpan node `containsSpan` sp =
278 getFirst $ foldMap (First . selectLargestContainedBy sp) $
279 nodeChildren node
280 | otherwise = Nothing
281
282 selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)
283 selectSmallestContaining sp node
284 | nodeSpan node `containsSpan` sp = getFirst $ mconcat
285 [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node
286 , First (Just node)
287 ]
288 | sp `containsSpan` nodeSpan node = Nothing
289 | otherwise = Nothing
290
291 definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool
292 definedInAsts asts n = case nameSrcSpan n of
293 RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts
294 _ -> False
295
296 isOccurrence :: ContextInfo -> Bool
297 isOccurrence Use = True
298 isOccurrence _ = False
299
300 scopeContainsSpan :: Scope -> Span -> Bool
301 scopeContainsSpan NoScope _ = False
302 scopeContainsSpan ModuleScope _ = True
303 scopeContainsSpan (LocalScope a) b = a `containsSpan` b
304
305 -- | One must contain the other. Leaf nodes cannot contain anything
306 combineAst :: HieAST Type -> HieAST Type -> HieAST Type
307 combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
308 | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)
309 | aSpn `containsSpan` bSpn = combineAst b a
310 combineAst a (Node xs span children) = Node xs span (insertAst a children)
311
312 -- | Insert an AST in a sorted list of disjoint Asts
313 insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
314 insertAst x = mergeAsts [x]
315
316 -- | Merge two nodes together.
317 --
318 -- Precondition and postcondition: elements in 'nodeType' are ordered.
319 combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
320 (NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =
321 NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
322 where
323 mergeSorted :: [Type] -> [Type] -> [Type]
324 mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of
325 LT -> a : mergeSorted as lb
326 EQ -> a : mergeSorted as bs
327 GT -> b : mergeSorted la bs
328 mergeSorted as [] = as
329 mergeSorted [] bs = bs
330
331
332 {- | Merge two sorted, disjoint lists of ASTs, combining when necessary.
333
334 In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),
335 different nodes in an AST tree should either have disjoint spans (in
336 which case you can say for sure which one comes first) or one span
337 should be completely contained in the other (in which case the contained
338 span corresponds to some child node).
339
340 However, since Haskell does have position-altering pragmas it /is/
341 possible for spans to be overlapping. Here is an example of a source file
342 in which @foozball@ and @quuuuuux@ have overlapping spans:
343
344 @
345 module Baz where
346
347 # line 3 "Baz.hs"
348 foozball :: Int
349 foozball = 0
350
351 # line 3 "Baz.hs"
352 bar, quuuuuux :: Int
353 bar = 1
354 quuuuuux = 2
355 @
356
357 In these cases, we just do our best to produce sensible `HieAST`'s. The blame
358 should be laid at the feet of whoever wrote the line pragmas in the first place
359 (usually the C preprocessor...).
360 -}
361 mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
362 mergeAsts xs [] = xs
363 mergeAsts [] ys = ys
364 mergeAsts xs@(a:as) ys@(b:bs)
365 | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs
366 | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs)
367 | span_a `rightOf` span_b = b : mergeAsts xs bs
368 | span_a `leftOf` span_b = a : mergeAsts as ys
369
370 -- These cases are to work around ASTs that are not fully disjoint
371 | span_a `startsRightOf` span_b = b : mergeAsts as ys
372 | otherwise = a : mergeAsts as ys
373 where
374 span_a = nodeSpan a
375 span_b = nodeSpan b
376
377 rightOf :: Span -> Span -> Bool
378 rightOf s1 s2
379 = (srcSpanStartLine s1, srcSpanStartCol s1)
380 >= (srcSpanEndLine s2, srcSpanEndCol s2)
381 && (srcSpanFile s1 == srcSpanFile s2)
382
383 leftOf :: Span -> Span -> Bool
384 leftOf s1 s2
385 = (srcSpanEndLine s1, srcSpanEndCol s1)
386 <= (srcSpanStartLine s2, srcSpanStartCol s2)
387 && (srcSpanFile s1 == srcSpanFile s2)
388
389 startsRightOf :: Span -> Span -> Bool
390 startsRightOf s1 s2
391 = (srcSpanStartLine s1, srcSpanStartCol s1)
392 >= (srcSpanStartLine s2, srcSpanStartCol s2)
393
394 -- | combines and sorts ASTs using a merge sort
395 mergeSortAsts :: [HieAST Type] -> [HieAST Type]
396 mergeSortAsts = go . map pure
397 where
398 go [] = []
399 go [xs] = xs
400 go xss = go (mergePairs xss)
401 mergePairs [] = []
402 mergePairs [xs] = [xs]
403 mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
404
405 simpleNodeInfo :: FastString -> FastString -> NodeInfo a
406 simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
407
408 locOnly :: SrcSpan -> [HieAST a]
409 locOnly (RealSrcSpan span) =
410 [Node e span []]
411 where e = NodeInfo S.empty [] M.empty
412 locOnly _ = []
413
414 mkScope :: SrcSpan -> Scope
415 mkScope (RealSrcSpan sp) = LocalScope sp
416 mkScope _ = NoScope
417
418 mkLScope :: Located a -> Scope
419 mkLScope = mkScope . getLoc
420
421 combineScopes :: Scope -> Scope -> Scope
422 combineScopes ModuleScope _ = ModuleScope
423 combineScopes _ ModuleScope = ModuleScope
424 combineScopes NoScope x = x
425 combineScopes x NoScope = x
426 combineScopes (LocalScope a) (LocalScope b) =
427 mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)
428
429 {-# INLINEABLE makeNode #-}
430 makeNode
431 :: (Applicative m, Data a)
432 => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
433 -> SrcSpan -- ^ return an empty list if this is unhelpful
434 -> m [HieAST b]
435 makeNode x spn = pure $ case spn of
436 RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]
437 _ -> []
438 where
439 cons = mkFastString . show . toConstr $ x
440 typ = mkFastString . show . typeRepTyCon . typeOf $ x
441
442 {-# INLINEABLE makeTypeNode #-}
443 makeTypeNode
444 :: (Applicative m, Data a)
445 => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
446 -> SrcSpan -- ^ return an empty list if this is unhelpful
447 -> Type -- ^ type to associate with the node
448 -> m [HieAST Type]
449 makeTypeNode x spn etyp = pure $ case spn of
450 RealSrcSpan span ->
451 [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
452 _ -> []
453 where
454 cons = mkFastString . show . toConstr $ x
455 typ = mkFastString . show . typeRepTyCon . typeOf $ x