Basic rip outwip/T11970

working

Add test files

tabs

test

Formatting

Formatting and comments

comment

Add test

Record usages

5 files changed, 164 insertions, 43 deletions

diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 4ab67ad56c..c5b19d39f2 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -4,7 +4,7 @@
 \section[RnEnv]{Environment manipulation for the renamer monad}
 -}
 
-{-# LANGUAGE CPP, MultiWayIf #-}
+{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}
 
 module RnEnv (
         newTopSrcBinder,
@@ -14,7 +14,7 @@ module RnEnv (
         lookupLocalOccThLvl_maybe,
         lookupTypeOccRn, lookupKindOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
-        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExportChild,
         reportUnboundName, unknownNameSuggestions,
         addNameClashErrRn,
 
@@ -549,6 +549,94 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name
       | FldParent { par_is = parent } <- p = parent == the_parent
       | otherwise                          = False
 
+
+
+-- | Used in export lists to lookup the children.
+lookupExportChild :: Name -> RdrName -> RnM (Maybe (Either Name [FieldLabel]))
+lookupExportChild parent rdr_name
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = Just . Left  <$> lookupExactOcc n
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = Just . Left <$> lookupOrig rdr_mod rdr_occ
+
+  | isUnboundName parent
+    -- Avoid an error cascade from malformed decls:
+    --   instance Int where { foo = e }
+    -- We have already generated an error in rnLHsInstDecl
+  = return (Just (Left (mkUnboundNameRdr rdr_name)))
+
+  | otherwise = do
+  gre_env <- getGlobalRdrEnv
+  overload_ok <- xoptM LangExt.DuplicateRecordFields
+
+
+  case lookupGRE_RdrName rdr_name gre_env of
+    [] -> return Nothing
+    [x] -> do
+      addUsedGRE True x
+      return (Just ((:[]) <$> checkFld x))
+    xs  -> Just <$> checkAmbig overload_ok rdr_name parent xs
+  where
+
+
+        checkFld :: GlobalRdrElt -> Either Name FieldLabel
+        checkFld GRE{gre_name, gre_par} =
+          case gre_par of
+            FldParent _ mfs -> Right (fldParentToFieldLabel gre_name mfs)
+            _ -> Left gre_name
+
+
+        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel
+        fldParentToFieldLabel name mfs =
+          case mfs of
+            Nothing ->
+              let fs = occNameFS (nameOccName name)
+              in FieldLabel fs False name
+            Just fs -> FieldLabel fs True name
+
+        checkAmbig :: Bool
+                   -> RdrName
+                   -> Name -- parent
+                   -> [GlobalRdrElt]
+                   -> RnM (Either Name [FieldLabel])
+        checkAmbig overload_ok rdr_name parent gres
+          -- Don't record ambiguous selector usage
+          | all isRecFldGRE
+                   gres && overload_ok
+                = return $
+                    Right [fldParentToFieldLabel (gre_name gre) mfs
+                            | gre <- gres
+                            , let FldParent _ mfs = gre_par gre ]
+          | Just gre <- disambigChildren rdr_name parent gres
+            = do
+                addUsedGRE True gre
+                return ((:[]) <$> checkFld gre)
+          | otherwise = do
+              addNameClashErrRn rdr_name gres
+              return (Left (gre_name (head gres)))
+
+        -- Return the single child with the matching parent
+        disambigChildren :: RdrName -> Name
+                            -> [GlobalRdrElt] -> Maybe GlobalRdrElt
+        disambigChildren rdr_name the_parent gres =
+          case picked_gres of
+            [] -> Nothing
+            [x] -> Just x
+            _  -> Nothing
+          where
+            picked_gres :: [GlobalRdrElt]
+            picked_gres
+              | isUnqual rdr_name = filter right_parent gres
+              | otherwise         = filter right_parent (pickGREs rdr_name gres)
+
+            right_parent (GRE { gre_par = p })
+              | ParentIs parent <- p               =
+                  parent == the_parent
+              | FldParent { par_is = parent } <- p =
+                  parent == the_parent
+              | otherwise                          = False
+
 {-
 Note [Family instance binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1081,7 +1169,6 @@ lookupImpDeprec iface gre
        ParentIs  p              -> mi_warn_fn iface (nameOccName p)
        FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
        NoParent                 -> Nothing
-       PatternSynonym           -> Nothing
 
 {-
 Note [Used names with interface not loaded]
@@ -2099,7 +2186,6 @@ warnUnusedTopBinds gres
          let isBoot = tcg_src env == HsBootFile
          let noParent gre = case gre_par gre of
                             NoParent -> True
-                            PatternSynonym -> True
                             _        -> False
              -- Don't warn about unused bindings with parents in
              -- .hs-boot files, as you are sometimes required to give
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index c92f69e6e3..b848b3352a 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -121,7 +121,7 @@ rnExpr (HsVar (L l v))
            Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
                                                         PlaceHolder)
                                              , mkFVs (map selectorFieldOcc fs));
-           Just (Right [])         -> error "runExpr/HsVar" } }
+           Just (Right [])         -> panic "runExpr/HsVar" } }
 
 rnExpr (HsIPVar v)
   = return (HsIPVar v, emptyFVs)
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)]
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 98ca38bf66..6adb436390 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -595,14 +595,14 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                    -- ignoring the record field itself
                    -- Eg.  data R = R { x,y :: Int }
                    --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
-                 arg_in_scope lbl
+                 arg_in_scope lbl sel_name
                    = rdr `elemLocalRdrEnv` lcl_env
                    || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
                                     , case gre_par gre of
                                         ParentIs p     -> Just p /= parent_tc
                                         FldParent p _  -> Just p /= parent_tc
-                                        PatternSynonym -> False
-                                        NoParent       -> True ]
+                                        NoParent       -> True
+                                    , gre_name gre /= sel_name ]
                    where
                      rdr = mkVarUnqual lbl
 
@@ -614,7 +614,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                 , let gres = lookupGRE_Field_Name rdr_env sel lbl
                                 , not (null gres)  -- Check selector is in scope
                                 , case ctxt of
-                                    HsRecFieldCon {} -> arg_in_scope lbl
+                                    HsRecFieldCon {} -> arg_in_scope lbl sel
                                     _other           -> True ]
 
            ; addUsedGREs (map thdOf3 dot_dot_gres)
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index d43945f7ff..1d216de16a 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -2011,7 +2011,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
      names_with_fls <- new_ps val_decls
    ; let pat_syn_bndrs = concat [ name: map flSelector fields
                                 | (name, fields) <- names_with_fls ]
-   ; let avails = map patSynAvail pat_syn_bndrs
+   ; let avails = map avail pat_syn_bndrs
    ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
 
    ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls