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
|
{-
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.Types.Module
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Binary
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 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 = []
|
