{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module HieUtils where

import GhcPrelude

import CoreMap
import DynFlags                   ( DynFlags )
import FastString                 ( FastString, mkFastString )
import IfaceType
import Name hiding (varName)
import Outputable                 ( renderWithStyle, ppr, defaultUserStyle )
import SrcLoc
import ToIface
import TyCon
import TyCoRep
import Type
import Var
import VarEnv

import HieTypes

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 )
import Data.Monoid
import Data.Traversable           ( for )
import Control.Monad.Trans.State.Strict hiding (get)


generateReferencesMap
  :: Foldable f
  => f (HieAST a)
  -> M.Map Identifier [(Span, IdentifierDetails a)]
generateReferencesMap :: f (HieAST a) -> Map Identifier [(Span, IdentifierDetails a)]
generateReferencesMap = (HieAST a
 -> Map Identifier [(Span, IdentifierDetails a)]
 -> Map Identifier [(Span, IdentifierDetails a)])
-> Map Identifier [(Span, IdentifierDetails a)]
-> f (HieAST a)
-> Map Identifier [(Span, IdentifierDetails a)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\HieAST a
ast Map Identifier [(Span, IdentifierDetails a)]
m -> ([(Span, IdentifierDetails a)]
 -> [(Span, IdentifierDetails a)] -> [(Span, IdentifierDetails a)])
-> Map Identifier [(Span, IdentifierDetails a)]
-> Map Identifier [(Span, IdentifierDetails a)]
-> Map Identifier [(Span, IdentifierDetails 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 -> Map Identifier [(Span, IdentifierDetails a)]
forall a. HieAST a -> Map Identifier [(Span, IdentifierDetails a)]
go HieAST a
ast) Map Identifier [(Span, IdentifierDetails a)]
m) Map Identifier [(Span, IdentifierDetails 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Span, IdentifierDetails a) -> [(Span, IdentifierDetails 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
$ NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (NodeInfo a -> Map Identifier (IdentifierDetails a))
-> NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a b. (a -> b) -> a -> b
$ HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo HieAST a
ast

renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType DynFlags
df HieTypeFix
ht = DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
df (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) PprStyle
sty
  where sty :: PprStyle
sty = DynFlags -> PprStyle
defaultUserStyle DynFlags
df

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) (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' = 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) (Bool, Type) -> [(Bool, Type)] -> [(Bool, Type)]
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) (Bool, Type) -> [(Bool, Type)] -> [(Bool, Type)]
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 :: (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 (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

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) = IfLclName -> IfaceType
IfaceTyVar (IfLclName -> IfaceType) -> IfLclName -> IfaceType
forall a b. (a -> b) -> a -> b
$ OccName -> IfLclName
occNameFS (OccName -> IfLclName) -> OccName -> IfLclName
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),ArgFlag
af) IfaceType
t) = let b :: (IfLclName, IfaceType)
b = (OccName -> IfLclName
occNameFS (OccName -> IfLclName) -> OccName -> IfLclName
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 -> ArgFlag -> IfaceForAllBndr
forall var argf. var -> argf -> VarBndr var argf
Bndr ((IfLclName, IfaceType) -> IfaceBndr
IfaceTvBndr (IfLclName, IfaceType)
b) ArgFlag
af) IfaceType
t
    go (HFunTy IfaceType
a IfaceType
b)     = AnonArgFlag -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy AnonArgFlag
VisArg   IfaceType
a    IfaceType
b
    go (HQualTy IfaceType
pred IfaceType
b) = AnonArgFlag -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy AnonArgFlag
InvisArg IfaceType
pred IfaceType
b
    go (HCastTy IfaceType
a) = IfaceType
a
    go HieType IfaceType
HCoercionTy = IfLclName -> IfaceType
IfaceTyVar IfLclName
"<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 (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 -> ArgFlag -> IfaceAppArgs -> IfaceAppArgs
IA_Arg IfaceType
x ArgFlag
Specified (IfaceAppArgs -> IfaceAppArgs) -> IfaceAppArgs -> IfaceAppArgs
forall a b. (a -> b) -> a -> b
$ [(Bool, IfaceType)] -> IfaceAppArgs
go' [(Bool, IfaceType)]
xs

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

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

freshTypeIndex :: State HieTypeState TypeIndex
freshTypeIndex :: State HieTypeState TypeIndex
freshTypeIndex = do
  TypeIndex
index <- (HieTypeState -> TypeIndex) -> State HieTypeState TypeIndex
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets HieTypeState -> TypeIndex
freshIndex
  (HieTypeState -> HieTypeState) -> StateT HieTypeState Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((HieTypeState -> HieTypeState) -> StateT HieTypeState Identity ())
-> (HieTypeState -> HieTypeState)
-> StateT HieTypeState Identity ()
forall a b. (a -> b) -> a -> b
$ \HieTypeState
hts -> HieTypeState
hts { freshIndex :: TypeIndex
freshIndex = TypeIndex
indexTypeIndex -> TypeIndex -> TypeIndex
forall a. Num a => a -> a -> a
+TypeIndex
1 }
  TypeIndex -> State HieTypeState TypeIndex
forall (m :: * -> *) a. Monad m => a -> m a
return TypeIndex
index

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

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

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

    go :: Type -> StateT HieTypeState Identity HieTypeFlat
go (TyVarTy TyCoVar
v) = HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat)
-> HieTypeFlat -> StateT HieTypeState Identity 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) = 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
      TypeIndex
ai <- Type -> State HieTypeState TypeIndex
getTypeIndex Type
head
      HieArgs TypeIndex
argsi <- (Type -> State HieTypeState TypeIndex)
-> HieArgs Type -> StateT HieTypeState Identity (HieArgs TypeIndex)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> State HieTypeState TypeIndex
getTypeIndex HieArgs Type
visArgs
      HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat)
-> HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall a b. (a -> b) -> a -> b
$ TypeIndex -> HieArgs TypeIndex -> HieTypeFlat
forall a. a -> HieArgs a -> HieType a
HAppTy TypeIndex
ai HieArgs TypeIndex
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
      HieArgs TypeIndex
is <- (Type -> State HieTypeState TypeIndex)
-> HieArgs Type -> StateT HieTypeState Identity (HieArgs TypeIndex)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> State HieTypeState TypeIndex
getTypeIndex HieArgs Type
visArgs
      HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat)
-> HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall a b. (a -> b) -> a -> b
$ IfaceTyCon -> HieArgs TypeIndex -> HieTypeFlat
forall a. IfaceTyCon -> HieArgs a -> HieType a
HTyConApp (TyCon -> IfaceTyCon
toIfaceTyCon TyCon
f) HieArgs TypeIndex
is
    go (ForAllTy (Bndr TyCoVar
v ArgFlag
a) Type
t) = do
      TypeIndex
k <- Type -> State HieTypeState TypeIndex
getTypeIndex (TyCoVar -> Type
varType TyCoVar
v)
      TypeIndex
i <- Type -> State HieTypeState TypeIndex
getTypeIndex Type
t
      HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat)
-> HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall a b. (a -> b) -> a -> b
$ ((Name, TypeIndex), ArgFlag) -> TypeIndex -> HieTypeFlat
forall a. ((Name, a), ArgFlag) -> a -> HieType a
HForAllTy ((TyCoVar -> Name
varName TyCoVar
v,TypeIndex
k),ArgFlag
a) TypeIndex
i
    go (FunTy { ft_af :: Type -> AnonArgFlag
ft_af = AnonArgFlag
af, ft_arg :: Type -> Type
ft_arg = Type
a, ft_res :: Type -> Type
ft_res = Type
b }) = do
      TypeIndex
ai <- Type -> State HieTypeState TypeIndex
getTypeIndex Type
a
      TypeIndex
bi <- Type -> State HieTypeState TypeIndex
getTypeIndex Type
b
      HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat)
-> HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall a b. (a -> b) -> a -> b
$ case AnonArgFlag
af of
                 AnonArgFlag
InvisArg -> TypeIndex -> TypeIndex -> HieTypeFlat
forall a. a -> a -> HieType a
HQualTy TypeIndex
ai TypeIndex
bi
                 AnonArgFlag
VisArg   -> TypeIndex -> TypeIndex -> HieTypeFlat
forall a. a -> a -> HieType a
HFunTy TypeIndex
ai TypeIndex
bi
    go (LitTy TyLit
a) = HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat)
-> HieTypeFlat -> StateT HieTypeState Identity 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
      TypeIndex
i <- Type -> State HieTypeState TypeIndex
getTypeIndex Type
t
      HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return (HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat)
-> HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall a b. (a -> b) -> a -> b
$ TypeIndex -> HieTypeFlat
forall a. a -> HieType a
HCastTy TypeIndex
i
    go (CoercionTy KindCoercion
_) = HieTypeFlat -> StateT HieTypeState Identity HieTypeFlat
forall (m :: * -> *) a. Monad m => a -> m a
return HieTypeFlat
forall a. HieType a
HCoercionTy

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

resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a
resolveTyVarScopeLocal :: HieAST a -> Map IfLclName (HieAST a) -> HieAST a
resolveTyVarScopeLocal HieAST a
ast Map IfLclName (HieAST a)
asts = HieAST a -> HieAST a
forall a. 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 =
      (ContextInfo -> ContextInfo) -> Set ContextInfo -> Set ContextInfo
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ContextInfo -> ContextInfo
resolveScope (IdentifierDetails a -> Set ContextInfo
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 (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 IfLclName (HieAST a) -> Maybe Span
forall a. Name -> Map IfLclName (HieAST a) -> Maybe Span
getNameBinding Name
name Map IfLclName (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 IfLclName (HieAST a) -> Maybe Span
forall a. Name -> Span -> Map IfLclName (HieAST a) -> Maybe Span
getNameBindingInClass Name
name Span
sp Map IfLclName (HieAST a)
asts]
        ]
    resolveScope ContextInfo
scope = ContextInfo
scope
    go :: HieAST a -> HieAST a
go (Node NodeInfo a
info Span
span [HieAST a]
children) = NodeInfo a -> Span -> [HieAST a] -> HieAST a
forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
Node NodeInfo 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' :: NodeInfo a
info' = NodeInfo a
info { nodeIdentifiers :: NodeIdentifiers a
nodeIdentifiers = NodeIdentifiers a
idents }
        idents :: NodeIdentifiers a
idents = (IdentifierDetails a -> IdentifierDetails a)
-> NodeIdentifiers a -> NodeIdentifiers a
forall a b k. (a -> b) -> Map k a -> Map k b
M.map IdentifierDetails a -> IdentifierDetails a
forall a. IdentifierDetails a -> IdentifierDetails a
resolveNameScope (NodeIdentifiers a -> NodeIdentifiers a)
-> NodeIdentifiers a -> NodeIdentifiers a
forall a b. (a -> b) -> a -> b
$ NodeInfo a -> NodeIdentifiers a
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo a
info

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

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

getNameBindingInClass
  :: Name
  -> Span
  -> M.Map FastString (HieAST a)
  -> Maybe Span
getNameBindingInClass :: Name -> Span -> Map IfLclName (HieAST a) -> Maybe Span
getNameBindingInClass Name
n Span
sp Map IfLclName (HieAST a)
asts = do
  HieAST a
ast <- IfLclName -> Map IfLclName (HieAST a) -> Maybe (HieAST a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Span -> IfLclName
srcSpanFile Span
sp) Map IfLclName (HieAST a)
asts
  First Span -> Maybe Span
forall a. First a -> Maybe a
getFirst (First Span -> Maybe Span) -> First Span -> Maybe Span
forall a b. (a -> b) -> a -> b
$ (Maybe Span -> First Span) -> [Maybe Span] -> First Span
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) -> [Maybe Span] -> First Span
forall a b. (a -> b) -> a -> b
$ do
    HieAST a
child <- HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
flattenAst HieAST a
ast
    IdentifierDetails a
dets <- Maybe (IdentifierDetails a) -> [IdentifierDetails a]
forall a. Maybe a -> [a]
maybeToList
      (Maybe (IdentifierDetails a) -> [IdentifierDetails a])
-> Maybe (IdentifierDetails a) -> [IdentifierDetails a]
forall a b. (a -> b) -> a -> b
$ Identifier
-> Map Identifier (IdentifierDetails a)
-> Maybe (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
n) (Map Identifier (IdentifierDetails a)
 -> Maybe (IdentifierDetails a))
-> Map Identifier (IdentifierDetails a)
-> Maybe (IdentifierDetails a)
forall a b. (a -> b) -> a -> b
$ NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (NodeInfo a -> Map Identifier (IdentifierDetails a))
-> NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a b. (a -> b) -> a -> b
$ HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo HieAST a
child
    let binding :: First Span
binding = (ContextInfo -> First Span) -> Set ContextInfo -> First Span
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)
    Maybe Span -> [Maybe Span]
forall (m :: * -> *) a. Monad m => a -> m a
return (First Span -> Maybe Span
forall a. First a -> Maybe a
getFirst First Span
binding)

getNameScopeAndBinding
  :: Name
  -> M.Map FastString (HieAST a)
  -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding :: Name -> Map IfLclName (HieAST a) -> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding Name
n Map IfLclName (HieAST a)
asts = case Name -> SrcSpan
nameSrcSpan Name
n of
  RealSrcSpan Span
sp -> do -- @Maybe
    HieAST a
ast <- IfLclName -> Map IfLclName (HieAST a) -> Maybe (HieAST a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Span -> IfLclName
srcSpanFile Span
sp) Map IfLclName (HieAST a)
asts
    HieAST a
defNode <- Span -> HieAST a -> Maybe (HieAST a)
forall a. Span -> HieAST a -> Maybe (HieAST a)
selectLargestContainedBy Span
sp HieAST a
ast
    First ([Scope], Maybe Span) -> Maybe ([Scope], Maybe Span)
forall a. First a -> Maybe a
getFirst (First ([Scope], Maybe Span) -> Maybe ([Scope], Maybe Span))
-> First ([Scope], Maybe Span) -> Maybe ([Scope], Maybe Span)
forall a b. (a -> b) -> a -> b
$ (Maybe ([Scope], Maybe Span) -> First ([Scope], Maybe Span))
-> [Maybe ([Scope], Maybe Span)] -> First ([Scope], Maybe Span)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Maybe ([Scope], Maybe Span) -> First ([Scope], Maybe Span)
forall a. Maybe a -> First a
First ([Maybe ([Scope], Maybe Span)] -> First ([Scope], Maybe Span))
-> [Maybe ([Scope], Maybe Span)] -> First ([Scope], Maybe Span)
forall a b. (a -> b) -> a -> b
$ do -- @[]
      HieAST a
node <- HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
flattenAst HieAST a
defNode
      IdentifierDetails a
dets <- Maybe (IdentifierDetails a) -> [IdentifierDetails a]
forall a. Maybe a -> [a]
maybeToList
        (Maybe (IdentifierDetails a) -> [IdentifierDetails a])
-> Maybe (IdentifierDetails a) -> [IdentifierDetails a]
forall a b. (a -> b) -> a -> b
$ Identifier
-> Map Identifier (IdentifierDetails a)
-> Maybe (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
n) (Map Identifier (IdentifierDetails a)
 -> Maybe (IdentifierDetails a))
-> Map Identifier (IdentifierDetails a)
-> Maybe (IdentifierDetails a)
forall a b. (a -> b) -> a -> b
$ NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (NodeInfo a -> Map Identifier (IdentifierDetails a))
-> NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a b. (a -> b) -> a -> b
$ HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo HieAST a
node
      [Scope]
scopes <- Maybe [Scope] -> [[Scope]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Scope] -> [[Scope]]) -> Maybe [Scope] -> [[Scope]]
forall a b. (a -> b) -> a -> b
$ (ContextInfo -> Maybe [Scope]) -> Set ContextInfo -> Maybe [Scope]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ContextInfo -> Maybe [Scope]
getScopeFromContext (IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
      let binding :: First Span
binding = (ContextInfo -> First Span) -> Set ContextInfo -> First Span
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)
      Maybe ([Scope], Maybe Span) -> [Maybe ([Scope], Maybe Span)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([Scope], Maybe Span) -> [Maybe ([Scope], Maybe Span)])
-> Maybe ([Scope], Maybe Span) -> [Maybe ([Scope], Maybe Span)]
forall a b. (a -> b) -> a -> b
$ ([Scope], Maybe Span) -> Maybe ([Scope], Maybe Span)
forall a. a -> Maybe a
Just ([Scope]
scopes, First Span -> Maybe Span
forall a. First a -> Maybe a
getFirst First Span
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 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 :: 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 :: 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 (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 :: 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 (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 :: 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 (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 FastString (HieAST a) -> Name -> Bool
definedInAsts :: Map IfLclName (HieAST a) -> Name -> Bool
definedInAsts Map IfLclName (HieAST a)
asts Name
n = case Name -> SrcSpan
nameSrcSpan Name
n of
  RealSrcSpan Span
sp -> Span -> IfLclName
srcSpanFile Span
sp IfLclName -> [IfLclName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map IfLclName (HieAST a) -> [IfLclName]
forall k a. Map k a -> [k]
M.keys Map IfLclName (HieAST a)
asts
  SrcSpan
_ -> Bool
False

isOccurrence :: ContextInfo -> Bool
isOccurrence :: ContextInfo -> Bool
isOccurrence ContextInfo
Use = 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 NodeInfo Type
aInf Span
aSpn [HieAST Type]
xs) b :: HieAST Type
b@(Node NodeInfo Type
bInf Span
bSpn [HieAST Type]
ys)
  | Span
aSpn Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
== Span
bSpn = NodeInfo Type -> Span -> [HieAST Type] -> HieAST Type
forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
Node (NodeInfo Type
aInf NodeInfo Type -> NodeInfo Type -> NodeInfo Type
`combineNodeInfo` NodeInfo 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 NodeInfo Type
xs Span
span [HieAST Type]
children) = NodeInfo Type -> Span -> [HieAST Type] -> HieAST Type
forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
Node NodeInfo 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]

-- | Merge two nodes together.
--
-- Precondition and postcondition: elements in 'nodeType' are ordered.
combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
(NodeInfo Set (IfLclName, IfLclName)
as [Type]
ai NodeIdentifiers Type
ad) combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
`combineNodeInfo` (NodeInfo Set (IfLclName, IfLclName)
bs [Type]
bi NodeIdentifiers Type
bd) =
  Set (IfLclName, IfLclName)
-> [Type] -> NodeIdentifiers Type -> NodeInfo Type
forall a.
Set (IfLclName, IfLclName)
-> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo (Set (IfLclName, IfLclName)
-> Set (IfLclName, IfLclName) -> Set (IfLclName, IfLclName)
forall a. Ord a => Set a -> Set a -> Set a
S.union Set (IfLclName, IfLclName)
as Set (IfLclName, IfLclName)
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 -> TypeIndex
srcSpanStartLine Span
s1, Span -> TypeIndex
srcSpanStartCol Span
s1)
       (TypeIndex, TypeIndex) -> (TypeIndex, TypeIndex) -> Bool
forall a. Ord a => a -> a -> Bool
>= (Span -> TypeIndex
srcSpanEndLine Span
s2, Span -> TypeIndex
srcSpanEndCol Span
s2)
    Bool -> Bool -> Bool
&& (Span -> IfLclName
srcSpanFile Span
s1 IfLclName -> IfLclName -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> IfLclName
srcSpanFile Span
s2)

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

startsRightOf :: Span -> Span -> Bool
startsRightOf :: Span -> Span -> Bool
startsRightOf Span
s1 Span
s2
  = (Span -> TypeIndex
srcSpanStartLine Span
s1, Span -> TypeIndex
srcSpanStartCol Span
s1)
       (TypeIndex, TypeIndex) -> (TypeIndex, TypeIndex) -> Bool
forall a. Ord a => a -> a -> Bool
>= (Span -> TypeIndex
srcSpanStartLine Span
s2, Span -> TypeIndex
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 (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 :: IfLclName -> IfLclName -> NodeInfo a
simpleNodeInfo IfLclName
cons IfLclName
typ = Set (IfLclName, IfLclName)
-> [a] -> NodeIdentifiers a -> NodeInfo a
forall a.
Set (IfLclName, IfLclName)
-> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo ((IfLclName, IfLclName) -> Set (IfLclName, IfLclName)
forall a. a -> Set a
S.singleton (IfLclName
cons, IfLclName
typ)) [] NodeIdentifiers a
forall k a. Map k a
M.empty

locOnly :: SrcSpan -> [HieAST a]
locOnly :: SrcSpan -> [HieAST a]
locOnly (RealSrcSpan Span
span) =
  [NodeInfo a -> Span -> [HieAST a] -> HieAST a
forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
Node NodeInfo a
forall a. NodeInfo a
e Span
span []]
    where e :: NodeInfo a
e = Set (IfLclName, IfLclName)
-> [a] -> NodeIdentifiers a -> NodeInfo a
forall a.
Set (IfLclName, IfLclName)
-> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo Set (IfLclName, IfLclName)
forall a. Set a
S.empty [] NodeIdentifiers a
forall k a. Map k a
M.empty
locOnly SrcSpan
_ = []

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

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

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 (SrcSpan -> Scope) -> SrcSpan -> Scope
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Span -> SrcSpan
RealSrcSpan Span
a) (Span -> SrcSpan
RealSrcSpan Span
b)

{-# INLINEABLE makeNode #-}
makeNode
  :: (Applicative m, Data a)
  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
  -> m [HieAST b]
makeNode :: a -> SrcSpan -> m [HieAST b]
makeNode a
x SrcSpan
spn = [HieAST b] -> m [HieAST b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HieAST b] -> m [HieAST b]) -> [HieAST b] -> m [HieAST b]
forall a b. (a -> b) -> a -> b
$ case SrcSpan
spn of
  RealSrcSpan Span
span -> [NodeInfo b -> Span -> [HieAST b] -> HieAST b
forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
Node (IfLclName -> IfLclName -> NodeInfo b
forall a. IfLclName -> IfLclName -> NodeInfo a
simpleNodeInfo IfLclName
cons IfLclName
typ) Span
span []]
  SrcSpan
_ -> []
  where
    cons :: IfLclName
cons = String -> IfLclName
mkFastString (String -> IfLclName) -> (a -> String) -> a -> IfLclName
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 -> IfLclName) -> a -> IfLclName
forall a b. (a -> b) -> a -> b
$ a
x
    typ :: IfLclName
typ = String -> IfLclName
mkFastString (String -> IfLclName) -> (a -> String) -> a -> IfLclName
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 -> IfLclName) -> a -> IfLclName
forall a b. (a -> b) -> a -> b
$ a
x

{-# INLINEABLE makeTypeNode #-}
makeTypeNode
  :: (Applicative m, Data a)
  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
  -> Type                    -- ^ type to associate with the node
  -> m [HieAST Type]
makeTypeNode :: a -> SrcSpan -> Type -> m [HieAST Type]
makeTypeNode a
x SrcSpan
spn Type
etyp = [HieAST Type] -> m [HieAST Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HieAST Type] -> m [HieAST Type])
-> [HieAST Type] -> m [HieAST Type]
forall a b. (a -> b) -> a -> b
$ case SrcSpan
spn of
  RealSrcSpan Span
span ->
    [NodeInfo Type -> Span -> [HieAST Type] -> HieAST Type
forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
Node (Set (IfLclName, IfLclName)
-> [Type] -> NodeIdentifiers Type -> NodeInfo Type
forall a.
Set (IfLclName, IfLclName)
-> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo ((IfLclName, IfLclName) -> Set (IfLclName, IfLclName)
forall a. a -> Set a
S.singleton (IfLclName
cons,IfLclName
typ)) [Type
etyp] NodeIdentifiers Type
forall k a. Map k a
M.empty) Span
span []]
  SrcSpan
_ -> []
  where
    cons :: IfLclName
cons = String -> IfLclName
mkFastString (String -> IfLclName) -> (a -> String) -> a -> IfLclName
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 -> IfLclName) -> a -> IfLclName
forall a b. (a -> b) -> a -> b
$ a
x
    typ :: IfLclName
typ = String -> IfLclName
mkFastString (String -> IfLclName) -> (a -> String) -> a -> IfLclName
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 -> IfLclName) -> a -> IfLclName
forall a b. (a -> b) -> a -> b
$ a
x