module HieTypes where
import GhcPrelude
import Config
import Binary
import FastString ( FastString )
import IfaceType
import Module ( ModuleName, Module )
import Name ( Name )
import Outputable hiding ( (<>) )
import SrcLoc ( RealSrcSpan )
import Avail
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 ( (<|>) )
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
| 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 a b) = do
putByte bh 4
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
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)
data HieAST a =
Node
{ nodeInfo :: NodeInfo a
, nodeSpan :: Span
, nodeChildren :: [HieAST a]
} deriving (Functor, Foldable, Traversable)
instance Binary (HieAST TypeIndex) where
put_ bh ast = do
put_ bh $ nodeInfo ast
put_ bh $ nodeSpan ast
put_ bh $ nodeChildren ast
get bh = Node
<$> get bh
<*> get bh
<*> get bh
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)
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 "IdentifierDetails" <+> 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.toAscList $ 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)
deriving (Eq, Ord, Show)
instance Outputable ContextInfo where
ppr = text . show
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
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
_ -> panic "Binary ContextInfo: invalid tag"
data IEType
= Import
| ImportAs
| ImportHiding
| Export
deriving (Eq, Enum, Ord, Show)
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, Show)
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, Show, Enum)
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, Show, Enum)
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, Show, 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 Show TyVarScope where
show (ResolvedScopes sc) = show sc
show _ = error "UnresolvedScope"
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"