1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
{-
Functions to validate and check .hie file ASTs generated by GHC.
-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module HieDebug where
import GhcPrelude
import SrcLoc
import Module
import FastString
import Outputable
import HieTypes
import HieBin
import HieUtils
import Name
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Function ( on )
import Data.List ( sortOn )
import Data.Foldable ( toList )
ppHies :: Outputable a => (HieASTs a) -> SDoc
ppHies (HieASTs asts) = M.foldrWithKey go "" asts
where
go k a rest = vcat $
[ "File: " <> ppr k
, ppHie a
, rest
]
ppHie :: Outputable a => HieAST a -> SDoc
ppHie = go 0
where
go n (Node inf sp children) = hang header n rest
where
rest = vcat $ map (go (n+2)) children
header = hsep
[ "Node"
, ppr sp
, ppInfo inf
]
ppInfo :: Outputable a => NodeInfo a -> SDoc
ppInfo ni = hsep
[ ppr $ toList $ nodeAnnotations ni
, ppr $ nodeType ni
, ppr $ M.toList $ nodeIdentifiers ni
]
type Diff a = a -> a -> [SDoc]
diffFile :: Diff HieFile
diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))
diffAsts f = diffList (diffAst f) `on` M.elems
diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)
diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2
where
spanDiff
| span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
| otherwise = []
infoDiff'
= (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
++ (diffList diffType `on` nodeType) info1 info2
++ (diffIdents `on` nodeIdentifiers) info1 info2
infoDiff = case infoDiff' of
[] -> []
xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)
, "and", ppr (nodeIdentifiers info2,span2)
, "While comparing"
, ppr (normalizeIdents $ nodeIdentifiers info1), "and"
, ppr (normalizeIdents $ nodeIdentifiers info2)
]
]
diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
diffIdent (a,b) (c,d) = diffName a c
++ eqDiff b d
diffName (Right a) (Right b) = case (a,b) of
(ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')
(LocalName o _, ExternalName _ o' _) -> eqDiff o o'
_ -> eqDiff a b
diffName a b = eqDiff a b
type DiffIdent = Either ModuleName HieName
normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
normalizeIdents = sortOn go . map (first toHieName) . M.toList
where
first f (a,b) = (fmap f a, b)
go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)
diffList :: Diff a -> Diff [a]
diffList f xs ys
| length xs == length ys = concat $ zipWith f xs ys
| otherwise = ["length of lists doesn't match"]
eqDiff :: (Outputable a, Eq a) => Diff a
eqDiff a b
| a == b = []
| otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]
validAst :: HieAST a -> Either SDoc ()
validAst (Node _ span children) = do
checkContainment children
checkSorted children
mapM_ validAst children
where
checkSorted [] = return ()
checkSorted [_] = return ()
checkSorted (x:y:xs)
| nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)
| otherwise = Left $ hsep
[ ppr $ nodeSpan x
, "is not to the left of"
, ppr $ nodeSpan y
]
checkContainment [] = return ()
checkContainment (x:xs)
| span `containsSpan` (nodeSpan x) = checkContainment xs
| otherwise = Left $ hsep
[ ppr $ span
, "does not contain"
, ppr $ nodeSpan x
]
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
validateScopes mod asts = validScopes
where
refMap = generateReferencesMap asts
-- We use a refmap for most of the computation
-- Check if all the names occur in their calculated scopes
validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
valid (Left _) _ = []
valid (Right n) refs = concatMap inScope refs
where
mapRef = foldMap getScopeFromContext . identInfo . snd
scopes = case foldMap mapRef refs of
Just xs -> xs
Nothing -> []
inScope (sp, dets)
| (definedInAsts asts n)
&& any isOccurrence (identInfo dets)
-- We validate scopes for names which are defined locally, and occur
-- in this span
= case scopes of
[] | (nameIsLocalOrFrom mod n
&& not (isDerivedOccName $ nameOccName n))
-- If we don't get any scopes for a local name then its an error.
-- We can ignore derived names.
-> return $ hsep $
[ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
, "Doesn't have a calculated scope: ", ppr scopes]
| otherwise -> []
_ -> if any (`scopeContainsSpan` sp) scopes
then []
else return $ hsep $
[ "Name", ppr n, pprDefinedAt n, "at position", ppr sp
, "doesn't occur in calculated scope", ppr scopes]
| otherwise = []
|
