Improve error reporting for type signatures

[ghc-hetmet.git] / compiler / rename / RnEnv.lhs

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 74c9646..54a768a 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -14,7 +14,8 @@ module RnEnv (
        lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, 
        lookupLocatedInstDeclBndr,
        lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
        lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, 
        lookupLocatedInstDeclBndr,
        lookupSyntaxName, lookupSyntaxTable, lookupImportedName,

-       lookupGreRn,    
+       lookupGreRn, lookupGreRn_maybe,
+       getLookupOccRn,

 
        newLocalsRn, newIPNameRn,
        bindLocalNames, bindLocalNamesFV,
 
        newLocalsRn, newIPNameRn,
        bindLocalNames, bindLocalNamesFV,

@@ -42,18 +43,17 @@ import RdrName              ( RdrName, isQual, isUnqual, isOrig_maybe,
                          mkRdrUnqual, setRdrNameSpace, rdrNameOcc,
                          pprGlobalRdrEnv, lookupGRE_RdrName, 
                          isExact_maybe, isSrcRdrName,
                          mkRdrUnqual, setRdrNameSpace, rdrNameOcc,
                          pprGlobalRdrEnv, lookupGRE_RdrName, 
                          isExact_maybe, isSrcRdrName,

+                         Parent(..),

                          GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, 
                          isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
                          Provenance(..), pprNameProvenance,
                          importSpecLoc, importSpecModule
                        )
                          GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, 
                          isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
                          Provenance(..), pprNameProvenance,
                          importSpecLoc, importSpecModule
                        )

-import HscTypes                ( availNames, ModIface(..), FixItem(..), lookupFixity,
-                          AvailInfo, GenAvailInfo(..) )
+import HscTypes                ( availNames, ModIface(..), FixItem(..), lookupFixity )

 import TcRnMonad
 import Name            ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
                          nameSrcLoc, nameOccName, nameModule, isExternalName )
 import NameSet
 import TcRnMonad
 import Name            ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
                          nameSrcLoc, nameOccName, nameModule, isExternalName )
 import NameSet

-import NameEnv          ( NameEnv, lookupNameEnv )

 import OccName         ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
                          reportIfUnused )
 import Module          ( Module, ModuleName )
 import OccName         ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
                          reportIfUnused )
 import Module          ( Module, ModuleName )

@@ -180,7 +180,9 @@ lookupTopBndrRn rdr_name
   | otherwise
   = do { mb_gre <- lookupGreLocalRn rdr_name
        ; case mb_gre of
   | otherwise
   = do { mb_gre <- lookupGreLocalRn rdr_name
        ; case mb_gre of

-               Nothing  -> unboundName rdr_name
+               Nothing  -> do
+                             traceRn $ text "lookupTopBndrRn"
+                             unboundName rdr_name

                Just gre -> returnM (gre_name gre) }
              
 -- lookupLocatedSigOccRn is used for type signatures and pragmas
                Just gre -> returnM (gre_name gre) }
              
 -- lookupLocatedSigOccRn is used for type signatures and pragmas

@@ -193,35 +195,52 @@ lookupTopBndrRn rdr_name
 -- The Haskell98 report does not stipulate this, but it will!
 -- So we must treat the 'f' in the signature in the same way
 -- as the binding occurrence of 'f', using lookupBndrRn
 -- The Haskell98 report does not stipulate this, but it will!
 -- So we must treat the 'f' in the signature in the same way
 -- as the binding occurrence of 'f', using lookupBndrRn

+--
+-- However, consider this case:
+--     import M( f )
+--     f :: Int -> Int
+--     g x = x
+-- We don't want to say 'f' is out of scope; instead, we want to
+-- return the imported 'f', so that later on the reanamer will
+-- correctly report "misplaced type sig".

 lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name)

-lookupLocatedSigOccRn = lookupLocatedBndrRn
+lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do
+       { local_env <- getLocalRdrEnv
+       ; case lookupLocalRdrEnv local_env rdr_name of {
+               Just n  -> return n ;
+               Nothing -> do
+       { mb_gre <- lookupGreLocalRn rdr_name
+       ; case mb_gre of 
+               Just gre -> return (gre_name gre) 
+               Nothing  -> lookupGlobalOccRn rdr_name
+       }}}

 
 -- lookupInstDeclBndr is used for the binders in an 
 -- instance declaration.   Here we use the class name to
 -- disambiguate.  
 
 lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name)
 
 -- lookupInstDeclBndr is used for the binders in an 
 -- instance declaration.   Here we use the class name to
 -- disambiguate.  
 
 lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name)

-lookupLocatedInstDeclBndr cls rdr = do
-   imp_avails <- getImports
-   wrapLocM (lookupInstDeclBndr (imp_parent imp_avails) cls) rdr
+lookupLocatedInstDeclBndr cls rdr = wrapLocM (lookupInstDeclBndr cls) rdr

 
 

-lookupInstDeclBndr :: NameEnv AvailInfo -> Name -> RdrName -> RnM Name
+lookupInstDeclBndr :: Name -> RdrName -> RnM Name

 -- This is called on the method name on the left-hand side of an 
 -- instance declaration binding. eg.  instance Functor T where
 --                                       fmap = ...
 --                                       ^^^^ called on this
 -- Regardless of how many unqualified fmaps are in scope, we want
 -- the one that comes from the Functor class.
 -- This is called on the method name on the left-hand side of an 
 -- instance declaration binding. eg.  instance Functor T where
 --                                       fmap = ...
 --                                       ^^^^ called on this
 -- Regardless of how many unqualified fmaps are in scope, we want
 -- the one that comes from the Functor class.

-lookupInstDeclBndr availenv cls_name rdr_name
+lookupInstDeclBndr cls_name rdr_name

   | isUnqual rdr_name  -- Find all the things the rdr-name maps to
   = do {               -- and pick the one with the right parent name
   | isUnqual rdr_name  -- Find all the things the rdr-name maps to
   = do {               -- and pick the one with the right parent name

-         let { is_op gre     = cls_name == nameParent (gre_name gre)
+         let { is_op gre@(GRE {gre_par = ParentIs n}) = cls_name == n
+             ; is_op other                            = False

              ; occ           = rdrNameOcc rdr_name
              ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) }
        ; mb_gre <- lookupGreRn_help rdr_name lookup_fn
        ; case mb_gre of
            Just gre -> return (gre_name gre)
            Nothing  -> do { addErr (unknownInstBndrErr cls_name rdr_name)
              ; occ           = rdrNameOcc rdr_name
              ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) }
        ; mb_gre <- lookupGreRn_help rdr_name lookup_fn
        ; case mb_gre of
            Just gre -> return (gre_name gre)
            Nothing  -> do { addErr (unknownInstBndrErr cls_name rdr_name)

+                          ; traceRn (text "lookupInstDeclBndr" <+> ppr rdr_name)

                           ; return (mkUnboundName rdr_name) } }
 
   | otherwise  -- Occurs in derived instances, where we just
                           ; return (mkUnboundName rdr_name) } }
 
   | otherwise  -- Occurs in derived instances, where we just

@@ -230,12 +249,6 @@ lookupInstDeclBndr availenv cls_name rdr_name
          -- NB: qualified names are rejected by the parser
     lookupImportedName rdr_name
 
          -- NB: qualified names are rejected by the parser
     lookupImportedName rdr_name
 

-  where nameParent nm
-           | Just (AvailTC tc subs) <- lookupNameEnv availenv nm = tc
-           | otherwise = nm -- might be an Avail, if the Name is 
-                            -- in scope some other way
-                                   
-

 newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
 newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
 
 newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
 newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
 

@@ -251,20 +264,20 @@ newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
 --
 lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name
 lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name)
 --
 lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name
 lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name)

-  | not (isSrcRdrName rdr_name)
-  = lookupImportedName rdr_name        
-
-  | otherwise
-  =    -- First look up the name in the normal environment.
-   lookupGreRn rdr_name                        `thenM` \ mb_gre ->
-   case mb_gre of {
-       Just gre -> returnM (gre_name gre) ;
-       Nothing  -> newTopSrcBinder mod lrdr_name }
+  = do { mb_gre <- lookupGreRn_maybe rdr_name
+       ; case mb_gre of
+           Just gre -> returnM (gre_name gre) ;
+          Nothing  -> newTopSrcBinder mod lrdr_name }

 
 --------------------------------------------------
 --             Occurrences
 --------------------------------------------------
 
 
 --------------------------------------------------
 --             Occurrences
 --------------------------------------------------
 

+getLookupOccRn :: RnM (Name -> Maybe Name)
+getLookupOccRn
+  = getLocalRdrEnv                     `thenM` \ local_env ->
+    return (lookupLocalRdrEnv local_env . mkRdrUnqual . nameOccName)
+

 lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedOccRn = wrapLocM lookupOccRn
 
 lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedOccRn = wrapLocM lookupOccRn
 

@@ -291,7 +304,7 @@ lookupGlobalOccRn rdr_name
 
   | otherwise
   =    -- First look up the name in the normal environment.
 
   | otherwise
   =    -- First look up the name in the normal environment.

-   lookupGreRn rdr_name                        `thenM` \ mb_gre ->
+   lookupGreRn_maybe rdr_name          `thenM` \ mb_gre ->

    case mb_gre of {
        Just gre -> returnM (gre_name gre) ;
        Nothing   -> 
    case mb_gre of {
        Just gre -> returnM (gre_name gre) ;
        Nothing   -> 

@@ -304,7 +317,8 @@ lookupGlobalOccRn rdr_name
    if isQual rdr_name && mod == iNTERACTIVE then       
                                        -- This test is not expensive,
        lookupQualifiedName rdr_name    -- and only happens for failed lookups
    if isQual rdr_name && mod == iNTERACTIVE then       
                                        -- This test is not expensive,
        lookupQualifiedName rdr_name    -- and only happens for failed lookups

-   else        
+   else        do
+        traceRn $ text "lookupGlobalOccRn"

        unboundName rdr_name }
 
 lookupImportedName :: RdrName -> TcRnIf m n Name
        unboundName rdr_name }
 
 lookupImportedName :: RdrName -> TcRnIf m n Name

@@ -342,17 +356,29 @@ unboundName rdr_name
 lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name)
 -- No filter function; does not report an error on failure
 lookupSrcOcc_maybe rdr_name
 lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name)
 -- No filter function; does not report an error on failure
 lookupSrcOcc_maybe rdr_name

-  = do { mb_gre <- lookupGreRn rdr_name
+  = do { mb_gre <- lookupGreRn_maybe rdr_name

        ; case mb_gre of
                Nothing  -> returnM Nothing
                Just gre -> returnM (Just (gre_name gre)) }
        
 -------------------------
        ; case mb_gre of
                Nothing  -> returnM Nothing
                Just gre -> returnM (Just (gre_name gre)) }
        
 -------------------------

-lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt)
+lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)

 -- Just look up the RdrName in the GlobalRdrEnv
 -- Just look up the RdrName in the GlobalRdrEnv

-lookupGreRn rdr_name 
+lookupGreRn_maybe rdr_name 

   = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
 
   = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
 

+lookupGreRn :: RdrName -> RnM GlobalRdrElt
+-- If not found, add error message, and return a fake GRE
+lookupGreRn rdr_name 
+  = do { mb_gre <- lookupGreRn_maybe rdr_name
+       ; case mb_gre of {
+           Just gre -> return gre ;
+           Nothing  -> do
+       { traceRn $ text "lookupGreRn"
+       ; name <- unboundName rdr_name
+       ; return (GRE { gre_name = name, gre_par = NoParent,
+                       gre_prov = LocalDef }) }}}
+

 lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt)
 -- Similar, but restricted to locally-defined things
 lookupGreLocalRn rdr_name 
 lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt)
 -- Similar, but restricted to locally-defined things
 lookupGreLocalRn rdr_name 

@@ -543,7 +569,7 @@ At the moment this just happens for
   * "do" notation
 
 We store the relevant Name in the HsSyn tree, in 
   * "do" notation
 
 We store the relevant Name in the HsSyn tree, in 

-  * HsIntegral/HsFractional    
+  * HsIntegral/HsFractional/HsIsString

   * NegApp
   * NPlusKPat
   * HsDo
   * NegApp
   * NPlusKPat
   * HsDo

@@ -772,12 +798,12 @@ warnUnusedMatches    names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals name
 -------------------------
 --     Helpers
 warnUnusedGREs gres 
 -------------------------
 --     Helpers
 warnUnusedGREs gres 

- = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres]
+ = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres]

 
 warnUnusedLocals names
 
 warnUnusedLocals names

- = warnUnusedBinds [(n,Nothing) | n<-names]
+ = warnUnusedBinds [(n,LocalDef) | n<-names]

 
 

-warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM ()
+warnUnusedBinds :: [(Name,Provenance)] -> RnM ()

 warnUnusedBinds names  = mappM_ warnUnusedName (filter reportable names)
  where reportable (name,_) 
        | isWiredInName name = False    -- Don't report unused wired-in names
 warnUnusedBinds names  = mappM_ warnUnusedName (filter reportable names)
  where reportable (name,_) 
        | isWiredInName name = False    -- Don't report unused wired-in names

@@ -787,23 +813,25 @@ warnUnusedBinds names  = mappM_ warnUnusedName (filter reportable names)
 
 -------------------------
 
 
 -------------------------
 

-warnUnusedName :: (Name, Maybe Provenance) -> RnM ()
-warnUnusedName (name, prov)
-  = addWarnAt loc $
+warnUnusedName :: (Name, Provenance) -> RnM ()
+warnUnusedName (name, LocalDef)
+  = addUnusedWarning name (srcLocSpan (nameSrcLoc name)) 
+                    (ptext SLIT("Defined but not used"))
+
+warnUnusedName (name, Imported is)
+  = mapM_ warn is
+  where
+    warn spec = addUnusedWarning name span msg
+       where
+          span = importSpecLoc spec
+          pp_mod = quotes (ppr (importSpecModule spec))
+          msg = ptext SLIT("Imported from") <+> pp_mod <+> ptext SLIT("but not used")
+
+addUnusedWarning name span msg
+  = addWarnAt span $

     sep [msg <> colon, 
         nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
                        <+> quotes (ppr name)]
     sep [msg <> colon, 
         nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
                        <+> quotes (ppr name)]

-       -- TODO should be a proper span
-  where
-    (loc,msg) = case prov of
-                 Just (Imported is)
-                       -> (importSpecLoc imp_spec, imp_from (importSpecModule imp_spec))
-                       where
-                         imp_spec = head is
-                 other -> (srcLocSpan (nameSrcLoc name), unused_msg)
-
-    unused_msg   = text "Defined but not used"
-    imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used"

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}