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
|
{-
Functions to validate and check .hie file ASTs generated by GHC.
-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.Iface.Ext.Debug where
import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
import GHC.Types.Name
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Function ( on )
import Data.List ( sortOn )
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 HiePath (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' i1 i2
= (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2
++ (diffList diffType `on` nodeType) i1 i2
++ (diffIdents `on` nodeIdentifiers) i1 i2
sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo)
infoDiff = case sinfoDiff info1 info2 of
[] -> []
xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1)
, "and", ppr (sourcedNodeIdents info2,span2)
, "While comparing"
, ppr (normalizeIdents $ sourcedNodeIdents info1), "and"
, ppr (normalizeIdents $ sourcedNodeIdents 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 HiePath (HieAST a) -> [SDoc]
validateScopes mod asts = validScopes ++ validEvs
where
refMap = generateReferencesMap asts
-- We use a refmap for most of the computation
evs = M.keys
$ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap
validEvs = do
i@(Right ev) <- evs
case M.lookup i refMap of
Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ]
Just refs
| nameIsLocalOrFrom mod ev
, not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs)
-> ["Evidence var" <+> ppr ev <+> "not bound in refmap"]
| otherwise -> []
-- 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 isEvidenceContext (identInfo dets)))
&& any isOccurrence (identInfo dets)
-- We validate scopes for names which are defined locally, and occur
-- in this span, or are evidence variables
= case scopes of
[] | nameIsLocalOrFrom mod n
, ( not (isDerivedOccName $ nameOccName n)
|| any isEvidenceContext (identInfo dets))
-- If we don't get any scopes for a local name or
-- an evidence variable, then its an error.
-- We can ignore other kinds of derived names as
-- long as we take evidence vars into account
-> 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 = []
|
