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 = []