module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where
import GHC.Prelude
import GHC.Hs
import GHC.Types.FieldLabel
import GHC.Builtin.Names
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Utils.Error
import GHC.Unit.Module
import GHC.Unit.Module.Imported
import GHC.Core.TyCon
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.ConLike
import GHC.Core.PatSyn
import GHC.Data.Maybe
import GHC.Data.FastString (fsLit)
import GHC.Driver.Env
import GHC.Types.Unique.Set
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Avail
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name.Reader
import Control.Monad
import GHC.Driver.Session
import GHC.Parser.PostProcess ( setRdrNameSpace )
import Data.Either ( partitionEithers )
import GHC.Rename.Doc
data ExportAccum
= ExportAccum
ExportOccMap
(UniqSet ModuleName)
emptyExportAccum :: ExportAccum
emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet
accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))
-> [x]
-> TcRn [y]
accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
where f' acc x = do
m <- attemptM (f acc x)
pure $ case m of
Just (Just (acc', y)) -> (acc', Just y)
_ -> (acc, Nothing)
type ExportOccMap = OccEnv (GreName, IE GhcPs)
rnExports :: Bool
-> Maybe (LocatedL [LIE GhcPs])
-> RnM TcGblEnv
rnExports explicit_mod exports
= checkNoErrs $
unsetWOptM Opt_WarnWarningsDeprecations $
do { hsc_env <- getTopEnv
; tcg_env <- getGblEnv
; let dflags = hsc_dflags hsc_env
TcGblEnv { tcg_mod = this_mod
, tcg_rdr_env = rdr_env
, tcg_imports = imports
, tcg_src = hsc_src } = tcg_env
default_main | mainModIs (hsc_HUE hsc_env) == this_mod
, Just main_fun <- mainFunIs dflags
= mkUnqual varName (fsLit main_fun)
| otherwise
= main_RDR_Unqual
; has_main <- (not . null) <$> lookupInfoOccRn default_main
; let real_exports
| explicit_mod = exports
| has_main
= Just (noLocA [noLocA (IEVar noExtField
(noLocA (IEName $ noLocA default_main)))])
| otherwise = Nothing
; let do_it = exports_from_avail real_exports rdr_env imports this_mod
; (rn_exports, final_avails)
<- if hsc_src == HsigFile
then do (mb_r, msgs) <- 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)
; return (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 }) }
exports_from_avail :: Maybe (LocatedL [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
exports_from_avail Nothing rdr_env _imports _this_mod
= do {
; addDiagnostic
(TcRnMissingExportList $ moduleName _this_mod)
; let avails =
map fix_faminst . gresToAvailInfo
. filter isLocalGRE . globalRdrEnvElts $ rdr_env
; return (Nothing, avails) }
where
fix_faminst avail@(AvailTC n ns)
| availExportsDecl avail = avail
| otherwise = AvailTC n (NormalGreName n:ns)
fix_faminst avail = avail
exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= do ie_avails <- accumExports do_litem rdr_items
let final_exports = nubAvails (concatMap snd ie_avails)
return (Just ie_avails, final_exports)
where
do_litem :: ExportAccum -> LIE GhcPs
-> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie)
kids_env :: NameEnv [GlobalRdrElt]
kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]
expand_tyty_gre (gre@GRE { gre_par = ParentIs p })
| isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }]
expand_tyty_gre gre = [gre]
imported_modules = [ imv_name imv
| xs <- moduleEnvElts $ imp_mods imports
, imv <- importedByUser xs ]
exports_from_item :: ExportAccum -> LIE GhcPs
-> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
exports_from_item (ExportAccum occs earlier_mods)
(L loc ie@(IEModuleContents _ lmod@(L _ mod)))
| mod `elementOfUniqSet` earlier_mods
= do { addDiagnostic (TcRnDupeModuleExport mod) ;
return Nothing }
| otherwise
= do { let { exportValid = (mod `elem` imported_modules)
|| (moduleName this_mod == mod)
; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
; new_exports = [ availFromGRE gre'
| (gre, _) <- gre_prs
, gre' <- expand_tyty_gre gre ]
; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
; mods = addOneToUniqSet earlier_mods mod
}
; checkErr exportValid (TcRnExportedModNotImported mod)
; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule 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 (Just ( ExportAccum occs' mods
, ( L loc (IEModuleContents noExtField lmod)
, new_exports))) }
exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do
m_new_ie <- lookup_doc_ie ie
case m_new_ie of
Just new_ie -> return (Just (acc, (L loc new_ie, [])))
Nothing -> do
(new_ie, avail) <- lookup_ie ie
if isUnboundName (ieName new_ie)
then return Nothing
else do
occs' <- check_occs ie occs [avail]
return (Just ( ExportAccum occs' mods
, (L loc new_ie, [avail])))
lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
lookup_ie (IEVar _ (L l rdr))
= do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail)
lookup_ie (IEThingAbs _ (L l rdr))
= do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
return (IEThingAbs noAnn (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 noAnn (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
let flds' = flds ++ (map noLoc all_flds)
return (IEThingWith flds' (replaceLWrappedName l name) wc subs,
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 (locA l) name, [], [name], [])
else return (L (locA 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
when (null gres) $
if isTyConName name
then addTcRnDiagnostic (TcRnDodgyExports name)
else
addErr (TcRnExportHiddenComponents ie)
return (L (locA l) name, non_flds, flds)
lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn))
lookup_doc_ie (IEGroup _ lev doc) = do
doc' <- rnLHsDoc doc
pure $ Just (IEGroup noExtField lev doc')
lookup_doc_ie (IEDoc _ doc) = do
doc' <- rnLHsDoc doc
pure $ Just (IEDoc noExtField doc')
lookup_doc_ie (IEDocNamed _ str) = pure $ Just (IEDocNamed noExtField str)
lookup_doc_ie _ = pure Nothing
addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
classifyGREs = partitionGreNames . map gre_name
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 (la2na l) ub))))}
FoundChild par child -> do { checkPatSynParent spec_parent par child
; return $ case child of
FieldGreName fl -> Right (L (getLocA n) fl)
NormalGreName name -> Left (replaceLWrappedName n name)
}
IncorrectParent p c gs -> failWithDcErr p c gs
checkPatSynParent :: Name
-> Parent
-> GreName
-> TcM ()
checkPatSynParent _ (ParentIs {}) _
= return ()
checkPatSynParent parent NoParent gname
| isUnboundName parent
= return ()
| otherwise
= do { parent_ty_con <- tcLookupTyCon parent
; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname)
; case mpat_syn_thing of
AnId i | isId i
, RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
-> handle_pat_syn (selErr gname) parent_ty_con p
AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
_ -> failWithDcErr parent gname [] }
where
psErr = exportErrCtxt "pattern synonym"
selErr = exportErrCtxt "pattern synonym record selector"
handle_pat_syn :: SDoc
-> TyCon
-> PatSyn
-> TcM ()
handle_pat_syn doc ty_con pat_syn
| not $ isTyConWithSrcDataCons ty_con
= addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon
| Nothing <- mtycon
= return ()
| Just p_ty_con <- mtycon, p_ty_con /= ty_con
= addErrCtxt doc $ failWithTc
(TcRnPatSynBundledWithWrongType expected_res_ty res_ty)
| otherwise
= return ()
where
expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
(_, _, _, _, _, res_ty) = patSynSig pat_syn
mtycon = fst <$> tcSplitTyConApp_maybe res_ty
check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
-> RnM ExportOccMap
check_occs ie occs avails
= foldlM check occs children
where
children = concatMap availGreNames avails
check :: ExportOccMap -> GreName -> RnM ExportOccMap
check occs child
= case try_insert occs child of
Right occs' -> return occs'
Left (child', ie')
| greNameMangledName child == greNameMangledName child'
-> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie')
; return occs }
| otherwise
-> do { global_env <- getGlobalRdrEnv ;
addErr (exportClashErr global_env child' child ie' ie) ;
return occs }
try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap
try_insert occs child
= case lookupOccEnv occs name_occ of
Nothing -> Right (extendOccEnv occs name_occ (child, ie))
Just x -> Left x
where
name_occ = nameOccName (greNameMangledName child)
dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool
dupExport_ok child ie1 ie2
= not ( single ie1 || single ie2
|| (explicit_in ie1 && explicit_in ie2) )
where
explicit_in (IEModuleContents {}) = False
explicit_in (IEThingAll _ r)
= occName child == rdrNameOcc (ieWrappedName $ unLoc r)
explicit_in _ = True
single IEVar {} = True
single IEThingAbs {} = True
single _ = False
exportErrCtxt :: Outputable o => String -> o -> SDoc
exportErrCtxt herald exp =
text "In the" <+> text (herald ++ ":") <+> ppr exp
addExportErrCtxt :: (OutputableBndrId p)
=> IE (GhcPass p) -> TcM a -> TcM a
addExportErrCtxt ie = addErrCtxt exportCtxt
where
exportCtxt = text "In the export:" <+> ppr ie
failWithDcErr :: Name -> GreName -> [Name] -> TcM a
failWithDcErr parent child parents = do
ty_thing <- tcLookupGlobal (greNameMangledName child)
failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents
exportClashErr :: GlobalRdrEnv
-> GreName -> GreName
-> IE GhcPs -> IE GhcPs
-> TcRnMessage
exportClashErr global_env child1 child2 ie1 ie2
= TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2'
where
occ = occName child1
gre1 = get_gre child1
gre2 = get_gre child2
get_gre child
= fromMaybe (pprPanic "exportClashErr" (ppr child))
(lookupGRE_GreName global_env child)
(child1', gre1', ie1', child2', gre2', ie2') =
case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of
LT -> (child1, gre1, ie1, child2, gre2, ie2)
GT -> (child2, gre2, ie2, child1, gre1, ie1)
EQ -> panic "exportClashErr: clashing exports have idential location"