[project @ 1998-05-04 20:56:54 by sof]
[ghc-hetmet.git] / ghc / compiler / rename / RnBinds.lhs
index d4df584..4f30204 100644 (file)
@@ -9,42 +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()
-IMPORT_DELOOPER(RnLoop)                -- break the RnPass/RnExpr/RnBinds loops
+#include "HsVersions.h"
+
+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, lookupRn, lookupOccRn, isUnboundName )
-
+import RnEnv           ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
+                         newLocalNames, isUnboundName, warnUnusedBinds
+                       )
 import CmdLineOpts     ( opt_SigsRequired )
-import Digraph         ( stronglyConnComp )
-import ErrUtils                ( addErrLoc, addShortErrLocLine )
+import Digraph         ( stronglyConnComp, SCC(..) )
 import Name            ( OccName(..), Provenance, 
-                         Name {- instance Eq -},
-                         NameSet(..), emptyNameSet, mkNameSet, unionNameSets, 
+                         Name, isExportedName,
+                         NameSet, emptyNameSet, mkNameSet, unionNameSets, 
                          minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
                        )
-import Maybes          ( catMaybes )
---import PprStyle--ToDo:rm
-import Pretty
-import Util            ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
-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
 \end{code}
 
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -165,8 +162,7 @@ contains bindings for the binders of this particular binding.
 rnTopBinds    :: RdrNameHsBinds -> RnMS s RenamedHsBinds
 
 rnTopBinds EmptyBinds                    = returnRn EmptyBinds
-rnTopBinds (SingleBind (RecBind bind))    = rnTopMonoBinds bind []
-rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
+rnTopBinds (MonoBind bind sigs _)        = rnTopMonoBinds bind sigs
   -- The parser doesn't produce other forms
 
 
@@ -174,12 +170,17 @@ rnTopMonoBinds EmptyMonoBinds sigs
   = returnRn EmptyBinds
 
 rnTopMonoBinds mbinds sigs
- =  mapRn lookupRn binder_rdr_names    `thenRn` \ binder_names ->
+ =  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))
@@ -202,9 +203,8 @@ rnBinds           :: RdrNameHsBinds
              -> (RenamedHsBinds -> RnMS s (result, FreeVars))
              -> RnMS s (result, FreeVars)
 
-rnBinds EmptyBinds                    thing_inside = thing_inside EmptyBinds
-rnBinds (SingleBind (RecBind bind))    thing_inside = rnMonoBinds bind []   thing_inside
-rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside
+rnBinds EmptyBinds            thing_inside = thing_inside EmptyBinds
+rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
   -- the parser doesn't produce other forms
 
 
@@ -218,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 "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}
@@ -245,29 +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 vertices    = mkVertices mbinds_info
-       edges       = mkEdges     mbinds_info
-       scc_result  = stronglyConnComp (==) edges vertices
-       final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result)
+    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}
@@ -276,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) ->
@@ -296,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_`
-    lookupRn name                              `thenRn` \ name' ->
+    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}
 
 
@@ -343,18 +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_`
-    lookupRn occname                           `thenRn` \ op_name ->
+    mapRn (checkPrecMatch inf name) matches    `thenRn_`
+
+    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                  $
-    lookupRn  occname                  `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)
@@ -382,40 +383,17 @@ This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
 as the two cases are similar.
 
 \begin{code}
-reconstructCycle :: [Edge]     -- Original edges
-                -> FlatMonoBindsInfo
-                -> Cycle
+reconstructCycle :: SCC FlatMonoBindsInfo
                 -> RenamedHsBinds
 
-reconstructCycle edges mbi cycle
-  = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle)
+reconstructCycle (AcyclicSCC (_, _, binds, sigs))
+  = MonoBind binds sigs NonRecursive
+
+reconstructCycle (CyclicSCC cycle)
+  = MonoBind this_gp_binds this_gp_sigs Recursive
   where
-    relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi,
-                                             vertex `is_elem` cycle]
-    (binds, sig_lists) = unzip relevant_binds_and_sigs
-    this_gp_binds      = foldr1 AndMonoBinds binds
-    this_gp_sigs       = foldr1 (++) sig_lists
-  
-    is_elem = isIn "reconstructRec"
-  
-    mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds
-    mk_binds bs [] True  = SingleBind (RecBind    bs)
-    mk_binds bs ss True  = BindWith   (RecBind    bs) ss
-    mk_binds bs [] False = SingleBind (NonRecBind bs)
-    mk_binds bs ss False = BindWith   (NonRecBind bs) ss
-  
-       -- moved from Digraph, as this is the only use here
-       -- (avoid overloading cost).  We have to use elem
-       -- (not FiniteMaps or whatever), because there may be
-       -- many edges out of one vertex.  We give it its own
-       -- "elem" just for speed.
-  
-    isCyclic es []  = panic "isCyclic: empty component"
-    isCyclic es [v] = (v,v) `elem` es
-    isCyclic es vs  = True
-  
-    elem _ []    = False
-    elem x (y:ys) = x==y || elem x ys
+    this_gp_binds      = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
+    this_gp_sigs       = foldr1 (++)        [sigs  | (_, _, _, sigs) <- cycle]
 \end{code}
 
 %************************************************************************
@@ -431,34 +409,24 @@ renamed.
 
 \begin{code}
 type FlatMonoBindsInfo
-  = [(VertexTag,               -- Identifies the 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)
-      [RenamedSig])            -- Signatures, if any, for this vertex
-    ]
-
-mkVertices :: FlatMonoBindsInfo -> [VertexTag]
-mkEdges    :: FlatMonoBindsInfo -> [Edge]
+  = (NameSet,                  -- Set of names defined in this vertex
+     NameSet,                  -- Set of names used in this vertex
+     RenamedMonoBinds,
+     [RenamedSig])             -- Signatures, if any, for this vertex
 
-mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
+mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
 
-mkEdges flat_info       -- An edge (v,v') indicates that v depends on v'
-  = [ (source_vertex, target_vertex)
-    | (source_vertex, _, used_names, _, _) <- flat_info,
-      target_name   <- nameSetToList used_names,
-      target_vertex <- vertices_defining target_name flat_info
+mkEdges flat_info
+  = [ (info, tag, dest_vertices (nameSetToList names_used))
+    | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
     ]
-    where
-    -- If each name only has one binding in this group, then
-    -- vertices_defining will always return the empty list, or a
-    -- singleton.  The case when there is more than one binding (an
-    -- error) needs more thought.
-
-    vertices_defining name flat_info2
-     = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
-                 name `elemNameSet` names_defined
-       ]
+  where
+        -- An edge (v,v') indicates that v depends on v'
+    dest_vertices src_mentions = [ target_vertex
+                                | ((names_defined, _, _, _), target_vertex) <- flat_info,
+                                  mentioned_name <- src_mentions,
+                                  mentioned_name `elemNameSet` names_defined
+                                ]
 \end{code}
 
 
@@ -468,17 +436,19 @@ mkEdges flat_info  -- An edge (v,v') indicates that v depends on v'
 %*                                                                     *
 %************************************************************************
 
-@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' ->
 
@@ -486,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:
@@ -503,15 +479,20 @@ rnBindSigs is_toplev binders sigs
 
 renameSig (Sig v ty src_loc)
   = pushSrcLocRn src_loc $
-    lookupRn v                 `thenRn` \ new_v ->
-    rnHsType ty                        `thenRn` \ new_ty ->
+    lookupBndrRn v                             `thenRn` \ new_v ->
+    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 $
-    lookupRn v                 `thenRn` \ new_v ->
-    rnHsType ty                        `thenRn` \ new_ty ->
-    rn_using using             `thenRn` \ new_using ->
+    lookupBndrRn v                     `thenRn` \ new_v ->
+    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
     rn_using Nothing  = returnRn Nothing
@@ -520,48 +501,31 @@ renameSig (SpecSig v ty using src_loc)
 
 renameSig (InlineSig v src_loc)
   = pushSrcLocRn src_loc $
-    lookupRn v         `thenRn` \ new_v ->
+    lookupBndrRn v             `thenRn` \ new_v ->
     returnRn (InlineSig new_v src_loc)
-
-renameSig (DeforestSig v src_loc)
-  = pushSrcLocRn src_loc $
-    lookupRn v        `thenRn` \ new_v ->
-    returnRn (DeforestSig new_v src_loc)
-
-renameSig (MagicUnfoldingSig v str src_loc)
-  = pushSrcLocRn src_loc $
-    lookupRn 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 (DeforestSig n1 _)         = ILIT(5)
+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}
 
 %************************************************************************
@@ -573,29 +537,30 @@ sig_name (MagicUnfoldingSig n _ _) = n
 \begin{code}
 dupSigDeclErr (sig:sigs)
   = pushSrcLocRn loc $
-    addErrRn (\sty -> ppSep [ppStr "more than one", 
-                           ppStr what_it_is, ppStr "given for", 
-                           ppQuote (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 -> ppSep [ppStr flavour, ppStr "but no definition for",
-                            ppQuote (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)       = ("type signature",loc)
-sig_doc (ClassOpSig _ _ _ loc)             = ("class-method type signature", loc)
-sig_doc (SpecSig    _ _ _ loc)             = ("SPECIALIZE pragma",loc)
-sig_doc (InlineSig  _     loc)             = ("INLINE pragma",loc)
-sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc)
+sig_doc (Sig        _ _ loc)       = (SLIT("type signature"),loc)
+sig_doc (ClassOpSig _ _ _ loc)             = (SLIT("class-method type signature"), loc)
+sig_doc (SpecSig    _ _ _ loc)             = (SLIT("SPECIALISE pragma"),loc)
+sig_doc (InlineSig  _     loc)             = (SLIT("INLINE pragma"),loc)
+sig_doc (SpecInstSig _ loc)        = (SLIT("SPECIALISE instance pragma"),loc)
 
-missingSigErr var sty
-  = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)]
+missingSigErr var
+  = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
 
-methodBindErr mbind sty
- =  ppHang (ppStr "Can't handle multiple methods defined by one pattern binding")
-          4 (ppr sty mbind)
+methodBindErr mbind
+ =  hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
+       4 (ppr mbind)
 \end{code}