Type checking of type signatures in interface files
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
import NameEnv
import OccName
import Module
-import UniqFM
+import LazyUniqFM
import UniqSupply
import Outputable
import ErrUtils
import Maybes
import SrcLoc
import DynFlags
-import Control.Monad
+import Util
+import FastString
+import BasicTypes (Arity)
+import Control.Monad
import Data.List
import Data.Maybe
\end{code}
An IfaceDecl is populated with RdrNames, and these are not renamed to
Names before typechecking, because there should be no scope errors etc.
- -- For (b) consider: f = $(...h....)
+ -- For (b) consider: f = \$(...h....)
-- where h is imported, and calls f via an hi-boot file.
-- This is bad! But it is not seen as a staging error, because h
-- is indeed imported. We don't want the type-checker to black-hole
; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
; case mb_iface of {
Failed err_msg -> return (Failed err_msg) ;
- Succeeded iface -> do
+ Succeeded _ -> do
-- Now look it up again; this time we should find it
{ eps <- getEps
Nothing -> return (Failed not_found_msg)
}}}
where
- nd_doc = ptext SLIT("Need decl for") <+> ppr name
- not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+>
+ nd_doc = ptext (sLit "Need decl for") <+> ppr name
+ not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
- 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
- ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
+ 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
\end{code}
%************************************************************************
; case lookupUFM hpt (moduleName mod) of
Just info | mi_boot (hm_iface info)
-> return (hm_details info)
- other -> return emptyModDetails }
+ _ -> return emptyModDetails }
else do
-- OK, so we're in one-shot mode.
Succeeded (iface, _path) -> typecheckIface iface
}}}}
where
- need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
- <+> ptext SLIT("to compare against the Real Thing")
+ need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod
+ <+> ptext (sLit "to compare against the Real Thing")
- moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
- <+> ptext SLIT("depends on itself")
+ moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod)
+ <+> ptext (sLit "depends on itself")
- elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+>
+ elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+>
quotes (ppr mod) <> colon) 4 err
\end{code}
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
; info <- tcIdInfo ignore_prags name ty info
- ; return (AnId (mkVanillaGlobal name ty info)) }
-
-tcIfaceDecl ignore_prags
- (IfaceData {ifName = occ_name,
- ifTyVars = tv_bndrs,
- ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
- ifCons = rdr_cons,
- ifRec = is_rec,
- ifGeneric = want_generic,
- ifFamInst = mb_family })
+ ; return (AnId (mkVanillaGlobalWithInfo name ty info)) }
+
+tcIfaceDecl _ (IfaceData {ifName = occ_name,
+ ifTyVars = tv_bndrs,
+ ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+ ifCons = rdr_cons,
+ ifRec = is_rec,
+ ifGeneric = want_generic,
+ ifFamInst = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
; return (ATyCon tycon)
}}
-tcIfaceDecl ignore_prags
- (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
- ifFamInst = mb_family})
+tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifSynRhs = mb_rhs_ty,
+ ifSynKind = kind, ifFamInst = mb_family})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_tyki <- tcIfaceType rdr_rhs_ty
- ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
- else SynonymTyCon rhs_tyki
- ; famInst <- case mb_family of
- Nothing -> return Nothing
- Just (fam, tys) ->
- do { famTyCon <- tcIfaceTyCon fam
- ; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys)
- }
- ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
+ ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
+ ; ~(rhs, fam) <- forkM (mk_doc tc_name) $
+ do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
+ ; fam <- tc_syn_fam mb_family
+ ; return (rhs, fam) }
+ ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
; return $ ATyCon tycon
}
+ where
+ mk_doc n = ptext (sLit "Type syonym") <+> ppr n
+ tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing)
+ tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty
+ ; return (SynonymTyCon rhs_ty) }
+ tc_syn_fam Nothing
+ = return Nothing
+ tc_syn_fam (Just (fam, tys))
+ = do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys) }
tcIfaceDecl ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ cls_name <- lookupIfaceTop occ_name
; ctxt <- tcIfaceCtxt rdr_ctxt
- ; sigs <- mappM tc_sig rdr_sigs
- ; fds <- mappM tc_fd rdr_fds
- ; ats' <- mappM (tcIfaceDecl ignore_prags) rdr_ats
+ ; sigs <- mapM tc_sig rdr_sigs
+ ; fds <- mapM tc_fd rdr_fds
+ ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
- ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec
+ ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
-- it mentions unless it's necessray to do so
; return (op_name, dm, op_ty) }
- mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
+ mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
- tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
- ; tvs2' <- mappM tcIfaceTyVar tvs2
+ tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
+ ; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
-- For each AT argument compute the position of the corresponding class
ATyCon (setTyConArgPoss tycon poss)
setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
-tcIfaceDecl ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
-tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
+tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon _ if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
IfOpenDataTyCon -> return mkOpenDataTyConRhs
- IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
+ IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
; mkNewTyConRhs tycon_name tycon data_con }
-- Read the argument types, but lazily to avoid faulting in
-- the component types unless they are really needed
- ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
- ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
+ ; lbl_names <- mapM lookupIfaceTop field_lbls
; buildDataCon name is_infix {- Not infix -}
stricts lbl_names
eq_spec theta
arg_tys tycon
}
- mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
+ mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
+tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
tcIfaceEqSpec spec
= mapM do_item spec
where
; return (tv,ty) }
\end{code}
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff). To see why,
+consider this (Trac #2412)
+
+M.hs: module M where { import X; data T = MkT S }
+X.hs: module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot: module M where { data T }
+
+When kind-checking M.hs we need S's kind. But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet! Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
%************************************************************************
%* *
\begin{code}
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
- ifInstCls = cls, ifInstTys = mb_tcs,
- ifInstOrph = orph })
- = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $
+ ifInstCls = cls, ifInstTys = mb_tcs })
+ = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedInstance cls mb_tcs' dfun oflag) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
ifFamInstFam = fam, ifFamInstTys = mb_tcs })
--- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $
--- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil!
- = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
- tcIfaceTyCon tycon
- ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
- ; return (mkImportedFamInst fam mb_tcs' tycon') }
+-- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
+-- the above line doesn't work, but this below does => CPP in Haskell = evil!
+ = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
+ tcIfaceTyCon tycon
+ let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ return (mkImportedFamInst fam mb_tcs' tycon')
\end{code}
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
- ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
- ifRuleOrph = orph })
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= do { ~(bndrs', args', rhs') <-
-- Typecheck the payload lazily, in the hope it'll never be looked at
- forkM (ptext SLIT("Rule") <+> ftext name) $
+ forkM (ptext (sLit "Rule") <+> ftext name) $
bindIfaceBndrs bndrs $ \ bndrs' ->
- do { args' <- mappM tcIfaceExpr args
+ do { args' <- mapM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
; return (bndrs', args', rhs') }
; let mb_tcs = map ifTopFreeName args
- ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act,
+ ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs', ru_args = args',
ru_rhs = rhs',
ru_rough = mb_tcs,
-- to write them out in coreRuleToIfaceRule
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
- ifTopFreeName (IfaceApp f a) = ifTopFreeName f
+ ifTopFreeName (IfaceApp f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
- ifTopFreeName other = Nothing
+ ifTopFreeName _ = Nothing
\end{code}
})
= do { vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
- ; tyConRes2 <- mapM vectTyConReuseMapping tycons
+ ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse
; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoVar = mkVarEnv vVars
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceTypes :: [IfaceType] -> IfL [Type]
tcIfaceTypes tys = mapM tcIfaceType tys
-----------------------------------------
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mappM tcIfacePredType sts
+tcIfaceCtxt sts = mapM tcIfacePredType sts
\end{code}
\begin{code}
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
- = tcIfaceType ty `thenM` \ ty' ->
- returnM (Type ty')
+ = Type <$> tcIfaceType ty
tcIfaceExpr (IfaceLcl name)
- = tcIfaceLclId name `thenM` \ id ->
- returnM (Var id)
+ = Var <$> tcIfaceLclId name
tcIfaceExpr (IfaceTick modName tickNo)
- = tcIfaceTick modName tickNo `thenM` \ id ->
- returnM (Var id)
+ = Var <$> tcIfaceTick modName tickNo
tcIfaceExpr (IfaceExt gbl)
- = tcIfaceExtId gbl `thenM` \ id ->
- returnM (Var id)
+ = Var <$> tcIfaceExtId gbl
tcIfaceExpr (IfaceLit lit)
- = returnM (Lit lit)
-
-tcIfaceExpr (IfaceFCall cc ty)
- = tcIfaceType ty `thenM` \ ty' ->
- newUnique `thenM` \ u ->
- returnM (Var (mkFCallId u cc ty'))
-
-tcIfaceExpr (IfaceTuple boxity args)
- = mappM tcIfaceExpr args `thenM` \ args' ->
- let
- -- Put the missing type arguments back in
- con_args = map (Type . exprType) args' ++ args'
- in
- returnM (mkApps (Var con_id) con_args)
+ = return (Lit lit)
+
+tcIfaceExpr (IfaceFCall cc ty) = do
+ ty' <- tcIfaceType ty
+ u <- newUnique
+ return (Var (mkFCallId u cc ty'))
+
+tcIfaceExpr (IfaceTuple boxity args) = do
+ args' <- mapM tcIfaceExpr args
+ -- Put the missing type arguments back in
+ let con_args = map (Type . exprType) args' ++ args'
+ return (mkApps (Var con_id) con_args)
where
arity = length args
con_id = dataConWorkId (tupleCon boxity arity)
tcIfaceExpr (IfaceLam bndr body)
- = bindIfaceBndr bndr $ \ bndr' ->
- tcIfaceExpr body `thenM` \ body' ->
- returnM (Lam bndr' body')
+ = bindIfaceBndr bndr $ \bndr' ->
+ Lam bndr' <$> tcIfaceExpr body
tcIfaceExpr (IfaceApp fun arg)
- = tcIfaceExpr fun `thenM` \ fun' ->
- tcIfaceExpr arg `thenM` \ arg' ->
- returnM (App fun' arg')
+ = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
-tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
- = tcIfaceExpr scrut `thenM` \ scrut' ->
- newIfaceName (mkVarOccFS case_bndr) `thenM` \ case_bndr_name ->
+tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do
+ scrut' <- tcIfaceExpr scrut
+ case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
scrut_ty = exprType scrut'
case_bndr' = mkLocalId case_bndr_name scrut_ty
-- NB: not tcSplitTyConApp; we are looking at Core here
-- look through non-rec newtypes to find the tycon that
-- corresponds to the datacon in this case alternative
- in
- extendIfaceIdEnv [case_bndr'] $
- mappM (tcIfaceAlt scrut' tc_app) alts `thenM` \ alts' ->
- tcIfaceType ty `thenM` \ ty' ->
- returnM (Case scrut' case_bndr' ty' alts')
-tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
- = do { rhs' <- tcIfaceExpr rhs
- ; id <- tcIfaceLetBndr bndr
- ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
- ; return (Let (NonRec id rhs') body') }
-
-tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
- = do { ids <- mapM tcIfaceLetBndr bndrs
- ; extendIfaceIdEnv ids $ do
- { rhss' <- mapM tcIfaceExpr rhss
- ; body' <- tcIfaceExpr body
- ; return (Let (Rec (ids `zip` rhss')) body') } }
+ extendIfaceIdEnv [case_bndr'] $ do
+ alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
+ ty' <- tcIfaceType ty
+ return (Case scrut' case_bndr' ty' alts')
+
+tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = do
+ rhs' <- tcIfaceExpr rhs
+ id <- tcIfaceLetBndr bndr
+ body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
+ return (Let (NonRec id rhs') body')
+
+tcIfaceExpr (IfaceLet (IfaceRec pairs) body) = do
+ ids <- mapM tcIfaceLetBndr bndrs
+ extendIfaceIdEnv ids $ do
+ rhss' <- mapM tcIfaceExpr rhss
+ body' <- tcIfaceExpr body
+ return (Let (Rec (ids `zip` rhss')) body')
where
(bndrs, rhss) = unzip pairs
tcIfaceExpr (IfaceCast expr co) = do
- expr' <- tcIfaceExpr expr
- co' <- tcIfaceType co
- returnM (Cast expr' co')
+ expr' <- tcIfaceExpr expr
+ co' <- tcIfaceType co
+ return (Cast expr' co')
-tcIfaceExpr (IfaceNote note expr)
- = tcIfaceExpr expr `thenM` \ expr' ->
+tcIfaceExpr (IfaceNote note expr) = do
+ expr' <- tcIfaceExpr expr
case note of
- IfaceInlineMe -> returnM (Note InlineMe expr')
- IfaceSCC cc -> returnM (Note (SCC cc) expr')
- IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
+ IfaceInlineMe -> return (Note InlineMe expr')
+ IfaceSCC cc -> return (Note (SCC cc) expr')
+ IfaceCoreNote n -> return (Note (CoreNote n) expr')
-------------------------
+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
+ -> (IfaceConAlt, [FastString], IfaceExpr)
+ -> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceAlt _ _ (IfaceDefault, names, rhs)
- = ASSERT( null names )
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DEFAULT, [], rhs')
+ = ASSERT( null names ) do
+ rhs' <- tcIfaceExpr rhs
+ return (DEFAULT, [], rhs')
tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
- = ASSERT( null names )
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (LitAlt lit, [], rhs')
+ = ASSERT( null names ) do
+ rhs' <- tcIfaceExpr rhs
+ return (LitAlt lit, [], rhs')
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
= do { con <- tcIfaceDataCon data_occ
-#ifdef DEBUG
- ; ifM (not (con `elem` tyConDataCons tycon))
- (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
-#endif
+ ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
+ (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt con inst_tys arg_strs rhs }
-tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
+tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
= ASSERT( isTupleTyCon tycon )
do { let [data_con] = tyConDataCons tycon
; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
+tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
+ -> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceDataAlt con inst_tys arg_strs rhs
= do { us <- newUniqueSupply
; let uniqs = uniqsFromSupply us
; return (NonRec bndr' rhs' : core_binds) }}
do_one (IfaceRec pairs) thing_inside
- = do { bndrs' <- mappM newExtCoreBndr bndrs
+ = do { bndrs' <- mapM newExtCoreBndr bndrs
; extendIfaceIdEnv bndrs' $ do
- { rhss' <- mappM tcIfaceExpr rhss
+ { rhss' <- mapM tcIfaceExpr rhss
; core_binds <- thing_inside
; return (Rec (bndrs' `zip` rhss') : core_binds) }}
where
-- we start; default assumption is that it has CAFs
init_info = vanillaIdInfo
- tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
- tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
- tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str)
+ tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
+ tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
+ tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str)
-- The next two are lazy, so they don't transitively suck stuff in
tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
- tcPrag info (HsInline inline_prag) = returnM (info `setInlinePragInfo` inline_prag)
- tcPrag info (HsUnfold expr)
- = tcPragExpr name expr `thenM` \ maybe_expr' ->
+ tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag)
+ tcPrag info (HsUnfold expr) = do
+ maybe_expr' <- tcPragExpr name expr
let
-- maybe_expr' doesn't get looked at if the unfolding
-- is never inspected; so the typecheck doesn't even happen
unfold_info = case maybe_expr' of
Nothing -> noUnfolding
Just expr' -> mkTopUnfolding expr'
- in
- returnM (info `setUnfoldingInfoLazily` unfold_info)
+ return (info `setUnfoldingInfoLazily` unfold_info)
\end{code}
\begin{code}
+tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo
tcWorkerInfo ty info wkr arity
= do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
-- over the unfolding until it's actually used does seem worth while.)
; us <- newUniqueSupply
- ; returnM (case mb_wkr_id of
+ ; return (case mb_wkr_id of
Nothing -> info
Just wkr_id -> add_wkr_info us wkr_id info) }
where
\begin{code}
tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr name expr
- = forkM_maybe doc $
- tcIfaceExpr expr `thenM` \ core_expr' ->
-
- -- Check for type consistency in the unfolding
- ifOptM Opt_DoCoreLinting (
- get_in_scope_ids `thenM` \ in_scope ->
- case lintUnfolding noSrcLoc in_scope core_expr' of
- Nothing -> returnM ()
- Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)
- ) `thenM_`
-
- returnM core_expr'
+ = forkM_maybe doc $ do
+ core_expr' <- tcIfaceExpr expr
+
+ -- Check for type consistency in the unfolding
+ ifOptM Opt_DoCoreLinting $ do
+ in_scope <- get_in_scope_ids
+ case lintUnfolding noSrcLoc in_scope core_expr' of
+ Nothing -> return ()
+ Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)
+
+ return core_expr'
where
doc = text "Unfolding of" <+> ppr name
get_in_scope_ids -- Urgh; but just for linting
{ type_env <- setLclEnv () get_type_env -- yuk
; case lookupNameEnv type_env name of
Just thing -> return thing
- Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
+ Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
(ppr name $$ ppr type_env) }
- ; other -> do
+ ; _ -> do
- { (eps,hpt) <- getEpsAndHpt
- ; dflags <- getDOpts
- ; case lookupType dflags hpt (eps_PTE eps) name of {
+ { hsc_env <- getTopEnv
+ ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+ ; case mb_thing of {
Just thing -> return thing ;
Nothing -> do
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
; return (check_tc (tyThingTyCon thing)) }
where
-#ifdef DEBUG
- check_tc tc = case toIfaceTyCon tc of
- IfaceTc _ -> tc
- other -> pprTrace "check_tc" (ppr tc) tc
-#else
- check_tc tc = tc
-#endif
+ check_tc tc
+ | debugIsOn = case toIfaceTyCon tc of
+ IfaceTc _ -> tc
+ _ -> pprTrace "check_tc" (ppr tc) tc
+ | otherwise = tc
-- we should be okay just returning Kind constructors without extra loading
tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon
tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
ADataCon dc -> return dc
- other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+ _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
; case thing of
AnId id -> return id
- other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
+ _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
\end{code}
%************************************************************************
thing_inside (b':bs')
-----------------------
+tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
tcIfaceLetBndr (IfLetBndr fs ty info)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
-----------------------
newExtCoreBndr :: IfaceLetBndr -> IfL Id
-newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now
+newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now
= do { mod <- getIfModule
; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
; ty' <- tcIfaceType ty
-----------------------
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
- = do { name <- newIfaceName (mkTyVarOcc occ)
+ = do { name <- newIfaceName (mkTyVarOccFS occ)
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars bndrs thing_inside
- = do { names <- newIfaceNames (map mkTyVarOcc occs)
- ; tyvars <- TcRnMonad.zipWithM mk_iface_tyvar names kinds
+ = do { names <- newIfaceNames (map mkTyVarOccFS occs)
+ ; tyvars <- zipWithM mk_iface_tyvar names kinds
; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
where
(occs,kinds) = unzip bndrs
projects / ghc-hetmet.git / blobdiff