module TcRnExports (tcRnExports, exports_from_avail) where
import GhcPrelude
import HsSyn
import PrelNames
import RdrName
import TcRnMonad
import TcEnv
import TcType
import RnNames
import RnEnv
import RnUnbound ( reportUnboundName )
import ErrUtils
import Id
import IdInfo
import Module
import Name
import NameEnv
import NameSet
import Avail
import TyCon
import SrcLoc
import HscTypes
import Outputable
import ConLike
import DataCon
import PatSyn
import Maybes
import Util (capitalise)
import Control.Monad
import DynFlags
import RnHsDoc ( rnHsDoc )
import RdrHsSyn ( setRdrNameSpace )
import Data.Either ( partitionEithers )
data ExportAccum
= ExportAccum
[(LIE GhcRn, Avails)]
ExportOccMap
emptyExportAccum :: ExportAccum
emptyExportAccum = ExportAccum [] emptyOccEnv
type ExportOccMap = OccEnv (Name, IE GhcPs)
tcRnExports :: Bool
-> Maybe (Located [LIE GhcPs])
-> TcGblEnv
-> RnM TcGblEnv
tcRnExports explicit_mod exports
tcg_env@TcGblEnv { tcg_mod = this_mod,
tcg_rdr_env = rdr_env,
tcg_imports = imports,
tcg_src = hsc_src }
= unsetWOptM Opt_WarnWarningsDeprecations $
do {
; dflags <- getDynFlags
; let real_exports
| explicit_mod = exports
| ghcLink dflags == LinkInMemory = Nothing
| otherwise
= Just (noLoc [noLoc (IEVar noExt
(noLoc (IEName $ noLoc main_RDR_Unqual)))])
; let do_it = exports_from_avail real_exports rdr_env imports this_mod
; (rn_exports, final_avails)
<- if hsc_src == HsigFile
then do (msgs, mb_r) <- tryTc do_it
case mb_r of
Just r -> return r
Nothing -> addMessages msgs >> failM
else checkNoErrs do_it
; let final_ns = availsToNameSetWithSelectors final_avails
; traceRn "rnExports: Exports:" (ppr final_avails)
; let new_tcg_env =
tcg_env { tcg_exports = final_avails,
tcg_rn_exports = case tcg_rn_exports tcg_env of
Nothing -> Nothing
Just _ -> rn_exports,
tcg_dus = tcg_dus tcg_env `plusDU`
usesOnly final_ns }
; failIfErrsM
; return new_tcg_env }
exports_from_avail :: Maybe (Located [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
exports_from_avail Nothing rdr_env _imports _this_mod
= do {
; warnMissingExportList <- woptM Opt_WarnMissingExportList
; warnIfFlag Opt_WarnMissingExportList
warnMissingExportList
(missingModuleExportWarn $ moduleName _this_mod)
; let avails =
map fix_faminst . gresToAvailInfo
. filter isLocalGRE . globalRdrEnvElts $ rdr_env
; return (Nothing, avails) }
where
fix_faminst (AvailTC n ns flds) =
let new_ns =
case ns of
[] -> [n]
(p:_) -> if p == n then ns else n:ns
in AvailTC n new_ns flds
fix_faminst avail = avail
exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= do ExportAccum ie_avails _
<- foldAndRecoverM do_litem emptyExportAccum rdr_items
let final_exports = nubAvails (concat (map snd ie_avails))
return (Just ie_avails, final_exports)
where
do_litem :: ExportAccum -> LIE GhcPs -> RnM ExportAccum
do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
kids_env :: NameEnv [GlobalRdrElt]
kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
imported_modules = [ imv_name imv
| xs <- moduleEnvElts $ imp_mods imports
, imv <- importedByUser xs ]
exports_from_item :: ExportAccum -> LIE GhcPs -> RnM ExportAccum
exports_from_item acc@(ExportAccum ie_avails occs)
(L loc ie@(IEModuleContents _ (L lm mod)))
| let earlier_mods
= [ mod
| ((L _ (IEModuleContents _ (L _ mod))), _) <- ie_avails ]
, mod `elem` earlier_mods
= do { warnIfFlag Opt_WarnDuplicateExports True
(dupModuleExport mod) ;
return acc }
| otherwise
= do { let { exportValid = (mod `elem` imported_modules)
|| (moduleName this_mod == mod)
; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
; new_exports = map (availFromGRE . fst) gre_prs
; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
}
; checkErr exportValid (moduleNotImported mod)
; warnIfFlag Opt_WarnDodgyExports
(exportValid && null gre_prs)
(nullModuleExport mod)
; traceRn "efa" (ppr mod $$ ppr all_gres)
; addUsedGREs all_gres
; occs' <- check_occs ie occs new_exports
; traceRn "export_mod"
(vcat [ ppr mod
, ppr new_exports ])
; return (ExportAccum (((L loc (IEModuleContents noExt (L lm mod)))
, new_exports) : ie_avails) occs') }
exports_from_item acc@(ExportAccum lie_avails occs) (L loc ie)
| isDoc ie
= do new_ie <- lookup_doc_ie ie
return (ExportAccum ((L loc new_ie, []) : lie_avails) occs)
| otherwise
= do (new_ie, avail) <-
setSrcSpan loc $ lookup_ie ie
if isUnboundName (ieName new_ie)
then return acc
else do
occs' <- check_occs ie occs [avail]
return (ExportAccum ((L loc new_ie, [avail]) : lie_avails) occs')
lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
lookup_ie (IEVar _ (L l rdr))
= do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
return (IEVar noExt (L l (replaceWrappedName rdr name)), avail)
lookup_ie (IEThingAbs _ (L l rdr))
= do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
return (IEThingAbs noExt (L l (replaceWrappedName rdr name))
, avail)
lookup_ie ie@(IEThingAll _ n')
= do
(n, avail, flds) <- lookup_ie_all ie n'
let name = unLoc n
return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))
, AvailTC name (name:avail) flds)
lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)
= do
(lname, subs, avails, flds)
<- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
(_, all_avail, all_flds) <-
case wc of
NoIEWildcard -> return (lname, [], [])
IEWildcard _ -> lookup_ie_all ie l
let name = unLoc lname
return (IEThingWith noExt (replaceLWrappedName l name) wc subs
(flds ++ (map noLoc all_flds)),
AvailTC name (name : avails ++ all_avail)
(map unLoc flds ++ all_flds))
lookup_ie _ = panic "lookup_ie"
lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
-> RnM (Located Name, [LIEWrappedName Name], [Name],
[Located FieldLabel])
lookup_ie_with (L l rdr) sub_rdrs
= do name <- lookupGlobalOccRn $ ieWrappedName rdr
(non_flds, flds) <- lookupChildrenExport name sub_rdrs
if isUnboundName name
then return (L l name, [], [name], [])
else return (L l name, non_flds
, map (ieWrappedName . unLoc) non_flds
, flds)
lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName
-> RnM (Located Name, [Name], [FieldLabel])
lookup_ie_all ie (L l rdr) =
do name <- lookupGlobalOccRn $ ieWrappedName rdr
let gres = findChildren kids_env name
(non_flds, flds) = classifyGREs gres
addUsedKids (ieWrappedName rdr) gres
warnDodgyExports <- woptM Opt_WarnDodgyExports
when (null gres) $
if isTyConName name
then when warnDodgyExports $
addWarn (Reason Opt_WarnDodgyExports)
(dodgyExportWarn name)
else
addErr (exportItemErr ie)
return (L l name, non_flds, flds)
lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)
lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc
return (IEGroup noExt lev rn_doc)
lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc
return (IEDoc noExt rn_doc)
lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExt str)
lookup_doc_ie _ = panic "lookup_doc_ie"
addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
classifyGREs = partitionEithers . map classifyGRE
classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
classifyGRE gre = case gre_par gre of
FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
_ -> Left n
where
n = gre_name gre
isDoc :: IE GhcPs -> Bool
isDoc (IEDoc {}) = True
isDoc (IEDocNamed {}) = True
isDoc (IEGroup {}) = True
isDoc _ = False
lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
-> RnM ([LIEWrappedName Name], [Located FieldLabel])
lookupChildrenExport spec_parent rdr_items =
do
xs <- mapAndReportM doOne rdr_items
return $ partitionEithers xs
where
choosePossibleNamespaces :: NameSpace -> [NameSpace]
choosePossibleNamespaces ns
| ns == varName = [varName, tcName]
| ns == tcName = [dataName, tcName]
| otherwise = [ns]
doOne :: LIEWrappedName RdrName
-> RnM (Either (LIEWrappedName Name) (Located FieldLabel))
doOne n = do
let bareName = (ieWrappedName . unLoc) n
lkup v = lookupSubBndrOcc_helper False True
spec_parent (setRdrNameSpace bareName v)
name <- combineChildLookupResult $ map lkup $
choosePossibleNamespaces (rdrNameSpace bareName)
traceRn "lookupChildrenExport" (ppr name)
let unboundName :: RdrName
unboundName = if rdrNameSpace bareName == varName
then bareName
else setRdrNameSpace bareName dataName
case name of
NameNotFound -> do { ub <- reportUnboundName unboundName
; let l = getLoc n
; return (Left (L l (IEName (L l ub))))}
FoundFL fls -> return $ Right (L (getLoc n) fls)
FoundName par name -> do { checkPatSynParent spec_parent par name
; return $ Left (replaceLWrappedName n name) }
IncorrectParent p g td gs -> failWithDcErr p g td gs
checkPatSynParent :: Name
-> Parent
-> Name
-> TcM ()
checkPatSynParent _ (ParentIs {}) _
= return ()
checkPatSynParent _ (FldParent {}) _
= return ()
checkPatSynParent parent NoParent mpat_syn
| isUnboundName parent
= return ()
| otherwise
= do { parent_ty_con <- tcLookupTyCon parent
; mpat_syn_thing <- tcLookupGlobal mpat_syn
; case mpat_syn_thing of
AnId i | isId i
, RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
-> handle_pat_syn (selErr i) parent_ty_con p
AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
_ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }
where
psErr = exportErrCtxt "pattern synonym"
selErr = exportErrCtxt "pattern synonym record selector"
assocClassErr :: SDoc
assocClassErr = text "Pattern synonyms can be bundled only with datatypes."
handle_pat_syn :: SDoc
-> TyCon
-> PatSyn
-> TcM ()
handle_pat_syn doc ty_con pat_syn
| not $ isTyConWithSrcDataCons ty_con
= addErrCtxt doc $ failWithTc assocClassErr
| Nothing <- mtycon
= return ()
| Just p_ty_con <- mtycon, p_ty_con /= ty_con
= addErrCtxt doc $ failWithTc typeMismatchError
| otherwise
= return ()
where
expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
(_, _, _, _, _, res_ty) = patSynSig pat_syn
mtycon = fst <$> tcSplitTyConApp_maybe res_ty
typeMismatchError :: SDoc
typeMismatchError =
text "Pattern synonyms can only be bundled with matching type constructors"
$$ text "Couldn't match expected type of"
<+> quotes (ppr expected_res_ty)
<+> text "with actual type of"
<+> quotes (ppr res_ty)
check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
-> RnM ExportOccMap
check_occs ie occs avails
= foldlM check occs names_with_occs
where
names_with_occs = availsNamesWithOccs avails
check occs (name, occ)
= case lookupOccEnv occs name_occ of
Nothing -> return (extendOccEnv occs name_occ (name, ie))
Just (name', ie')
| name == name'
-> do { warnIfFlag Opt_WarnDuplicateExports
(not (dupExport_ok name ie ie'))
(dupExportWarn occ ie ie')
; return occs }
| otherwise
-> do { global_env <- getGlobalRdrEnv ;
addErr (exportClashErr global_env occ name' name ie' ie) ;
return occs }
where
name_occ = nameOccName name
dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool
dupExport_ok n ie1 ie2
= not ( single ie1 || single ie2
|| (explicit_in ie1 && explicit_in ie2) )
where
explicit_in (IEModuleContents {}) = False
explicit_in (IEThingAll _ r)
= nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)
explicit_in _ = True
single IEVar {} = True
single IEThingAbs {} = True
single _ = False
dupModuleExport :: ModuleName -> SDoc
dupModuleExport mod
= hsep [text "Duplicate",
quotes (text "Module" <+> ppr mod),
text "in export list"]
moduleNotImported :: ModuleName -> SDoc
moduleNotImported mod
= hsep [text "The export item",
quotes (text "module" <+> ppr mod),
text "is not imported"]
nullModuleExport :: ModuleName -> SDoc
nullModuleExport mod
= hsep [text "The export item",
quotes (text "module" <+> ppr mod),
text "exports nothing"]
missingModuleExportWarn :: ModuleName -> SDoc
missingModuleExportWarn mod
= hsep [text "The export item",
quotes (text "module" <+> ppr mod),
text "is missing an export list"]
dodgyExportWarn :: Name -> SDoc
dodgyExportWarn item
= dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)
exportErrCtxt :: Outputable o => String -> o -> SDoc
exportErrCtxt herald exp =
text "In the" <+> text (herald ++ ":") <+> ppr exp
addExportErrCtxt :: (OutputableBndrId (GhcPass p))
=> IE (GhcPass p) -> TcM a -> TcM a
addExportErrCtxt ie = addErrCtxt exportCtxt
where
exportCtxt = text "In the export:" <+> ppr ie
exportItemErr :: IE GhcPs -> SDoc
exportItemErr export_item
= sep [ text "The export item" <+> quotes (ppr export_item),
text "attempts to export constructors or class methods that are not visible here" ]
dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc
dupExportWarn occ_name ie1 ie2
= hsep [quotes (ppr occ_name),
text "is exported by", quotes (ppr ie1),
text "and", quotes (ppr ie2)]
dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc
dcErrMsg ty_con what_is thing parents =
text "The type constructor" <+> quotes (ppr ty_con)
<+> text "is not the parent of the" <+> text what_is
<+> quotes thing <> char '.'
$$ text (capitalise what_is)
<> text "s can only be exported with their parent type constructor."
$$ (case parents of
[] -> empty
[_] -> text "Parent:"
_ -> text "Parents:") <+> fsep (punctuate comma parents)
failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a
failWithDcErr parent thing thing_doc parents = do
ty_thing <- tcLookupGlobal thing
failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
thing_doc (map ppr parents)
where
tyThingCategory' :: TyThing -> String
tyThingCategory' (AnId i)
| isRecordSelector i = "record selector"
tyThingCategory' i = tyThingCategory i
exportClashErr :: GlobalRdrEnv -> OccName
-> Name -> Name
-> IE GhcPs -> IE GhcPs
-> MsgDoc
exportClashErr global_env occ name1 name2 ie1 ie2
= vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
, ppr_export ie1' name1'
, ppr_export ie2' name2' ]
where
ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
quotes (ppr_name name))
2 (pprNameProvenance (get_gre name)))
ppr_name name
| nameOccName name == occ = ppr name
| otherwise = ppr occ
get_gre name
= fromMaybe (pprPanic "exportClashErr" (ppr name))
(lookupGRE_Name_OccName global_env name occ)
get_loc name = greSrcSpan (get_gre name)
(name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
then (name1, ie1, name2, ie2)
else (name2, ie2, name1, ie1)