{-# 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.Session    ( DynFlags )
import GHC.Driver.Ppr
import GHC.Data.FastString   ( FastString, mkFastString )
import GHC.Iface.Type
import GHC.Core.Multiplicity
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.Type
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Parser.Annotation

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 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)
  -> RefMap a
generateReferencesMap :: forall (f :: * -> *) a. Foldable f => f (HieAST a) -> RefMap a
generateReferencesMap = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\HieAST a
ast RefMap a
m -> forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. [a] -> [a] -> [a]
(++) (forall {a}.
HieAST a -> Map Identifier [(Span, IdentifierDetails a)]
go HieAST a
ast) RefMap a
m) forall k a. Map k a
M.empty
  where
    go :: HieAST a -> Map Identifier [(Span, IdentifierDetails a)]
go HieAST a
ast = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith forall a. [a] -> [a] -> [a]
(++) (Map Identifier [(Span, IdentifierDetails a)]
this forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map HieAST a -> Map Identifier [(Span, IdentifierDetails a)]
go (forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
ast))
      where
        this :: Map Identifier [(Span, IdentifierDetails a)]
this = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. HieAST a -> Span
nodeSpan HieAST a
ast,)) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents forall a b. (a -> b) -> a -> b
$ 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 (forall a. Outputable a => a -> SDoc
ppr 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
  = TCvSubst -> Type -> [Type] -> [(Bool, Type)]
go (InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope) Type
kind [Type]
ty_args
  where
    in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes [Type]
ty_args)

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

    go TCvSubst
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) forall a. a -> [a] -> [a]
: (TCvSubst -> Type -> [Type] -> [(Bool, Type)]
go TCvSubst
env Type
res [Type]
ts)

    go TCvSubst
env (TyVarTy TyCoVar
tv) [Type]
ts
      | Just Type
ki <- TCvSubst -> TyCoVar -> Maybe Type
lookupTyVar TCvSubst
env TyCoVar
tv = TCvSubst -> Type -> [Type] -> [(Bool, Type)]
go TCvSubst
env Type
ki [Type]
ts
    go TCvSubst
env Type
kind (Type
t:[Type]
ts) = (Bool
True, Type
t) forall a. a -> [a] -> [a]
: (TCvSubst -> Type -> [Type] -> [(Bool, Type)]
go TCvSubst
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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) = forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall k a. Map k a -> [(k, a)]
M.toList (forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hf)) forall a b. (a -> b) -> a -> b
$ \(HiePath FastString
fs,HieAST Int
ast) -> forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$
      case forall a. Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining (FastString -> Span
sp FastString
fs) HieAST Int
ast of
        Maybe (HieAST Int)
Nothing -> forall a. Maybe a
Nothing
        Just HieAST Int
ast' -> 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, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceUse (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)]
 where
   xs :: [(Identifier, IdentifierDetails a)]
xs = 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
forall a. Eq a => EvidenceInfo a -> EvidenceInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EvidenceInfo a -> EvidenceInfo a -> Bool
$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
Eq,EvidenceInfo a -> EvidenceInfo a -> Bool
EvidenceInfo a -> EvidenceInfo a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (EvidenceInfo a)
forall a. Ord a => EvidenceInfo a -> EvidenceInfo a -> Bool
forall a. Ord a => EvidenceInfo a -> EvidenceInfo a -> Ordering
forall a.
Ord a =>
EvidenceInfo a -> EvidenceInfo a -> EvidenceInfo a
min :: EvidenceInfo a -> EvidenceInfo a -> EvidenceInfo a
$cmin :: forall a.
Ord a =>
EvidenceInfo a -> EvidenceInfo a -> EvidenceInfo a
max :: EvidenceInfo a -> EvidenceInfo a -> EvidenceInfo a
$cmax :: forall a.
Ord a =>
EvidenceInfo a -> EvidenceInfo a -> EvidenceInfo a
>= :: EvidenceInfo a -> EvidenceInfo a -> Bool
$c>= :: forall a. Ord a => EvidenceInfo a -> EvidenceInfo a -> Bool
> :: EvidenceInfo a -> EvidenceInfo a -> Bool
$c> :: forall a. Ord a => EvidenceInfo a -> EvidenceInfo a -> Bool
<= :: EvidenceInfo a -> EvidenceInfo a -> Bool
$c<= :: forall a. Ord a => EvidenceInfo a -> EvidenceInfo a -> Bool
< :: EvidenceInfo a -> EvidenceInfo a -> Bool
$c< :: forall a. Ord a => EvidenceInfo a -> EvidenceInfo a -> Bool
compare :: EvidenceInfo a -> EvidenceInfo a -> Ordering
$ccompare :: forall a. Ord a => EvidenceInfo a -> EvidenceInfo a -> Ordering
Ord,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
<$ :: forall a b. a -> EvidenceInfo b -> EvidenceInfo a
$c<$ :: forall a b. a -> EvidenceInfo b -> EvidenceInfo a
fmap :: forall a b. (a -> b) -> EvidenceInfo a -> EvidenceInfo b
$cfmap :: forall a b. (a -> b) -> EvidenceInfo a -> EvidenceInfo b
Functor)

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 (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Span
span SDoc -> SDoc -> SDoc
O.<> String -> SDoc
text String
", of type:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
typ) Int
4 forall a b. (a -> b) -> a -> b
$
      SDoc
pdets SDoc -> SDoc -> SDoc
$$ (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
text String
"is a usage of an external evidence variable"
        Just (EvVarSource
src,Scope
scp,Maybe Span
spn) -> String -> SDoc
text String
"is an" SDoc -> SDoc -> 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 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HieFile -> (Int, Int) -> Maybe (HieAST Int)
selectPoint HieFile
hf (Int, Int)
point
     , Name
n        <- forall a. NodeIdentifiers a -> [Name]
findEvidenceUse (forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo HieAST Int
ast)
     , Just Tree (EvidenceInfo a)
t   <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = forall a. Maybe a
Nothing
      | Bool
otherwise = do
          [(Span, IdentifierDetails a)]
xs <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a b. b -> Either a b
Right Name
var) RefMap a
refmap
          case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceBind forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Set ContextInfo
identInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Span, IdentifierDetails a)]
xs of
            Just (Span
sp,IdentifierDetails a
dets) -> do
              a
typ <- forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails a
dets
              ((EvVarSource, Scope, Maybe Span)
evdet,[Tree (EvidenceInfo a)]
children) <- forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ do
                 ContextInfo
det <- forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets
                 case ContextInfo
det of
                   EvidenceVarBind src :: EvVarSource
src@(EvLetBind (EvBindDeps -> [Name]
getEvBindDeps -> [Name]
xs)) Scope
scp Maybe Span
spn ->
                     forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ((EvVarSource
src,Scope
scp,Maybe Span
spn),forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSet -> Name -> Maybe (Tree (EvidenceInfo a))
go 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ((EvVarSource
src,Scope
scp,Maybe Span
spn),[])
                   ContextInfo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Tree.Node (forall a.
Name
-> Span
-> a
-> Maybe (EvVarSource, Scope, Maybe Span)
-> EvidenceInfo a
EvidenceInfo Name
var Span
sp a
typ (forall a. a -> Maybe a
Just (EvVarSource, Scope, Maybe Span)
evdet)) [Tree (EvidenceInfo a)]
children
            -- It is externally bound
            Maybe (Span, IdentifierDetails a)
Nothing -> forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ do
              (Span
sp,IdentifierDetails a
dets) <- [(Span, IdentifierDetails a)]
xs
              if (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceUse forall a b. (a -> b) -> a -> b
$ forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
                then do
                  case forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails a
dets of
                    Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                    Just a
typ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Tree.Node (forall a.
Name
-> Span
-> a
-> Maybe (EvVarSource, Scope, Maybe Span)
-> EvidenceInfo a
EvidenceInfo Name
var Span
sp a
typ forall a. Maybe a
Nothing) []
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = forall a. (HieType a -> a) -> HieTypeFix -> a
foldType HieType IfaceType -> IfaceType
go
  where
    go :: HieType IfaceType -> IfaceType
go (HTyVarTy Name
n) = FastString -> IfaceType
IfaceTyVar forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameFS forall a b. (a -> b) -> a -> b
$ 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),ArgFlag
af) IfaceType
t) = let b :: (FastString, IfaceType)
b = (OccName -> FastString
occNameFS forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> OccName
getOccName Name
n, IfaceType
k)
                                  in IfaceForAllBndr -> IfaceType -> IfaceType
IfaceForAllTy (forall var argf. var -> argf -> VarBndr var argf
Bndr ((FastString, IfaceType) -> IfaceBndr
IfaceTvBndr (FastString, IfaceType)
b) ArgFlag
af) IfaceType
t
    go (HFunTy IfaceType
w IfaceType
a IfaceType
b)   = AnonArgFlag -> IfaceType -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy AnonArgFlag
VisArg   IfaceType
w       IfaceType
a    IfaceType
b
    go (HQualTy IfaceType
pred IfaceType
b) = AnonArgFlag -> IfaceType -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy AnonArgFlag
InvisArg 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 -> ArgFlag -> IfaceAppArgs -> IfaceAppArgs
IA_Arg IfaceType
x ArgFlag
Required forall a b. (a -> b) -> a -> b
$ [(Bool, IfaceType)] -> IfaceAppArgs
go' [(Bool, IfaceType)]
xs
        go' ((Bool
False,IfaceType
x):[(Bool, IfaceType)]
xs) = IfaceType -> ArgFlag -> IfaceAppArgs -> IfaceAppArgs
IA_Arg IfaceType
x ArgFlag
Specified 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 forall a. TypeMap a
emptyTypeMap forall a. IntMap a
IM.empty Int
0

freshTypeIndex :: State HieTypeState TypeIndex
freshTypeIndex :: State HieTypeState Int
freshTypeIndex = do
  Int
index <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets HieTypeState -> Int
freshIndex
  forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' forall a b. (a -> b) -> a -> b
$ \HieTypeState
hts -> HieTypeState
hts { freshIndex :: Int
freshIndex = Int
indexforall a. Num a => a -> a -> a
+Int
1 }
  forall (m :: * -> *) a. Monad m => a -> m a
return Int
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)) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState HieTypeState
initialHTS forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for HieASTs Type
asts forall a b. (a -> b) -> a -> b
$ \Type
typ ->
        Type -> State HieTypeState Int
getTypeIndex Type
typ
    arr :: Array Int HieTypeFlat
arr = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
A.array (Int
0,Int
iforall a. Num a => a -> a -> a
-Int
1) (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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> HieTypeFix
go (Array Int HieTypeFlat
m 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
      TypeMap Int
tm <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets HieTypeState -> TypeMap Int
tyMap
      case forall a. TypeMap a -> Type -> Maybe a
lookupTypeMap TypeMap Int
tm Type
t of
        Just Int
i -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
        Maybe Int
Nothing -> do
          HieTypeFlat
ht <- Type -> StateT HieTypeState Identity HieTypeFlat
go Type
t
          Type -> HieTypeFlat -> State HieTypeState Int
extendHTS Type
t HieTypeFlat
ht
  where
    extendHTS :: Type -> HieTypeFlat -> State HieTypeState Int
extendHTS Type
t HieTypeFlat
ht = do
      Int
i <- State HieTypeState Int
freshTypeIndex
      forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' forall a b. (a -> b) -> a -> b
$ \(HTS TypeMap Int
tm IntMap HieTypeFlat
tt Int
fi) ->
        TypeMap Int -> IntMap HieTypeFlat -> Int -> HieTypeState
HTS (forall a. TypeMap a -> Type -> a -> TypeMap a
extendTypeMap TypeMap Int
tm Type
t Int
i) (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i HieTypeFlat
ht IntMap HieTypeFlat
tt) Int
fi
      forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

    go :: Type -> StateT HieTypeState Identity HieTypeFlat
go (TyVarTy TyCoVar
v) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Name -> HieType a
HTyVarTy 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) = Type -> (Type, [Type])
splitAppTys Type
ty
          visArgs :: HieArgs Type
visArgs = forall a. [(Bool, a)] -> HieArgs a
HieArgs forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> [(Bool, Type)]
resolveVisibility (HasDebugCallStack => Type -> Type
typeKind Type
head) [Type]
args
      Int
ai <- Type -> State HieTypeState Int
getTypeIndex Type
head
      HieArgs Int
argsi <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> State HieTypeState Int
getTypeIndex HieArgs Type
visArgs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> HieArgs a -> HieType a
HAppTy Int
ai HieArgs Int
argsi
    go (TyConApp TyCon
f [Type]
xs) = do
      let visArgs :: HieArgs Type
visArgs = forall a. [(Bool, a)] -> HieArgs a
HieArgs forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> [(Bool, Type)]
resolveVisibility (TyCon -> Type
tyConKind TyCon
f) [Type]
xs
      HieArgs Int
is <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> State HieTypeState Int
getTypeIndex HieArgs Type
visArgs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IfaceTyCon -> HieArgs a -> HieType a
HTyConApp (TyCon -> IfaceTyCon
toIfaceTyCon TyCon
f) HieArgs Int
is
    go (ForAllTy (Bndr TyCoVar
v ArgFlag
a) Type
t) = do
      Int
k <- Type -> State HieTypeState Int
getTypeIndex (TyCoVar -> Type
varType TyCoVar
v)
      Int
i <- Type -> State HieTypeState Int
getTypeIndex Type
t
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ((Name, a), ArgFlag) -> a -> HieType a
HForAllTy ((TyCoVar -> Name
varName TyCoVar
v,Int
k),ArgFlag
a) Int
i
    go (FunTy { ft_af :: Type -> AnonArgFlag
ft_af = AnonArgFlag
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
      Int
ai <- Type -> State HieTypeState Int
getTypeIndex Type
a
      Int
bi <- Type -> State HieTypeState Int
getTypeIndex Type
b
      Int
wi <- Type -> State HieTypeState Int
getTypeIndex Type
w
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case AnonArgFlag
af of
                 AnonArgFlag
InvisArg -> case Type
w of Type
Many -> forall a. a -> a -> HieType a
HQualTy Int
ai Int
bi; Type
_ -> forall a. HasCallStack => String -> a
error String
"Unexpected non-unrestricted predicate"
                 AnonArgFlag
VisArg   -> forall a. a -> a -> a -> HieType a
HFunTy Int
wi Int
ai Int
bi
    go (LitTy TyLit
a) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IfaceTyLit -> HieType a
HLitTy forall a b. (a -> b) -> a -> b
$ TyLit -> IfaceTyLit
toIfaceTyLit TyLit
a
    go (CastTy Type
t KindCoercion
_) = do
      Int
i <- Type -> State HieTypeState Int
getTypeIndex Type
t
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> HieType a
HCastTy Int
i
    go (CoercionTy KindCoercion
_) = forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 = 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 :: Set ContextInfo
identInfo =
      forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ContextInfo -> ContextInfo
resolveScope (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)}
    resolveScope :: ContextInfo -> ContextInfo
resolveScope (TyVarBind Scope
sc (UnresolvedScope [Name]
names Maybe Span
Nothing)) =
      Scope -> TyVarScope -> ContextInfo
TyVarBind Scope
sc forall a b. (a -> b) -> a -> b
$ [Scope] -> TyVarScope
ResolvedScopes
        [ Span -> Scope
LocalScope Span
binding
        | Name
name <- [Name]
names
        , Just Span
binding <- [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 forall a b. (a -> b) -> a -> b
$ [Scope] -> TyVarScope
ResolvedScopes
        [ Span -> Scope
LocalScope Span
binding
        | Name
name <- [Name]
names
        , Just Span
binding <- [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) = forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node SourcedNodeInfo a
info' Span
span forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map HieAST a -> HieAST a
go [HieAST a]
children
      where
        info' :: SourcedNodeInfo a
info' = forall a. Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
SourcedNodeInfo (NodeInfo a -> NodeInfo a
updateNodeInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: NodeIdentifiers a
nodeIdentifiers = NodeIdentifiers a
idents }
          where
            idents :: NodeIdentifiers a
idents = forall a b k. (a -> b) -> Map k a -> Map k b
M.map IdentifierDetails a -> IdentifierDetails a
resolveNameScope forall a b. (a -> b) -> a -> b
$ 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
  ([Scope]
_,Maybe Span
msp) <- forall a.
Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding Name
n Map HiePath (HieAST a)
asts
  Maybe Span
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
  ([Scope]
scopes,Maybe Span
_) <- forall a.
Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding Name
n Map HiePath (HieAST a)
asts
  forall (m :: * -> *) a. Monad m => a -> m a
return [Scope]
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
  HieAST a
ast <- 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
  forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ do
    HieAST a
child <- forall a. HieAST a -> [HieAST a]
flattenAst HieAST a
ast
    IdentifierDetails a
dets <- forall a. Maybe a -> [a]
maybeToList
      forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a b. b -> Either a b
Right Name
n) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo HieAST a
child
    let binding :: First Span
binding = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextInfo -> Maybe Span
getBindSiteFromContext) (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. First a -> Maybe a
getFirst First Span
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
    HieAST a
ast <- 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
    HieAST a
defNode <- forall a. Span -> HieAST a -> Maybe (HieAST a)
selectLargestContainedBy Span
sp HieAST a
ast
    forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ do -- @[]
      HieAST a
node <- forall a. HieAST a -> [HieAST a]
flattenAst HieAST a
defNode
      IdentifierDetails a
dets <- forall a. Maybe a -> [a]
maybeToList
        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a b. b -> Either a b
Right Name
n) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo HieAST a
node
      [Scope]
scopes <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ContextInfo -> Maybe [Scope]
getScopeFromContext (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
      let binding :: First Span
binding = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextInfo -> Maybe Span
getBindSiteFromContext) (forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([Scope]
scopes, forall a. First a -> Maybe a
getFirst First Span
binding)
  SrcSpan
_ -> forall a. Maybe a
Nothing

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

flattenAst :: HieAST a -> [HieAST a]
flattenAst :: forall a. HieAST a -> [HieAST a]
flattenAst HieAST a
n =
  HieAST a
n forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. HieAST a -> [HieAST a]
flattenAst (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
  | forall a. HieAST a -> Span
nodeSpan HieAST a
node Span -> Span -> Bool
`containsSpan` Span
sp = forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Span -> (HieAST a -> Bool) -> HieAST a -> Maybe (HieAST a)
smallestContainingSatisfying Span
sp HieAST a -> Bool
cond) forall a b. (a -> b) -> a -> b
$
          forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
      , forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ if HieAST a -> Bool
cond HieAST a
node then forall a. a -> Maybe a
Just HieAST a
node else forall a. Maybe a
Nothing
      ]
  | Span
sp Span -> Span -> Bool
`containsSpan` forall a. HieAST a -> Span
nodeSpan HieAST a
node = forall a. Maybe a
Nothing
  | Bool
otherwise = 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` forall a. HieAST a -> Span
nodeSpan HieAST a
node = forall a. a -> Maybe a
Just HieAST a
node
  | forall a. HieAST a -> Span
nodeSpan HieAST a
node Span -> Span -> Bool
`containsSpan` Span
sp =
      forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Span -> HieAST a -> Maybe (HieAST a)
selectLargestContainedBy Span
sp) forall a b. (a -> b) -> a -> b
$
        forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  | Bool
otherwise = 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
  | forall a. HieAST a -> Span
nodeSpan HieAST a
node Span -> Span -> Bool
`containsSpan` Span
sp = forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining Span
sp) forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
      , forall a. Maybe a -> First a
First (forall a. a -> Maybe a
Just HieAST a
node)
      ]
  | Span
sp Span -> Span -> Bool
`containsSpan` forall a. HieAST a -> Span
nodeSpan HieAST a
node = forall a. Maybe a
Nothing
  | Bool
otherwise = 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
_ -> 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 forall a. Eq a => a -> a -> Bool
== Span
bSpn = 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) = 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' NodeInfo Type -> NodeInfo Type -> NodeInfo Type
combineNodeInfo forall a. NodeInfo a
emptyNodeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo

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

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

combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type
combineSourcedNodeInfo :: SourcedNodeInfo Type
-> SourcedNodeInfo Type -> SourcedNodeInfo Type
combineSourcedNodeInfo = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ 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) =
  forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo (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) (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith 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 forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
as [Type]
lb
                                        Ordering
EQ -> Type
a forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
as [Type]
bs
                                        Ordering
GT -> Type
b 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 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 forall a. a -> [a] -> [a]
: [HieAST Type]
bs)
  | Span
span_a Span -> Span -> Bool
`rightOf`        Span
span_b = HieAST Type
b 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 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 forall a. a -> [a] -> [a]
: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
as [HieAST Type]
ys
  | Bool
otherwise                      = HieAST Type
a forall a. a -> [a] -> [a]
: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts [HieAST Type]
as [HieAST Type]
ys
  where
    span_a :: Span
span_a = forall a. HieAST a -> Span
nodeSpan HieAST Type
a
    span_b :: Span
span_b = 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)
       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 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)
       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 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)
       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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 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 = forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo (forall a. a -> Set a
S.singleton (FastString -> FastString -> NodeAnnotation
NodeAnnotation FastString
cons FastString
typ)) [] 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
  NodeOrigin
org <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let e :: SourcedNodeInfo a
e = forall a. NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
mkSourcedNodeInfo NodeOrigin
org forall a b. (a -> b) -> a -> b
$ forall a. NodeInfo a
emptyNodeInfo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node SourcedNodeInfo a
e Span
span []]
locOnly SrcSpan
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkScopeA :: SrcSpanAnn' ann -> Scope
mkScopeA :: forall ann. SrcSpanAnn' ann -> Scope
mkScopeA SrcSpanAnn' ann
l = SrcSpan -> Scope
mkScope (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' ann
l)

mkScope :: SrcSpan -> Scope
mkScope :: SrcSpan -> Scope
mkScope (RealSrcSpan Span
sp Maybe BufSpan
_) = Span -> Scope
LocalScope Span
sp
mkScope SrcSpan
_ = Scope
NoScope

mkLScope :: Located a -> Scope
mkLScope :: forall a. Located a -> Scope
mkLScope = SrcSpan -> Scope
mkScope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc

mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope
mkLScopeA :: forall a e. GenLocated (SrcSpanAnn' a) e -> Scope
mkLScopeA = SrcSpan -> Scope
mkScope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SrcSpanAnn' a -> SrcSpan
locA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc

mkLScopeN :: LocatedN a -> Scope
mkLScopeN :: forall a. LocatedN a -> Scope
mkLScopeN = SrcSpan -> Scope
mkScope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA

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
mkScope forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Span -> Maybe BufSpan -> SrcSpan
RealSrcSpan Span
a forall a. Maybe a
Nothing) (Span -> Maybe BufSpan -> SrcSpan
RealSrcSpan Span
b forall a. Maybe a
Nothing)

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