diff options
Diffstat (limited to 'compiler/rename/RnNames.hs')
| -rw-r--r-- | compiler/rename/RnNames.hs | 101 |
1 files changed, 68 insertions, 33 deletions
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 2fc62637e8..2434bd9cce 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -4,7 +4,7 @@ \section[RnNames]{Extracting imported and top-level names in scope} -} -{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} module RnNames ( rnImports, getLocalNonValBinders, newRecordSelector, @@ -12,7 +12,8 @@ module RnNames ( gresFromAvails, calculateAvails, reportUnusedNames, - checkConName + checkConName, + exportItemErr ) where #include "HsVersions.h" @@ -49,6 +50,7 @@ import PatSyn import qualified GHC.LanguageExtensions as LangExt import Control.Monad +import Data.Foldable (asum) import Data.Either ( partitionEithers, isRight, rights ) -- import qualified Data.Foldable as Foldable import Data.Map ( Map ) @@ -996,7 +998,7 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo -trimAvail (Avail b n) _ = Avail b n +trimAvail (Avail n) _ = Avail n trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of Just x -> AvailTC n [] [x] Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] @@ -1009,7 +1011,7 @@ filterAvails keep avails = foldr (filterAvail keep) [] avails filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest = case ie of - Avail _ n | keep n -> ie : rest + Avail n | keep n -> ie : rest | otherwise -> rest AvailTC tc ns fs -> let ns' = filter keep ns @@ -1053,14 +1055,6 @@ mkChildEnv gres = foldr add emptyNameEnv gres FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre ParentIs p -> extendNameEnv_Acc (:) singleton env p gre NoParent -> env - PatternSynonym -> env - -findPatSyns :: [GlobalRdrElt] -> [GlobalRdrElt] -findPatSyns gres = foldr add [] gres - where - add g@(GRE { gre_par = PatternSynonym }) ps = - g:ps - add _ ps = ps findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] @@ -1088,6 +1082,58 @@ lookupChildren all_kids rdr_items [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] +-- This is a minefield. Three different things can appear in exports list. +-- 1. Record selectors +-- 2. Type constructors +-- 3. Data constructors +-- +-- However, things get put into weird name spaces. +-- 1. Some type constructors are parsed as variables (-.->) for example. +-- 2. All data constructors are parsed as type constructors +-- 3. When there is ambiguity, we default type constructors to data +-- constructors and require the explicit `type` keyword for type +-- constructors. +-- +-- +-- Further to this madness, duplicate record fields complicate +-- things as we must find the FieldLabel rather than just the Name. +-- +lookupChildrenExport :: Name -> [Located RdrName] + -> RnM ([Located Name], [Located FieldLabel]) +lookupChildrenExport parent rdr_items = + do + let + + doOne :: Located RdrName + -> RnM (Either (Located Name) [Located FieldLabel]) + doOne n = do + + let bareName = unLoc n + lkup = lookupExportChild parent + + mname <- runMaybeT . asum . map (MaybeT . lkup) $ + [ (setRdrNameSpace bareName varName) -- Record selector + , (setRdrNameSpace bareName dataName) -- data constructor + , (setRdrNameSpace bareName tcName) -- type constructor + ] + + -- Default to data constructors for slightly better error + -- messages + let unboundName :: RdrName + unboundName = if rdrNameSpace bareName == varName + then bareName + else setRdrNameSpace bareName dataName + + + name <- maybe (Left <$> reportUnboundName unboundName) return mname + + case name of + Right fls -> return $ Right (map (L (getLoc n)) fls) + Left name -> return $ Left (L (getLoc n) name) + + xs <- mapM doOne rdr_items + return $ (fmap concat . partitionEithers) xs + classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) classifyGREs = partitionEithers . map classifyGRE @@ -1219,6 +1265,7 @@ rnExports explicit_mod exports Just _ -> rn_exports, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly final_ns }) + ; failIfErrsM ; return (rn_exports, new_tcg_env) } exports_from_avail :: Maybe (Located [LIE RdrName]) @@ -1260,8 +1307,6 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod kids_env :: NameEnv [GlobalRdrElt] kids_env = mkChildEnv (globalRdrEnvElts rdr_env) - pat_syns :: [GlobalRdrElt] - pat_syns = findPatSyns (globalRdrEnvElts rdr_env) imported_modules = [ imv_name imv | xs <- moduleEnvElts $ imp_mods imports, imv <- xs ] @@ -1339,13 +1384,13 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie ie@(IEThingWith l wc sub_rdrs _) = do - (lname, subs, avails, flds) <- lookup_ie_with ie l sub_rdrs + (lname, subs, avails, flds) <- 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 lname wc subs [], + return (IEThingWith lname wc subs (map noLoc (flds ++ all_flds)), AvailTC name (name : avails ++ all_avail) (flds ++ all_flds)) @@ -1354,26 +1399,16 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - lookup_ie_with :: IE RdrName -> Located RdrName -> [Located RdrName] + lookup_ie_with :: Located RdrName -> [Located RdrName] -> RnM (Located Name, [Located Name], [Name], [FieldLabel]) - lookup_ie_with ie (L l rdr) sub_rdrs + lookup_ie_with (L l rdr) sub_rdrs = do name <- lookupGlobalOccRn rdr - let gres = findChildren kids_env name - mchildren = - lookupChildren (map classifyGRE (gres ++ pat_syns)) sub_rdrs - addUsedKids rdr gres + (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name then return (L l name, [], [name], []) - else - case mchildren of - Nothing -> do - addErr (exportItemErr ie) - return (L l name, [], [name], []) - Just (non_flds, flds) -> do - addUsedKids rdr gres - return (L l name, non_flds - , map unLoc non_flds - , map unLoc flds) + else return (L l name, non_flds + , map unLoc non_flds + , map unLoc flds) lookup_ie_all :: IE RdrName -> Located RdrName -> RnM (Located Name, [Name], [FieldLabel]) lookup_ie_all ie (L l rdr) = @@ -1811,7 +1846,7 @@ printMinimalImports imports_w_usage -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail _ n) + to_ie _ (Avail n) = [IEVar (noLoc n)] to_ie _ (AvailTC n [m] []) | n==m = [IEThingAbs (noLoc n)] |