[project @ 1998-04-07 16:40:08 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnBinds.lhs
index b3a776f..a92ac88 100644 (file)
@@ -9,46 +9,39 @@ type-synonym declarations; those cannot be done at this stage because
 they may be affected by renaming (which isn't fully worked out yet).
 
 \begin{code}
-#include "HsVersions.h"
-
 module RnBinds (
        rnTopBinds, rnTopMonoBinds,
-       rnMethodBinds,
+       rnMethodBinds, renameSigs,
        rnBinds, rnMonoBinds
    ) where
 
-IMP_Ubiq()
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(RnLoop)                -- break the RnPass/RnExpr/RnBinds loops
-#else
+#include "HsVersions.h"
+
 import {-# SOURCE #-} RnSource ( rnHsSigType )
-#endif
 
 import HsSyn
-import HsPragmas       ( isNoGenPragmas, noGenPragmas )
+import HsBinds         ( sigsForMe )
 import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnExpr          ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
-import RnEnv           ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, newLocalNames, isUnboundName )
-
+import RnEnv           ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
+                         newLocalNames, isUnboundName, warnUnusedBinds
+                       )
 import CmdLineOpts     ( opt_SigsRequired )
 import Digraph         ( stronglyConnComp, SCC(..) )
-import ErrUtils                ( addErrLoc, addShortErrLocLine )
 import Name            ( OccName(..), Provenance, 
-                         Name {- instance Eq -},
+                         Name, isExportedName,
                          NameSet(..), emptyNameSet, mkNameSet, unionNameSets, 
                          minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
                        )
-import Maybes          ( catMaybes )
-import Pretty
-import Util            ( Ord3(..), thenCmp, isIn, removeDups, panic, panic#, assertPanic, assocDefault )
-import UniqSet         ( SYN_IE(UniqSet) )
+import BasicTypes      ( RecFlag(..), TopLevelFlag(..) )
+import Util            ( thenCmp, removeDups, panic, panic#, assertPanic )
+import UniqSet         ( UniqSet )
 import ListSetOps      ( minusList )
 import Bag             ( bagToList )
 import UniqFM          ( UniqFM )
-import ErrUtils                ( SYN_IE(Error) )
-import Outputable      ( Outputable(..) )
+import Outputable
 \end{code}
 
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -179,10 +172,15 @@ rnTopMonoBinds EmptyMonoBinds sigs
 rnTopMonoBinds mbinds sigs
  =  mapRn lookupBndrRn binder_rdr_names        `thenRn` \ binder_names ->
     let
-       binder_set = mkNameSet binder_names
+       binder_set       = mkNameSet binder_names
+       exported_binders = mkNameSet (filter isExportedName binder_names)
     in
-    rn_mono_binds True {- top level -}
+    rn_mono_binds TopLevel
                  binder_set mbinds sigs                `thenRn` \ (new_binds, fv_set) ->
+    let
+       unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
+    in
+    warnUnusedBinds unused_binders     `thenRn_`
     returnRn new_binds
   where
     binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
@@ -220,16 +218,22 @@ rnMonoBinds mbinds sigs   thing_inside -- Non-empty monobinds
   =    -- Extract all the binders in this group,
        -- and extend current scope, inventing new names for the new binders
        -- This also checks that the names form a set
-    bindLocatedLocalsRn (\_ -> text "binding group") mbinders_w_srclocs                $ \ new_mbinders ->
+    bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs              $ \ new_mbinders ->
     let
        binder_set = mkNameSet new_mbinders
     in
-    rn_mono_binds False {- not top level -}
+    rn_mono_binds NotTopLevel
                  binder_set mbinds sigs        `thenRn` \ (binds,bind_fvs) ->
 
        -- Now do the "thing inside", and deal with the free-variable calculations
     thing_inside binds                                 `thenRn` \ (result,result_fvs) ->
-    returnRn (result, (result_fvs `unionNameSets` bind_fvs) `minusNameSet` binder_set)
+    let
+       all_fvs        = result_fvs  `unionNameSets` bind_fvs
+       net_fvs        = all_fvs `minusNameSet` binder_set
+       unused_binders = binder_set `minusNameSet` all_fvs
+    in
+    warnUnusedBinds unused_binders     `thenRn_`
+    returnRn (result, net_fvs)
   where
     mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
 \end{code}
@@ -247,28 +251,28 @@ This is done *either* by pass 3 (for the top-level bindings), *or* by
 @rnNestedMonoBinds@ (for the nested ones).
 
 \begin{code}
-rn_mono_binds :: Bool                  -- True <=> top level
+rn_mono_binds :: TopLevelFlag
              -> NameSet                -- Binders of this group
              -> RdrNameMonoBinds       
              -> [RdrNameSig]           -- Signatures attached to this group
              -> RnMS s (RenamedHsBinds,        -- 
                         FreeVars)      -- Free variables
 
-rn_mono_binds is_top_lev binders mbinds sigs
+rn_mono_binds top_lev binders mbinds sigs
   =
         -- Rename the bindings, returning a MonoBindsInfo
         -- which is a list of indivisible vertices so far as
         -- the strongly-connected-components (SCC) analysis is concerned
-    rnBindSigs is_top_lev binders sigs `thenRn` \ siglist ->
-    flattenMonoBinds 0 siglist mbinds  `thenRn` \ (_, mbinds_info) ->
+    renameSigs top_lev False binders sigs      `thenRn` \ siglist ->
+    flattenMonoBinds siglist mbinds    `thenRn` \ mbinds_info ->
 
         -- Do the SCC analysis
-    let edges      = mkEdges mbinds_info
+    let edges      = mkEdges (mbinds_info `zip` [(0::Int)..])
        scc_result  = stronglyConnComp edges
        final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
 
         -- Deal with bound and free-var calculation
-       rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
+       rhs_fvs = unionManyNameSets [fvs | (_,fvs,_,_) <- mbinds_info]
     in
     returnRn (final_binds, rhs_fvs)
 \end{code}
@@ -277,19 +281,18 @@ rn_mono_binds is_top_lev binders mbinds sigs
 unique ``vertex tags'' on its output; minor plumbing required.
 
 \begin{code}
-flattenMonoBinds :: Int                                -- Next free vertex tag
-                -> [RenamedSig]                -- Signatures
+flattenMonoBinds :: [RenamedSig]               -- Signatures
                 -> RdrNameMonoBinds
-                -> RnMS s (Int, [FlatMonoBindsInfo])
+                -> RnMS s [FlatMonoBindsInfo]
 
-flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
+flattenMonoBinds sigs EmptyMonoBinds = returnRn []
 
-flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
-  = flattenMonoBinds uniq  sigs bs1    `thenRn` \ (uniq1, flat1) ->
-    flattenMonoBinds uniq1 sigs bs2    `thenRn` \ (uniq2, flat2) ->
-    returnRn (uniq2, flat1 ++ flat2)
+flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
+  = flattenMonoBinds sigs bs1  `thenRn` \ flat1 ->
+    flattenMonoBinds sigs bs2  `thenRn` \ flat2 ->
+    returnRn (flat1 ++ flat2)
 
-flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
+flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
   = pushSrcLocRn locn                  $
     rnPat pat                          `thenRn` \ pat' ->
     rnGRHSsAndBinds grhss_and_binds    `thenRn` \ (grhss_and_binds', fvs) ->
@@ -297,38 +300,32 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
         -- Find which things are bound in this group
     let
        names_bound_here = mkNameSet (collectPatBinders pat')
-       sigs_for_me      = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
+       sigs_for_me      = sigsForMe (`elemNameSet` names_bound_here) sigs
        sigs_fvs         = foldr sig_fv emptyNameSet sigs_for_me
     in
-    returnRn (
-       uniq + 1,
-       [(uniq,
-         names_bound_here,
+    returnRn 
+       [(names_bound_here,
          fvs `unionNameSets` sigs_fvs,
          PatMonoBind pat' grhss_and_binds' locn,
          sigs_for_me
         )]
-    )
 
-flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
+flattenMonoBinds sigs (FunMonoBind name inf matches locn)
   = pushSrcLocRn locn                           $
     mapRn (checkPrecMatch inf name) matches    `thenRn_`
     lookupBndrRn name                          `thenRn` \ name' ->
     mapAndUnzipRn rnMatch matches              `thenRn` \ (new_matches, fv_lists) ->
     let
        fvs         = unionManyNameSets fv_lists
-       sigs_for_me = filter ((name' ==) . sig_name) sigs
+       sigs_for_me = sigsForMe (name' ==) sigs
        sigs_fvs    = foldr sig_fv emptyNameSet sigs_for_me
     in
-    returnRn (
-      uniq + 1,
-      [(uniq,
-       unitNameSet name',
+    returnRn
+      [(unitNameSet name',
        fvs `unionNameSets` sigs_fvs,
        FunMonoBind name' inf new_matches locn,
        sigs_for_me
        )]
-    )
 \end{code}
 
 
@@ -344,23 +341,21 @@ rnMethodBinds (AndMonoBinds mb1 mb2)
   = andRn AndMonoBinds (rnMethodBinds mb1)
                       (rnMethodBinds mb2)
 
-rnMethodBinds (FunMonoBind occname inf matches locn)
+rnMethodBinds (FunMonoBind name inf matches locn)
   = pushSrcLocRn locn                             $
-    mapRn (checkPrecMatch inf occname) matches `thenRn_`
+    mapRn (checkPrecMatch inf name) matches    `thenRn_`
 
-    newLocalNames [(occname, locn)]            `thenRn` \ [op_name] ->
-       -- Make a fresh local for the bound variable; it must be different
-       -- to occurrences of the same thing on the LHS, which refer to the global
-       -- selectors.
+    lookupGlobalOccRn name                     `thenRn` \ sel_name -> 
+       -- We use the selector name as the binder
 
     mapAndUnzipRn rnMatch matches              `thenRn` \ (new_matches, _) ->
-    returnRn (FunMonoBind op_name inf new_matches locn)
+    returnRn (FunMonoBind sel_name inf new_matches locn)
 
-rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
+rnMethodBinds (PatMonoBind (VarPatIn name) grhss_and_binds locn)
   = pushSrcLocRn locn                  $
-    newLocalNames [(occname, locn)]    `thenRn` \ [op_name] ->
+    lookupGlobalOccRn name                     `thenRn` \ sel_name -> 
     rnGRHSsAndBinds grhss_and_binds    `thenRn` \ (grhss_and_binds', _) ->
-    returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
+    returnRn (PatMonoBind (VarPatIn sel_name) grhss_and_binds' locn)
 
 -- Can't handle method pattern-bindings which bind multiple methods.
 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
@@ -391,14 +386,14 @@ as the two cases are similar.
 reconstructCycle :: SCC FlatMonoBindsInfo
                 -> RenamedHsBinds
 
-reconstructCycle (AcyclicSCC (_, _, _, binds, sigs))
-  = MonoBind binds sigs nonRecursive
+reconstructCycle (AcyclicSCC (_, _, binds, sigs))
+  = MonoBind binds sigs NonRecursive
 
 reconstructCycle (CyclicSCC cycle)
-  = MonoBind this_gp_binds this_gp_sigs recursive
+  = MonoBind this_gp_binds this_gp_sigs Recursive
   where
-    this_gp_binds      = foldr1 AndMonoBinds [binds | (_, _, _, binds, _) <- cycle]
-    this_gp_sigs       = foldr1 (++)        [sigs  | (_, _, _, _, sigs) <- cycle]
+    this_gp_binds      = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
+    this_gp_sigs       = foldr1 (++)        [sigs  | (_, _, _, sigs) <- cycle]
 \end{code}
 
 %************************************************************************
@@ -414,23 +409,21 @@ renamed.
 
 \begin{code}
 type FlatMonoBindsInfo
-  = (VertexTag,                        -- Identifies the vertex
-     NameSet,                  -- Set of names defined in this vertex
+  = (NameSet,                  -- Set of names defined in this vertex
      NameSet,                  -- Set of names used in this vertex
-     RenamedMonoBinds,         -- Binding for this vertex (always just one binding, either fun or pat)
+     RenamedMonoBinds,
      [RenamedSig])             -- Signatures, if any, for this vertex
 
-
-mkEdges :: [FlatMonoBindsInfo] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
+mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
 
 mkEdges flat_info
   = [ (info, tag, dest_vertices (nameSetToList names_used))
-    | info@(tag, names_defined, names_used, mbind, sigs) <- flat_info
+    | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
     ]
   where
         -- An edge (v,v') indicates that v depends on v'
     dest_vertices src_mentions = [ target_vertex
-                                | (target_vertex, names_defined, _, _, _) <- flat_info,
+                                | ((names_defined, _, _, _), target_vertex) <- flat_info,
                                   mentioned_name <- src_mentions,
                                   mentioned_name `elemNameSet` names_defined
                                 ]
@@ -443,17 +436,19 @@ mkEdges flat_info
 %*                                                                     *
 %************************************************************************
 
-@rnBindSigs@ checks for: (a)~more than one sig for one thing;
+@renameSigs@ checks for: (a)~more than one sig for one thing;
 (b)~signatures given for things not bound here; (c)~with suitably
 flaggery, that all top-level things have type signatures.
 
 \begin{code}
-rnBindSigs :: Bool                     -- True <=> top-level binders
+renameSigs :: TopLevelFlag
+           -> Bool                     -- True <-> sigs for an instance decl
+                                       -- hence SPECIALISE instance prags ok
            -> NameSet                  -- Set of names bound in this group
            -> [RdrNameSig]
            -> RnMS s [RenamedSig]               -- List of Sig constructors
 
-rnBindSigs is_toplev binders sigs
+renameSigs top_lev inst_decl binders sigs
   =     -- Rename the signatures
     mapRn renameSig sigs       `thenRn` \ sigs' ->
 
@@ -461,15 +456,21 @@ rnBindSigs is_toplev binders sigs
        --           (b) signatures for things not in this group
        --           (c) optionally, bindings with no signature
     let
-       (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
-       not_this_group  = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
+       (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
+       not_this_group  = sigsForMe (not . (`elemNameSet` binders)) goodies
+       spec_inst_sigs  = [s | s@(SpecInstSig _ _) <- goodies]
        type_sig_vars   = [n | Sig n _ _ <- goodies]
-       un_sigd_binders 
-           | is_toplev && opt_SigsRequired = nameSetToList binders `minusList` type_sig_vars
-           | otherwise                     = []
+       sigs_required   = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
+       un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
+                       | otherwise     = []
     in
     mapRn dupSigDeclErr dups                           `thenRn_`
     mapRn unknownSigErr not_this_group                 `thenRn_`
+    (if not inst_decl then
+       mapRn unknownSigErr spec_inst_sigs
+     else
+       returnRn []
+    )                                                  `thenRn_`
     mapRn (addErrRn.missingSigErr) un_sigd_binders     `thenRn_`
 
     returnRn sigs' -- bad ones and all:
@@ -479,13 +480,18 @@ rnBindSigs is_toplev binders sigs
 renameSig (Sig v ty src_loc)
   = pushSrcLocRn src_loc $
     lookupBndrRn v                             `thenRn` \ new_v ->
-    rnHsSigType (\ sty -> ppr sty v) ty                `thenRn` \ new_ty ->
+    rnHsSigType (quotes (ppr v)) ty            `thenRn` \ new_ty ->
     returnRn (Sig new_v new_ty src_loc)
 
+renameSig (SpecInstSig ty src_loc)
+  = pushSrcLocRn src_loc $
+    rnHsSigType (text "A SPECIALISE instance pragma") ty               `thenRn` \ new_ty ->
+    returnRn (SpecInstSig new_ty src_loc)
+
 renameSig (SpecSig v ty using src_loc)
   = pushSrcLocRn src_loc $
     lookupBndrRn v                     `thenRn` \ new_v ->
-    rnHsSigType (\ sty -> ppr sty v) ty        `thenRn` \ new_ty ->
+    rnHsSigType (quotes (ppr v)) ty    `thenRn` \ new_ty ->
     rn_using using                     `thenRn` \ new_using ->
     returnRn (SpecSig new_v new_ty new_using src_loc)
   where
@@ -497,40 +503,29 @@ renameSig (InlineSig v src_loc)
   = pushSrcLocRn src_loc $
     lookupBndrRn v             `thenRn` \ new_v ->
     returnRn (InlineSig new_v src_loc)
-
-renameSig (MagicUnfoldingSig v str src_loc)
-  = pushSrcLocRn src_loc $
-    lookupBndrRn v             `thenRn` \ new_v ->
-    returnRn (MagicUnfoldingSig new_v str src_loc)
 \end{code}
 
 Checking for distinct signatures; oh, so boring
 
 \begin{code}
-cmp_sig :: RenamedSig -> RenamedSig -> TAG_
-cmp_sig (Sig n1 _ _)              (Sig n2 _ _)           = n1 `cmp` n2
-cmp_sig (InlineSig n1 _)          (InlineSig n2 _)       = n1 `cmp` n2
-cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
-cmp_sig (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
+cmp_sig :: RenamedSig -> RenamedSig -> Ordering
+cmp_sig (Sig n1 _ _)        (Sig n2 _ _)         = n1 `compare` n2
+cmp_sig (InlineSig n1 _)     (InlineSig n2 _)    = n1 `compare` n2
+cmp_sig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = cmpHsType compare ty1 ty2
+cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) 
   = -- may have many specialisations for one value;
        -- but not ones that are exactly the same...
-       thenCmp (n1 `cmp` n2) (cmpHsType cmp ty1 ty2)
+       thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
 
 cmp_sig other_1 other_2                                        -- Tags *must* be different
-  | (sig_tag other_1) _LT_ (sig_tag other_2) = LT_ 
-  | otherwise                               = GT_
+  | (sig_tag other_1) _LT_ (sig_tag other_2) = LT 
+  | otherwise                               = GT
 
 sig_tag (Sig n1 _ _)              = (ILIT(1) :: FAST_INT)
 sig_tag (SpecSig n1 _ _ _)        = ILIT(2)
 sig_tag (InlineSig n1 _)          = ILIT(3)
-sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
+sig_tag (SpecInstSig _ _)         = ILIT(5)
 sig_tag _                         = panic# "tag(RnBinds)"
-
-sig_name (Sig        n _ _)       = n
-sig_name (ClassOpSig n _ _ _)     = n
-sig_name (SpecSig    n _ _ _)     = n
-sig_name (InlineSig  n     _)     = n  
-sig_name (MagicUnfoldingSig n _ _) = n
 \end{code}
 
 %************************************************************************
@@ -542,29 +537,30 @@ sig_name (MagicUnfoldingSig n _ _) = n
 \begin{code}
 dupSigDeclErr (sig:sigs)
   = pushSrcLocRn loc $
-    addErrRn (\sty -> sep [ptext SLIT("more than one"), 
-                            ptext what_it_is, ptext SLIT("given for"), 
-                            ppr sty (sig_name sig)])
+    addErrRn (sep [ptext SLIT("Duplicate"),
+                  ptext what_it_is <> colon,
+                  ppr sig])
   where
     (what_it_is, loc) = sig_doc sig
 
 unknownSigErr sig
   = pushSrcLocRn loc $
-    addErrRn (\sty -> sep [ptext flavour, ptext SLIT("but no definition for"),
-                            ppr sty (sig_name sig)])
+    addErrRn (sep [ptext SLIT("Misplaced"),
+                  ptext what_it_is <> colon,
+                  ppr sig])
   where
-    (flavour, loc) = sig_doc sig
+    (what_it_is, loc) = sig_doc sig
 
 sig_doc (Sig        _ _ loc)       = (SLIT("type signature"),loc)
 sig_doc (ClassOpSig _ _ _ loc)             = (SLIT("class-method type signature"), loc)
-sig_doc (SpecSig    _ _ _ loc)             = (SLIT("SPECIALIZE pragma"),loc)
+sig_doc (SpecSig    _ _ _ loc)             = (SLIT("SPECIALISE pragma"),loc)
 sig_doc (InlineSig  _     loc)             = (SLIT("INLINE pragma"),loc)
-sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
+sig_doc (SpecInstSig _ loc)        = (SLIT("SPECIALISE instance pragma"),loc)
 
-missingSigErr var sty
-  = sep [ptext SLIT("a definition but no type signature for"), ppr sty var]
+missingSigErr var
+  = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
 
-methodBindErr mbind sty
+methodBindErr mbind
  =  hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
-          4 (ppr sty mbind)
+       4 (ppr mbind)
 \end{code}