[project @ 2000-02-09 18:32:09 by lewie]

Misc. fixes to implicit parameters support.

diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 3b0cd48..721325d 100644 (file)
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -137,7 +137,8 @@ mkIPName :: Unique -> OccName -> Name
 mkIPName uniq occ
   = Name { n_uniq = uniq,
           n_sort = Local,
-          n_occ  = mkIPOcc occ,
+          n_occ  = occ,
+          -- ZZ is this an appropriate provinence?
           n_prov = SystemProv }
 
 ------------------------- Wired in names -------------------------
@@ -240,6 +241,7 @@ all_toplev_ids_visible =
        opt_EnsureSplittableC            -- Splitting requires visiblilty
 \end{code}
 
+
 \begin{code}
 setNameProvenance :: Name -> Provenance -> Name        
        -- setNameProvenance used to only change the provenance of 

diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index c530956..ba980ee 100644 (file)
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -213,7 +213,7 @@ pprExpr e = pprDeeper (ppr_expr e)
 pprBinds b = pprDeeper (ppr b)
 
 ppr_expr (HsVar v) = ppr v
-ppr_expr (HsIPVar v) = char '?' <> ppr v
+ppr_expr (HsIPVar v) = {- char '?' <> -} ppr v
 
 ppr_expr (HsLit    lit)   = ppr lit
 ppr_expr (HsLitOut lit _) = ppr lit

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 0f70df5..c9637b4 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -52,6 +52,8 @@ data HsType name
   | MonoTupleTy                [HsType name]   -- Element types (length gives arity)
                        Bool            -- boxed?
 
+  | MonoIParamTy       name (HsType name)
+
   -- these next two are only used in interfaces
   | MonoDictTy         name    -- Class
                        [HsType name]
@@ -135,7 +137,7 @@ pprHsPred :: (Outputable name) => HsPred name -> SDoc
 pprHsPred (HsPClass clas tys)
   = ppr clas <+> hsep (map pprParendHsType tys)
 pprHsPred (HsPIParam n ty)
-  = hsep [char '?' <> ppr n, text "::", ppr ty]
+  = hsep [{- char '?' <> -} ppr n, text "::", ppr ty]
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index e882a37..056880e 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -50,7 +50,7 @@ import Class          ( Class, classExtraBigSig )
 import FieldLabel      ( fieldLabelName, fieldLabelType )
 import Type            ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
                          deNoteType, classesToPreds,
-                         Type, ThetaType
+                         Type, ThetaType, PredType(..), ClassContext
                        )
 
 import PprType
@@ -578,15 +578,21 @@ ppr_decl_context :: ThetaType -> SDoc
 ppr_decl_context []    = empty
 ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
 
-ppr_decl_class_context :: [(Class,[Type])] -> SDoc
+ppr_decl_class_context :: ClassContext -> SDoc
 ppr_decl_class_context []    = empty
 ppr_decl_class_context ctxt  = pprIfaceClasses ctxt <+> ptext SLIT(" =>")
 
 pprIfaceTheta :: ThetaType -> SDoc     -- Use braces rather than parens in interface files
 pprIfaceTheta []    = empty
-pprIfaceTheta theta = braces (hsep (punctuate comma [pprPred p | p <- theta]))
+pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta]))
 
-pprIfaceClasses :: [(Class,[Type])] -> SDoc
+-- ZZ - not sure who uses this - i.e. whether IParams really show up or not
+-- (it's not used to print normal value signatures)
+pprIfacePred :: PredType -> SDoc
+pprIfacePred (Class clas tys) = pprConstraint clas tys
+pprIfacePred (IParam n ty)    = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty
+
+pprIfaceClasses :: ClassContext -> SDoc
 pprIfaceClasses []    = empty
 pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
 \end{code}

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 8dae914..7d74bed 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -595,7 +595,7 @@ lexToken cont glaexts buf =
               cont (ITunknown "\NUL") (stepOn buf)
 
     '?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
-           lex_ip cont (setCurrentPos# buf 1#)
+           lex_ip cont (stepOn buf)
     c | is_digit  c -> lex_num cont glaexts 0 buf
       | is_symbol c -> lex_sym cont buf
       | is_upper  c -> lex_con cont glaexts buf

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index b410fee..c396e3f 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -136,13 +136,21 @@ checkInstType t
 
 checkContext :: RdrNameHsType -> P RdrNameContext
 checkContext (MonoTupleTy ts True) 
-  = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
-    returnP (map (uncurry HsPClass) cs)
+  = mapP (\t -> checkPred t []) ts `thenP` \ps ->
+    returnP ps
 checkContext (MonoTyVar t) -- empty contexts are allowed
   | t == unitTyCon_RDR = returnP []
 checkContext t 
-  = checkAssertion t [] `thenP` \(c,ts) ->
-    returnP [HsPClass c ts]
+  = checkPred t [] `thenP` \p ->
+    returnP [p]
+
+checkPred :: RdrNameHsType -> [RdrNameHsType] 
+       -> P (HsPred RdrName)
+checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) 
+       = returnP (HsPClass t args)
+checkPred (MonoTyApp l r) args = checkPred l (r:args)
+checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
+checkPred _ _ = parseError "Illegal class assertion"
 
 checkAssertion :: RdrNameHsType -> [RdrNameHsType] 
        -> P (HsClassAssertion RdrName)

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 759c2dc..a94edff 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.19 2000/01/28 20:52:39 lewie Exp $
+$Id: Parser.y,v 1.20 2000/02/09 18:32:10 lewie Exp $
 
 Haskell grammar.
 
@@ -35,6 +35,7 @@ import GlaExts
 {-
 -----------------------------------------------------------------------------
 Conflicts: 14 shift/reduce
+       (note: it's currently 21 -- JRL, 31/1/2000)
 
 8 for abiguity in 'if x then y else z + 1'
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
@@ -85,7 +86,6 @@ Conflicts: 14 shift/reduce
  'then'        { ITthen }
  'type'        { ITtype }
  'where'       { ITwhere }
- 'with'        { ITwith }
  '_scc_'       { ITscc }
 
  'forall'      { ITforall }                    -- GHC extension keywords
@@ -94,6 +94,7 @@ Conflicts: 14 shift/reduce
  'label'       { ITlabel } 
  'dynamic'     { ITdynamic }
  'unsafe'      { ITunsafe }
+ 'with'        { ITwith }
  'stdcall'      { ITstdcallconv }
  'ccall'        { ITccallconv }
  '_ccall_'     { ITccall (False, False, False) }
@@ -174,7 +175,8 @@ Conflicts: 14 shift/reduce
  QCONID        { ITqconid   $$ }
  QVARSYM       { ITqvarsym  $$ }
  QCONSYM       { ITqconsym  $$ }
- IPVARID       { ITipvarid  $$ }
+
+ IPVARID       { ITipvarid  $$ }               -- GHC extension
 
  PRAGMA                { ITpragma   $$ }
 
@@ -489,6 +491,7 @@ type :: { RdrNameHsType }
 
 btype :: { RdrNameHsType }
        : btype atype                   { MonoTyApp $1 $2 }
+       | IPVARID '::' type             { MonoIParamTy (mkSrcUnqual ipName $1) $3 }
        | atype                         { $1 }
 
 atype :: { RdrNameHsType }

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 950fe54..2d3239a 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -145,7 +145,8 @@ import Ratio ( (%) )
  QCONID        { ITqconid   $$ }
  QVARSYM       { ITqvarsym  $$ }
  QCONSYM       { ITqconsym  $$ }
- IPVARID       { ITipvarid  $$ }
+
+ IPVARID       { ITipvarid  $$ }               -- GHC extension
 
  PRAGMA                { ITpragma   $$ }
 
@@ -452,6 +453,7 @@ atype               :  qtc_name                             { MonoTyVar $1 }
                |  '(#' types0 '#)'                     { MonoTupleTy $2 False{-unboxed-} }
                |  '[' type ']'                         { MonoListTy  $2 }
                |  '{' qcls_name atypes '}'             { MonoDictTy $2 $3 }
+               |  '{' IPVARID '::' type '}'            { MonoIParamTy (mkSysUnqual ipName $2) $4 }
                |  '(' type ')'                         { $2 }
 
 -- This one is dealt with via qtc_name

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index ad7df46..9f8e343 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -25,10 +25,11 @@ module Inst (
 
        lookupInst, lookupSimpleInst, LookupInstResult(..),
 
-       isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
+       isDict, isClassDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
        instBindingRequired, instCanBeGeneralised,
 
-       zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
+       zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
+       instToId, instToIdBndr, ipToId,
 
        InstOrigin(..), InstLoc, pprInstLoc
     ) where
@@ -52,7 +53,8 @@ import Class  ( classInstEnv, Class )
 import FunDeps ( instantiateFdClassTys )
 import Id      ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
 import PrelInfo        ( isStandardClass, isCcallishClass, isNoDictClass )
-import Name    ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName, nameUnique )
+import Name    ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
+                 getOccName, nameUnique )
 import PprType ( pprPred )     
 import InstEnv ( InstEnv, lookupInstEnv )
 import SrcLoc  ( SrcLoc )
@@ -310,8 +312,11 @@ Predicates
 ~~~~~~~~~~
 \begin{code}
 isDict :: Inst -> Bool
-isDict (Dict _ (Class _ _) _) = True
+isDict (Dict _ _ _) = True
 isDict other         = False
+isClassDict :: Inst -> Bool
+isClassDict (Dict _ (Class _ _) _) = True
+isClassDict other            = False
 
 isMethodFor :: TcIdSet -> Inst -> Bool
 isMethodFor ids (Method uniq id tys _ _ loc) 
@@ -485,9 +490,7 @@ instToIdBndr :: Inst -> TcId
 instToIdBndr (Dict u (Class clas ty) (_,loc,_))
   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
---  = mkUserLocal (mkIPOcc (getOccName n)) u (mkPredTy (IParam n ty)) loc
-  = mkUserLocal (getOccName n) (nameUnique n) (mkPredTy (IParam n ty)) loc
---  = mkVanillaId n ty
+  = ipToId n ty loc
 
 instToIdBndr (Method u id tys theta tau (_,loc,_))
   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
@@ -497,6 +500,9 @@ instToIdBndr (LitInst u list ty loc)
 
 instToIdBndr (FunDep clas fds _)
   = panic "FunDep escaped!!!"
+
+ipToId n ty loc
+  = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
 \end{code}
 
 
@@ -539,6 +545,8 @@ zonkInst (FunDep clas fds loc)
   = zonkFunDeps fds                    `thenNF_Tc` \ fds' ->
     returnNF_Tc (FunDep clas fds' loc)
 
+zonkInsts insts = mapNF_Tc zonkInst insts
+
 zonkFunDeps fds = mapNF_Tc zonkFd fds
   where
   zonkFd (ts1, ts2)

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index ec5a592..d9dc3a2 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -291,7 +291,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        -- SIMPLIFY THE LIE
     tcExtendGlobalTyVars tyvars_not_to_gen (
        let ips = getIPsOfLIE lie_req in
-       if null real_tyvars_to_gen_list && null ips then
+       if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
                -- No polymorphism, and no IPs, so no need to simplify context
            returnTc (lie_req, EmptyMonoBinds, [])
        else

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 273d259..b125752 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -25,7 +25,7 @@ import Inst           ( Inst, InstOrigin(..), OverloadedLit(..),
                          lieToList, listToLIE, tyVarsOfLIE, zonkLIE,
                          newOverloadedLit, newMethod, newIPDict,
                          instOverloadedFun, newDicts, newClassDicts,
-                         partitionLIEbyMeth, getIPsOfLIE
+                         partitionLIEbyMeth, getIPsOfLIE, instToId, ipToId
                        )
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcInstId,
@@ -200,10 +200,11 @@ tcMonoExpr (HsVar name) res_ty
 
 \begin{code}
 tcMonoExpr (HsIPVar name) res_ty
+  -- ZZ What's the `id' used for here...
   = let id = mkVanillaId name res_ty in
     tcGetInstLoc (OccurrenceOf id)     `thenNF_Tc` \ loc ->
     newIPDict name res_ty loc          `thenNF_Tc` \ ip ->
-    returnNF_Tc (HsIPVar id, unitLIE ip)
+    returnNF_Tc (HsIPVar (instToId ip), unitLIE ip)
 \end{code}
 
 %************************************************************************
@@ -746,7 +747,8 @@ tcMonoExpr (HsWith expr binds) res_ty
 
 tcIPBinds ((name, expr) : binds)
   = newTyVarTy_OpenKind                `thenTc` \ ty ->
-    let id = mkVanillaId name ty in
+    tcGetSrcLoc                        `thenTc` \ loc ->
+    let id = ipToId name ty loc in
     tcMonoExpr expr ty         `thenTc` \ (expr', lie) ->
     zonkTcType ty              `thenTc` \ ty' ->
     tcIPBinds binds            `thenTc` \ (binds', types, lie2) ->

diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs
index 0cacae3..dfe35dd 100644 (file)
--- a/ghc/compiler/typecheck/TcImprove.lhs
+++ b/ghc/compiler/typecheck/TcImprove.lhs
@@ -12,7 +12,7 @@ import TcMonad
 import TcType          ( zonkTcType, zonkTcTypes )
 import TcUnify         ( unifyTauTyLists )
 import Inst            ( Inst, LookupInstResult(..),
-                         lookupInst, isDict, getFunDepsOfLIE, getIPsOfLIE,
+                         lookupInst, getFunDepsOfLIE, getIPsOfLIE,
                          zonkLIE, zonkFunDeps {- for debugging -} )
 import InstEnv         ( InstEnv )             -- Reqd for 4.02; InstEnv is a synonym, and
                                                -- 4.02 doesn't "see" it soon enough

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 4fe0e3e..ce5d681 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -198,13 +198,13 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty)
                --      f :: forall a. Num a => (# a->a, a->a #)
                -- And we want these to get through the type checker
         check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau)
-                              | otherwise = returnTc ()
          where ct_vars = tyVarsOfTypes tys
                forall_tyvars = map varName in_scope_vars
                tau_vars = tyVarsOfType tau
                ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
                               not (ct_var `elemUFM` tau_vars)
                ambiguous = foldUFM ((||) . ambig) False ct_vars
+       check _ = returnTc ()
     in
     mapTc check theta                  `thenTc_`
     returnTc (body_kind, mkSigmaTy tyvars theta tau)

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 104fc9d..4de479c 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -132,7 +132,8 @@ import TcHsSyn              ( TcExpr, TcId,
 import TcMonad
 import Inst            ( lookupInst, lookupSimpleInst, LookupInstResult(..),
                          tyVarsOfInst, tyVarsOfInsts,
-                         isDict, isStdClassTyVarDict, isMethodFor, notFunDep,
+                         isDict, isClassDict, isStdClassTyVarDict,
+                         isMethodFor, notFunDep,
                          instToId, instBindingRequired, instCanBeGeneralised,
                          newDictFromOld,
                          getDictClassTys, getIPs,
@@ -220,8 +221,6 @@ tcSimplify str local_tvs wanted_lie
        (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
        ambig_tv_fn dict    = tyVarsOfInst dict `minusVarSet` avail_tvs
     in
-    -- pprTrace "tcS" (ppr (frees, irreds')) $
-    -- pprTrace "tcS bad" (ppr bad_guys) $
     addAmbigErrs ambig_tv_fn bad_guys  `thenNF_Tc_`
 
 
@@ -288,7 +287,7 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie
     givens  = lieToList given_lie
     -- see comment on wanteds in tcSimplify
     wanteds = filter notFunDep (lieToList wanted_lie)
-    given_dicts = filter isDict givens
+    given_dicts = filter isClassDict givens
 
     try_me inst 
       -- Does not constrain a local tyvar
@@ -722,7 +721,7 @@ addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
                -- Invariant: the Inst is already in Avails.
 
 addSuperClasses avails dict
-  | not (isDict dict)
+  | not (isClassDict dict)
   = returnNF_Tc avails
 
   | otherwise  -- It is a dictionary
@@ -1217,7 +1216,7 @@ addNoInstanceErr str givens dict
         ptext SLIT("Probable cause:") <+> 
              vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
                    ptext SLIT("in") <+> str],
-                   if isDict dict && all_tyvars then empty else
+                   if isClassDict dict && all_tyvars then empty else
                    ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
     )
   where

diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 24294ba..db54a7d 100644 (file)
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -69,7 +69,7 @@ pprParendKind = pprParendType
 
 pprPred :: PredType -> SDoc
 pprPred (Class clas tys) = pprConstraint clas tys
-pprPred (IParam n ty)    = ppr n <+> ppr ty
+pprPred (IParam n ty)    = hsep [ppr n, ptext SLIT("::"), ppr ty]
 
 pprConstraint :: Class -> [Type] -> SDoc
 pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
@@ -189,7 +189,7 @@ ppr_ty env ctxt_prec ty@(ForAllTy _ _)
                          <+> ptext SLIT("=>")
 
     ppr_pred (Class clas tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)
-    ppr_pred (IParam n ty)    = hsep [char '?' <> ppr n, text "::",
+    ppr_pred (IParam n ty)    = hsep [{- char '?' <> -} ppr n, text "::",
                                      ppr_ty env tYCON_PREC ty]
 
 ppr_ty env ctxt_prec (FunTy ty1 ty2)

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index a060f63..cba55fb 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -89,7 +89,7 @@ import Var    ( TyVar, IdOrTyVar, UVar,
 import VarEnv
 import VarSet
 
-import Name    ( Name, NamedThing(..), mkLocalName, tidyOccName,
+import Name    ( Name, NamedThing(..), mkLocalName, tidyOccName
                )
 import NameSet
 import Class   ( classTyCon, Class )
@@ -864,7 +864,7 @@ tidyType env@(tidy_env, subst) ty
     go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
     go_note note@(UsgNote _)    = note  -- Usage annotation is already tidy
     go_note note@(UsgForAll _)  = note  -- Uvar binder is already tidy
-    go_note note@(IPNote _)    = note  -- IP is already tidy
+    go_note (IPNote n)         = IPNote (tidyIPName n)
 
 tidyTypes  env tys    = map (tidyType env) tys
 \end{code}
@@ -888,6 +888,12 @@ tidyTopType :: Type -> Type
 tidyTopType ty = tidyType emptyTidyEnv ty
 \end{code}
 
+\begin{code}
+tidyIPName :: Name -> Name
+tidyIPName name
+  = mkLocalName (getUnique name) (getOccName name) noSrcLoc
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *