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