[project @ 1998-04-07 16:40:08 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnBinds.lhs
index 18d47c0..a92ac88 100644 (file)
@@ -11,7 +11,7 @@ they may be affected by renaming (which isn't fully worked out yet).
 \begin{code}
 module RnBinds (
        rnTopBinds, rnTopMonoBinds,
-       rnMethodBinds,
+       rnMethodBinds, renameSigs,
        rnBinds, rnMonoBinds
    ) where
 
@@ -20,13 +20,13 @@ module RnBinds (
 import {-# SOURCE #-} RnSource ( rnHsSigType )
 
 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, warnUnusedNames
+import RnEnv           ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
+                         newLocalNames, isUnboundName, warnUnusedBinds
                        )
 import CmdLineOpts     ( opt_SigsRequired )
 import Digraph         ( stronglyConnComp, SCC(..) )
@@ -36,8 +36,7 @@ import Name           ( OccName(..), Provenance,
                          minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
                        )
 import BasicTypes      ( RecFlag(..), TopLevelFlag(..) )
-import Maybes          ( catMaybes )
-import Util            ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, assocDefault )
+import Util            ( thenCmp, removeDups, panic, panic#, assertPanic )
 import UniqSet         ( UniqSet )
 import ListSetOps      ( minusList )
 import Bag             ( bagToList )
@@ -181,7 +180,7 @@ rnTopMonoBinds mbinds sigs
     let
        unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
     in
-    warnUnusedNames unused_binders     `thenRn_`
+    warnUnusedBinds unused_binders     `thenRn_`
     returnRn new_binds
   where
     binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
@@ -233,7 +232,7 @@ rnMonoBinds mbinds sigs     thing_inside -- Non-empty monobinds
        net_fvs        = all_fvs `minusNameSet` binder_set
        unused_binders = binder_set `minusNameSet` all_fvs
     in
-    warnUnusedNames unused_binders     `thenRn_`
+    warnUnusedBinds unused_binders     `thenRn_`
     returnRn (result, net_fvs)
   where
     mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
@@ -264,16 +263,16 @@ 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 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}
@@ -282,19 +281,18 @@ rn_mono_binds 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) ->
@@ -302,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}
 
 
@@ -349,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)
@@ -396,14 +386,14 @@ as the two cases are similar.
 reconstructCycle :: SCC FlatMonoBindsInfo
                 -> RenamedHsBinds
 
-reconstructCycle (AcyclicSCC (_, _, _, binds, sigs))
+reconstructCycle (AcyclicSCC (_, _, binds, sigs))
   = MonoBind binds sigs NonRecursive
 
 reconstructCycle (CyclicSCC cycle)
   = 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}
 
 %************************************************************************
@@ -419,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
                                 ]
@@ -448,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 :: TopLevelFlag
-          -> NameSet                   -- Set of names bound in this group
-          -> [RdrNameSig]
-          -> RnMS s [RenamedSig]                -- List of Sig constructors
-
-rnBindSigs top_lev binders sigs
+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
+
+renameSigs top_lev inst_decl binders sigs
   =     -- Rename the signatures
     mapRn renameSig sigs       `thenRn` \ sigs' ->
 
@@ -466,8 +456,9 @@ rnBindSigs top_lev 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]
        sigs_required   = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
        un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
@@ -475,6 +466,11 @@ rnBindSigs top_lev binders sigs
     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:
@@ -487,6 +483,11 @@ renameSig (Sig v ty src_loc)
     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 ->
@@ -502,21 +503,16 @@ 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 -> Ordering
-cmp_sig (Sig n1 _ _)              (Sig n2 _ _)           = n1 `compare` n2
-cmp_sig (InlineSig n1 _)          (InlineSig n2 _)       = n1 `compare` n2
-cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `compare` n2
-cmp_sig (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
+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 `compare` n2) (cmpHsType compare ty1 ty2)
@@ -528,14 +524,8 @@ cmp_sig other_1 other_2                                    -- Tags *must* be different
 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}
 
 %************************************************************************
@@ -547,27 +537,28 @@ sig_name (MagicUnfoldingSig n _ _) = n
 \begin{code}
 dupSigDeclErr (sig:sigs)
   = pushSrcLocRn loc $
-    addErrRn (sep [ptext SLIT("more than one"), 
-                  ptext what_it_is, ptext SLIT("given for"), 
-                  quotes (ppr (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 (sep [ptext flavour, ptext SLIT("but no definition for"),
-                  quotes (ppr (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
-  = sep [ptext SLIT("a definition but no type signature for"), quotes (ppr var)]
+  = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
 
 methodBindErr mbind
  =  hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))