summaryrefslogtreecommitdiff
path: root/compiler/GHC/Iface/Ext/Debug.hs
blob: 66a6eec34947a3e898da8bf367811491c5b9570e (plain)
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.Unit.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 = []