Tidy up some convoluted "child/parent" code
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 4 Oct 2017 09:48:10 +0000 (10:48 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 11 Oct 2017 10:05:56 +0000 (11:05 +0100)
In investigating something else (Trac #14307) I encountered the
wonders of TcRnExports.lookupChildrenExport, and the data
type ChildLookupResult.

I managed to remove the NameErr constructor from ChildLookupResult,
and simplify the code significantly at the same time.

This is just refactoring; no change in behaviour.

compiler/rename/RnEnv.hs
compiler/typecheck/TcRnExports.hs

index 7b5d18e..dbc3baf 100644 (file)
@@ -17,10 +17,9 @@ module RnEnv (
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
         lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
 
-        lookupSubBndrOcc_helper,
         ChildLookupResult(..),
-
-        combineChildLookupResult,
+        lookupSubBndrOcc_helper,
+        combineChildLookupResult, -- Called by lookupChildrenExport
 
         HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
         lookupSigCtxtOccRn,
@@ -64,8 +63,8 @@ import Module
 import ConLike
 import DataCon
 import TyCon
+import ErrUtils         ( MsgDoc )
 import PrelNames        ( rOOT_MAIN )
-import ErrUtils         ( MsgDoc, ErrMsg )
 import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))
 import SrcLoc
 import Outputable
@@ -78,7 +77,6 @@ import ListSetOps       ( minusList )
 import qualified GHC.LanguageExtensions as LangExt
 import RnUnbound
 import RnUtils
-import Data.Functor (($>))
 import Data.Maybe (isJust)
 import qualified Data.Semigroup as Semi
 
@@ -613,9 +611,6 @@ instance Monoid DisambigInfo where
 -- Records the result of looking up a child.
 data ChildLookupResult
       = NameNotFound                --  We couldn't find a suitable name
-      | NameErr ErrMsg              --  We found an unambiguous name
-                                    --  but there's another error
-                                    --  we should abort from
       | IncorrectParent Name        -- Parent
                         Name        -- Name of thing we were looking for
                         SDoc        -- How to print the name
@@ -634,9 +629,8 @@ combineChildLookupResult (x:xs) = do
 
 instance Outputable ChildLookupResult where
   ppr NameNotFound = text "NameNotFound"
-  ppr (FoundName _p n) = text "Found:" <+> ppr n
+  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n
   ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls
-  ppr (NameErr _) = text "Error"
   ppr (IncorrectParent p n td ns) = text "IncorrectParent"
                                   <+> hsep [ppr p, ppr n, td, ppr ns]
 
@@ -656,7 +650,6 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
     NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))
     FoundName _p n -> return (Right n)
     FoundFL fl  ->  return (Right (flSelector fl))
-    NameErr err ->  reportError err $> (Right $ mkUnboundNameRdr rdr_name)
     IncorrectParent {} -> return $ Left (unknownSubordinateErr doc rdr_name)
 
 
index b593d52..a79e30d 100644 (file)
@@ -12,7 +12,6 @@ import PrelNames
 import RdrName
 import TcRnMonad
 import TcEnv
-import TcMType
 import TcType
 import RnNames
 import RnEnv
@@ -407,7 +406,7 @@ isDoc _ = False
 
 lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
                      -> RnM ([LIEWrappedName Name], [Located FieldLabel])
-lookupChildrenExport parent rdr_items =
+lookupChildrenExport spec_parent rdr_items =
   do
     xs <- mapAndReportM doOne rdr_items
     return $ partitionEithers xs
@@ -427,10 +426,10 @@ lookupChildrenExport parent rdr_items =
 
           let bareName = (ieWrappedName . unLoc) n
               lkup v = lookupSubBndrOcc_helper False True
-                        parent (setRdrNameSpace bareName v)
+                        spec_parent (setRdrNameSpace bareName v)
 
-          name <-  combineChildLookupResult . map lkup $
-                    choosePossibleNamespaces (rdrNameSpace bareName)
+          name <-  combineChildLookupResult $ map lkup $
+                   choosePossibleNamespaces (rdrNameSpace bareName)
           traceRn "lookupChildrenExport" (ppr name)
           -- Default to data constructors for slightly better error
           -- messages
@@ -439,32 +438,16 @@ lookupChildrenExport parent rdr_items =
                                 then bareName
                                 else setRdrNameSpace bareName dataName
 
-          -- Might need to check here for FLs as well
-          name' <- case name of
-                     FoundName NoParent n -> checkPatSynParent parent n
-                     _ -> return name
-
-          traceRn "lookupChildrenExport" (ppr name')
-
-          case name' of
+          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 _p name -> return $ Left (replaceLWrappedName n name)
-            NameErr err_msg -> reportError err_msg >> failM
-            IncorrectParent p g td gs -> do
-              mkDcErrMsg p g td gs >>= reportError
-              failM
-
-
--- | Also captures the current context
-mkNameErr :: SDoc -> TcM ChildLookupResult
-mkNameErr errMsg = NameErr <$> mkErrTc errMsg
-
+            FoundName par name -> do { checkPatSynParent spec_parent par name
+                                     ; return $ Left (replaceLWrappedName n name) }
+            IncorrectParent p g td gs -> failWithDcErr p g td gs
 
 
---
 -- Note: [Typing Pattern Synonym Exports]
 -- It proved quite a challenge to precisely specify which pattern synonyms
 -- should be allowed to be bundled with which type constructors.
@@ -521,58 +504,68 @@ mkNameErr errMsg = NameErr <$> mkErrTc errMsg
 -- whether we are allowed to export the child with the parent.
 -- Invariant: gre_par == NoParent
 -- See note [Typing Pattern Synonym Exports]
-checkPatSynParent    :: Name   -- ^ Type constructor
-                     -> Name   -- ^ Either a
-                               --   a) Pattern Synonym Constructor
-                               --   b) A pattern synonym selector
-               -> TcM ChildLookupResult
-checkPatSynParent parent mpat_syn
+checkPatSynParent :: Name    -- ^ Alleged parent type constructor
+                             -- User wrote T( P, Q )
+                  -> Parent  -- The parent of P we discovered
+                  -> Name    -- ^ Either a
+                             --   a) Pattern Synonym Constructor
+                             --   b) A pattern synonym selector
+                  -> TcM ()  -- Fails if wrong parent
+checkPatSynParent _ (ParentIs {}) _
+  = return ()
+
+checkPatSynParent _ (FldParent {}) _
+  = return ()
+
+checkPatSynParent parent NoParent mpat_syn
   | isUnboundName parent -- Avoid an error cascade
-  = return (FoundName NoParent mpat_syn)
-  | otherwise = do
-  parent_ty_con <- tcLookupTyCon parent
-  mpat_syn_thing <- tcLookupGlobal mpat_syn
-  let expected_res_ty =
-          mkTyConApp parent_ty_con (mkTyVarTys (tyConTyVars parent_ty_con))
-
-      handlePatSyn errCtxt =
-        addErrCtxt errCtxt
-        . tc_one_ps_export_with expected_res_ty parent_ty_con
-  -- 1. Check that the Id was actually from a thing associated with patsyns
-  case mpat_syn_thing of
-      AnId i
-        | isId i               ->
-        case idDetails i of
-          RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p
-          _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) []
-      AConLike (PatSynCon p)    ->  handlePatSyn (psErr p) p
-      _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) []
-  where
+  = return ()
+
+  | otherwise
+  = do { parent_ty_con <- tcLookupTyCon parent
+       ; mpat_syn_thing <- tcLookupGlobal mpat_syn
+
+        -- 1. Check that the Id was actually from a thing associated with patsyns
+       ; 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
 
-    psErr = exportErrCtxt "pattern synonym"
+            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."
+    assocClassErr = text "Pattern synonyms can be bundled only with datatypes."
 
-    tc_one_ps_export_with :: TcTauType -- ^ TyCon type
-                       -> TyCon       -- ^ Parent TyCon
-                       -> PatSyn   -- ^ Corresponding bundled PatSyn
-                                           -- and pretty printed origin
-                       -> TcM ChildLookupResult
-    tc_one_ps_export_with expected_res_ty ty_con pat_syn
+    handle_pat_syn :: SDoc
+                   -> TyCon      -- ^ Parent TyCon
+                   -> PatSyn     -- ^ Corresponding bundled PatSyn
+                                 --   and pretty printed origin
+                   -> TcM ()
+    handle_pat_syn doc ty_con pat_syn
 
       -- 2. See note [Types of TyCon]
-      | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr
+      | not $ isTyConWithSrcDataCons ty_con
+      = addErrCtxt doc $ failWithTc assocClassErr
+
       -- 3. Is the head a type variable?
-      | Nothing <- mtycon = return (FoundName (ParentIs parent) mpat_syn)
+      | Nothing <- mtycon
+      = return ()
       -- 4. Ok. Check they are actually the same type constructor.
-      | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError
+
+      | Just p_ty_con <- mtycon, p_ty_con /= ty_con
+      = addErrCtxt doc $ failWithTc typeMismatchError
+
       -- 5. We passed!
-      | otherwise = return (FoundName (ParentIs parent) mpat_syn)
+      | 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
@@ -584,11 +577,7 @@ checkPatSynParent parent mpat_syn
               <+> quotes (ppr res_ty)
 
 
-
-
 {-===========================================================================-}
-
-
 check_occs :: IE GhcPs -> ExportOccMap -> [Name] -> RnM ExportOccMap
 check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
   = foldlM check occs names
@@ -709,11 +698,11 @@ dcErrMsg ty_con what_is thing parents =
                       [_] -> text "Parent:"
                       _  -> text "Parents:") <+> fsep (punctuate comma parents)
 
-mkDcErrMsg :: Name -> Name -> SDoc -> [Name] -> TcM ErrMsg
-mkDcErrMsg parent thing thing_doc parents = do
+failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a
+failWithDcErr parent thing thing_doc parents = do
   ty_thing <- tcLookupGlobal thing
-  mkErrTc $
-    dcErrMsg parent (tyThingCategory' ty_thing) thing_doc (map ppr parents)
+  failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
+                        thing_doc (map ppr parents)
   where
     tyThingCategory' :: TyThing -> String
     tyThingCategory' (AnId i)