Add info about typeclass evidence to .hie files

See `testsuite/tests/hiefile/should_run/HieQueries.hs` and
`testsuite/tests/hiefile/should_run/HieQueries.stdout` for an example of this

We add two new fields, `EvidenceVarBind` and `EvidenceVarUse` to the
`ContextInfo` associated with an Identifier. These are associated with the
appropriate identifiers for the evidence variables collected when we come across
`HsWrappers`, `TcEvBinds` and `IPBinds` while traversing the AST.

Instance dictionary and superclass selector dictionaries from `tcg_insts` and
classes defined in `tcg_tcs` are also recorded in the AST as originating from
their definition span

This allows us to save a complete picture of the evidence constructed by the
constraint solver, and will let us report this to the user, enabling features
like going to the instance definition from the invocation of a class method(or
any other method taking a constraint) and finding all usages of a particular
instance.

Additionally,

- Mark NodeInfo with an origin so we can differentiate between bindings
  origininating in the source vs those in ghc
- Along with typeclass evidence info, also include information on Implicit
  Parameters
- Add a few utility functions to HieUtils in order to query the new info

Updates haddock submodule

5 files changed, 663 insertions, 218 deletions

diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 230ea6a884..ad50fbd228 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -13,36 +13,47 @@ Main functions for .hie file generation
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where
 
+import GHC.Utils.Outputable(ppr)
+
 import GHC.Prelude
 
 import GHC.Types.Avail            ( Avails )
 import GHC.Data.Bag               ( Bag, bagToList )
 import GHC.Types.Basic
 import GHC.Data.BooleanFormula
-import GHC.Core.Class             ( FunDep )
+import GHC.Core.Class             ( FunDep, className, classSCSelIds )
 import GHC.Core.Utils             ( exprType )
 import GHC.Core.ConLike           ( conLikeName )
+import GHC.Core.TyCon             ( TyCon, tyConClass_maybe )
+import GHC.Core.FVs
 import GHC.HsToCore               ( deSugarExpr )
 import GHC.Types.FieldLabel
 import GHC.Hs
 import GHC.Driver.Types
 import GHC.Unit.Module            ( ModuleName, ml_hs_file )
 import GHC.Utils.Monad            ( concatMapM, liftIO )
-import GHC.Types.Name             ( Name, nameSrcSpan, setNameLoc )
+import GHC.Types.Name             ( Name, nameSrcSpan, setNameLoc, nameUnique )
 import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
 import GHC.Types.SrcLoc
 import GHC.Tc.Utils.Zonk          ( hsLitType, hsPatType )
 import GHC.Core.Type              ( mkVisFunTys, Type )
+import GHC.Core.Predicate
+import GHC.Core.InstEnv
 import GHC.Builtin.Types          ( mkListTy, mkSumTy )
-import GHC.Types.Var              ( Id, Var, setVarName, varName, varType )
 import GHC.Tc.Types
+import GHC.Tc.Types.Evidence
+import GHC.Types.Var              ( Id, Var, EvId, setVarName, varName, varType, varUnique )
+import GHC.Types.Var.Env
+import GHC.Types.Unique
 import GHC.Iface.Make             ( mkIfaceExports )
 import GHC.Utils.Panic
 import GHC.Data.Maybe
+import GHC.Data.FastString
 
 import GHC.Iface.Ext.Types
 import GHC.Iface.Ext.Utils
@@ -53,6 +64,8 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Data                  ( Data, Typeable )
 import Data.List                  ( foldl1' )
+import Control.Monad              ( forM_ )
+import Control.Monad.Trans.State.Strict
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Class  ( lift )
 
@@ -196,12 +209,47 @@ The Typechecker introduces new names for mono names in AbsBinds.
 We don't care about the distinction between mono and poly bindings,
 so we replace all occurrences of the mono name with the poly name.
 -}
-newtype HieState = HieState
+type VarMap a = DVarEnv (Var,a)
+data HieState = HieState
   { name_remapping :: NameEnv Id
+  , unlocated_ev_binds :: VarMap (S.Set ContextInfo)
+  -- These contain evidence bindings that we don't have a location for
+  -- These are placed at the top level Node in the HieAST after everything
+  -- else has been generated
+  -- This includes things like top level evidence bindings.
   }
 
+addUnlocatedEvBind :: Var -> ContextInfo -> HieM ()
+addUnlocatedEvBind var ci = do
+  let go (a,b) (_,c) = (a,S.union b c)
+  lift $ modify' $ \s ->
+    s { unlocated_ev_binds =
+          extendDVarEnv_C go (unlocated_ev_binds s)
+                          var (var,S.singleton ci)
+      }
+
+getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type])
+getUnlocatedEvBinds file = do
+  binds <- lift $ gets unlocated_ev_binds
+  org <- ask
+  let elts = dVarEnvElts binds
+
+      mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci)
+
+      go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of
+        RealSrcSpan spn _
+          | srcSpanFile spn == file ->
+            let node = Node (mkSourcedNodeInfo org ni) spn []
+                ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e]
+              in (xs,node:ys)
+        _ -> (mkNodeInfo e : xs,ys)
+
+      (nis,asts) = foldr go ([],[]) elts
+
+  pure $ (M.fromList nis, asts)
+
 initState :: HieState
-initState = HieState emptyNameEnv
+initState = HieState emptyNameEnv emptyDVarEnv
 
 class ModifyState a where -- See Note [Name Remapping]
   addSubstitution :: a -> a -> HieState -> HieState
@@ -216,10 +264,11 @@ instance ModifyState Id where
 modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
 modifyState = foldr go id
   where
-    go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
+    go ABE{abe_poly=poly,abe_mono=mono} f
+      = addSubstitution mono poly . f
     go _ f = f
 
-type HieM = ReaderT HieState Hsc
+type HieM = ReaderT NodeOrigin (StateT HieState Hsc)
 
 -- | Construct an 'HieFile' from the outputs of the typechecker.
 mkHieFile :: ModSummary
@@ -239,7 +288,10 @@ mkHieFileWithSource :: FilePath
                     -> RenamedSource -> Hsc HieFile
 mkHieFileWithSource src_file src ms ts rs = do
   let tc_binds = tcg_binds ts
-  (asts', arr) <- getCompressedAsts tc_binds rs
+      top_ev_binds = tcg_ev_binds ts
+      insts = tcg_insts ts
+      tcs = tcg_tcs ts
+  (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs
   return $ HieFile
       { hie_hs_file = src_file
       , hie_module = ms_mod ms
@@ -250,38 +302,70 @@ mkHieFileWithSource src_file src ms ts rs = do
       , hie_hs_src = src
       }
 
-getCompressedAsts :: TypecheckedSource -> RenamedSource
+getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
   -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
-getCompressedAsts ts rs = do
-  asts <- enrichHie ts rs
+getCompressedAsts ts rs top_ev_binds insts tcs = do
+  asts <- enrichHie ts rs top_ev_binds insts tcs
   return $ compressTypes asts
 
-enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
-enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
+enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
+  -> Hsc (HieASTs Type)
+enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
+  flip evalStateT initState $ flip runReaderT SourceInfo $ do
     tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
     rasts <- processGrp hsGrp
     imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
     exps <- toHie $ fmap (map $ IEC Export . fst) exports
-    let spanFile children = case children of
-          [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
+    -- Add Instance bindings
+    forM_ insts $ \i ->
+      addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)
+    -- Add class parent bindings
+    forM_ tcs $ \tc ->
+      case tyConClass_maybe tc of
+        Nothing -> pure ()
+        Just c -> forM_ (classSCSelIds c) $ \v ->
+          addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing)
+    let spanFile file children = case children of
+          [] -> realSrcLocSpan (mkRealSrcLoc file 1 1)
           _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
                              (realSrcSpanEnd   $ nodeSpan $ last children)
 
-        modulify xs =
-          Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
-
-        asts = HieASTs
-          $ resolveTyVarScopes
-          $ M.map (modulify . mergeSortAsts)
-          $ M.fromListWith (++)
-          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
-
         flat_asts = concat
           [ tasts
           , rasts
           , imps
           , exps
           ]
+
+        modulify file xs' = do
+
+          top_ev_asts <-
+            toHie $ EvBindContext ModuleScope Nothing
+                  $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)
+                  $ EvBinds ev_bs
+
+          (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file
+
+          let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts
+              span = spanFile file xs
+
+              moduleInfo = SourcedNodeInfo
+                             $ M.singleton SourceInfo
+                               $ (simpleNodeInfo "Module" "Module")
+                                  {nodeIdentifiers = uloc_evs}
+
+              moduleNode = Node moduleInfo span []
+
+          case mergeSortAsts $ moduleNode : xs of
+            [x] -> return x
+            xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs)
+
+    asts' <- sequence
+          $ M.mapWithKey modulify
+          $ M.fromListWith (++)
+          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+
+    let asts = HieASTs $ resolveTyVarScopes asts'
     return asts
   where
     processGrp grp = concatM
@@ -305,13 +389,16 @@ grhss_span :: GRHSs p body -> SrcSpan
 grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
 grhss_span (XGRHSs _) = panic "XGRHS has no span"
 
-bindingsOnly :: [Context Name] -> [HieAST a]
-bindingsOnly [] = []
-bindingsOnly (C c n : xs) = case nameSrcSpan n of
-  RealSrcSpan span _ -> Node nodeinfo span [] : bindingsOnly xs
-    where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
-          info = mempty{identInfo = S.singleton c}
-  _ -> bindingsOnly xs
+bindingsOnly :: [Context Name] -> HieM [HieAST a]
+bindingsOnly [] = pure []
+bindingsOnly (C c n : xs) = do
+  org <- ask
+  rest <- bindingsOnly xs
+  pure $ case nameSrcSpan n of
+    RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
+      where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
+            info = mempty{identInfo = S.singleton c}
+    _ -> rest
 
 concatM :: Monad m => [m [a]] -> m [a]
 concatM xs = concat <$> sequence xs
@@ -345,6 +432,8 @@ data SigInfo = SI SigType (Maybe Span)
 
 data SigType = BindSig | ClassSig | InstSig
 
+data EvBindContext a = EvBindContext Scope (Maybe Span) a
+
 data RScoped a = RS Scope a
 -- ^ Scope spans over everything to the right of a, (mostly) not
 -- including a itself
@@ -502,8 +591,9 @@ instance ToHie (TScoped NoExtField) where
   toHie _ = pure []
 
 instance ToHie (IEContext (Located ModuleName)) where
-  toHie (IEC c (L (RealSrcSpan span _) mname)) =
-      pure $ [Node (NodeInfo S.empty [] idents) span []]
+  toHie (IEC c (L (RealSrcSpan span _) mname)) = do
+      org <- ask
+      pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]
     where details = mempty{identInfo = S.singleton (IEThing c)}
           idents = M.singleton (Left mname) details
   toHie _ = pure []
@@ -511,38 +601,90 @@ instance ToHie (IEContext (Located ModuleName)) where
 instance ToHie (Context (Located Var)) where
   toHie c = case c of
       C context (L (RealSrcSpan span _) name')
-        -> do
-        m <- asks name_remapping
-        let name = case lookupNameEnv m (varName name') of
-              Just var -> var
-              Nothing-> name'
-        pure
-          [Node
-            (NodeInfo S.empty [] $
-              M.singleton (Right $ varName name)
-                          (IdentifierDetails (Just $ varType name')
-                                             (S.singleton context)))
-            span
-            []]
+        | varUnique name' == mkBuiltinUnique 1 -> pure []
+          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
+        | otherwise -> do
+          m <- lift $ gets name_remapping
+          org <- ask
+          let name = case lookupNameEnv m (varName name') of
+                Just var -> var
+                Nothing-> name'
+          pure
+            [Node
+              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
+                M.singleton (Right $ varName name)
+                            (IdentifierDetails (Just $ varType name')
+                                               (S.singleton context)))
+              span
+              []]
+      C (EvidenceVarBind i _ sp)  (L _ name) -> do
+        addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
+        pure []
       _ -> pure []
 
 instance ToHie (Context (Located Name)) where
   toHie c = case c of
-      C context (L (RealSrcSpan span _) name') -> do
-        m <- asks name_remapping
-        let name = case lookupNameEnv m name' of
-              Just var -> varName var
-              Nothing -> name'
-        pure
-          [Node
-            (NodeInfo S.empty [] $
-              M.singleton (Right name)
-                          (IdentifierDetails Nothing
-                                             (S.singleton context)))
-            span
-            []]
+      C context (L (RealSrcSpan span _) name')
+        | nameUnique name' == mkBuiltinUnique 1 -> pure []
+          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
+        | otherwise -> do
+          m <- lift $ gets name_remapping
+          org <- ask
+          let name = case lookupNameEnv m name' of
+                Just var -> varName var
+                Nothing -> name'
+          pure
+            [Node
+              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
+                M.singleton (Right name)
+                            (IdentifierDetails Nothing
+                                               (S.singleton context)))
+              span
+              []]
       _ -> pure []
 
+evVarsOfTermList :: EvTerm -> [EvId]
+evVarsOfTermList (EvExpr e)         = exprSomeFreeVarsList isEvVar e
+evVarsOfTermList (EvTypeable _ ev)  =
+  case ev of
+    EvTypeableTyCon _ e   -> concatMap evVarsOfTermList e
+    EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2]
+    EvTypeableTrFun e1 e2 -> concatMap evVarsOfTermList [e1,e2]
+    EvTypeableTyLit e     -> evVarsOfTermList e
+evVarsOfTermList (EvFun{}) = []
+
+instance ToHie (EvBindContext (Located TcEvBinds)) where
+  toHie (EvBindContext sc sp (L span (EvBinds bs)))
+    = concatMapM go $ bagToList bs
+    where
+      go evbind = do
+          let evDeps = evVarsOfTermList $ eb_rhs evbind
+              depNames = EvBindDeps $ map varName evDeps
+          concatM $
+            [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)
+                                        (L span $ eb_lhs evbind))
+            , toHie $ map (C EvidenceVarUse . L span) $ evDeps
+            ]
+  toHie _ = pure []
+
+instance ToHie (EvBindContext (Located NoExtField)) where
+  toHie _ = pure []
+
+instance ToHie (Located HsWrapper) where
+  toHie (L osp wrap)
+    = case wrap of
+        (WpLet bs)      -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs)
+        (WpCompose a b) -> concatM $
+          [toHie (L osp a), toHie (L osp b)]
+        (WpFun a b _ _) -> concatM $
+          [toHie (L osp a), toHie (L osp b)]
+        (WpEvLam a) ->
+          toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp))
+                $ L osp a
+        (WpEvApp a) ->
+          concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
+        _               -> pure []
+
 -- | Dummy instances - never called
 instance ToHie (TScoped (LHsSigWcType GhcTc)) where
   toHie _ = pure []
@@ -586,7 +728,7 @@ instance HasType (LHsExpr GhcRn) where
 --
 -- See #16233
 instance HasType (LHsExpr GhcTc) where
-  getTypeNode e@(L spn e') = lift $
+  getTypeNode e@(L spn e') =
     -- Some expression forms have their type immediately available
     let tyOpt = case e' of
           HsLit _ l -> Just (hsLitType l)
@@ -609,7 +751,7 @@ instance HasType (LHsExpr GhcTc) where
       Nothing
         | skipDesugaring e' -> fallback
         | otherwise -> do
-            hs_env <- Hsc $ \e w -> return (e,w)
+            hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w)
             (_,mbe) <- liftIO $ deSugarExpr hs_env e
             maybe fallback (makeTypeNode e' spn . exprType) mbe
     where
@@ -634,21 +776,25 @@ instance HasType (LHsExpr GhcTc) where
         XExpr (HsWrap{}) -> False
         _                -> True
 
-instance ( ToHie (Context (Located (IdP a)))
-         , ToHie (MatchGroup a (LHsExpr a))
-         , ToHie (PScoped (LPat a))
-         , ToHie (GRHSs a (LHsExpr a))
-         , ToHie (LHsExpr a)
-         , ToHie (Located (PatSynBind a a))
-         , HasType (LHsBind a)
-         , ModifyState (IdP a)
-         , Data (HsBind a)
-         ) => ToHie (BindContext (LHsBind a)) where
+instance ( ToHie (Context (Located (IdP (GhcPass a))))
+         , ToHie (MatchGroup (GhcPass a) (LHsExpr (GhcPass a)))
+         , ToHie (PScoped (LPat (GhcPass a)))
+         , ToHie (GRHSs (GhcPass a) (LHsExpr (GhcPass a)))
+         , ToHie (LHsExpr (GhcPass a))
+         , ToHie (Located (PatSynBind (GhcPass a) (GhcPass a)))
+         , HasType (LHsBind (GhcPass a))
+         , ModifyState (IdP (GhcPass a))
+         , Data (HsBind (GhcPass a))
+         , IsPass a
+         ) => ToHie (BindContext (LHsBind (GhcPass a))) where
   toHie (BC context scope b@(L span bind)) =
     concatM $ getTypeNode b : case bind of
-      FunBind{fun_id = name, fun_matches = matches} ->
+      FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
         [ toHie $ C (ValBind context scope $ getRealSpan span) name
         , toHie matches
+        , case ghcPass @a of
+            GhcTc -> toHie $ L span wrap
+            _ -> pure []
         ]
       PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
         [ toHie $ PS (getRealSpan span) scope NoScope lhs
@@ -657,39 +803,55 @@ instance ( ToHie (Context (Located (IdP a)))
       VarBind{var_rhs = expr} ->
         [ toHie expr
         ]
-      AbsBinds{abs_exports = xs, abs_binds = binds} ->
-        [ local (modifyState xs) $ -- Note [Name Remapping]
-            toHie $ fmap (BC context scope) binds
+      AbsBinds{ abs_exports = xs, abs_binds = binds
+              , abs_ev_binds = ev_binds
+              , abs_ev_vars = ev_vars } ->
+        [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]
+                (toHie $ fmap (BC context scope) binds)
+        , toHie $ map (L span . abe_wrap) xs
+        , toHie $
+            map (EvBindContext (mkScope span) (getRealSpan span)
+                . L span) ev_binds
+        , toHie $
+            map (C (EvidenceVarBind EvSigBind
+                                    (mkScope span)
+                                    (getRealSpan span))
+                . L span) ev_vars
         ]
       PatSynBind _ psb ->
         [ toHie $ L span psb -- PatSynBinds only occur at the top level
         ]
-      XHsBindsLR _ -> []
 
 instance ( ToHie (LMatch a body)
          ) => ToHie (MatchGroup a body) where
-  toHie mg = concatM $ case mg of
-    MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
-      [ pure $ locOnly span
-      , toHie alts
-      ]
-    MG{} -> []
-    XMatchGroup _ -> []
+  toHie mg = case mg of
+    MG{ mg_alts = (L span alts) , mg_origin = origin} ->
+      local (setOrigin origin) $ concatM
+        [ locOnly span
+        , toHie alts
+        ]
+    XMatchGroup _ -> pure []
+
+setOrigin :: Origin -> NodeOrigin -> NodeOrigin
+setOrigin FromSource _ = SourceInfo
+setOrigin Generated _ = GeneratedInfo
 
 instance ( ToHie (Context (Located (IdP a)))
          , ToHie (PScoped (LPat a))
          , ToHie (HsPatSynDir a)
+         , (a ~ GhcPass p)
          ) => ToHie (Located (PatSynBind a a)) where
     toHie (L sp psb) = concatM $ case psb of
       PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
         [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
         , toHie $ toBind dets
-        , toHie $ PS Nothing lhsScope NoScope pat
+        , toHie $ PS Nothing lhsScope patScope pat
         , toHie dir
         ]
         where
           lhsScope = combineScopes varScope detScope
           varScope = mkLScope var
+          patScope = mkScope $ getLoc pat
           detScope = case dets of
             (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
             (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
@@ -702,7 +864,6 @@ instance ( ToHie (Context (Located (IdP a)))
           toBind (PrefixCon args) = PrefixCon $ map (C Use) args
           toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
           toBind (RecCon r) = RecCon $ map (PSC detSpan) r
-      XPatSynBind _ -> []
 
 instance ( ToHie (MatchGroup a (LHsExpr a))
          ) => ToHie (HsPatSynDir a) where
@@ -780,12 +941,24 @@ instance ( a ~ GhcPass p
       SumPat _ pat _ _ ->
         [ toHie $ PS rsp scope pscope pat
         ]
-      ConPat {pat_con = con, pat_args = dets}->
+      ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext}->
         [ case ghcPass @p of
             GhcPs -> toHie $ C Use $ con
             GhcRn -> toHie $ C Use $ con
             GhcTc -> toHie $ C Use $ fmap conLikeName con
         , toHie $ contextify dets
+        , case ghcPass @p of
+            GhcTc ->
+              let ev_binds = cpt_binds ext
+                  ev_vars = cpt_dicts ext
+                  wrap = cpt_wrap ext
+                  evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope
+                in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds
+                           , toHie $ L ospan wrap
+                           , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
+                                         . L ospan) ev_vars
+                           ]
+            _ -> pure []
         ]
       ViewPat _ expr pat ->
         [ toHie expr
@@ -816,10 +989,12 @@ instance ( a ~ GhcPass p
         GhcPs -> noExtCon e
         GhcRn -> noExtCon e
 #endif
-        GhcTc -> []
+        GhcTc ->
+            [ toHie $ L ospan wrap
+            , toHie $ PS rsp scope pscope $ (L ospan pat :: LPat a)
+            ]
           where
-            -- Make sure we get an error if this changes
-            _noWarn@(CoPat _ _ _) = e
+            CoPat wrap pat _ = e
     where
       contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
       contextify (InfixCon a b) = InfixCon a' b'
@@ -833,7 +1008,7 @@ instance ( a ~ GhcPass p
 
 instance ToHie (TScoped (HsPatSigType GhcRn)) where
   toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
-      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
+      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
       , toHie body
       ]
   -- See Note [Scoping Rules for SigPat]
@@ -850,15 +1025,14 @@ instance ( ToHie body
     XGRHSs _ -> []
 
 instance ( ToHie (Located body)
-         , ToHie (RScoped (GuardLStmt a))
-         , Data (GRHS a (Located body))
-         ) => ToHie (LGRHS a (Located body)) where
+         , ToHie (RScoped (GuardLStmt (GhcPass a)))
+         , Data (GRHS (GhcPass a) (Located body))
+         ) => ToHie (LGRHS (GhcPass a) (Located body)) where
   toHie (L span g) = concatM $ makeNode g span : case g of
     GRHS _ guards body ->
       [ toHie $ listScopes (mkLScope body) guards
       , toHie body
       ]
-    XGRHS _ -> []
 
 instance ( a ~ GhcPass p
          , ToHie (Context (Located (IdP a)))
@@ -954,7 +1128,7 @@ instance ( a ~ GhcPass p
         , toHie expr
         ]
       HsDo _ _ (L ispan stmts) ->
-        [ pure $ locOnly ispan
+        [ locOnly ispan
         , toHie $ listScopes NoScope stmts
         ]
       ExplicitList _ _ exprs ->
@@ -1008,9 +1182,10 @@ instance ( a ~ GhcPass p
         ]
       XExpr x
         | GhcTc <- ghcPass @p
-        , HsWrap _ a <- x
-        -> [ toHie $ L mspan a ]
-
+        , HsWrap w a <- x
+        -> [ toHie $ L mspan a
+           , toHie (L mspan w)
+           ]
         | otherwise
         -> []
 
@@ -1070,17 +1245,37 @@ instance ( ToHie (LHsExpr a)
          , ToHie (BindContext (LHsBind a))
          , ToHie (SigContext (LSig a))
          , ToHie (RScoped (HsValBindsLR a a))
+         , ToHie (EvBindContext (Located (XIPBinds a)))
+         , ToHie (RScoped (LIPBind a))
          , Data (HsLocalBinds a)
          ) => ToHie (RScoped (LHsLocalBinds a)) where
   toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
       EmptyLocalBinds _ -> []
-      HsIPBinds _ _ -> []
+      HsIPBinds _ ipbinds -> case ipbinds of
+        IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in
+          [ toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds
+          , toHie $ map (RS sc) xs
+          ]
+        XHsIPBinds _ -> []
       HsValBinds _ valBinds ->
         [ toHie $ RS (combineScopes scope $ mkScope sp)
                       valBinds
         ]
       XHsLocalBindsLR _ -> []
 
+instance ( ToHie (LHsExpr a)
+         , ToHie (Context (Located (IdP a)))
+         , Data (IPBind a)
+         ) => ToHie (RScoped (LIPBind a)) where
+  toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of
+    IPBind _ (Left _) expr -> [toHie expr]
+    IPBind _ (Right v) expr ->
+      [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp))
+              $ L sp v
+      , toHie expr
+      ]
+    XIPBind _ -> []
+
 instance ( ToHie (BindContext (LHsBind a))
          , ToHie (SigContext (LSig a))
          , ToHie (RScoped (XXValBindsLR a a))
@@ -1160,6 +1355,7 @@ instance ( a ~ GhcPass p
          , ToHie (LHsExpr a)
          , ToHie (SigContext (LSig a))
          , ToHie (RScoped (HsValBindsLR a a))
+         , ToHie (RScoped (ExprLStmt a))
          , Data (StmtLR a a (Located (HsExpr a)))
          , Data (HsLocalBinds a)
          ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
@@ -1193,6 +1389,7 @@ instance ( a ~ GhcPass p
          , ToHie (MatchGroup a (LHsCmd a))
          , ToHie (SigContext (LSig a))
          , ToHie (RScoped (HsValBindsLR a a))
+         , ToHie (RScoped (LHsLocalBinds a))
          , Data (HsCmd a)
          , Data (HsCmdTop a)
          , Data (StmtLR a a (Located (HsCmd a)))
@@ -1235,7 +1432,7 @@ instance ( a ~ GhcPass p
         , toHie cmd'
         ]
       HsCmdDo _ (L ispan stmts) ->
-        [ pure $ locOnly ispan
+        [ locOnly ispan
         , toHie $ listScopes NoScope stmts
         ]
       XCmd _ -> []
@@ -1289,7 +1486,7 @@ instance ToHie (LTyClDecl GhcRn) where
         , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
         , toHie $ fmap (BC InstanceBind ModuleScope) meths
         , toHie typs
-        , concatMapM (pure . locOnly . getLoc) deftyps
+        , concatMapM (locOnly . getLoc) deftyps
         , toHie deftyps
         ]
         where
@@ -1313,7 +1510,7 @@ instance ToHie (LFamilyDecl GhcRn) where
 
 instance ToHie (FamilyInfo GhcRn) where
   toHie (ClosedTypeFamily (Just eqns)) = concatM $
-    [ concatMapM (pure . locOnly . getLoc) eqns
+    [ concatMapM (locOnly . getLoc) eqns
     , toHie $ map go eqns
     ]
     where
@@ -1371,7 +1568,7 @@ instance ToHie (HsDataDefn GhcRn) where
 
 instance ToHie (HsDeriving GhcRn) where
   toHie (L span clauses) = concatM
-    [ pure $ locOnly span
+    [ locOnly span
     , toHie clauses
     ]
 
@@ -1379,7 +1576,7 @@ instance ToHie (LHsDerivingClause GhcRn) where
   toHie (L span cl) = concatM $ makeNode cl span : case cl of
       HsDerivingClause _ strat (L ispan tys) ->
         [ toHie strat
-        , pure $ locOnly ispan
+        , locOnly ispan
         , toHie $ map (TS (ResolvedScopes [])) tys
         ]
 
@@ -1391,14 +1588,14 @@ instance ToHie (Located (DerivStrategy GhcRn)) where
       ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
 
 instance ToHie (Located OverlapMode) where
-  toHie (L span _) = pure $ locOnly span
+  toHie (L span _) = locOnly span
 
 instance ToHie (LConDecl GhcRn) where
   toHie (L span decl) = concatM $ makeNode decl span : case decl of
       ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
                   , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
         [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
-        , concatM $ [ pure $ bindingsOnly bindings
+        , concatM $ [ bindingsOnly bindings
                     , toHie $ tvScopes resScope NoScope exp_vars ]
         , toHie ctx
         , toHie args
@@ -1429,7 +1626,7 @@ instance ToHie (LConDecl GhcRn) where
 
 instance ToHie (Located [LConDeclField GhcRn]) where
   toHie (L span decls) = concatM $
-    [ pure $ locOnly span
+    [ locOnly span
     , toHie decls
     ]
 
@@ -1437,7 +1634,7 @@ instance ( HasLoc thing
          , ToHie (TScoped thing)
          ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
   toHie (TS sc (HsIB ibrn a)) = concatM $
-      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
+      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
       , toHie $ TS sc a
       ]
     where span = loc a
@@ -1446,7 +1643,7 @@ instance ( HasLoc thing
          , ToHie (TScoped thing)
          ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
   toHie (TS sc (HsWC names a)) = concatM $
-      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
+      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
       , toHie $ TS sc a
       ]
     where span = loc a
@@ -1496,10 +1693,10 @@ instance ToHie (SigContext (LSig GhcRn)) where
         ]
       SCCFunSig _ _ name mtxt ->
         [ toHie $ (C Use) name
-        , pure $ maybe [] (locOnly . getLoc) mtxt
+        , maybe (pure []) (locOnly . getLoc) mtxt
         ]
       CompleteMatchSig _ _ (L ispan names) typ ->
-        [ pure $ locOnly ispan
+        [ locOnly ispan
         , toHie $ map (C Use) names
         , toHie $ fmap (C Use) typ
         ]
@@ -1583,7 +1780,7 @@ instance ToHie (TScoped (LHsType GhcRn)) where
 instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
   toHie (HsValArg tm) = toHie tm
   toHie (HsTypeArg _ ty) = toHie ty
-  toHie (HsArgPar sp) = pure $ locOnly sp
+  toHie (HsArgPar sp) = locOnly sp
 
 instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where
   toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
@@ -1597,7 +1794,7 @@ instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where
 
 instance ToHie (TScoped (LHsQTyVars GhcRn)) where
   toHie (TS sc (HsQTvs implicits vars)) = concatM $
-    [ pure $ bindingsOnly bindings
+    [ bindingsOnly bindings
     , toHie $ tvScopes sc NoScope vars
     ]
     where
@@ -1606,7 +1803,7 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where
 
 instance ToHie (LHsContext GhcRn) where
   toHie (L span tys) = concatM $
-      [ pure $ locOnly span
+      [ locOnly span
       , toHie tys
       ]
 
@@ -1679,7 +1876,7 @@ instance ( a ~ GhcPass p
         [ toHie expr
         ]
       HsQuasiQuote _ _ _ ispan _ ->
-        [ pure $ locOnly ispan
+        [ locOnly ispan
         ]
       HsSpliced _ _ _ ->
         []
@@ -1695,7 +1892,7 @@ instance ToHie (LRoleAnnotDecl GhcRn) where
   toHie (L span annot) = concatM $ makeNode annot span : case annot of
       RoleAnnotDecl _ var roles ->
         [ toHie $ C Use var
-        , concatMapM (pure . locOnly . getLoc) roles
+        , concatMapM (locOnly . getLoc) roles
         ]
 
 instance ToHie (LInstDecl GhcRn) where
@@ -1715,9 +1912,9 @@ instance ToHie (LClsInstDecl GhcRn) where
     [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
     , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
     , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
-    , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
+    , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl
     , toHie $ cid_tyfam_insts decl
-    , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
+    , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl
     , toHie $ cid_datafam_insts decl
     , toHie $ cid_overlap_mode decl
     ]
@@ -1769,14 +1966,14 @@ instance ToHie (LForeignDecl GhcRn) where
         ]
 
 instance ToHie ForeignImport where
-  toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
+  toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $
     [ locOnly a
     , locOnly b
     , locOnly c
     ]
 
 instance ToHie ForeignExport where
-  toHie (CExport (L a _) (L b _)) = pure $ concat $
+  toHie (CExport (L a _) (L b _)) = concatM $
     [ locOnly a
     , locOnly b
     ]
@@ -1814,7 +2011,7 @@ instance ToHie (LRuleDecls GhcRn) where
 instance ToHie (LRuleDecl GhcRn) where
   toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
         [ makeNode r span
-        , pure $ locOnly $ getLoc rname
+        , locOnly $ getLoc rname
         , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
         , toHie $ map (RS $ mkScope span) bndrs
         , toHie exprA
@@ -1844,7 +2041,7 @@ instance ToHie (LImportDecl GhcRn) where
         ]
     where
       goIE (hiding, (L sp liens)) = concatM $
-        [ pure $ locOnly sp
+        [ locOnly sp
         , toHie $ map (IEC c) liens
         ]
         where
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index cc13910723..550b3d0462 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -23,7 +23,6 @@ import GHC.Utils.Binary
 import GHC.Iface.Binary           ( getDictFastString )
 import GHC.Data.FastMutInt
 import GHC.Data.FastString        ( FastString )
-import GHC.Unit.Module            ( Module )
 import GHC.Types.Name
 import GHC.Types.Name.Cache
 import GHC.Utils.Outputable
@@ -32,7 +31,6 @@ import GHC.Types.SrcLoc as SrcLoc
 import GHC.Types.Unique.Supply    ( takeUniqFromSupply )
 import GHC.Types.Unique
 import GHC.Types.Unique.FM
-import GHC.Utils.Misc
 import GHC.Iface.Env (NameCacheUpdater(..))
 
 import qualified Data.Array as A
@@ -48,42 +46,6 @@ import System.FilePath            ( takeDirectory )
 
 import GHC.Iface.Ext.Types
 
--- | `Name`'s get converted into `HieName`'s before being written into @.hie@
--- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
--- these two types.
-data HieName
-  = ExternalName !Module !OccName !SrcSpan
-  | LocalName !OccName !SrcSpan
-  | KnownKeyName !Unique
-  deriving (Eq)
-
-instance Ord HieName where
-  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` SrcLoc.leftmost_smallest c f
-    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
-  compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` SrcLoc.leftmost_smallest b d
-    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
-  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
-    -- Not actually non deterministic as it is a KnownKey
-  compare ExternalName{} _ = LT
-  compare LocalName{} ExternalName{} = GT
-  compare LocalName{} _ = LT
-  compare KnownKeyName{} _ = GT
-
-instance Outputable HieName where
-  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
-  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
-  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
-
-hieNameOcc :: HieName -> OccName
-hieNameOcc (ExternalName _ occ _) = occ
-hieNameOcc (LocalName occ _) = occ
-hieNameOcc (KnownKeyName u) =
-  case lookupKnownKeyName u of
-    Just n -> nameOccName n
-    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
-                        (ppr (unpkUnique u))
-
-
 data HieSymbolTable = HieSymbolTable
   { hie_symtab_next :: !FastMutInt
   , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))
@@ -352,14 +314,6 @@ putName (HieSymbolTable next ref) bh name = do
 
 -- ** Converting to and from `HieName`'s
 
-toHieName :: Name -> HieName
-toHieName name
-  | isKnownKeyName name = KnownKeyName (nameUnique name)
-  | isExternalName name = ExternalName (nameModule name)
-                                       (nameOccName name)
-                                       (nameSrcSpan name)
-  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
-
 fromHieName :: NameCache -> HieName -> (NameCache, Name)
 fromHieName nc (ExternalName mod occ span) =
     let cache = nsNames nc
diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs
index 66a6eec349..903413eaab 100644
--- a/compiler/GHC/Iface/Ext/Debug.hs
+++ b/compiler/GHC/Iface/Ext/Debug.hs
@@ -15,7 +15,6 @@ 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
 
@@ -39,17 +38,18 @@ diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
     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
+    infoDiff' i1 i2
+      = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2
+     ++ (diffList diffType `on` nodeType) i1 i2
+     ++ (diffIdents `on` nodeIdentifiers) i1 i2
+    sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo)
+    infoDiff = case sinfoDiff info1 info2 of
       [] -> []
-      xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)
-                           , "and", ppr (nodeIdentifiers info2,span2)
+      xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1)
+                           , "and", ppr (sourcedNodeIdents info2,span2)
                         , "While comparing"
-                        , ppr (normalizeIdents $ nodeIdentifiers info1), "and"
-                        , ppr (normalizeIdents $ nodeIdentifiers info2)
+                        , ppr (normalizeIdents $ sourcedNodeIdents info1), "and"
+                        , ppr (normalizeIdents $ sourcedNodeIdents info2)
                         ]
                   ]
 
@@ -107,11 +107,24 @@ validAst (Node _ span children) = do
 -- | 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
+validateScopes mod asts = validScopes ++ validEvs
   where
     refMap = generateReferencesMap asts
     -- We use a refmap for most of the computation
 
+    evs = M.keys
+      $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap
+
+    validEvs = do
+      i@(Right ev) <- evs
+      case M.lookup i refMap of
+        Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ]
+        Just refs
+          | nameIsLocalOrFrom mod ev
+          , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs)
+          -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"]
+          | otherwise -> []
+
     -- Check if all the names occur in their calculated scopes
     validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
     valid (Left _) _ = []
@@ -122,15 +135,18 @@ validateScopes mod asts = validScopes
           Just xs -> xs
           Nothing -> []
         inScope (sp, dets)
-          |  (definedInAsts asts n)
+          |  (definedInAsts asts n || (any isEvidenceContext (identInfo dets)))
           && any isOccurrence (identInfo dets)
           -- We validate scopes for names which are defined locally, and occur
-          -- in this span
+          -- in this span, or are evidence variables
             = 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.
+              [] | nameIsLocalOrFrom mod n
+                  , (  not (isDerivedOccName $ nameOccName n)
+                    || any isEvidenceContext (identInfo 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
                    -> return $ hsep $
                      [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
                      , "Doesn't have a calculated scope: ", ppr scopes]
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
index a216272d7f..3419e441a7 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -17,13 +17,16 @@ import GHC.Prelude
 import GHC.Settings.Config
 import GHC.Utils.Binary
 import GHC.Data.FastString        ( FastString )
+import GHC.Builtin.Utils
 import GHC.Iface.Type
-import GHC.Unit.Module           ( ModuleName, Module )
-import GHC.Types.Name             ( Name )
+import GHC.Unit.Module            ( ModuleName, Module )
+import GHC.Types.Name
 import GHC.Utils.Outputable hiding ( (<>) )
-import GHC.Types.SrcLoc           ( RealSrcSpan )
+import GHC.Types.SrcLoc
 import GHC.Types.Avail
+import GHC.Types.Unique
 import qualified GHC.Utils.Outputable as O ( (<>) )
+import GHC.Utils.Misc
 
 import qualified Data.Array as A
 import qualified Data.Map as M
@@ -33,6 +36,8 @@ import Data.Data                  ( Typeable, Data )
 import Data.Semigroup             ( Semigroup(..) )
 import Data.Word                  ( Word8 )
 import Control.Applicative        ( (<|>) )
+import Data.Coerce                ( coerce  )
+import Data.Function              ( on )
 
 type Span = RealSrcSpan
 
@@ -222,17 +227,16 @@ instance Outputable a => Outputable (HieASTs a) where
         , rest
         ]
 
-
 data HieAST a =
   Node
-    { nodeInfo :: NodeInfo a
+    { sourcedNodeInfo :: SourcedNodeInfo a
     , nodeSpan :: Span
     , nodeChildren :: [HieAST a]
     } deriving (Functor, Foldable, Traversable)
 
 instance Binary (HieAST TypeIndex) where
   put_ bh ast = do
-    put_ bh $ nodeInfo ast
+    put_ bh $ sourcedNodeInfo ast
     put_ bh $ nodeSpan ast
     put_ bh $ nodeChildren ast
 
@@ -247,6 +251,38 @@ instance Outputable a => Outputable (HieAST a) where
       header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
       rest = vcat (map ppr ch)
 
+
+-- | NodeInfos grouped by source
+newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) }
+  deriving (Functor, Foldable, Traversable)
+
+instance Binary (SourcedNodeInfo TypeIndex) where
+  put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts
+  get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh)
+
+instance Outputable a => Outputable (SourcedNodeInfo a) where
+  ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts
+    where
+      go k a rest = vcat $
+        [ "Source: " O.<> ppr k
+        , ppr a
+        , rest
+        ]
+
+-- | Source of node info
+data NodeOrigin
+  = SourceInfo
+  | GeneratedInfo
+    deriving (Eq, Enum, Ord)
+
+instance Outputable NodeOrigin where
+  ppr SourceInfo = text "From source"
+  ppr GeneratedInfo = text "generated by ghc"
+
+instance Binary NodeOrigin where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
 -- | The information stored in one AST node.
 --
 -- The type parameter exists to provide flexibility in representation of types
@@ -314,7 +350,7 @@ instance Monoid (IdentifierDetails a) where
 instance Binary (IdentifierDetails TypeIndex) where
   put_ bh dets = do
     put_ bh $ identType dets
-    put_ bh $ S.toAscList $ identInfo dets
+    put_ bh $ S.toList $ identInfo dets
   get bh =  IdentifierDetails
     <$> get bh
     <*> fmap S.fromDistinctAscList (get bh)
@@ -363,6 +399,14 @@ data ContextInfo
 
   -- | Record field
   | RecField RecFieldContext (Maybe Span)
+  -- | Constraint/Dictionary evidence variable binding
+  | EvidenceVarBind
+      EvVarSource  -- ^ how did this bind come into being
+      Scope        -- ^ scope over which the value is bound
+      (Maybe Span) -- ^ span of the binding site
+
+  -- | Usage of evidence variable
+  | EvidenceVarUse
     deriving (Eq, Ord)
 
 instance Outputable ContextInfo where
@@ -385,10 +429,16 @@ instance Outputable ContextInfo where
      <+> ppr sc1 <+> "," <+> ppr sc2
  ppr (RecField ctx sp) =
    text "record field" <+> ppr ctx <+> pprBindSpan sp
+ ppr (EvidenceVarBind ctx sc sp) =
+   text "evidence variable" <+> ppr ctx
+     $$ "with scope:" <+> ppr sc
+     $$ pprBindSpan sp
+ ppr (EvidenceVarUse) =
+   text "usage of evidence variable"
 
 pprBindSpan :: Maybe Span -> SDoc
 pprBindSpan Nothing = text ""
-pprBindSpan (Just sp) = text "at:" <+> ppr sp
+pprBindSpan (Just sp) = text "bound at:" <+> ppr sp
 
 instance Binary ContextInfo where
   put_ bh Use = putByte bh 0
@@ -422,6 +472,12 @@ instance Binary ContextInfo where
     put_ bh a
     put_ bh b
   put_ bh MatchBind = putByte bh 9
+  put_ bh (EvidenceVarBind a b c) = do
+    putByte bh 10
+    put_ bh a
+    put_ bh b
+    put_ bh c
+  put_ bh EvidenceVarUse = putByte bh 11
 
   get bh = do
     (t :: Word8) <- get bh
@@ -436,8 +492,69 @@ instance Binary ContextInfo where
       7 -> TyVarBind <$> get bh <*> get bh
       8 -> RecField <$> get bh <*> get bh
       9 -> return MatchBind
+      10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh
+      11 -> return EvidenceVarUse
       _ -> panic "Binary ContextInfo: invalid tag"
 
+data EvVarSource
+  = EvPatternBind -- ^ bound by a pattern match
+  | EvSigBind -- ^ bound by a type signature
+  | EvWrapperBind -- ^ bound by a hswrapper
+  | EvImplicitBind -- ^ bound by an implicit variable
+  | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class
+  | EvLetBind EvBindDeps -- ^ A direct let binding
+  deriving (Eq,Ord)
+
+instance Binary EvVarSource where
+  put_ bh EvPatternBind = putByte bh 0
+  put_ bh EvSigBind = putByte bh 1
+  put_ bh EvWrapperBind = putByte bh 2
+  put_ bh EvImplicitBind = putByte bh 3
+  put_ bh (EvInstBind b cls) = do
+    putByte bh 4
+    put_ bh b
+    put_ bh cls
+  put_ bh (EvLetBind deps) = do
+    putByte bh 5
+    put_ bh deps
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> pure EvPatternBind
+      1 -> pure EvSigBind
+      2 -> pure EvWrapperBind
+      3 -> pure EvImplicitBind
+      4 -> EvInstBind <$> get bh <*> get bh
+      5 -> EvLetBind <$> get bh
+      _ -> panic "Binary EvVarSource: invalid tag"
+
+instance Outputable EvVarSource where
+  ppr EvPatternBind = text "bound by a pattern"
+  ppr EvSigBind = text "bound by a type signature"
+  ppr EvWrapperBind = text "bound by a HsWrapper"
+  ppr EvImplicitBind = text "bound by an implicit variable binding"
+  ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls
+  ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls
+  ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
+
+-- | Eq/Ord instances compare on the converted HieName,
+-- as non-exported names may have different uniques after
+-- a roundtrip
+newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
+  deriving Outputable
+
+instance Eq EvBindDeps where
+  (==) = coerce ((==) `on` map toHieName)
+
+instance Ord EvBindDeps where
+  compare = coerce (compare `on` map toHieName)
+
+instance Binary EvBindDeps where
+  put_ bh (EvBindDeps xs) = put_ bh xs
+  get bh = EvBindDeps <$> get bh
+
+
 -- | Types of imports and exports
 data IEType
   = Import
@@ -587,3 +704,46 @@ instance Binary TyVarScope where
       0 -> ResolvedScopes <$> get bh
       1 -> UnresolvedScope <$> get bh <*> get bh
       _ -> panic "Binary TyVarScope: invalid tag"
+
+-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
+-- these two types.
+data HieName
+  = ExternalName !Module !OccName !SrcSpan
+  | LocalName !OccName !SrcSpan
+  | KnownKeyName !Unique
+  deriving (Eq)
+
+instance Ord HieName where
+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f
+    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
+  compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d
+    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
+    -- Not actually non deterministic as it is a KnownKey
+  compare ExternalName{} _ = LT
+  compare LocalName{} ExternalName{} = GT
+  compare LocalName{} _ = LT
+  compare KnownKeyName{} _ = GT
+
+instance Outputable HieName where
+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
+
+hieNameOcc :: HieName -> OccName
+hieNameOcc (ExternalName _ occ _) = occ
+hieNameOcc (LocalName occ _) = occ
+hieNameOcc (KnownKeyName u) =
+  case lookupKnownKeyName u of
+    Just n -> nameOccName n
+    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
+                        (ppr (unpkUnique u))
+
+toHieName :: Name -> HieName
+toHieName name
+  | isKnownKeyName name = KnownKeyName (nameUnique name)
+  | isExternalName name = ExternalName (nameModule name)
+                                       (nameOccName name)
+                                       (nameSrcSpan name)
+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index 9684a493b2..b0a6f84404 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -1,7 +1,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
 module GHC.Iface.Ext.Utils where
 
 import GHC.Prelude
@@ -11,7 +13,9 @@ import GHC.Driver.Session    ( DynFlags )
 import GHC.Data.FastString   ( FastString, mkFastString )
 import GHC.Iface.Type
 import GHC.Types.Name hiding (varName)
-import GHC.Utils.Outputable  ( renderWithStyle, ppr, defaultUserStyle, initSDocContext )
+import GHC.Types.Name.Set
+import GHC.Utils.Outputable hiding ( (<>) )
+import qualified GHC.Utils.Outputable as O
 import GHC.Types.SrcLoc
 import GHC.CoreToIface
 import GHC.Core.TyCon
@@ -27,21 +31,26 @@ import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Array as A
 import Data.Data                  ( typeOf, typeRepTyCon, Data(toConstr) )
-import Data.Maybe                 ( maybeToList )
+import Data.Maybe                 ( maybeToList, mapMaybe)
 import Data.Monoid
+import Data.List                  (find)
 import Data.Traversable           ( for )
+import Data.Coerce
 import Control.Monad.Trans.State.Strict hiding (get)
+import Control.Monad.Trans.Reader
+import qualified Data.Tree as Tree
 
+type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]
 
 generateReferencesMap
   :: Foldable f
   => f (HieAST a)
-  -> M.Map Identifier [(Span, IdentifierDetails a)]
+  -> RefMap a
 generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
   where
     go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
       where
-        this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
+        this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast
 
 renderHieType :: DynFlags -> HieTypeFix -> String
 renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht)
@@ -72,6 +81,73 @@ resolveVisibility kind ty_args
 foldType :: (HieType a -> a) -> HieTypeFix -> a
 foldType f (Roll t) = f $ fmap (foldType f) t
 
+selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
+selectPoint hf (sl,sc) = getFirst $
+  flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $
+      case selectSmallestContaining (sp fs) ast of
+        Nothing -> Nothing
+        Just ast' -> Just ast'
+ where
+   sloc fs = mkRealSrcLoc fs sl sc
+   sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
+
+findEvidenceUse :: NodeIdentifiers a -> [Name]
+findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)]
+ where
+   xs = M.toList ni
+
+data EvidenceInfo a
+  = EvidenceInfo
+  { evidenceVar :: Name
+  , evidenceSpan :: RealSrcSpan
+  , evidenceType :: a
+  , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
+  } deriving (Eq,Ord,Functor)
+
+instance (Outputable a) => Outputable (EvidenceInfo a) where
+  ppr (EvidenceInfo name span typ dets) =
+    hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $
+      pdets $$ (pprDefinedAt name)
+    where
+      pdets = case dets of
+        Nothing -> text "is a usage of an external evidence variable"
+        Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn)
+
+getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)
+getEvidenceTreesAtPoint hf refmap point =
+  [t | Just ast <- pure $ selectPoint hf point
+     , n        <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast)
+     , Just t   <- pure $ getEvidenceTree refmap n
+     ]
+
+getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))
+getEvidenceTree refmap var = go emptyNameSet var
+  where
+    go seen var
+      | var `elemNameSet` seen = Nothing
+      | otherwise = do
+          xs <- M.lookup (Right var) refmap
+          case find (any isEvidenceBind . identInfo . snd) xs of
+            Just (sp,dets) -> do
+              typ <- identType dets
+              (evdet,children) <- getFirst $ foldMap First $ do
+                 det <- S.toList $ identInfo dets
+                 case det of
+                   EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->
+                     pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)
+                   EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[])
+                   _ -> pure Nothing
+              pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children
+            -- It is externally bound
+            Nothing -> getFirst $ foldMap First $ do
+              (sp,dets) <- xs
+              if (any isEvidenceUse $ identInfo dets)
+                then do
+                  case identType dets of
+                    Nothing -> pure Nothing
+                    Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) []
+                else pure Nothing
+
 hieTypeToIface :: HieTypeFix -> IfaceType
 hieTypeToIface = foldType go
   where
@@ -194,8 +270,10 @@ resolveTyVarScopeLocal ast asts = go ast
     resolveScope scope = scope
     go (Node info span children) = Node info' span $ map go children
       where
-        info' = info { nodeIdentifiers = idents }
-        idents = M.map resolveNameScope $ nodeIdentifiers info
+        info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info)
+        updateNodeInfo i = i { nodeIdentifiers = idents }
+          where
+            idents = M.map resolveNameScope $ nodeIdentifiers i
 
 getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
 getNameBinding n asts = do
@@ -217,7 +295,7 @@ getNameBindingInClass n sp asts = do
   getFirst $ foldMap First $ do
     child <- flattenAst ast
     dets <- maybeToList
-      $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
+      $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child
     let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
     return (getFirst binding)
 
@@ -232,7 +310,7 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of
     getFirst $ foldMap First $ do -- @[]
       node <- flattenAst defNode
       dets <- maybeToList
-        $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node
+        $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node
       scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
       let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
       return $ Just (scopes, getFirst binding)
@@ -245,6 +323,7 @@ getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
 getScopeFromContext (Decl _ _) = Just [ModuleScope]
 getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
 getScopeFromContext (TyVarBind a _) = Just [a]
+getScopeFromContext (EvidenceVarBind _ a _) = Just [a]
 getScopeFromContext _ = Nothing
 
 getBindSiteFromContext :: ContextInfo -> Maybe Span
@@ -292,8 +371,27 @@ definedInAsts asts n = case nameSrcSpan n of
   RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts
   _ -> False
 
+getEvidenceBindDeps :: ContextInfo -> [Name]
+getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) =
+  getEvBindDeps xs
+getEvidenceBindDeps _ = []
+
+isEvidenceBind :: ContextInfo -> Bool
+isEvidenceBind EvidenceVarBind{} = True
+isEvidenceBind _ = False
+
+isEvidenceContext :: ContextInfo -> Bool
+isEvidenceContext EvidenceVarUse = True
+isEvidenceContext EvidenceVarBind{} = True
+isEvidenceContext _ = False
+
+isEvidenceUse :: ContextInfo -> Bool
+isEvidenceUse EvidenceVarUse = True
+isEvidenceUse _ = False
+
 isOccurrence :: ContextInfo -> Bool
 isOccurrence Use = True
+isOccurrence EvidenceVarUse = True
 isOccurrence _ = False
 
 scopeContainsSpan :: Scope -> Span -> Bool
@@ -304,7 +402,7 @@ scopeContainsSpan (LocalScope a) b = a `containsSpan` b
 -- | One must contain the other. Leaf nodes cannot contain anything
 combineAst :: HieAST Type -> HieAST Type -> HieAST Type
 combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
-  | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)
+  | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys)
   | aSpn `containsSpan` bSpn = combineAst b a
 combineAst a (Node xs span children) = Node xs span (insertAst a children)
 
@@ -312,6 +410,18 @@ combineAst a (Node xs span children) = Node xs span (insertAst a children)
 insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
 insertAst x = mergeAsts [x]
 
+nodeInfo :: HieAST Type -> NodeInfo Type
+nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
+
+emptyNodeInfo :: NodeInfo a
+emptyNodeInfo = NodeInfo S.empty [] M.empty
+
+sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a
+sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo
+
+combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type
+combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo
+
 -- | Merge two nodes together.
 --
 -- Precondition and postcondition: elements in 'nodeType' are ordered.
@@ -404,11 +514,12 @@ mergeSortAsts = go . map pure
 simpleNodeInfo :: FastString -> FastString -> NodeInfo a
 simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
 
-locOnly :: SrcSpan -> [HieAST a]
-locOnly (RealSrcSpan span _) =
-  [Node e span []]
-    where e = NodeInfo S.empty [] M.empty
-locOnly _ = []
+locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
+locOnly (RealSrcSpan span _) = do
+  org <- ask
+  let e = mkSourcedNodeInfo org $ emptyNodeInfo
+  pure [Node e span []]
+locOnly _ = pure []
 
 mkScope :: SrcSpan -> Scope
 mkScope (RealSrcSpan sp _) = LocalScope sp
@@ -425,30 +536,37 @@ combineScopes x NoScope = x
 combineScopes (LocalScope a) (LocalScope b) =
   mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)
 
+mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
+mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
+
 {-# INLINEABLE makeNode #-}
 makeNode
-  :: (Applicative m, Data a)
+  :: (Monad m, Data a)
   => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
   -> SrcSpan                 -- ^ return an empty list if this is unhelpful
-  -> m [HieAST b]
-makeNode x spn = pure $ case spn of
-  RealSrcSpan span _ -> [Node (simpleNodeInfo cons typ) span []]
-  _ -> []
+  -> ReaderT NodeOrigin m [HieAST b]
+makeNode x spn = do
+  org <- ask
+  pure $ case spn of
+    RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
+    _ -> []
   where
     cons = mkFastString . show . toConstr $ x
     typ = mkFastString . show . typeRepTyCon . typeOf $ x
 
 {-# INLINEABLE makeTypeNode #-}
 makeTypeNode
-  :: (Applicative m, Data a)
+  :: (Monad m, Data a)
   => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
   -> SrcSpan                 -- ^ return an empty list if this is unhelpful
   -> Type                    -- ^ type to associate with the node
-  -> m [HieAST Type]
-makeTypeNode x spn etyp = pure $ case spn of
-  RealSrcSpan span _ ->
-    [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
-  _ -> []
+  -> ReaderT NodeOrigin m [HieAST Type]
+makeTypeNode x spn etyp = do
+  org <- ask
+  pure $ case spn of
+    RealSrcSpan span _ ->
+      [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
+    _ -> []
   where
     cons = mkFastString . show . toConstr $ x
     typ = mkFastString . show . typeRepTyCon . typeOf $ x