{-# 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 (\ast :: HieAST a
ast m :: 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 ast :: 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 df :: DynFlags
df ht :: 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 kind :: Type
kind ty_args :: [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 _   _                   []     = []
    go env :: TCvSubst
env ty :: Type
ty                  ts :: [Type]
ts
      | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty
      = TCvSubst -> Type -> [Type] -> [(Bool, Type)]
go TCvSubst
env Type
ty' [Type]
ts
    go env :: TCvSubst
env (ForAllTy (Bndr tv :: TyCoVar
tv vis :: ArgFlag
vis) res :: Type
res) (t :: Type
t:ts :: [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 env :: TCvSubst
env (FunTy _ res :: Type
res) (t :: Type
t:ts :: [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 env :: TCvSubst
env (TyVarTy tv :: TyCoVar
tv) ts :: [Type]
ts
      | Just ki :: Type
ki <- TCvSubst -> TyCoVar -> Maybe Type
lookupTyVar TCvSubst
env TyCoVar
tv = TCvSubst -> Type -> [Type] -> [(Bool, Type)]
go TCvSubst
env Type
ki [Type]
ts
    go env :: TCvSubst
env kind :: Type
kind (t :: Type
t:ts :: [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 f :: HieType a -> a
f (Roll t :: 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 n :: 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 a :: IfaceType
a b :: HieArgs IfaceType
b) = IfaceType -> IfaceAppArgs -> IfaceType
IfaceAppTy IfaceType
a (HieArgs IfaceType -> IfaceAppArgs
hieToIfaceArgs HieArgs IfaceType
b)
    go (HLitTy l :: IfaceTyLit
l) = IfaceTyLit -> IfaceType
IfaceLitTy IfaceTyLit
l
    go (HForAllTy ((n :: Name
n,k :: IfaceType
k),af :: ArgFlag
af) t :: 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 a :: IfaceType
a b :: IfaceType
b) = IfaceType -> IfaceType -> IfaceType
IfaceFunTy IfaceType
a IfaceType
b
    go (HQualTy pred :: IfaceType
pred b :: IfaceType
b) = IfaceType -> IfaceType -> IfaceType
IfaceDFunTy IfaceType
pred IfaceType
b
    go (HCastTy a :: IfaceType
a) = IfaceType
a
    go HCoercionTy = IfLclName -> IfaceType
IfaceTyVar "<coercion type>"
    go (HTyConApp a :: IfaceTyCon
a xs :: 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 xs :: [(Bool, IfaceType)]
xs) = [(Bool, IfaceType)] -> IfaceAppArgs
go' [(Bool, IfaceType)]
xs
      where
        go' :: [(Bool, IfaceType)] -> IfaceAppArgs
go' [] = IfaceAppArgs
IA_Nil
        go' ((True ,x :: IfaceType
x):xs :: [(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' ((False,x :: IfaceType
x):xs :: [(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 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
$ \hts :: HieTypeState
hts -> HieTypeState
hts { freshIndex :: TypeIndex
freshIndex = TypeIndex
indexTypeIndex -> TypeIndex -> TypeIndex
forall a. Num a => a -> a -> a
+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 asts :: HieASTs Type
asts = (HieASTs TypeIndex
a, Array TypeIndex HieTypeFlat
arr)
  where
    (a :: HieASTs TypeIndex
a, (HTS _ m :: IntMap HieTypeFlat
m i :: 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
$ \typ :: 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 (0,TypeIndex
iTypeIndex -> TypeIndex -> TypeIndex
forall a. Num a => a -> a -> a
-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 i :: TypeIndex
i m :: Array TypeIndex HieTypeFlat
m = TypeIndex -> HieTypeFix
go TypeIndex
i
  where
    go :: TypeIndex -> HieTypeFix
go i :: 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 t :: 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 i :: TypeIndex
i -> TypeIndex -> State HieTypeState TypeIndex
forall (m :: * -> *) a. Monad m => a -> m a
return TypeIndex
i
        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 t :: Type
t ht :: 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 tm :: TypeMap TypeIndex
tm tt :: IntMap HieTypeFlat
tt fi :: 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 v :: 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 _ _) = do
      let (head :: Type
head,args :: [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 f :: TyCon
f xs :: [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 v :: TyCoVar
v a :: ArgFlag
a) t :: 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 a :: Type
a b :: 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
$ if Type -> Bool
isPredTy Type
a
                  then TypeIndex -> TypeIndex -> HieTypeFlat
forall a. a -> a -> HieType a
HQualTy TypeIndex
ai TypeIndex
bi
                  else TypeIndex -> TypeIndex -> HieTypeFlat
forall a. a -> a -> HieType a
HFunTy TypeIndex
ai TypeIndex
bi
    go (LitTy a :: 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 t :: Type
t _) = 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 _) = 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 asts :: 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 ast :: 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 ast :: HieAST a
ast asts :: 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 dets :: 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 sc :: Scope
sc (UnresolvedScope names :: [Name]
names 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 binding :: 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 sc :: Scope
sc (UnresolvedScope names :: [Name]
names (Just sp :: 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 binding :: 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 scope :: ContextInfo
scope = ContextInfo
scope
    go :: HieAST a -> HieAST a
go (Node info :: NodeInfo a
info span :: Span
span children :: [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 n :: Name
n asts :: Map IfLclName (HieAST a)
asts = do
  (_,msp :: 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 n :: Name
n asts :: Map IfLclName (HieAST a)
asts = do
  (scopes :: [Scope]
scopes,_) <- 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 n :: Name
n sp :: Span
sp asts :: 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 n :: Name
n asts :: Map IfLclName (HieAST a)
asts = case Name -> SrcSpan
nameSrcSpan Name
n of
  RealSrcSpan sp :: 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)
  _ -> Maybe ([Scope], Maybe Span)
forall a. Maybe a
Nothing

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

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

flattenAst :: HieAST a -> [HieAST a]
flattenAst :: HieAST a -> [HieAST a]
flattenAst n :: 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 sp :: Span
sp cond :: HieAST a -> Bool
cond node :: 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 sp :: Span
sp node :: 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 sp :: Span
sp node :: 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 asts :: Map IfLclName (HieAST a)
asts n :: Name
n = case Name -> SrcSpan
nameSrcSpan Name
n of
  RealSrcSpan sp :: 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
  _ -> Bool
False

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

scopeContainsSpan :: Scope -> Span -> Bool
scopeContainsSpan :: Scope -> Span -> Bool
scopeContainsSpan NoScope _ = Bool
False
scopeContainsSpan ModuleScope _ = Bool
True
scopeContainsSpan (LocalScope a :: Span
a) b :: 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 aInf :: NodeInfo Type
aInf aSpn :: Span
aSpn xs :: [HieAST Type]
xs) b :: HieAST Type
b@(Node bInf :: NodeInfo Type
bInf bSpn :: Span
bSpn ys :: [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 a :: HieAST Type
a (Node xs :: NodeInfo Type
xs span :: Span
span children :: [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 x :: 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 as :: Set (IfLclName, IfLclName)
as ai :: [Type]
ai ad :: NodeIdentifiers Type
ad) combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
`combineNodeInfo` (NodeInfo bs :: Set (IfLclName, IfLclName)
bs bi :: [Type]
bi bd :: 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@(a :: Type
a:as :: [Type]
as) lb :: [Type]
lb@(b :: Type
b:bs :: [Type]
bs) = case Type -> Type -> Ordering
nonDetCmpType Type
a Type
b of
                                        LT -> Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
as [Type]
lb
                                        EQ -> Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
as [Type]
bs
                                        GT -> Type
b Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> [Type] -> [Type]
mergeSorted [Type]
la [Type]
bs
    mergeSorted as :: [Type]
as [] = [Type]
as
    mergeSorted [] bs :: [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 xs :: [HieAST Type]
xs [] = [HieAST Type]
xs
mergeAsts [] ys :: [HieAST Type]
ys = [HieAST Type]
ys
mergeAsts xs :: [HieAST Type]
xs@(a :: HieAST Type
a:as :: [HieAST Type]
as) ys :: [HieAST Type]
ys@(b :: HieAST Type
b:bs :: [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 s1 :: Span
s1 s2 :: 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 s1 :: Span
s1 s2 :: 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 s1 :: Span
s1 s2 :: 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 [xs :: [HieAST Type]
xs] = [HieAST Type]
xs
    go xss :: [[HieAST Type]]
xss = [[HieAST Type]] -> [HieAST Type]
go ([[HieAST Type]] -> [[HieAST Type]]
mergePairs [[HieAST Type]]
xss)
    mergePairs :: [[HieAST Type]] -> [[HieAST Type]]
mergePairs [] = []
    mergePairs [xs :: [HieAST Type]
xs] = [[HieAST Type]
xs]
    mergePairs (xs :: [HieAST Type]
xs:ys :: [HieAST Type]
ys:xss :: [[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 cons :: IfLclName
cons typ :: 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
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 _ = []

mkScope :: SrcSpan -> Scope
mkScope :: SrcSpan -> Scope
mkScope (RealSrcSpan sp :: Span
sp) = Span -> Scope
LocalScope Span
sp
mkScope _ = 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 ModuleScope _ = Scope
ModuleScope
combineScopes _ ModuleScope = Scope
ModuleScope
combineScopes NoScope x :: Scope
x = Scope
x
combineScopes x :: Scope
x NoScope = Scope
x
combineScopes (LocalScope a :: Span
a) (LocalScope b :: 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 x :: a
x spn :: 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
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 []]
  _ -> []
  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 x :: a
x spn :: SrcSpan
spn etyp :: 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
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 []]
  _ -> []
  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