+mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
+-- Make the ModIface for a hi-boot file
+-- The decls are of very limited form
+mkBootIface mod decls
+ = (emptyModIface opt_InPackage mod) {
+ mi_boot = True,
+ mi_exports = [(mod, map mk_export decls')],
+ mi_decls = decls_w_vers,
+ mi_ver_fn = mkIfaceVerCache decls_w_vers }
+ where
+ decls' = map hsIfaceDecl decls
+ decls_w_vers = repeat initialVersion `zip` decls'
+
+ -- hi-boot declarations don't (currently)
+ -- expose constructors or class methods
+ mk_export decl | isValOcc occ = Avail occ
+ | otherwise = AvailTC occ [occ]
+ where
+ occ = ifName decl
+
+
+hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
+ -- Change to Iface syntax, and replace unqualified names with
+ -- qualified Orig names from this module. Reason: normal
+ -- iface files have everything fully qualified, so it's convenient
+ -- for hi-boot files to look the same
+ --
+ -- NB: no constructors or class ops to worry about
+hsIfaceDecl (SigD (Sig name ty))
+ = IfaceId { ifName = rdrNameOcc (unLoc name),
+ ifType = hsIfaceLType ty,
+ ifIdInfo = NoInfo }
+
+hsIfaceDecl (TyClD decl@(TySynonym {}))
+ = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifSynRhs = hsIfaceLType (tcdSynRhs decl),
+ ifVrcs = [] }
+
+hsIfaceDecl (TyClD decl@(TyData {}))
+ = IfaceData { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
+ ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
+ ifRec = NonRecursive,
+ ifVrcs = [], ifGeneric = False }
+ -- I'm not sure that [] is right for ifVrcs, but
+ -- since we don't use them I'm not going to fiddle
+
+hsIfaceDecl (TyClD decl@(ClassDecl {}))
+ = IfaceClass { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
+ ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
+ ifSigs = [], -- Is this right??
+ ifRec = NonRecursive, ifVrcs = [] }
+
+hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
+
+hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
+hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
+ = IfAbstractTyCon -- not "no constructors"
+
+hsIfaceCons DataType cons -- data type
+ = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
+
+hsIfaceCons NewType [con] -- newtype
+ = IfNewTyCon (hsIfaceCon (unLoc con))
+
+
+hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
+hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
+ = IfaceConDecl (get_occ lname) is_infix
+ (hsIfaceTvs ex_tvs)
+ (hsIfaceCtxt (unLoc ex_ctxt))
+ (map (hsIfaceLType . getBangType . unLoc) args)
+ (map (hsStrictMark . getBangStrictness . unLoc) args)
+ flds
+ where
+ (is_infix, args, flds) = case details of
+ PrefixCon args -> (False, args, [])
+ InfixCon a1 a2 -> (True, [a1,a2], [])
+ RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
+ get_occ lname = rdrNameOcc (unLoc lname)
+
+hsStrictMark :: HsBang -> StrictnessMark
+-- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
+-- but in an hi-boot file it's interpreted as the Truth!
+hsStrictMark HsNoBang = NotMarkedStrict
+hsStrictMark HsStrict = MarkedStrict
+hsStrictMark HsUnbox = MarkedUnboxed
+
+hsIfaceName rdr_name -- Qualify unqualifed occurrences
+ -- with the module name
+ | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
+ | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+hsIfaceLType :: LHsType RdrName -> IfaceType
+hsIfaceLType = hsIfaceType . unLoc
+
+hsIfaceType :: HsType RdrName -> IfaceType
+hsIfaceType (HsForAllTy exp tvs cxt ty)
+ = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
+ where
+ rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
+ tau = hsIfaceLType ty
+ tvs' = case exp of
+ Explicit -> map unLoc tvs
+ Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
+
+hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
+hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
+hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
+hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
+hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
+hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
+hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
+hsIfaceType (HsParTy t) = hsIfaceLType t
+hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
+hsIfaceType (HsKindSig t _) = hsIfaceLType t
+hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
+hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
+
+-----------
+hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
+
+-----------
+hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
+hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
+
+-----------
+hsIfaceLPred :: LHsPred RdrName -> IfacePredType
+hsIfaceLPred = hsIfacePred . unLoc
+
+hsIfacePred :: HsPred RdrName -> IfacePredType
+hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
+hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
+
+-----------
+hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
+hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
+hs_tc_app (HsTyVar n) args
+ | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
+ | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
+hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
+
+-----------
+hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
+
+-----------
+hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
+hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
+
+-----------
+hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
+hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
+ | (xs,ys) <- fds ]