module GHC.Iface.Ext.Types where
import GHC.Prelude
import GHC.Settings.Config
import GHC.Utils.Binary
import GHC.Data.FastString ( FastString )
import GHC.Builtin.Utils
import GHC.Iface.Type
import GHC.Unit.Module ( ModuleName, Module )
import GHC.Types.Name
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Types.SrcLoc
import GHC.Types.Avail
import GHC.Types.Unique
import qualified GHC.Utils.Outputable as O ( (<>) )
import GHC.Utils.Misc
import qualified Data.Array as A
import qualified Data.Map as M
import qualified Data.Set as S
import Data.ByteString ( ByteString )
import Data.Data ( Typeable, Data )
import Data.Semigroup ( Semigroup(..) )
import Data.Word ( Word8 )
import Control.Applicative ( (<|>) )
import Data.Coerce ( coerce )
import Data.Function ( on )
type Span = RealSrcSpan
hieVersion :: Integer
hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
data HieFile = HieFile
{ hie_hs_file :: FilePath
, hie_module :: Module
, hie_types :: A.Array TypeIndex HieTypeFlat
, hie_asts :: HieASTs TypeIndex
, hie_exports :: [AvailInfo]
, hie_hs_src :: ByteString
}
instance Binary HieFile where
put_ bh hf = do
put_ bh $ hie_hs_file hf
put_ bh $ hie_module hf
put_ bh $ hie_types hf
put_ bh $ hie_asts hf
put_ bh $ hie_exports hf
put_ bh $ hie_hs_src hf
get bh = HieFile
<$> get bh
<*> get bh
<*> get bh
<*> get bh
<*> get bh
<*> get bh
type TypeIndex = Int
data HieType a
= HTyVarTy Name
| HAppTy a (HieArgs a)
| HTyConApp IfaceTyCon (HieArgs a)
| HForAllTy ((Name, a),ArgFlag) a
| HFunTy a a a
| HQualTy a a
| HLitTy IfaceTyLit
| HCastTy a
| HCoercionTy
deriving (Functor, Foldable, Traversable, Eq)
type HieTypeFlat = HieType TypeIndex
newtype HieTypeFix = Roll (HieType (HieTypeFix))
instance Binary (HieType TypeIndex) where
put_ bh (HTyVarTy n) = do
putByte bh 0
put_ bh n
put_ bh (HAppTy a b) = do
putByte bh 1
put_ bh a
put_ bh b
put_ bh (HTyConApp n xs) = do
putByte bh 2
put_ bh n
put_ bh xs
put_ bh (HForAllTy bndr a) = do
putByte bh 3
put_ bh bndr
put_ bh a
put_ bh (HFunTy w a b) = do
putByte bh 4
put_ bh w
put_ bh a
put_ bh b
put_ bh (HQualTy a b) = do
putByte bh 5
put_ bh a
put_ bh b
put_ bh (HLitTy l) = do
putByte bh 6
put_ bh l
put_ bh (HCastTy a) = do
putByte bh 7
put_ bh a
put_ bh (HCoercionTy) = putByte bh 8
get bh = do
(t :: Word8) <- get bh
case t of
0 -> HTyVarTy <$> get bh
1 -> HAppTy <$> get bh <*> get bh
2 -> HTyConApp <$> get bh <*> get bh
3 -> HForAllTy <$> get bh <*> get bh
4 -> HFunTy <$> get bh <*> get bh <*> get bh
5 -> HQualTy <$> get bh <*> get bh
6 -> HLitTy <$> get bh
7 -> HCastTy <$> get bh
8 -> return HCoercionTy
_ -> panic "Binary (HieArgs Int): invalid tag"
newtype HieArgs a = HieArgs [(Bool,a)]
deriving (Functor, Foldable, Traversable, Eq)
instance Binary (HieArgs TypeIndex) where
put_ bh (HieArgs xs) = put_ bh xs
get bh = HieArgs <$> get bh
newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }
deriving (Functor, Foldable, Traversable)
instance Binary (HieASTs TypeIndex) where
put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
instance Outputable a => Outputable (HieASTs a) where
ppr (HieASTs asts) = M.foldrWithKey go "" asts
where
go k a rest = vcat $
[ "File: " O.<> ppr k
, ppr a
, rest
]
data HieAST a =
Node
{ sourcedNodeInfo :: SourcedNodeInfo a
, nodeSpan :: Span
, nodeChildren :: [HieAST a]
} deriving (Functor, Foldable, Traversable)
instance Binary (HieAST TypeIndex) where
put_ bh ast = do
put_ bh $ sourcedNodeInfo ast
put_ bh $ nodeSpan ast
put_ bh $ nodeChildren ast
get bh = Node
<$> get bh
<*> get bh
<*> get bh
instance Outputable a => Outputable (HieAST a) where
ppr (Node ni sp ch) = hang header 2 rest
where
header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
rest = vcat (map ppr ch)
newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) }
deriving (Functor, Foldable, Traversable)
instance Binary (SourcedNodeInfo TypeIndex) where
put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts
get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh)
instance Outputable a => Outputable (SourcedNodeInfo a) where
ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts
where
go k a rest = vcat $
[ "Source: " O.<> ppr k
, ppr a
, rest
]
data NodeOrigin
= SourceInfo
| GeneratedInfo
deriving (Eq, Enum, Ord)
instance Outputable NodeOrigin where
ppr SourceInfo = text "From source"
ppr GeneratedInfo = text "generated by ghc"
instance Binary NodeOrigin where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
data NodeInfo a = NodeInfo
{ nodeAnnotations :: S.Set (FastString,FastString)
, nodeType :: [a]
, nodeIdentifiers :: NodeIdentifiers a
} deriving (Functor, Foldable, Traversable)
instance Binary (NodeInfo TypeIndex) where
put_ bh ni = do
put_ bh $ S.toAscList $ nodeAnnotations ni
put_ bh $ nodeType ni
put_ bh $ M.toList $ nodeIdentifiers ni
get bh = NodeInfo
<$> fmap (S.fromDistinctAscList) (get bh)
<*> get bh
<*> fmap (M.fromList) (get bh)
instance Outputable a => Outputable (NodeInfo a) where
ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", "
[ parens (text "annotations:" <+> ppr anns)
, parens (text "types:" <+> ppr typs)
, parens (text "identifier info:" <+> pprNodeIdents idents)
]
pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc
pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni
where
go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id]
pprIdentifier :: Identifier -> SDoc
pprIdentifier (Left mod) = text "module" <+> ppr mod
pprIdentifier (Right name) = text "name" <+> ppr name
type Identifier = Either ModuleName Name
type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)
data IdentifierDetails a = IdentifierDetails
{ identType :: Maybe a
, identInfo :: S.Set ContextInfo
} deriving (Eq, Functor, Foldable, Traversable)
instance Outputable a => Outputable (IdentifierDetails a) where
ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x)
instance Semigroup (IdentifierDetails a) where
d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)
(S.union (identInfo d1) (identInfo d2))
instance Monoid (IdentifierDetails a) where
mempty = IdentifierDetails Nothing S.empty
instance Binary (IdentifierDetails TypeIndex) where
put_ bh dets = do
put_ bh $ identType dets
put_ bh $ S.toList $ identInfo dets
get bh = IdentifierDetails
<$> get bh
<*> fmap S.fromDistinctAscList (get bh)
data ContextInfo
= Use
| MatchBind
| IEThing IEType
| TyDecl
| ValBind
BindType
Scope
(Maybe Span)
| PatternBind
Scope
Scope
(Maybe Span)
| ClassTyDecl (Maybe Span)
| Decl
DeclType
(Maybe Span)
| TyVarBind Scope TyVarScope
| RecField RecFieldContext (Maybe Span)
| EvidenceVarBind
EvVarSource
Scope
(Maybe Span)
| EvidenceVarUse
deriving (Eq, Ord)
instance Outputable ContextInfo where
ppr (Use) = text "usage"
ppr (MatchBind) = text "LHS of a match group"
ppr (IEThing x) = ppr x
ppr (TyDecl) = text "bound in a type signature declaration"
ppr (ValBind t sc sp) =
ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp
ppr (PatternBind sc1 sc2 sp) =
text "bound in a pattern with scope:"
<+> ppr sc1 <+> "," <+> ppr sc2
<+> pprBindSpan sp
ppr (ClassTyDecl sp) =
text "bound in a class type declaration" <+> pprBindSpan sp
ppr (Decl d sp) =
text "declaration of" <+> ppr d <+> pprBindSpan sp
ppr (TyVarBind sc1 sc2) =
text "type variable binding with scope:"
<+> ppr sc1 <+> "," <+> ppr sc2
ppr (RecField ctx sp) =
text "record field" <+> ppr ctx <+> pprBindSpan sp
ppr (EvidenceVarBind ctx sc sp) =
text "evidence variable" <+> ppr ctx
$$ "with scope:" <+> ppr sc
$$ pprBindSpan sp
ppr (EvidenceVarUse) =
text "usage of evidence variable"
pprBindSpan :: Maybe Span -> SDoc
pprBindSpan Nothing = text ""
pprBindSpan (Just sp) = text "bound at:" <+> ppr sp
instance Binary ContextInfo where
put_ bh Use = putByte bh 0
put_ bh (IEThing t) = do
putByte bh 1
put_ bh t
put_ bh TyDecl = putByte bh 2
put_ bh (ValBind bt sc msp) = do
putByte bh 3
put_ bh bt
put_ bh sc
put_ bh msp
put_ bh (PatternBind a b c) = do
putByte bh 4
put_ bh a
put_ bh b
put_ bh c
put_ bh (ClassTyDecl sp) = do
putByte bh 5
put_ bh sp
put_ bh (Decl a b) = do
putByte bh 6
put_ bh a
put_ bh b
put_ bh (TyVarBind a b) = do
putByte bh 7
put_ bh a
put_ bh b
put_ bh (RecField a b) = do
putByte bh 8
put_ bh a
put_ bh b
put_ bh MatchBind = putByte bh 9
put_ bh (EvidenceVarBind a b c) = do
putByte bh 10
put_ bh a
put_ bh b
put_ bh c
put_ bh EvidenceVarUse = putByte bh 11
get bh = do
(t :: Word8) <- get bh
case t of
0 -> return Use
1 -> IEThing <$> get bh
2 -> return TyDecl
3 -> ValBind <$> get bh <*> get bh <*> get bh
4 -> PatternBind <$> get bh <*> get bh <*> get bh
5 -> ClassTyDecl <$> get bh
6 -> Decl <$> get bh <*> get bh
7 -> TyVarBind <$> get bh <*> get bh
8 -> RecField <$> get bh <*> get bh
9 -> return MatchBind
10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh
11 -> return EvidenceVarUse
_ -> panic "Binary ContextInfo: invalid tag"
data EvVarSource
= EvPatternBind
| EvSigBind
| EvWrapperBind
| EvImplicitBind
| EvInstBind { isSuperInst :: Bool, cls :: Name }
| EvLetBind EvBindDeps
deriving (Eq,Ord)
instance Binary EvVarSource where
put_ bh EvPatternBind = putByte bh 0
put_ bh EvSigBind = putByte bh 1
put_ bh EvWrapperBind = putByte bh 2
put_ bh EvImplicitBind = putByte bh 3
put_ bh (EvInstBind b cls) = do
putByte bh 4
put_ bh b
put_ bh cls
put_ bh (EvLetBind deps) = do
putByte bh 5
put_ bh deps
get bh = do
(t :: Word8) <- get bh
case t of
0 -> pure EvPatternBind
1 -> pure EvSigBind
2 -> pure EvWrapperBind
3 -> pure EvImplicitBind
4 -> EvInstBind <$> get bh <*> get bh
5 -> EvLetBind <$> get bh
_ -> panic "Binary EvVarSource: invalid tag"
instance Outputable EvVarSource where
ppr EvPatternBind = text "bound by a pattern"
ppr EvSigBind = text "bound by a type signature"
ppr EvWrapperBind = text "bound by a HsWrapper"
ppr EvImplicitBind = text "bound by an implicit variable binding"
ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls
ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls
ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
deriving Outputable
instance Eq EvBindDeps where
(==) = coerce ((==) `on` map toHieName)
instance Ord EvBindDeps where
compare = coerce (compare `on` map toHieName)
instance Binary EvBindDeps where
put_ bh (EvBindDeps xs) = put_ bh xs
get bh = EvBindDeps <$> get bh
data IEType
= Import
| ImportAs
| ImportHiding
| Export
deriving (Eq, Enum, Ord)
instance Outputable IEType where
ppr Import = text "import"
ppr ImportAs = text "import as"
ppr ImportHiding = text "import hiding"
ppr Export = text "export"
instance Binary IEType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
data RecFieldContext
= RecFieldDecl
| RecFieldAssign
| RecFieldMatch
| RecFieldOcc
deriving (Eq, Enum, Ord)
instance Outputable RecFieldContext where
ppr RecFieldDecl = text "declaration"
ppr RecFieldAssign = text "assignment"
ppr RecFieldMatch = text "pattern match"
ppr RecFieldOcc = text "occurence"
instance Binary RecFieldContext where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
data BindType
= RegularBind
| InstanceBind
deriving (Eq, Ord, Enum)
instance Outputable BindType where
ppr RegularBind = "regular"
ppr InstanceBind = "instance"
instance Binary BindType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
data DeclType
= FamDec
| SynDec
| DataDec
| ConDec
| PatSynDec
| ClassDec
| InstDec
deriving (Eq, Ord, Enum)
instance Outputable DeclType where
ppr FamDec = text "type or data family"
ppr SynDec = text "type synonym"
ppr DataDec = text "data"
ppr ConDec = text "constructor"
ppr PatSynDec = text "pattern synonym"
ppr ClassDec = text "class"
ppr InstDec = text "instance"
instance Binary DeclType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
data Scope
= NoScope
| LocalScope Span
| ModuleScope
deriving (Eq, Ord, Typeable, Data)
instance Outputable Scope where
ppr NoScope = text "NoScope"
ppr (LocalScope sp) = text "LocalScope" <+> ppr sp
ppr ModuleScope = text "ModuleScope"
instance Binary Scope where
put_ bh NoScope = putByte bh 0
put_ bh (LocalScope span) = do
putByte bh 1
put_ bh span
put_ bh ModuleScope = putByte bh 2
get bh = do
(t :: Word8) <- get bh
case t of
0 -> return NoScope
1 -> LocalScope <$> get bh
2 -> return ModuleScope
_ -> panic "Binary Scope: invalid tag"
data TyVarScope
= ResolvedScopes [Scope]
| UnresolvedScope
[Name]
(Maybe Span)
deriving (Eq, Ord)
instance Outputable TyVarScope where
ppr (ResolvedScopes xs) =
text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs)
ppr (UnresolvedScope ns sp) =
text "unresolved type variable scope for name" O.<> plural ns
<+> pprBindSpan sp
instance Binary TyVarScope where
put_ bh (ResolvedScopes xs) = do
putByte bh 0
put_ bh xs
put_ bh (UnresolvedScope ns span) = do
putByte bh 1
put_ bh ns
put_ bh span
get bh = do
(t :: Word8) <- get bh
case t of
0 -> ResolvedScopes <$> get bh
1 -> UnresolvedScope <$> get bh <*> get bh
_ -> panic "Binary TyVarScope: invalid tag"
data HieName
= ExternalName !Module !OccName !SrcSpan
| LocalName !OccName !SrcSpan
| KnownKeyName !Unique
deriving (Eq)
instance Ord HieName where
compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f
compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d
compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
compare ExternalName{} _ = LT
compare LocalName{} ExternalName{} = GT
compare LocalName{} _ = LT
compare KnownKeyName{} _ = GT
instance Outputable HieName where
ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
hieNameOcc :: HieName -> OccName
hieNameOcc (ExternalName _ occ _) = occ
hieNameOcc (LocalName occ _) = occ
hieNameOcc (KnownKeyName u) =
case lookupKnownKeyName u of
Just n -> nameOccName n
Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
(ppr (unpkUnique u))
toHieName :: Name -> HieName
toHieName name
| isKnownKeyName name = KnownKeyName (nameUnique name)
| isExternalName name = ExternalName (nameModule name)
(nameOccName name)
(nameSrcSpan name)
| otherwise = LocalName (nameOccName name) (nameSrcSpan name)