{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE OverloadedStrings  #-}

{-
Functions to validate and check .hie file ASTs generated by GHC.
-}

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 :: Diff HieFile
diffFile = forall a.
(Outputable a, Eq a, Ord a) =>
Diff a -> Diff (Map HiePath (HieAST a))
diffAsts forall a. (Outputable a, Eq a) => Diff a
eqDiff forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> HieASTs TypeIndex
hie_asts)

diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a))
diffAsts :: forall a.
(Outputable a, Eq a, Ord a) =>
Diff a -> Diff (Map HiePath (HieAST a))
diffAsts Diff a
f = forall a. Diff a -> Diff [a]
diffList (forall a. (Outputable a, Eq a, Ord a) => Diff a -> Diff (HieAST a)
diffAst Diff a
f) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall k a. Map k a -> [a]
M.elems

diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)
diffAst :: forall a. (Outputable a, Eq a, Ord a) => Diff a -> Diff (HieAST a)
diffAst Diff a
diffType (Node SourcedNodeInfo a
info1 Span
span1 [HieAST a]
xs1) (Node SourcedNodeInfo a
info2 Span
span2 [HieAST a]
xs2) =
    [SDoc]
infoDiff forall a. [a] -> [a] -> [a]
++ [SDoc]
spanDiff forall a. [a] -> [a] -> [a]
++ forall a. Diff a -> Diff [a]
diffList (forall a. (Outputable a, Eq a, Ord a) => Diff a -> Diff (HieAST a)
diffAst Diff a
diffType) [HieAST a]
xs1 [HieAST a]
xs2
  where
    spanDiff :: [SDoc]
spanDiff
      | Span
span1 forall a. Eq a => a -> a -> Bool
/= Span
span2 = [[SDoc] -> SDoc
hsep [SDoc
"Spans", forall a. Outputable a => a -> SDoc
ppr Span
span1, SDoc
"and", forall a. Outputable a => a -> SDoc
ppr Span
span2, SDoc
"differ"]]
      | Bool
otherwise = []
    infoDiff' :: NodeInfo a -> NodeInfo a -> [SDoc]
infoDiff' NodeInfo a
i1 NodeInfo a
i2
      = (forall a. Diff a -> Diff [a]
diffList forall a. (Outputable a, Eq a) => Diff a
eqDiff forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. Set a -> [a]
S.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations)) NodeInfo a
i1 NodeInfo a
i2
     forall a. [a] -> [a] -> [a]
++ (forall a. Diff a -> Diff [a]
diffList Diff a
diffType forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. NodeInfo a -> [a]
nodeType) NodeInfo a
i1 NodeInfo a
i2
     forall a. [a] -> [a] -> [a]
++ (forall {a}.
(Outputable a, Ord a) =>
NodeIdentifiers a -> NodeIdentifiers a -> [SDoc]
diffIdents forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers) NodeInfo a
i1 NodeInfo a
i2
    sinfoDiff :: SourcedNodeInfo a -> SourcedNodeInfo a -> [SDoc]
sinfoDiff = forall a. Diff a -> Diff [a]
diffList (\(NodeOrigin
k1,NodeInfo a
a) (NodeOrigin
k2,NodeInfo a
b) -> forall a. (Outputable a, Eq a) => Diff a
eqDiff NodeOrigin
k1 NodeOrigin
k2 forall a. [a] -> [a] -> [a]
++ NodeInfo a -> NodeInfo a -> [SDoc]
infoDiff' NodeInfo a
a NodeInfo a
b) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo)
    infoDiff :: [SDoc]
infoDiff = case SourcedNodeInfo a -> SourcedNodeInfo a -> [SDoc]
sinfoDiff SourcedNodeInfo a
info1 SourcedNodeInfo a
info2 of
      [] -> []
      [SDoc]
xs -> [SDoc]
xs forall a. [a] -> [a] -> [a]
++ [[SDoc] -> SDoc
vcat [SDoc
"In Node:",forall a. Outputable a => a -> SDoc
ppr (forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents SourcedNodeInfo a
info1,Span
span1)
                           , SDoc
"and", forall a. Outputable a => a -> SDoc
ppr (forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents SourcedNodeInfo a
info2,Span
span2)
                        , SDoc
"While comparing"
                        , forall a. Outputable a => a -> SDoc
ppr (forall a.
Ord a =>
NodeIdentifiers a -> [(DiffIdent, IdentifierDetails a)]
normalizeIdents forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents SourcedNodeInfo a
info1), SDoc
"and"
                        , forall a. Outputable a => a -> SDoc
ppr (forall a.
Ord a =>
NodeIdentifiers a -> [(DiffIdent, IdentifierDetails a)]
normalizeIdents forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents SourcedNodeInfo a
info2)
                        ]
                  ]

    diffIdents :: NodeIdentifiers a -> NodeIdentifiers a -> [SDoc]
diffIdents NodeIdentifiers a
a NodeIdentifiers a
b = (forall a. Diff a -> Diff [a]
diffList forall {a} {a}.
(Outputable a, Outputable a, Eq a, Eq a) =>
(Either a HieName, a) -> (Either a HieName, a) -> [SDoc]
diffIdent forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a.
Ord a =>
NodeIdentifiers a -> [(DiffIdent, IdentifierDetails a)]
normalizeIdents) NodeIdentifiers a
a NodeIdentifiers a
b
    diffIdent :: (Either a HieName, a) -> (Either a HieName, a) -> [SDoc]
diffIdent (Either a HieName
a,a
b) (Either a HieName
c,a
d) = forall {a}.
(Outputable a, Eq a) =>
Either a HieName -> Either a HieName -> [SDoc]
diffName Either a HieName
a Either a HieName
c
                         forall a. [a] -> [a] -> [a]
++ forall a. (Outputable a, Eq a) => Diff a
eqDiff a
b a
d
    diffName :: Either a HieName -> Either a HieName -> [SDoc]
diffName (Right HieName
a) (Right HieName
b) = case (HieName
a,HieName
b) of
      (ExternalName Module
m OccName
o SrcSpan
_, ExternalName Module
m' OccName
o' SrcSpan
_) -> forall a. (Outputable a, Eq a) => Diff a
eqDiff (Module
m,OccName
o) (Module
m',OccName
o')
      (LocalName OccName
o SrcSpan
_, ExternalName Module
_ OccName
o' SrcSpan
_) -> forall a. (Outputable a, Eq a) => Diff a
eqDiff OccName
o OccName
o'
      (HieName, HieName)
_ -> forall a. (Outputable a, Eq a) => Diff a
eqDiff HieName
a HieName
b
    diffName Either a HieName
a Either a HieName
b = forall a. (Outputable a, Eq a) => Diff a
eqDiff Either a HieName
a Either a HieName
b

type DiffIdent = Either ModuleName HieName

normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
normalizeIdents :: forall a.
Ord a =>
NodeIdentifiers a -> [(DiffIdent, IdentifierDetails a)]
normalizeIdents = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall {f :: * -> *} {a}.
Functor f =>
(f HieName, IdentifierDetails a)
-> (f OccName, Set ContextInfo, Maybe a)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall {f :: * -> *} {a} {b} {b}.
Functor f =>
(a -> b) -> (f a, b) -> (f b, b)
first Name -> HieName
toHieName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList
  where
    first :: (a -> b) -> (f a, b) -> (f b, b)
first a -> b
f (f a
a,b
b) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
a, b
b)
    go :: (f HieName, IdentifierDetails a)
-> (f OccName, Set ContextInfo, Maybe a)
go (f HieName
a,IdentifierDetails a
b) = (HieName -> OccName
hieNameOcc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f HieName
a,forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
b,forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails a
b)

diffList :: Diff a -> Diff [a]
diffList :: forall a. Diff a -> Diff [a]
diffList Diff a
f [a]
xs [a]
ys
  | forall (t :: * -> *) a. Foldable t => t a -> TypeIndex
length [a]
xs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> TypeIndex
length [a]
ys = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Diff a
f [a]
xs [a]
ys
  | Bool
otherwise = [SDoc
"length of lists doesn't match"]

eqDiff :: (Outputable a, Eq a) => Diff a
eqDiff :: forall a. (Outputable a, Eq a) => Diff a
eqDiff a
a a
b
  | a
a forall a. Eq a => a -> a -> Bool
== a
b = []
  | Bool
otherwise = [[SDoc] -> SDoc
hsep [forall a. Outputable a => a -> SDoc
ppr a
a, SDoc
"and", forall a. Outputable a => a -> SDoc
ppr a
b, SDoc
"do not match"]]

validAst :: HieAST a -> Either SDoc ()
validAst :: forall a. HieAST a -> Either SDoc ()
validAst (Node SourcedNodeInfo a
_ Span
span [HieAST a]
children) = do
  [HieAST a] -> Either SDoc ()
checkContainment [HieAST a]
children
  forall {a}. [HieAST a] -> Either SDoc ()
checkSorted [HieAST a]
children
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. HieAST a -> Either SDoc ()
validAst [HieAST a]
children
  where
    checkSorted :: [HieAST a] -> Either SDoc ()
checkSorted [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkSorted [HieAST a
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkSorted (HieAST a
x:HieAST a
y:[HieAST a]
xs)
      | forall a. HieAST a -> Span
nodeSpan HieAST a
x Span -> Span -> Bool
`leftOf` forall a. HieAST a -> Span
nodeSpan HieAST a
y = [HieAST a] -> Either SDoc ()
checkSorted (HieAST a
yforall a. a -> [a] -> [a]
:[HieAST a]
xs)
      | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
          [ forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> Span
nodeSpan HieAST a
x
          , SDoc
"is not to the left of"
          , forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> Span
nodeSpan HieAST a
y
          ]
    checkContainment :: [HieAST a] -> Either SDoc ()
checkContainment [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkContainment (HieAST a
x:[HieAST a]
xs)
      | Span
span Span -> Span -> Bool
`containsSpan` (forall a. HieAST a -> Span
nodeSpan HieAST a
x) = [HieAST a] -> Either SDoc ()
checkContainment [HieAST a]
xs
      | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
          [ forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ Span
span
          , SDoc
"does not contain"
          , forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> Span
nodeSpan HieAST a
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 :: forall a. Module -> Map HiePath (HieAST a) -> [SDoc]
validateScopes Module
mod Map HiePath (HieAST a)
asts = [SDoc]
validScopes forall a. [a] -> [a] -> [a]
++ [SDoc]
validEvs
  where
    refMap :: RefMap a
refMap = forall (f :: * -> *) a. Foldable f => f (HieAST a) -> RefMap a
generateReferencesMap Map HiePath (HieAST a)
asts
    -- We use a refmap for most of the computation

    evs :: [Either ModuleName Name]
evs = forall k a. Map k a -> [k]
M.keys
      forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Set ContextInfo
identInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) RefMap a
refMap

    validEvs :: [SDoc]
validEvs = do
      i :: Either ModuleName Name
i@(Right Name
ev) <- [Either ModuleName Name]
evs
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Either ModuleName Name
i RefMap a
refMap of
        Maybe [(Span, IdentifierDetails a)]
Nothing -> [SDoc
"Impossible, ev"SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
ev SDoc -> SDoc -> SDoc
<+> SDoc
"not found in refmap" ]
        Just [(Span, IdentifierDetails a)]
refs
          | Module -> Name -> Bool
nameIsLocalOrFrom Module
mod Name
ev
          , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceBind forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Set ContextInfo
identInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ [(Span, IdentifierDetails a)]
refs)
          -> [SDoc
"Evidence var" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
ev SDoc -> SDoc -> SDoc
<+> SDoc
"not bound in refmap"]
          | Bool
otherwise -> []

    -- Check if all the names occur in their calculated scopes
    validScopes :: [SDoc]
validScopes = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\Either ModuleName Name
k [(Span, IdentifierDetails a)]
a [SDoc]
b -> Either ModuleName Name -> [(Span, IdentifierDetails a)] -> [SDoc]
valid Either ModuleName Name
k [(Span, IdentifierDetails a)]
a forall a. [a] -> [a] -> [a]
++ [SDoc]
b) [] RefMap a
refMap
    valid :: Either ModuleName Name -> [(Span, IdentifierDetails a)] -> [SDoc]
valid (Left ModuleName
_) [(Span, IdentifierDetails a)]
_ = []
    valid (Right Name
n) [(Span, IdentifierDetails a)]
refs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Span, IdentifierDetails a) -> [SDoc]
inScope [(Span, IdentifierDetails a)]
refs
      where
        mapRef :: (a, IdentifierDetails a) -> Maybe [Scope]
mapRef = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ContextInfo -> Maybe [Scope]
getScopeFromContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Set ContextInfo
identInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
        scopes :: [Scope]
scopes = case forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall {a} {a}. (a, IdentifierDetails a) -> Maybe [Scope]
mapRef [(Span, IdentifierDetails a)]
refs of
          Just [Scope]
xs -> [Scope]
xs
          Maybe [Scope]
Nothing -> []
        inScope :: (Span, IdentifierDetails a) -> [SDoc]
inScope (Span
sp, IdentifierDetails a
dets)
          |  (forall a. Map HiePath (HieAST a) -> Name -> Bool
definedInAsts Map HiePath (HieAST a)
asts Name
n Bool -> Bool -> Bool
|| (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceContext (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)))
          Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isOccurrence (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
          -- We validate scopes for names which are defined locally, and occur
          -- in this span, or are evidence variables
            = case [Scope]
scopes of
              [] | Module -> Name -> Bool
nameIsLocalOrFrom Module
mod Name
n
                  , (  Bool -> Bool
not (OccName -> Bool
isDerivedOccName forall a b. (a -> b) -> a -> b
$ Name -> OccName
nameOccName Name
n)
                    Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceContext (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
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
                   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep forall a b. (a -> b) -> a -> b
$
                     [ SDoc
"Locally defined Name", forall a. Outputable a => a -> SDoc
ppr Name
n,Name -> SDoc
pprDefinedAt Name
n , SDoc
"at position", forall a. Outputable a => a -> SDoc
ppr Span
sp
                     , SDoc
"Doesn't have a calculated scope: ", forall a. Outputable a => a -> SDoc
ppr [Scope]
scopes]
                 | Bool
otherwise -> []
              [Scope]
_ -> if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Scope -> Span -> Bool
`scopeContainsSpan` Span
sp) [Scope]
scopes
                   then []
                   else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep forall a b. (a -> b) -> a -> b
$
                     [ SDoc
"Name", forall a. Outputable a => a -> SDoc
ppr Name
n, Name -> SDoc
pprDefinedAt Name
n, SDoc
"at position", forall a. Outputable a => a -> SDoc
ppr Span
sp
                     , SDoc
"doesn't occur in calculated scope", forall a. Outputable a => a -> SDoc
ppr [Scope]
scopes]
          | Bool
otherwise = []