{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
module GHC.Iface.Ext.Utils where

import GHC.Prelude

import GHC.Core.Map.Type
import GHC.Driver.DynFlags    ( DynFlags )
import GHC.Driver.Ppr
import GHC.Data.FastString   ( FastString, mkFastString )
import GHC.Iface.Type
import GHC.Types.Name hiding (varName)
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
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare( nonDetCmpType )
import GHC.Core.Type
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Parser.Annotation
import qualified GHC.Data.Strict as Strict

import GHC.Iface.Ext.Types

import qualified Data.Map as M
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, mapMaybe)
import Data.Monoid
import Data.List                  (find)
import Data.Traversable           ( for )
import Data.Coerce
import GHC.Utils.Monad.State.Strict hiding (get)
import GHC.Utils.Panic.Plain( assert )
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)
  -> RefMap a
generateReferencesMap :: forall (f :: * -> *) a. Foldable f => f (HieAST a) -> RefMap a
generateReferencesMap = (HieAST a -> RefMap a -> RefMap a)
-> RefMap a -> f (HieAST a) -> RefMap a
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\HieAST a
ast RefMap a
m -> ([(Span, IdentifierDetails a)]
 -> [(Span, IdentifierDetails a)] -> [(Span, IdentifierDetails a)])
-> RefMap a -> RefMap a -> RefMap a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [(Span, IdentifierDetails a)]
-> [(Span, IdentifierDetails a)] -> [(Span, IdentifierDetails a)]
forall a. [a] -> [a] -> [a]
(++) (HieAST a -> RefMap a
forall {a}.
HieAST a -> Map Identifier [(Span, IdentifierDetails a)]
go HieAST a
ast) RefMap a
m) RefMap a
forall k a. Map k a
M.empty
  where
    go :: HieAST a -> Map Identifier [(Span, IdentifierDetails a)]
go HieAST a
ast = ([(Span, IdentifierDetails a)]
 -> [(Span, IdentifierDetails a)] -> [(Span, IdentifierDetails a)])
-> [Map Identifier [(Span, IdentifierDetails a)]]
-> Map Identifier [(Span, IdentifierDetails a)]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith [(Span, IdentifierDetails a)]
-> [(Span, IdentifierDetails a)] -> [(Span, IdentifierDetails a)]
forall a. [a] -> [a] -> [a]
(++) (Map Identifier [(Span, IdentifierDetails a)]
this Map Identifier [(Span, IdentifierDetails a)]
-> [Map Identifier [(Span, IdentifierDetails a)]]
-> [Map Identifier [(Span, IdentifierDetails a)]]
forall a. a -> [a] -> [a]
: (HieAST a -> Map Identifier [(Span, IdentifierDetails a)])
-> [HieAST a] -> [Map Identifier [(Span, IdentifierDetails a)]]
forall a b. (a -> b) -> [a] -> [b]
map HieAST a -> Map Identifier [(Span, IdentifierDetails a)]
go (HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
ast))
      where
        this :: Map Identifier [(Span, IdentifierDetails a)]
this = (IdentifierDetails a -> [(Span, IdentifierDetails a)])
-> Map Identifier (IdentifierDetails a)
-> Map Identifier [(Span, IdentifierDetails a)]
forall a b. (a -> b) -> Map Identifier a -> Map Identifier b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Span, IdentifierDetails a) -> [(Span, IdentifierDetails a)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Span, IdentifierDetails a) -> [(Span, IdentifierDetails a)])
-> (IdentifierDetails a -> (Span, IdentifierDetails a))
-> IdentifierDetails a
-> [(Span, IdentifierDetails a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
ast,)) (Map Identifier (IdentifierDetails a)
 -> Map Identifier [(Span, IdentifierDetails a)])
-> Map Identifier (IdentifierDetails a)
-> Map Identifier [(Span, IdentifierDetails a)]
forall a b. (a -> b) -> a -> b
$ SourcedNodeInfo a -> Map Identifier (IdentifierDetails a)
forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents (SourcedNodeInfo a -> Map Identifier (IdentifierDetails a))
-> SourcedNodeInfo a -> Map Identifier (IdentifierDetails a)
forall a b. (a -> b) -> a -> b
$ HieAST a -> SourcedNodeInfo a
forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo HieAST a
ast

renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType DynFlags
dflags HieTypeFix
ht = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (IfaceType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IfaceType -> SDoc) -> IfaceType -> SDoc
forall a b. (a -> b) -> a -> b
$ HieTypeFix -> IfaceType
hieTypeToIface HieTypeFix
ht)

resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
resolveVisibility :: Type -> [Type] -> [(Bool, Type)]
resolveVisibility Type
kind [Type]
ty_args
  = Subst -> Type -> [Type] -> [(Bool, Type)]
go (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) Type
kind [Type]
ty_args
  where
    in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes [Type]
ty_args)

    go :: Subst -> Type -> [Type] -> [(Bool, Type)]
go Subst
_   Type
_                   []     = []
    go Subst
env Type
ty                  [Type]
ts
      | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
      = Subst -> Type -> [Type] -> [(Bool, Type)]
go Subst
env Type
ty' [Type]
ts
    go Subst
env (ForAllTy (Bndr TyCoVar
tv ForAllTyFlag
vis) Type
res) (Type
t:[Type]
ts)
      | ForAllTyFlag -> Bool
isVisibleForAllTyFlag ForAllTyFlag
vis = (Bool
True , Type
t) (Bool, Type) -> [(Bool, Type)] -> [(Bool, Type)]
forall a. a -> [a] -> [a]
: [(Bool, Type)]
ts'
      | Bool
otherwise                 = (Bool
False, Type
t) (Bool, Type) -> [(Bool, Type)] -> [(Bool, Type)]
forall a. a -> [a] -> [a]
: [(Bool, Type)]
ts'
      where
        ts' :: [(Bool, Type)]
ts' = Subst -> Type -> [Type] -> [(Bool, Type)]
go (Subst -> TyCoVar -> Type -> Subst
extendTvSubst Subst
env TyCoVar
tv Type
t) Type
res [Type]
ts

    go Subst
env (FunTy { ft_res :: Type -> Type
ft_res = Type
res }) (Type
t:[Type]
ts) -- No type-class args in tycon apps
      = (Bool
True,Type
t) (Bool, Type) -> [(Bool, Type)] -> [(Bool, Type)]
forall a. a -> [a] -> [a]
: (Subst -> Type -> [Type] -> [(Bool, Type)]
go Subst
env Type
res [Type]
ts)

    go Subst
env (TyVarTy TyCoVar
tv) [Type]
ts
      | Just Type
ki <- Subst -> TyCoVar -> Maybe Type
lookupTyVar Subst
env TyCoVar
tv = Subst -> Type -> [Type] -> [(Bool, Type)]
go Subst
env Type
ki [Type]
ts
    go Subst
env Type
kind (Type
t:[Type]
ts) = (Bool
True, Type
t) (Bool, Type) -> [(Bool, Type)] -> [(Bool, Type)]
forall a. a -> [a] -> [a]
: (Subst -> Type -> [Type] -> [(Bool, Type)]
go Subst
env Type
kind [Type]
ts) -- Ill-kinded

foldType :: (HieType a -> a) -> HieTypeFix -> a
foldType :: forall a. (HieType a -> a) -> HieTypeFix -> a
foldType HieType a -> a
f (Roll HieType HieTypeFix
t) = HieType a -> a
f (HieType a -> a) -> HieType a -> a
forall a b. (a -> b) -> a -> b
$ (HieTypeFix -> a) -> HieType HieTypeFix -> HieType a
forall a b. (a -> b) -> HieType a -> HieType b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HieType a -> a) -> HieTypeFix -> a
forall a. (HieType a -> a) -> HieTypeFix -> a
foldType HieType a -> a
f) HieType HieTypeFix
t

selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
selectPoint :: HieFile -> (Int, Int) -> Maybe (HieAST Int)
selectPoint HieFile
hf (Int
sl,Int
sc) = First (HieAST Int) -> Maybe (HieAST Int)
forall a. First a -> Maybe a
getFirst (First (HieAST Int) -> Maybe (HieAST Int))
-> First (HieAST Int) -> Maybe (HieAST Int)
forall a b. (a -> b) -> a -> b
$
  (((HiePath, HieAST Int) -> First (HieAST Int))
 -> [(HiePath, HieAST Int)] -> First (HieAST Int))
-> [(HiePath, HieAST Int)]
-> ((HiePath, HieAST Int) -> First (HieAST Int))
-> First (HieAST Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((HiePath, HieAST Int) -> First (HieAST Int))
-> [(HiePath, HieAST Int)] -> First (HieAST Int)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map HiePath (HieAST Int) -> [(HiePath, HieAST Int)]
forall k a. Map k a -> [(k, a)]
M.toList (HieASTs Int -> Map HiePath (HieAST Int)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts (HieASTs Int -> Map HiePath (HieAST Int))
-> HieASTs Int -> Map HiePath (HieAST Int)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hf)) (((HiePath, HieAST Int) -> First (HieAST Int))
 -> First (HieAST Int))
-> ((HiePath, HieAST Int) -> First (HieAST Int))
-> First (HieAST Int)
forall a b. (a -> b) -> a -> b
$ \(HiePath FastString
fs,HieAST Int
ast) -> Maybe (HieAST Int) -> First (HieAST Int)
forall a. Maybe a -> First a
First (Maybe (HieAST Int) -> First (HieAST Int))
-> Maybe (HieAST Int) -> First (HieAST Int)
forall a b. (a -> b) -> a -> b
$
      case Span -> HieAST Int -> Maybe (HieAST Int)
forall a. Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining (FastString -> Span
sp FastString
fs) HieAST Int
ast of
        Maybe (HieAST Int)
Nothing -> Maybe (HieAST Int)
forall a. Maybe a
Nothing
        Just HieAST Int
ast' -> HieAST Int -> Maybe (HieAST Int)
forall a. a -> Maybe a
Just HieAST Int
ast'
 where
   sloc :: FastString -> RealSrcLoc
sloc FastString
fs = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fs Int
sl Int
sc
   sp :: FastString -> Span
sp FastString
fs = RealSrcLoc -> RealSrcLoc -> Span
mkRealSrcSpan (FastString -> RealSrcLoc
sloc FastString
fs) (FastString -> RealSrcLoc
sloc FastString
fs)

findEvidenceUse :: NodeIdentifiers a -> [Name]
findEvidenceUse :: forall a. NodeIdentifiers a -> [Name]
findEvidenceUse NodeIdentifiers a
ni = [Name
n | (Right Name
n, IdentifierDetails a
dets) <- [(Identifier, IdentifierDetails a)]
xs, (ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceUse (IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)]
 where
   xs :: [(Identifier, IdentifierDetails a)]
xs = NodeIdentifiers a -> [(Identifier, IdentifierDetails a)]
forall k a. Map k a -> [(k, a)]
M.toList NodeIdentifiers a
ni

data EvidenceInfo a
  = EvidenceInfo
  { forall a. EvidenceInfo a -> Name
evidenceVar :: Name
  , forall a. EvidenceInfo a -> Span
evidenceSpan :: RealSrcSpan
  , forall a. EvidenceInfo a -> a
evidenceType :: a
  , forall a. EvidenceInfo a -> Maybe (EvVarSource, Scope, Maybe Span)
evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
  } deriving (EvidenceInfo a -> EvidenceInfo a -> Bool
(EvidenceInfo a -> EvidenceInfo a -> Bool)
-> (EvidenceInfo a -> EvidenceInfo a -> Bool)
-> Eq (EvidenceInfo a)
forall a. Eq a => EvidenceInfo a -> EvidenceInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => EvidenceInfo a -> EvidenceInfo a -> Bool
== :: EvidenceInfo a -> EvidenceInfo a -> Bool
$c/= :: forall a. Eq a => EvidenceInfo a -> EvidenceInfo a -> Bool
/= :: EvidenceInfo a -> EvidenceInfo a -> Bool
Eq, (forall a b. (a -> b) -> EvidenceInfo a -> EvidenceInfo b)
-> (forall a b. a -> EvidenceInfo b -> EvidenceInfo a)
-> Functor EvidenceInfo
forall a b. a -> EvidenceInfo b -> EvidenceInfo a
forall a b. (a -> b) -> EvidenceInfo a -> EvidenceInfo b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> EvidenceInfo a -> EvidenceInfo b
fmap :: forall a b. (a -> b) -> EvidenceInfo a -> EvidenceInfo b
$c<$ :: forall a b. a -> EvidenceInfo b -> EvidenceInfo a
<$ :: forall a b. a -> EvidenceInfo b -> EvidenceInfo a
Functor)

instance Ord a => Ord (EvidenceInfo a) where
  compare :: EvidenceInfo a -> EvidenceInfo a -> Ordering
compare (EvidenceInfo Name
name Span
span a
typ Maybe (EvVarSource, Scope, Maybe Span)
dets) (EvidenceInfo Name
name' Span
span' a
typ' Maybe (EvVarSource, Scope, Maybe Span)
dets') =
    case Name -> Name -> Ordering
stableNameCmp Name
name Name
name' of
      Ordering
EQ -> (Span, a, Maybe (EvVarSource, Scope, Maybe Span))
-> (Span, a, Maybe (EvVarSource, Scope, Maybe Span)) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Span
span, a
typ, Maybe (EvVarSource, Scope, Maybe Span)
dets) (Span
span', a
typ', Maybe (EvVarSource, Scope, Maybe Span)
dets')
      Ordering
r -> Ordering
r

instance (Outputable a) => Outputable (EvidenceInfo a) where
  ppr :: EvidenceInfo a -> SDoc
ppr (EvidenceInfo Name
name Span
span a
typ Maybe (EvVarSource, Scope, Maybe Span)
dets) =
    SDoc -> Int -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Span -> SDoc
forall a. Outputable a => a -> SDoc
ppr Span
span SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", of type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
typ) Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
      SDoc
pdets SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (Name -> SDoc
pprDefinedAt Name
name)
    where
      pdets :: SDoc
pdets = case Maybe (EvVarSource, Scope, Maybe Span)
dets of
        Maybe (EvVarSource, Scope, Maybe Span)
Nothing -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is a usage of an external evidence variable"
        Just (EvVarSource
src,Scope
scp,Maybe Span
spn) -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is an" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ContextInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr (EvVarSource -> Scope -> Maybe Span -> ContextInfo
EvidenceVarBind EvVarSource
src Scope
scp Maybe Span
spn)

getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)
getEvidenceTreesAtPoint :: forall a.
HieFile -> RefMap a -> (Int, Int) -> Forest (EvidenceInfo a)
getEvidenceTreesAtPoint HieFile
hf RefMap a
refmap (Int, Int)
point =
  [Tree (EvidenceInfo a)
t | Just HieAST Int
ast <- Maybe (HieAST Int) -> [Maybe (HieAST Int)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (HieAST Int) -> [Maybe (HieAST Int)])
-> Maybe (HieAST Int) -> [Maybe (HieAST Int)]
forall a b. (a -> b) -> a -> b
$ HieFile -> (Int, Int) -> Maybe (HieAST Int)
selectPoint HieFile
hf (Int, Int)
point
     , Name
n        <- NodeIdentifiers Int -> [Name]
forall a. NodeIdentifiers a -> [Name]
findEvidenceUse (SourcedNodeInfo Int -> NodeIdentifiers Int
forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents (SourcedNodeInfo Int -> NodeIdentifiers Int)
-> SourcedNodeInfo Int -> NodeIdentifiers Int
forall a b. (a -> b) -> a -> b
$ HieAST Int -> SourcedNodeInfo Int
forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo HieAST Int
ast)
     , Just Tree (EvidenceInfo a)
t   <- Maybe (Tree (EvidenceInfo a)) -> [Maybe (Tree (EvidenceInfo a))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Tree (EvidenceInfo a)) -> [Maybe (Tree (EvidenceInfo a))])
-> Maybe (Tree (EvidenceInfo a)) -> [Maybe (Tree (EvidenceInfo a))]
forall a b. (a -> b) -> a -> b
$ RefMap a -> Name -> Maybe (Tree (EvidenceInfo a))
forall a. RefMap a -> Name -> Maybe (Tree (EvidenceInfo a))
getEvidenceTree RefMap a
refmap Name
n
     ]

getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))
getEvidenceTree :: forall a. RefMap a -> Name -> Maybe (Tree (EvidenceInfo a))
getEvidenceTree RefMap a
refmap Name
var = NameSet -> Name -> Maybe (Tree (EvidenceInfo a))
go NameSet
emptyNameSet Name
var
  where
    go :: NameSet -> Name -> Maybe (Tree (EvidenceInfo a))
go NameSet
seen Name
var
      | Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
seen = Maybe (Tree (EvidenceInfo a))
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          xs <- Identifier -> RefMap a -> Maybe [(Span, IdentifierDetails a)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Name -> Identifier
forall a b. b -> Either a b
Right Name
var) RefMap a
refmap
          case find (any isEvidenceBind . identInfo . snd) xs of
            Just (Span
sp,IdentifierDetails a
dets) -> do
              typ <- IdentifierDetails a -> Maybe a
forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails a
dets
              (evdet,children) <- getFirst $ foldMap First $ do
                 det <- S.toList $ identInfo dets
                 case det of
                   EvidenceVarBind src :: EvVarSource
src@(EvLetBind (EvBindDeps -> [Name]
getEvBindDeps -> [Name]
xs)) Scope
scp Maybe Span
spn ->
                     Maybe ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
-> [Maybe
      ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
 -> [Maybe
       ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])])
-> Maybe
     ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
-> [Maybe
      ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])]
forall a b. (a -> b) -> a -> b
$ ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
-> Maybe
     ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
forall a. a -> Maybe a
Just ((EvVarSource
src,Scope
scp,Maybe Span
spn),(Name -> Maybe (Tree (EvidenceInfo a)))
-> [Name] -> [Tree (EvidenceInfo a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSet -> Name -> Maybe (Tree (EvidenceInfo a))
go (NameSet -> Name -> Maybe (Tree (EvidenceInfo a)))
-> NameSet -> Name -> Maybe (Tree (EvidenceInfo a))
forall a b. (a -> b) -> a -> b
$ NameSet -> Name -> NameSet
extendNameSet NameSet
seen Name
var) [Name]
xs)
                   EvidenceVarBind EvVarSource
src Scope
scp Maybe Span
spn -> Maybe ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
-> [Maybe
      ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
 -> [Maybe
       ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])])
-> Maybe
     ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
-> [Maybe
      ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])]
forall a b. (a -> b) -> a -> b
$ ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
-> Maybe
     ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
forall a. a -> Maybe a
Just ((EvVarSource
src,Scope
scp,Maybe Span
spn),[])
                   ContextInfo
_ -> Maybe ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
-> [Maybe
      ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ((EvVarSource, Scope, Maybe Span), [Tree (EvidenceInfo a)])
forall a. Maybe a
Nothing
              pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children
            -- It is externally bound
            Maybe (Span, IdentifierDetails a)
Nothing -> First (Tree (EvidenceInfo a)) -> Maybe (Tree (EvidenceInfo a))
forall a. First a -> Maybe a
getFirst (First (Tree (EvidenceInfo a)) -> Maybe (Tree (EvidenceInfo a)))
-> First (Tree (EvidenceInfo a)) -> Maybe (Tree (EvidenceInfo a))
forall a b. (a -> b) -> a -> b
$ (Maybe (Tree (EvidenceInfo a)) -> First (Tree (EvidenceInfo a)))
-> [Maybe (Tree (EvidenceInfo a))] -> First (Tree (EvidenceInfo a))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Maybe (Tree (EvidenceInfo a)) -> First (Tree (EvidenceInfo a))
forall a. Maybe a -> First a
First ([Maybe (Tree (EvidenceInfo a))] -> First (Tree (EvidenceInfo a)))
-> [Maybe (Tree (EvidenceInfo a))] -> First (Tree (EvidenceInfo a))
forall a b. (a -> b) -> a -> b
$ do
              (sp,dets) <- [(Span, IdentifierDetails a)]
xs
              if (any isEvidenceUse $ identInfo dets)
                then do
                  case identType dets of
                    Maybe a
Nothing -> Maybe (Tree (EvidenceInfo a)) -> [Maybe (Tree (EvidenceInfo a))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Tree (EvidenceInfo a))
forall a. Maybe a
Nothing
                    Just a
typ -> Maybe (Tree (EvidenceInfo a)) -> [Maybe (Tree (EvidenceInfo a))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Tree (EvidenceInfo a)) -> [Maybe (Tree (EvidenceInfo a))])
-> Maybe (Tree (EvidenceInfo a)) -> [Maybe (Tree (EvidenceInfo a))]
forall a b. (a -> b) -> a -> b
$ Tree (EvidenceInfo a) -> Maybe (Tree (EvidenceInfo a))
forall a. a -> Maybe a
Just (Tree (EvidenceInfo a) -> Maybe (Tree (EvidenceInfo a)))
-> Tree (EvidenceInfo a) -> Maybe (Tree (EvidenceInfo a))
forall a b. (a -> b) -> a -> b
$ EvidenceInfo a -> [Tree (EvidenceInfo a)] -> Tree (EvidenceInfo a)
forall a. a -> [Tree a] -> Tree a
Tree.Node (Name
-> Span
-> a
-> Maybe (EvVarSource, Scope, Maybe Span)
-> EvidenceInfo a
forall a.
Name
-> Span
-> a
-> Maybe (EvVarSource, Scope, Maybe Span)
-> EvidenceInfo a
EvidenceInfo Name
var Span
sp a
typ Maybe (EvVarSource, Scope, Maybe Span)
forall a. Maybe a
Nothing) []
                else pure Nothing

hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = (HieType IfaceType -> IfaceType) -> HieTypeFix -> IfaceType
forall a. (HieType a -> a) -> HieTypeFix -> a
foldType HieType IfaceType -> IfaceType
go
  where
    go :: HieType IfaceType -> IfaceType
go (HTyVarTy Name
n) = FastString -> IfaceType
IfaceTyVar (FastString -> IfaceType) -> FastString -> IfaceType
forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
n
    go (HAppTy IfaceType
a HieArgs IfaceType
b) = IfaceType -> IfaceAppArgs -> IfaceType
IfaceAppTy IfaceType
a (HieArgs IfaceType -> IfaceAppArgs
hieToIfaceArgs HieArgs IfaceType
b)
    go (HLitTy IfaceTyLit
l) = IfaceTyLit -> IfaceType
IfaceLitTy IfaceTyLit
l
    go (HForAllTy ((Name
n,IfaceType
k),ForAllTyFlag
af) IfaceType
t) = let b :: (FastString, IfaceType)
b = (OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
n, IfaceType
k)
                                  in IfaceForAllBndr -> IfaceType -> IfaceType
IfaceForAllTy (IfaceBndr -> ForAllTyFlag -> IfaceForAllBndr
forall var argf. var -> argf -> VarBndr var argf
Bndr ((FastString, IfaceType) -> IfaceBndr
IfaceTvBndr (FastString, IfaceType)
b) ForAllTyFlag
af) IfaceType
t
    go (HFunTy IfaceType
w IfaceType
a IfaceType
b)   = FunTyFlag -> IfaceType -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy FunTyFlag
visArgTypeLike   IfaceType
w       IfaceType
a    IfaceType
b
    go (HQualTy IfaceType
pred IfaceType
b) = FunTyFlag -> IfaceType -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy FunTyFlag
invisArgTypeLike IfaceType
many_ty IfaceType
pred IfaceType
b
    go (HCastTy IfaceType
a) = IfaceType
a
    go HieType IfaceType
HCoercionTy = FastString -> IfaceType
IfaceTyVar FastString
"<coercion type>"
    go (HTyConApp IfaceTyCon
a HieArgs IfaceType
xs) = IfaceTyCon -> IfaceAppArgs -> IfaceType
IfaceTyConApp IfaceTyCon
a (HieArgs IfaceType -> IfaceAppArgs
hieToIfaceArgs HieArgs IfaceType
xs)

    -- This isn't fully faithful - we can't produce the 'Inferred' case
    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
hieToIfaceArgs (HieArgs [(Bool, IfaceType)]
xs) = [(Bool, IfaceType)] -> IfaceAppArgs
go' [(Bool, IfaceType)]
xs
      where
        go' :: [(Bool, IfaceType)] -> IfaceAppArgs
go' [] = IfaceAppArgs
IA_Nil
        go' ((Bool
True ,IfaceType
x):[(Bool, IfaceType)]
xs) = IfaceType -> ForAllTyFlag -> IfaceAppArgs -> IfaceAppArgs
IA_Arg IfaceType
x ForAllTyFlag
Required (IfaceAppArgs -> IfaceAppArgs) -> IfaceAppArgs -> IfaceAppArgs
forall a b. (a -> b) -> a -> b
$ [(Bool, IfaceType)] -> IfaceAppArgs
go' [(Bool, IfaceType)]
xs
        go' ((Bool
False,IfaceType
x):[(Bool, IfaceType)]
xs) = IfaceType -> ForAllTyFlag -> IfaceAppArgs -> IfaceAppArgs
IA_Arg IfaceType
x ForAllTyFlag
Specified (IfaceAppArgs -> IfaceAppArgs) -> IfaceAppArgs -> IfaceAppArgs
forall a b. (a -> b) -> a -> b
$ [(Bool, IfaceType)] -> IfaceAppArgs
go' [(Bool, IfaceType)]
xs

data HieTypeState
  = HTS
    { HieTypeState -> TypeMap Int
tyMap      :: !(TypeMap TypeIndex)
    , HieTypeState -> IntMap HieTypeFlat
htyTable   :: !(IM.IntMap HieTypeFlat)
    , HieTypeState -> Int
freshIndex :: !TypeIndex
    }

initialHTS :: HieTypeState
initialHTS :: HieTypeState
initialHTS = TypeMap Int -> IntMap HieTypeFlat -> Int -> HieTypeState
HTS TypeMap Int
forall a. TypeMap a
emptyTypeMap IntMap HieTypeFlat
forall a. IntMap a
IM.empty Int
0

freshTypeIndex :: State HieTypeState TypeIndex
freshTypeIndex :: State HieTypeState Int
freshTypeIndex = do
  index <- (HieTypeState -> Int) -> State HieTypeState Int
forall s a. (s -> a) -> State s a
gets HieTypeState -> Int
freshIndex
  modify $ \HieTypeState
hts -> HieTypeState
hts { freshIndex = index+1 }
  return index

compressTypes
  :: HieASTs Type
  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
compressTypes :: HieASTs Type -> (HieASTs Int, Array Int HieTypeFlat)
compressTypes HieASTs Type
asts = (HieASTs Int
a, Array Int HieTypeFlat
arr)
  where
    (HieASTs Int
a, (HTS TypeMap Int
_ IntMap HieTypeFlat
m Int
i)) = (State HieTypeState (HieASTs Int)
 -> HieTypeState -> (HieASTs Int, HieTypeState))
-> HieTypeState
-> State HieTypeState (HieASTs Int)
-> (HieASTs Int, HieTypeState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State HieTypeState (HieASTs Int)
-> HieTypeState -> (HieASTs Int, HieTypeState)
forall s a. State s a -> s -> (a, s)
runState HieTypeState
initialHTS (State HieTypeState (HieASTs Int) -> (HieASTs Int, HieTypeState))
-> State HieTypeState (HieASTs Int) -> (HieASTs Int, HieTypeState)
forall a b. (a -> b) -> a -> b
$
      HieASTs Type
-> (Type -> State HieTypeState Int)
-> State HieTypeState (HieASTs Int)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for HieASTs Type
asts ((Type -> State HieTypeState Int)
 -> State HieTypeState (HieASTs Int))
-> (Type -> State HieTypeState Int)
-> State HieTypeState (HieASTs Int)
forall a b. (a -> b) -> a -> b
$ \Type
typ ->
        Type -> State HieTypeState Int
getTypeIndex Type
typ
    arr :: Array Int HieTypeFlat
arr = (Int, Int) -> [(Int, HieTypeFlat)] -> Array Int HieTypeFlat
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
A.array (Int
0,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (IntMap HieTypeFlat -> [(Int, HieTypeFlat)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap HieTypeFlat
m)

recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
recoverFullType :: Int -> Array Int HieTypeFlat -> HieTypeFix
recoverFullType Int
i Array Int HieTypeFlat
m = Int -> HieTypeFix
go Int
i
  where
    go :: Int -> HieTypeFix
go Int
i = HieType HieTypeFix -> HieTypeFix
Roll (HieType HieTypeFix -> HieTypeFix)
-> HieType HieTypeFix -> HieTypeFix
forall a b. (a -> b) -> a -> b
$ (Int -> HieTypeFix) -> HieTypeFlat -> HieType HieTypeFix
forall a b. (a -> b) -> HieType a -> HieType b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> HieTypeFix
go (Array Int HieTypeFlat
m Array Int HieTypeFlat -> Int -> HieTypeFlat
forall i e. Ix i => Array i e -> i -> e
A.! Int
i)

getTypeIndex :: Type -> State HieTypeState TypeIndex
getTypeIndex :: Type -> State HieTypeState Int
getTypeIndex Type
t
  | Bool
otherwise = do
      tm <- (HieTypeState -> TypeMap Int) -> State HieTypeState (TypeMap Int)
forall s a. (s -> a) -> State s a
gets HieTypeState -> TypeMap Int
tyMap
      case lookupTypeMap tm t of
        Just Int
i -> Int -> State HieTypeState Int
forall a. a -> State HieTypeState a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
        Maybe Int
Nothing -> do
          ht <- Type -> State HieTypeState HieTypeFlat
go Type
t
          extendHTS t ht
  where
    extendHTS :: Type -> HieTypeFlat -> State HieTypeState Int
extendHTS Type
t HieTypeFlat
ht = do
      i <- State HieTypeState Int
freshTypeIndex
      modify $ \(HTS TypeMap Int
tm IntMap HieTypeFlat
tt Int
fi) ->
        TypeMap Int -> IntMap HieTypeFlat -> Int -> HieTypeState
HTS (TypeMap Int -> Type -> Int -> TypeMap Int
forall a. TypeMap a -> Type -> a -> TypeMap a
extendTypeMap TypeMap Int
tm Type
t Int
i) (Int -> HieTypeFlat -> IntMap HieTypeFlat -> IntMap HieTypeFlat
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i HieTypeFlat
ht IntMap HieTypeFlat
tt) Int
fi
      return i

    go :: Type -> State HieTypeState HieTypeFlat
go (TyVarTy TyCoVar
v) = HieTypeFlat -> State HieTypeState HieTypeFlat
forall a. a -> State HieTypeState a
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> State HieTypeState HieTypeFlat)
-> HieTypeFlat -> State HieTypeState HieTypeFlat
forall a b. (a -> b) -> a -> b
$ Name -> HieTypeFlat
forall a. Name -> HieType a
HTyVarTy (Name -> HieTypeFlat) -> Name -> HieTypeFlat
forall a b. (a -> b) -> a -> b
$ TyCoVar -> Name
varName TyCoVar
v
    go ty :: Type
ty@(AppTy Type
_ Type
_) = do
      let (Type
head,[Type]
args) = HasDebugCallStack => Type -> (Type, [Type])
Type -> (Type, [Type])
splitAppTys Type
ty
          visArgs :: HieArgs Type
visArgs = [(Bool, Type)] -> HieArgs Type
forall a. [(Bool, a)] -> HieArgs a
HieArgs ([(Bool, Type)] -> HieArgs Type) -> [(Bool, Type)] -> HieArgs Type
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> [(Bool, Type)]
resolveVisibility (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
head) [Type]
args
      ai <- Type -> State HieTypeState Int
getTypeIndex Type
head
      argsi <- mapM getTypeIndex visArgs
      return $ HAppTy ai argsi
    go (TyConApp TyCon
f [Type]
xs) = do
      let visArgs :: HieArgs Type
visArgs = [(Bool, Type)] -> HieArgs Type
forall a. [(Bool, a)] -> HieArgs a
HieArgs ([(Bool, Type)] -> HieArgs Type) -> [(Bool, Type)] -> HieArgs Type
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> [(Bool, Type)]
resolveVisibility (TyCon -> Type
tyConKind TyCon
f) [Type]
xs
      is <- (Type -> State HieTypeState Int)
-> HieArgs Type -> State HieTypeState (HieArgs Int)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HieArgs a -> m (HieArgs b)
mapM Type -> State HieTypeState Int
getTypeIndex HieArgs Type
visArgs
      return $ HTyConApp (toIfaceTyCon f) is
    go (ForAllTy (Bndr TyCoVar
v ForAllTyFlag
a) Type
t) = do
      k <- Type -> State HieTypeState Int
getTypeIndex (TyCoVar -> Type
varType TyCoVar
v)
      i <- getTypeIndex t
      return $ HForAllTy ((varName v,k),a) i
    go (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_mult :: Type -> Type
ft_mult = Type
w, ft_arg :: Type -> Type
ft_arg = Type
a, ft_res :: Type -> Type
ft_res = Type
b }) = do
      ai <- Type -> State HieTypeState Int
getTypeIndex Type
a
      bi <- getTypeIndex b
      wi <- getTypeIndex w
      return $ if isInvisibleFunArg af
               then assert (isManyTy w) $ HQualTy ai bi
               else                       HFunTy wi ai bi
    go (LitTy TyLit
a) = HieTypeFlat -> State HieTypeState HieTypeFlat
forall a. a -> State HieTypeState a
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> State HieTypeState HieTypeFlat)
-> HieTypeFlat -> State HieTypeState HieTypeFlat
forall a b. (a -> b) -> a -> b
$ IfaceTyLit -> HieTypeFlat
forall a. IfaceTyLit -> HieType a
HLitTy (IfaceTyLit -> HieTypeFlat) -> IfaceTyLit -> HieTypeFlat
forall a b. (a -> b) -> a -> b
$ TyLit -> IfaceTyLit
toIfaceTyLit TyLit
a
    go (CastTy Type
t KindCoercion
_) = do
      i <- Type -> State HieTypeState Int
getTypeIndex Type
t
      return $ HCastTy i
    go (CoercionTy KindCoercion
_) = HieTypeFlat -> State HieTypeState HieTypeFlat
forall a. a -> State HieTypeState a
forall (m :: * -> *) a. Monad m => a -> m a
return HieTypeFlat
forall a. HieType a
HCoercionTy

resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a)
resolveTyVarScopes :: forall a. Map HiePath (HieAST a) -> Map HiePath (HieAST a)
resolveTyVarScopes Map HiePath (HieAST a)
asts = (HieAST a -> HieAST a)
-> Map HiePath (HieAST a) -> Map HiePath (HieAST a)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map HieAST a -> HieAST a
go Map HiePath (HieAST a)
asts
  where
    go :: HieAST a -> HieAST a
go HieAST a
ast = HieAST a -> Map HiePath (HieAST a) -> HieAST a
forall a. HieAST a -> Map HiePath (HieAST a) -> HieAST a
resolveTyVarScopeLocal HieAST a
ast Map HiePath (HieAST a)
asts

resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a
resolveTyVarScopeLocal :: forall a. HieAST a -> Map HiePath (HieAST a) -> HieAST a
resolveTyVarScopeLocal HieAST a
ast Map HiePath (HieAST a)
asts = HieAST a -> HieAST a
go HieAST a
ast
  where
    resolveNameScope :: IdentifierDetails a -> IdentifierDetails a
resolveNameScope IdentifierDetails a
dets = IdentifierDetails a
dets{identInfo =
      S.map resolveScope (identInfo dets)}
    resolveScope :: ContextInfo -> ContextInfo
resolveScope (TyVarBind Scope
sc (UnresolvedScope [Name]
names Maybe Span
Nothing)) =
      Scope -> TyVarScope -> ContextInfo
TyVarBind Scope
sc (TyVarScope -> ContextInfo) -> TyVarScope -> ContextInfo
forall a b. (a -> b) -> a -> b
$ [Scope] -> TyVarScope
ResolvedScopes
        [ Span -> Scope
LocalScope Span
binding
        | Name
name <- [Name]
names
        , Just Span
binding <- [Name -> Map HiePath (HieAST a) -> Maybe Span
forall a. Name -> Map HiePath (HieAST a) -> Maybe Span
getNameBinding Name
name Map HiePath (HieAST a)
asts]
        ]
    resolveScope (TyVarBind Scope
sc (UnresolvedScope [Name]
names (Just Span
sp))) =
      Scope -> TyVarScope -> ContextInfo
TyVarBind Scope
sc (TyVarScope -> ContextInfo) -> TyVarScope -> ContextInfo
forall a b. (a -> b) -> a -> b
$ [Scope] -> TyVarScope
ResolvedScopes
        [ Span -> Scope
LocalScope Span
binding
        | Name
name <- [Name]
names
        , Just Span
binding <- [Name -> Span -> Map HiePath (HieAST a) -> Maybe Span
forall a. Name -> Span -> Map HiePath (HieAST a) -> Maybe Span
getNameBindingInClass Name
name Span
sp Map HiePath (HieAST a)
asts]
        ]
    resolveScope ContextInfo
scope = ContextInfo
scope
    go :: HieAST a -> HieAST a
go (Node SourcedNodeInfo a
info Span
span [HieAST a]
children) = SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node SourcedNodeInfo a
info' Span
span ([HieAST a] -> HieAST a) -> [HieAST a] -> HieAST a
forall a b. (a -> b) -> a -> b
$ (HieAST a -> HieAST a) -> [HieAST a] -> [HieAST a]
forall a b. (a -> b) -> [a] -> [b]
map HieAST a -> HieAST a
go [HieAST a]
children
      where
        info' :: SourcedNodeInfo a
info' = Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
forall a. Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
SourcedNodeInfo (NodeInfo a -> NodeInfo a
updateNodeInfo (NodeInfo a -> NodeInfo a)
-> Map NodeOrigin (NodeInfo a) -> Map NodeOrigin (NodeInfo a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
info)
        updateNodeInfo :: NodeInfo a -> NodeInfo a
updateNodeInfo NodeInfo a
i = NodeInfo a
i { nodeIdentifiers = idents }
          where
            idents :: Map Identifier (IdentifierDetails a)
idents = (IdentifierDetails a -> IdentifierDetails a)
-> Map Identifier (IdentifierDetails a)
-> Map Identifier (IdentifierDetails a)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map IdentifierDetails a -> IdentifierDetails a
resolveNameScope (Map Identifier (IdentifierDetails a)
 -> Map Identifier (IdentifierDetails a))
-> Map Identifier (IdentifierDetails a)
-> Map Identifier (IdentifierDetails a)
forall a b. (a -> b) -> a -> b
$ NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo a
i

getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span
getNameBinding :: forall a. Name -> Map HiePath (HieAST a) -> Maybe Span
getNameBinding Name
n Map HiePath (HieAST a)
asts = do
  (_,msp) <- Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)
forall a.
Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding Name
n Map HiePath (HieAST a)
asts
  msp

getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope]
getNameScope :: forall a. Name -> Map HiePath (HieAST a) -> Maybe [Scope]
getNameScope Name
n Map HiePath (HieAST a)
asts = do
  (scopes,_) <- Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)
forall a.
Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding Name
n Map HiePath (HieAST a)
asts
  return scopes

getNameBindingInClass
  :: Name
  -> Span
  -> M.Map HiePath (HieAST a)
  -> Maybe Span
getNameBindingInClass :: forall a. Name -> Span -> Map HiePath (HieAST a) -> Maybe Span
getNameBindingInClass Name
n Span
sp Map HiePath (HieAST a)
asts = do
  ast <- HiePath -> Map HiePath (HieAST a) -> Maybe (HieAST a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (FastString -> HiePath
HiePath (Span -> FastString
srcSpanFile Span
sp)) Map HiePath (HieAST a)
asts
  clsNode <- selectLargestContainedBy sp ast
  getFirst $ foldMap First $ do
    child <- flattenAst clsNode
    dets <- maybeToList
      $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child
    let binding = (ContextInfo -> First Span) -> Set ContextInfo -> First Span
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe Span -> First Span
forall a. Maybe a -> First a
First (Maybe Span -> First Span)
-> (ContextInfo -> Maybe Span) -> ContextInfo -> First Span
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextInfo -> Maybe Span
getBindSiteFromContext) (IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
    return (getFirst binding)

getNameScopeAndBinding
  :: Name
  -> M.Map HiePath (HieAST a)
  -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding :: forall a.
Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding Name
n Map HiePath (HieAST a)
asts = case Name -> SrcSpan
nameSrcSpan Name
n of
  RealSrcSpan Span
sp Maybe BufSpan
_ -> do -- @Maybe
    ast <- HiePath -> Map HiePath (HieAST a) -> Maybe (HieAST a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (FastString -> HiePath
HiePath (Span -> FastString
srcSpanFile Span
sp)) Map HiePath (HieAST a)
asts
    defNode <- selectLargestContainedBy sp ast
    getFirst $ foldMap First $ do -- @[]
      node <- flattenAst defNode
      dets <- maybeToList
        $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node
      scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
      let binding = (ContextInfo -> First Span) -> Set ContextInfo -> First Span
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe Span -> First Span
forall a. Maybe a -> First a
First (Maybe Span -> First Span)
-> (ContextInfo -> Maybe Span) -> ContextInfo -> First Span
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextInfo -> Maybe Span
getBindSiteFromContext) (IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
      return $ Just (scopes, getFirst binding)
  SrcSpan
_ -> Maybe ([Scope], Maybe Span)
forall a. Maybe a
Nothing

getScopeFromContext :: ContextInfo -> Maybe [Scope]
getScopeFromContext :: ContextInfo -> Maybe [Scope]
getScopeFromContext (ValBind BindType
_ Scope
sc Maybe Span
_) = [Scope] -> Maybe [Scope]
forall a. a -> Maybe a
Just [Scope
sc]
getScopeFromContext (PatternBind Scope
a Scope
b Maybe Span
_) = [Scope] -> Maybe [Scope]
forall a. a -> Maybe a
Just [Scope
a, Scope
b]
getScopeFromContext (ClassTyDecl Maybe Span
_) = [Scope] -> Maybe [Scope]
forall a. a -> Maybe a
Just [Scope
ModuleScope]
getScopeFromContext (Decl DeclType
_ Maybe Span
_) = [Scope] -> Maybe [Scope]
forall a. a -> Maybe a
Just [Scope
ModuleScope]
getScopeFromContext (TyVarBind Scope
a (ResolvedScopes [Scope]
xs)) = [Scope] -> Maybe [Scope]
forall a. a -> Maybe a
Just ([Scope] -> Maybe [Scope]) -> [Scope] -> Maybe [Scope]
forall a b. (a -> b) -> a -> b
$ Scope
aScope -> [Scope] -> [Scope]
forall a. a -> [a] -> [a]
:[Scope]
xs
getScopeFromContext (TyVarBind Scope
a TyVarScope
_) = [Scope] -> Maybe [Scope]
forall a. a -> Maybe a
Just [Scope
a]
getScopeFromContext (EvidenceVarBind EvVarSource
_ Scope
a Maybe Span
_) = [Scope] -> Maybe [Scope]
forall a. a -> Maybe a
Just [Scope
a]
getScopeFromContext ContextInfo
_ = Maybe [Scope]
forall a. Maybe a
Nothing

getBindSiteFromContext :: ContextInfo -> Maybe Span
getBindSiteFromContext :: ContextInfo -> Maybe Span
getBindSiteFromContext (ValBind BindType
_ Scope
_ Maybe Span
sp) = Maybe Span
sp
getBindSiteFromContext (PatternBind Scope
_ Scope
_ Maybe Span
sp) = Maybe Span
sp
getBindSiteFromContext ContextInfo
_ = Maybe Span
forall a. Maybe a
Nothing

flattenAst :: HieAST a -> [HieAST a]
flattenAst :: forall a. HieAST a -> [HieAST a]
flattenAst HieAST a
n =
  HieAST a
n HieAST a -> [HieAST a] -> [HieAST a]
forall a. a -> [a] -> [a]
: (HieAST a -> [HieAST a]) -> [HieAST a] -> [HieAST a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
flattenAst (HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
n)

smallestContainingSatisfying
  :: Span
  -> (HieAST a -> Bool)
  -> HieAST a
  -> Maybe (HieAST a)
smallestContainingSatisfying :: forall a.
Span -> (HieAST a -> Bool) -> HieAST a -> Maybe (HieAST a)
smallestContainingSatisfying Span
sp HieAST a -> Bool
cond HieAST a
node
  | HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
node Span -> Span -> Bool
`containsSpan` Span
sp = First (HieAST a) -> Maybe (HieAST a)
forall a. First a -> Maybe a
getFirst (First (HieAST a) -> Maybe (HieAST a))
-> First (HieAST a) -> Maybe (HieAST a)
forall a b. (a -> b) -> a -> b
$ [First (HieAST a)] -> First (HieAST a)
forall a. Monoid a => [a] -> a
mconcat
      [ (HieAST a -> First (HieAST a)) -> [HieAST a] -> First (HieAST a)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe (HieAST a) -> First (HieAST a)
forall a. Maybe a -> First a
First (Maybe (HieAST a) -> First (HieAST a))
-> (HieAST a -> Maybe (HieAST a)) -> HieAST a -> First (HieAST a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> (HieAST a -> Bool) -> HieAST a -> Maybe (HieAST a)
forall a.
Span -> (HieAST a -> Bool) -> HieAST a -> Maybe (HieAST a)
smallestContainingSatisfying Span
sp HieAST a -> Bool
cond) ([HieAST a] -> First (HieAST a)) -> [HieAST a] -> First (HieAST a)
forall a b. (a -> b) -> a -> b
$
          HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
      , Maybe (HieAST a) -> First (HieAST a)
forall a. Maybe a -> First a
First (Maybe (HieAST a) -> First (HieAST a))
-> Maybe (HieAST a) -> First (HieAST a)
forall a b. (a -> b) -> a -> b
$ if HieAST a -> Bool
cond HieAST a
node then HieAST a -> Maybe (HieAST a)
forall a. a -> Maybe a
Just HieAST a
node else Maybe (HieAST a)
forall a. Maybe a
Nothing
      ]
  | Span
sp Span -> Span -> Bool
`containsSpan` HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
node = Maybe (HieAST a)
forall a. Maybe a
Nothing
  | Bool
otherwise = Maybe (HieAST a)
forall a. Maybe a
Nothing

selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)
selectLargestContainedBy :: forall a. Span -> HieAST a -> Maybe (HieAST a)
selectLargestContainedBy Span
sp HieAST a
node
  | Span
sp Span -> Span -> Bool
`containsSpan` HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
node = HieAST a -> Maybe (HieAST a)
forall a. a -> Maybe a
Just HieAST a
node
  | HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
node Span -> Span -> Bool
`containsSpan` Span
sp =
      First (HieAST a) -> Maybe (HieAST a)
forall a. First a -> Maybe a
getFirst (First (HieAST a) -> Maybe (HieAST a))
-> First (HieAST a) -> Maybe (HieAST a)
forall a b. (a -> b) -> a -> b
$ (HieAST a -> First (HieAST a)) -> [HieAST a] -> First (HieAST a)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe (HieAST a) -> First (HieAST a)
forall a. Maybe a -> First a
First (Maybe (HieAST a) -> First (HieAST a))
-> (HieAST a -> Maybe (HieAST a)) -> HieAST a -> First (HieAST a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> HieAST a -> Maybe (HieAST a)
forall a. Span -> HieAST a -> Maybe (HieAST a)
selectLargestContainedBy Span
sp) ([HieAST a] -> First (HieAST a)) -> [HieAST a] -> First (HieAST a)
forall a b. (a -> b) -> a -> b
$
        HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  | Bool
otherwise = Maybe (HieAST a)
forall a. Maybe a
Nothing

selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining :: forall a. Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining Span
sp HieAST a
node
  | HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
node Span -> Span -> Bool
`containsSpan` Span
sp = First (HieAST a) -> Maybe (HieAST a)
forall a. First a -> Maybe a
getFirst (First (HieAST a) -> Maybe (HieAST a))
-> First (HieAST a) -> Maybe (HieAST a)
forall a b. (a -> b) -> a -> b
$ [First (HieAST a)] -> First (HieAST a)
forall a. Monoid a => [a] -> a
mconcat
      [ (HieAST a -> First (HieAST a)) -> [HieAST a] -> First (HieAST a)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe (HieAST a) -> First (HieAST a)
forall a. Maybe a -> First a
First (Maybe (HieAST a) -> First (HieAST a))
-> (HieAST a -> Maybe (HieAST a)) -> HieAST a -> First (HieAST a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> HieAST a -> Maybe (HieAST a)
forall a. Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining Span
sp) ([HieAST a] -> First (HieAST a)) -> [HieAST a] -> First (HieAST a)
forall a b. (a -> b) -> a -> b
$ HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
      , Maybe (HieAST a) -> First (HieAST a)
forall a. Maybe a -> First a
First (HieAST a -> Maybe (HieAST a)
forall a. a -> Maybe a
Just HieAST a
node)
      ]
  | Span
sp Span -> Span -> Bool
`containsSpan` HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
node = Maybe (HieAST a)
forall a. Maybe a
Nothing
  | Bool
otherwise = Maybe (HieAST a)
forall a. Maybe a
Nothing

definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool
definedInAsts :: forall a. Map HiePath (HieAST a) -> Name -> Bool
definedInAsts Map HiePath (HieAST a)
asts Name
n = case Name -> SrcSpan
nameSrcSpan Name
n of
  RealSrcSpan Span
sp Maybe BufSpan
_ -> HiePath -> Map HiePath (HieAST a) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (FastString -> HiePath
HiePath (Span -> FastString
srcSpanFile Span
sp)) Map HiePath (HieAST a)
asts
  SrcSpan
_ -> Bool
False

getEvidenceBindDeps :: ContextInfo -> [Name]
getEvidenceBindDeps :: ContextInfo -> [Name]
getEvidenceBindDeps (EvidenceVarBind (EvLetBind EvBindDeps
xs) Scope
_ Maybe Span
_) =
  EvBindDeps -> [Name]
getEvBindDeps EvBindDeps
xs
getEvidenceBindDeps ContextInfo
_ = []

isEvidenceBind :: ContextInfo -> Bool
isEvidenceBind :: ContextInfo -> Bool
isEvidenceBind EvidenceVarBind{} = Bool
True
isEvidenceBind ContextInfo
_ = Bool
False

isEvidenceContext :: ContextInfo -> Bool
isEvidenceContext :: ContextInfo -> Bool
isEvidenceContext ContextInfo
EvidenceVarUse = Bool
True
isEvidenceContext EvidenceVarBind{} = Bool
True
isEvidenceContext ContextInfo
_ = Bool
False

isEvidenceUse :: ContextInfo -> Bool
isEvidenceUse :: ContextInfo -> Bool
isEvidenceUse ContextInfo
EvidenceVarUse = Bool
True
isEvidenceUse ContextInfo
_ = Bool
False

isOccurrence :: ContextInfo -> Bool
isOccurrence :: ContextInfo -> Bool
isOccurrence ContextInfo
Use = Bool
True
isOccurrence ContextInfo
EvidenceVarUse = Bool
True
isOccurrence ContextInfo
_ = Bool
False

scopeContainsSpan :: Scope -> Span -> Bool
scopeContainsSpan :: Scope -> Span -> Bool
scopeContainsSpan Scope
NoScope Span
_ = Bool
False
scopeContainsSpan Scope
ModuleScope Span
_ = Bool
True
scopeContainsSpan (LocalScope Span
a) Span
b = Span
a Span -> Span -> Bool
`containsSpan` Span
b

-- | One must contain the other. Leaf nodes cannot contain anything
combineAst :: HieAST Type -> HieAST Type -> HieAST Type
combineAst :: HieAST Type -> HieAST Type -> HieAST Type
combineAst a :: HieAST Type
a@(Node SourcedNodeInfo Type
aInf Span
aSpn [HieAST Type]
xs) b :: HieAST Type
b@(Node SourcedNodeInfo Type
bInf Span
bSpn [HieAST Type]
ys)
  | Span
aSpn Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
== Span
bSpn = SourcedNodeInfo Type -> Span -> [HieAST Type] -> HieAST Type
forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node (SourcedNodeInfo Type
aInf SourcedNodeInfo Type
-> SourcedNodeInfo Type -> SourcedNodeInfo Type
`combineSourcedNodeInfo` SourcedNodeInfo Type
bInf) Span
aSpn ([HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
xs [HieAST Type]
ys)
  | Span
aSpn Span -> Span -> Bool
`containsSpan` Span
bSpn = HieAST Type -> HieAST Type -> HieAST Type
combineAst HieAST Type
b HieAST Type
a
combineAst HieAST Type
a (Node SourcedNodeInfo Type
xs Span
span [HieAST Type]
children) = SourcedNodeInfo Type -> Span -> [HieAST Type] -> HieAST Type
forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node SourcedNodeInfo Type
xs Span
span (HieAST Type -> [HieAST Type] -> [HieAST Type]
insertAst HieAST Type
a [HieAST Type]
children)

-- | Insert an AST in a sorted list of disjoint Asts
insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
insertAst HieAST Type
x = [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type
x]

nodeInfo :: HieAST Type -> NodeInfo Type
nodeInfo :: HieAST Type -> NodeInfo Type
nodeInfo = (NodeInfo Type -> NodeInfo Type -> NodeInfo Type)
-> NodeInfo Type -> Map NodeOrigin (NodeInfo Type) -> NodeInfo Type
forall b a. (b -> a -> b) -> b -> Map NodeOrigin a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' NodeInfo Type -> NodeInfo Type -> NodeInfo Type
combineNodeInfo NodeInfo Type
forall a. NodeInfo a
emptyNodeInfo (Map NodeOrigin (NodeInfo Type) -> NodeInfo Type)
-> (HieAST Type -> Map NodeOrigin (NodeInfo Type))
-> HieAST Type
-> NodeInfo Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcedNodeInfo Type -> Map NodeOrigin (NodeInfo Type)
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo (SourcedNodeInfo Type -> Map NodeOrigin (NodeInfo Type))
-> (HieAST Type -> SourcedNodeInfo Type)
-> HieAST Type
-> Map NodeOrigin (NodeInfo Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST Type -> SourcedNodeInfo Type
forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo

emptyNodeInfo :: NodeInfo a
emptyNodeInfo :: forall a. NodeInfo a
emptyNodeInfo = Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo Set NodeAnnotation
forall a. Set a
S.empty [] NodeIdentifiers a
forall k a. Map k a
M.empty

sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents :: forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents = (IdentifierDetails a -> IdentifierDetails a -> IdentifierDetails a)
-> Map NodeOrigin (Map Identifier (IdentifierDetails a))
-> Map Identifier (IdentifierDetails a)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith IdentifierDetails a -> IdentifierDetails a -> IdentifierDetails a
forall a. Semigroup a => a -> a -> a
(<>) (Map NodeOrigin (Map Identifier (IdentifierDetails a))
 -> Map Identifier (IdentifierDetails a))
-> (SourcedNodeInfo a
    -> Map NodeOrigin (Map Identifier (IdentifierDetails a)))
-> SourcedNodeInfo a
-> Map Identifier (IdentifierDetails a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeInfo a -> Map Identifier (IdentifierDetails a))
-> Map NodeOrigin (NodeInfo a)
-> Map NodeOrigin (Map Identifier (IdentifierDetails a))
forall a b. (a -> b) -> Map NodeOrigin a -> Map NodeOrigin b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (Map NodeOrigin (NodeInfo a)
 -> Map NodeOrigin (Map Identifier (IdentifierDetails a)))
-> (SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a))
-> SourcedNodeInfo a
-> Map NodeOrigin (Map Identifier (IdentifierDetails a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo

combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type
combineSourcedNodeInfo :: SourcedNodeInfo Type
-> SourcedNodeInfo Type -> SourcedNodeInfo Type
combineSourcedNodeInfo = (Map NodeOrigin (NodeInfo Type)
 -> Map NodeOrigin (NodeInfo Type)
 -> Map NodeOrigin (NodeInfo Type))
-> SourcedNodeInfo Type
-> SourcedNodeInfo Type
-> SourcedNodeInfo Type
forall a b. Coercible a b => a -> b
coerce ((Map NodeOrigin (NodeInfo Type)
  -> Map NodeOrigin (NodeInfo Type)
  -> Map NodeOrigin (NodeInfo Type))
 -> SourcedNodeInfo Type
 -> SourcedNodeInfo Type
 -> SourcedNodeInfo Type)
-> (Map NodeOrigin (NodeInfo Type)
    -> Map NodeOrigin (NodeInfo Type)
    -> Map NodeOrigin (NodeInfo Type))
-> SourcedNodeInfo Type
-> SourcedNodeInfo Type
-> SourcedNodeInfo Type
forall a b. (a -> b) -> a -> b
$ (NodeInfo Type -> NodeInfo Type -> NodeInfo Type)
-> Map NodeOrigin (NodeInfo Type)
-> Map NodeOrigin (NodeInfo Type)
-> Map NodeOrigin (NodeInfo Type)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith NodeInfo Type -> NodeInfo Type -> NodeInfo Type
combineNodeInfo

-- | Merge two nodes together.
--
-- Precondition and postcondition: elements in 'nodeType' are ordered.
combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
(NodeInfo Set NodeAnnotation
as [Type]
ai NodeIdentifiers Type
ad) combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
`combineNodeInfo` (NodeInfo Set NodeAnnotation
bs [Type]
bi NodeIdentifiers Type
bd) =
  Set NodeAnnotation
-> [Type] -> NodeIdentifiers Type -> NodeInfo Type
forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo (Set NodeAnnotation -> Set NodeAnnotation -> Set NodeAnnotation
forall a. Ord a => Set a -> Set a -> Set a
S.union Set NodeAnnotation
as Set NodeAnnotation
bs) ([Type] -> [Type] -> [Type]
mergeSorted [Type]
ai [Type]
bi) ((IdentifierDetails Type
 -> IdentifierDetails Type -> IdentifierDetails Type)
-> NodeIdentifiers Type
-> NodeIdentifiers Type
-> NodeIdentifiers Type
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith IdentifierDetails Type
-> IdentifierDetails Type -> IdentifierDetails Type
forall a. Semigroup a => a -> a -> a
(<>) NodeIdentifiers Type
ad NodeIdentifiers Type
bd)
  where
    mergeSorted :: [Type] -> [Type] -> [Type]
    mergeSorted :: [Type] -> [Type] -> [Type]
mergeSorted la :: [Type]
la@(Type
a:[Type]
as) lb :: [Type]
lb@(Type
b:[Type]
bs) = case Type -> Type -> Ordering
nonDetCmpType Type
a Type
b of
                                        Ordering
LT -> Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
as [Type]
lb
                                        Ordering
EQ -> Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
as [Type]
bs
                                        Ordering
GT -> Type
b Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
la [Type]
bs
    mergeSorted [Type]
as [] = [Type]
as
    mergeSorted [] [Type]
bs = [Type]
bs


{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.

In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),
different nodes in an AST tree should either have disjoint spans (in
which case you can say for sure which one comes first) or one span
should be completely contained in the other (in which case the contained
span corresponds to some child node).

However, since Haskell does have position-altering pragmas it /is/
possible for spans to be overlapping. Here is an example of a source file
in which @foozball@ and @quuuuuux@ have overlapping spans:

@
module Baz where

# line 3 "Baz.hs"
foozball :: Int
foozball = 0

# line 3 "Baz.hs"
bar, quuuuuux :: Int
bar = 1
quuuuuux = 2
@

In these cases, we just do our best to produce sensible `HieAST`'s. The blame
should be laid at the feet of whoever wrote the line pragmas in the first place
(usually the C preprocessor...).
-}
mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
xs [] = [HieAST Type]
xs
mergeAsts [] [HieAST Type]
ys = [HieAST Type]
ys
mergeAsts xs :: [HieAST Type]
xs@(HieAST Type
a:[HieAST Type]
as) ys :: [HieAST Type]
ys@(HieAST Type
b:[HieAST Type]
bs)
  | Span
span_a Span -> Span -> Bool
`containsSpan`   Span
span_b = [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts (HieAST Type -> HieAST Type -> HieAST Type
combineAst HieAST Type
a HieAST Type
b HieAST Type -> [HieAST Type] -> [HieAST Type]
forall a. a -> [a] -> [a]
: [HieAST Type]
as) [HieAST Type]
bs
  | Span
span_b Span -> Span -> Bool
`containsSpan`   Span
span_a = [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
as (HieAST Type -> HieAST Type -> HieAST Type
combineAst HieAST Type
a HieAST Type
b HieAST Type -> [HieAST Type] -> [HieAST Type]
forall a. a -> [a] -> [a]
: [HieAST Type]
bs)
  | Span
span_a Span -> Span -> Bool
`rightOf`        Span
span_b = HieAST Type
b HieAST Type -> [HieAST Type] -> [HieAST Type]
forall a. a -> [a] -> [a]
: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
xs [HieAST Type]
bs
  | Span
span_a Span -> Span -> Bool
`leftOf`         Span
span_b = HieAST Type
a HieAST Type -> [HieAST Type] -> [HieAST Type]
forall a. a -> [a] -> [a]
: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
as [HieAST Type]
ys

  -- These cases are to work around ASTs that are not fully disjoint
  | Span
span_a Span -> Span -> Bool
`startsRightOf`  Span
span_b = HieAST Type
b HieAST Type -> [HieAST Type] -> [HieAST Type]
forall a. a -> [a] -> [a]
: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
as [HieAST Type]
ys
  | Bool
otherwise                      = HieAST Type
a HieAST Type -> [HieAST Type] -> [HieAST Type]
forall a. a -> [a] -> [a]
: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
as [HieAST Type]
ys
  where
    span_a :: Span
span_a = HieAST Type -> Span
forall a. HieAST a -> Span
nodeSpan HieAST Type
a
    span_b :: Span
span_b = HieAST Type -> Span
forall a. HieAST a -> Span
nodeSpan HieAST Type
b

rightOf :: Span -> Span -> Bool
rightOf :: Span -> Span -> Bool
rightOf Span
s1 Span
s2
  = (Span -> Int
srcSpanStartLine Span
s1, Span -> Int
srcSpanStartCol Span
s1)
       (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
>= (Span -> Int
srcSpanEndLine Span
s2, Span -> Int
srcSpanEndCol Span
s2)
    Bool -> Bool -> Bool
&& (Span -> FastString
srcSpanFile Span
s1 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> FastString
srcSpanFile Span
s2)

leftOf :: Span -> Span -> Bool
leftOf :: Span -> Span -> Bool
leftOf Span
s1 Span
s2
  = (Span -> Int
srcSpanEndLine Span
s1, Span -> Int
srcSpanEndCol Span
s1)
       (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Span -> Int
srcSpanStartLine Span
s2, Span -> Int
srcSpanStartCol Span
s2)
    Bool -> Bool -> Bool
&& (Span -> FastString
srcSpanFile Span
s1 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> FastString
srcSpanFile Span
s2)

startsRightOf :: Span -> Span -> Bool
startsRightOf :: Span -> Span -> Bool
startsRightOf Span
s1 Span
s2
  = (Span -> Int
srcSpanStartLine Span
s1, Span -> Int
srcSpanStartCol Span
s1)
       (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
>= (Span -> Int
srcSpanStartLine Span
s2, Span -> Int
srcSpanStartCol Span
s2)

-- | combines and sorts ASTs using a merge sort
mergeSortAsts :: [HieAST Type] -> [HieAST Type]
mergeSortAsts :: [HieAST Type] -> [HieAST Type]
mergeSortAsts = [[HieAST Type]] -> [HieAST Type]
go ([[HieAST Type]] -> [HieAST Type])
-> ([HieAST Type] -> [[HieAST Type]])
-> [HieAST Type]
-> [HieAST Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HieAST Type -> [HieAST Type]) -> [HieAST Type] -> [[HieAST Type]]
forall a b. (a -> b) -> [a] -> [b]
map HieAST Type -> [HieAST Type]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    go :: [[HieAST Type]] -> [HieAST Type]
go [] = []
    go [[HieAST Type]
xs] = [HieAST Type]
xs
    go [[HieAST Type]]
xss = [[HieAST Type]] -> [HieAST Type]
go ([[HieAST Type]] -> [[HieAST Type]]
mergePairs [[HieAST Type]]
xss)
    mergePairs :: [[HieAST Type]] -> [[HieAST Type]]
mergePairs [] = []
    mergePairs [[HieAST Type]
xs] = [[HieAST Type]
xs]
    mergePairs ([HieAST Type]
xs:[HieAST Type]
ys:[[HieAST Type]]
xss) = [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
xs [HieAST Type]
ys [HieAST Type] -> [[HieAST Type]] -> [[HieAST Type]]
forall a. a -> [a] -> [a]
: [[HieAST Type]] -> [[HieAST Type]]
mergePairs [[HieAST Type]]
xss

simpleNodeInfo :: FastString -> FastString -> NodeInfo a
simpleNodeInfo :: forall a. FastString -> FastString -> NodeInfo a
simpleNodeInfo FastString
cons FastString
typ = Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo (NodeAnnotation -> Set NodeAnnotation
forall a. a -> Set a
S.singleton (FastString -> FastString -> NodeAnnotation
NodeAnnotation FastString
cons FastString
typ)) [] NodeIdentifiers a
forall k a. Map k a
M.empty

locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
locOnly :: forall (m :: * -> *) a.
Monad m =>
SrcSpan -> ReaderT NodeOrigin m [HieAST a]
locOnly (RealSrcSpan Span
span Maybe BufSpan
_) = do
  org <- ReaderT NodeOrigin m NodeOrigin
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let e = NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
forall a. NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
mkSourcedNodeInfo NodeOrigin
org (NodeInfo a -> SourcedNodeInfo a)
-> NodeInfo a -> SourcedNodeInfo a
forall a b. (a -> b) -> a -> b
$ NodeInfo a
forall a. NodeInfo a
emptyNodeInfo
  pure [Node e span []]
locOnly SrcSpan
_ = [HieAST a] -> ReaderT NodeOrigin m [HieAST a]
forall a. a -> ReaderT NodeOrigin m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a]
locOnlyE :: forall (m :: * -> *) a.
Monad m =>
EpaLocation -> ReaderT NodeOrigin m [HieAST a]
locOnlyE (EpaSpan SrcSpan
s) = SrcSpan -> ReaderT NodeOrigin m [HieAST a]
forall (m :: * -> *) a.
Monad m =>
SrcSpan -> ReaderT NodeOrigin m [HieAST a]
locOnly SrcSpan
s
locOnlyE EpaLocation
_ = [HieAST a] -> ReaderT NodeOrigin m [HieAST a]
forall a. a -> ReaderT NodeOrigin m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkScope :: (HasLoc a) => a -> Scope
mkScope :: forall a. HasLoc a => a -> Scope
mkScope a
a = case a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc a
a of
              (RealSrcSpan Span
sp Maybe BufSpan
_) -> Span -> Scope
LocalScope Span
sp
              SrcSpan
_ -> Scope
NoScope

combineScopes :: Scope -> Scope -> Scope
combineScopes :: Scope -> Scope -> Scope
combineScopes Scope
ModuleScope Scope
_ = Scope
ModuleScope
combineScopes Scope
_ Scope
ModuleScope = Scope
ModuleScope
combineScopes Scope
NoScope Scope
x = Scope
x
combineScopes Scope
x Scope
NoScope = Scope
x
combineScopes (LocalScope Span
a) (LocalScope Span
b) =
  SrcSpan -> Scope
forall a. HasLoc a => a -> Scope
mkScope (SrcSpan -> Scope) -> SrcSpan -> Scope
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Span -> Maybe BufSpan -> SrcSpan
RealSrcSpan Span
a Maybe BufSpan
forall a. Maybe a
Strict.Nothing) (Span -> Maybe BufSpan -> SrcSpan
RealSrcSpan Span
b Maybe BufSpan
forall a. Maybe a
Strict.Nothing)

mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
mkSourcedNodeInfo :: forall a. NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
mkSourcedNodeInfo NodeOrigin
org NodeInfo a
ni = Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
forall a. Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
SourcedNodeInfo (Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a)
-> Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
forall a b. (a -> b) -> a -> b
$ NodeOrigin -> NodeInfo a -> Map NodeOrigin (NodeInfo a)
forall k a. k -> a -> Map k a
M.singleton NodeOrigin
org NodeInfo a
ni

{-# INLINEABLE makeNodeA #-}
makeNodeA
  :: (Monad m, Data a)
  => a                 -- ^ helps fill in 'nodeAnnotations' (with 'Data')
  -> EpAnn ann         -- ^ return an empty list if this is unhelpful
  -> ReaderT NodeOrigin m [HieAST b]
makeNodeA :: forall (m :: * -> *) a ann b.
(Monad m, Data a) =>
a -> EpAnn ann -> ReaderT NodeOrigin m [HieAST b]
makeNodeA a
x EpAnn ann
spn = a -> SrcSpan -> ReaderT NodeOrigin m [HieAST b]
forall (m :: * -> *) a b.
(Monad m, Data a) =>
a -> SrcSpan -> ReaderT NodeOrigin m [HieAST b]
makeNode a
x (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
spn)

{-# INLINEABLE makeNode #-}
makeNode
  :: (Monad m, Data a)
  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
  -> ReaderT NodeOrigin m [HieAST b]
makeNode :: forall (m :: * -> *) a b.
(Monad m, Data a) =>
a -> SrcSpan -> ReaderT NodeOrigin m [HieAST b]
makeNode a
x SrcSpan
spn = do
  org <- ReaderT NodeOrigin m NodeOrigin
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  pure $ case spn of
    RealSrcSpan Span
span Maybe BufSpan
_ -> [SourcedNodeInfo b -> Span -> [HieAST b] -> HieAST b
forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node (NodeOrigin -> NodeInfo b -> SourcedNodeInfo b
forall a. NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
mkSourcedNodeInfo NodeOrigin
org (NodeInfo b -> SourcedNodeInfo b)
-> NodeInfo b -> SourcedNodeInfo b
forall a b. (a -> b) -> a -> b
$ FastString -> FastString -> NodeInfo b
forall a. FastString -> FastString -> NodeInfo a
simpleNodeInfo FastString
cons FastString
typ) Span
span []]
    SrcSpan
_ -> []
  where
    cons :: FastString
cons = String -> FastString
mkFastString (String -> FastString) -> (a -> String) -> a -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> String
forall a. Show a => a -> String
show (Constr -> String) -> (a -> Constr) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Constr
forall a. Data a => a -> Constr
toConstr (a -> FastString) -> a -> FastString
forall a b. (a -> b) -> a -> b
$ a
x
    typ :: FastString
typ = String -> FastString
mkFastString (String -> FastString) -> (a -> String) -> a -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> String
forall a. Show a => a -> String
show (TyCon -> String) -> (a -> TyCon) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (a -> TypeRep) -> a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a -> FastString) -> a -> FastString
forall a b. (a -> b) -> a -> b
$ a
x

{-# INLINEABLE makeTypeNodeA #-}
makeTypeNodeA
  :: (Monad m, Data a)
  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
  -> SrcSpanAnnA             -- ^ return an empty list if this is unhelpful
  -> Type                    -- ^ type to associate with the node
  -> ReaderT NodeOrigin m [HieAST Type]
makeTypeNodeA :: forall (m :: * -> *) a.
(Monad m, Data a) =>
a -> SrcSpanAnnA -> Type -> ReaderT NodeOrigin m [HieAST Type]
makeTypeNodeA a
x SrcSpanAnnA
spn Type
etyp = a -> SrcSpan -> Type -> ReaderT NodeOrigin m [HieAST Type]
forall (m :: * -> *) a.
(Monad m, Data a) =>
a -> SrcSpan -> Type -> ReaderT NodeOrigin m [HieAST Type]
makeTypeNode a
x (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
spn) Type
etyp

{-# INLINEABLE makeTypeNode #-}
makeTypeNode
  :: (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
  -> ReaderT NodeOrigin m [HieAST Type]
makeTypeNode :: forall (m :: * -> *) a.
(Monad m, Data a) =>
a -> SrcSpan -> Type -> ReaderT NodeOrigin m [HieAST Type]
makeTypeNode a
x SrcSpan
spn Type
etyp = do
  org <- ReaderT NodeOrigin m NodeOrigin
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  pure $ case spn of
    RealSrcSpan Span
span Maybe BufSpan
_ ->
      [SourcedNodeInfo Type -> Span -> [HieAST Type] -> HieAST Type
forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node (NodeOrigin -> NodeInfo Type -> SourcedNodeInfo Type
forall a. NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
mkSourcedNodeInfo NodeOrigin
org (NodeInfo Type -> SourcedNodeInfo Type)
-> NodeInfo Type -> SourcedNodeInfo Type
forall a b. (a -> b) -> a -> b
$ Set NodeAnnotation
-> [Type] -> NodeIdentifiers Type -> NodeInfo Type
forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo (NodeAnnotation -> Set NodeAnnotation
forall a. a -> Set a
S.singleton (FastString -> FastString -> NodeAnnotation
NodeAnnotation FastString
cons FastString
typ)) [Type
etyp] NodeIdentifiers Type
forall k a. Map k a
M.empty) Span
span []]
    SrcSpan
_ -> []
  where
    cons :: FastString
cons = String -> FastString
mkFastString (String -> FastString) -> (a -> String) -> a -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> String
forall a. Show a => a -> String
show (Constr -> String) -> (a -> Constr) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Constr
forall a. Data a => a -> Constr
toConstr (a -> FastString) -> a -> FastString
forall a b. (a -> b) -> a -> b
$ a
x
    typ :: FastString
typ = String -> FastString
mkFastString (String -> FastString) -> (a -> String) -> a -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> String
forall a. Show a => a -> String
show (TyCon -> String) -> (a -> TyCon) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (a -> TypeRep) -> a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a -> FastString) -> a -> FastString
forall a b. (a -> b) -> a -> b
$ a
x