[add DeNameable class to un-rename source before printing error messages.
John Meacham <john@repetae.net>**20120201015918
 Ignore-this: 959bd035adf0dbf03cd36da091ecb519
] hunk ./src/E/Values.hs 111
-eJustIO w x = eTuple' [w,x] -- ELit litCons { litName = dc_JustIO, litArgs = [w,x], litType = ELit litCons { litName = tc_IOResult, litArgs = [getType x], litType = eStar } }
-tIO t = ELit (litCons { litName = tc_IO, litArgs = [t], litType = eStar })
+eJustIO w x = eTuple' [w,x]
hunk ./src/E/Values.hs 161
---tWorldzh = ELit litCons { litName = tc_World__, litArgs = [], litType = eHash }
hunk ./src/FrontEnd/Rename.hs 6
+    DeNameable(..),
hunk ./src/FrontEnd/Rename.hs 10
-import Data.Char
hunk ./src/FrontEnd/Rename.hs 11
+import Control.Monad.Identity
hunk ./src/FrontEnd/Rename.hs 14
-import List hiding(union)
+import Data.Char
hunk ./src/FrontEnd/Rename.hs 16
+import List hiding(union)
hunk ./src/FrontEnd/Rename.hs 48
-type SubTable = Map.Map HsName HsName
+type SubTable = Map.Map Name Name
hunk ./src/FrontEnd/Rename.hs 86
-        
+
hunk ./src/FrontEnd/Rename.hs 90
-    ds' :: [(HsName,[(HsName,HsBangType)])]
+    ds' :: [(Name,[(Name,HsBangType)])]
hunk ./src/FrontEnd/Rename.hs 165
-qualifyMethodName :: Maybe Module -> HsName -> HsName
+qualifyMethodName :: Maybe Module -> Name -> Name
hunk ./src/FrontEnd/Rename.hs 256
-        updateWith (Set.toList $ freeVars hsNames :: [HsName]) $ do
+        updateWith (Set.toList $ freeVars hsNames :: [Name]) $ do
hunk ./src/FrontEnd/Rename.hs 475
-buildRecPat :: FieldMap -> HsName -> [HsPatField] -> RM HsPat
+buildRecPat :: FieldMap -> Name -> [HsPatField] -> RM HsPat
hunk ./src/FrontEnd/Rename.hs 495
-        hsName' <- renameName (toName FieldLabel hsName) --renameHsName hsName gt
+        hsName' <- renameName (toName FieldLabel hsName) --renameName hsName gt
hunk ./src/FrontEnd/Rename.hs 515
-    --let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromHsName hsName' -} ++ "_var@"))
+    --let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromName hsName' -} ++ "_var@"))
hunk ./src/FrontEnd/Rename.hs 582
-buildRecConstr ::  FieldMap -> HsName -> [HsFieldUpdate] -> RM HsExp
+buildRecConstr ::  FieldMap -> Name -> [HsFieldUpdate] -> RM HsExp
hunk ./src/FrontEnd/Rename.hs 660
- --       hsName' <- renameHsName hsName gt      -- TODO field names should have own namespace
+ --       hsName' <- renameName hsName gt      -- TODO field names should have own namespace
hunk ./src/FrontEnd/Rename.hs 665
-renameValName :: HsName -> RM HsName
+renameValName :: Name -> RM Name
hunk ./src/FrontEnd/Rename.hs 668
-renameTypeName :: HsName -> RM HsName
+renameTypeName :: Name -> RM Name
hunk ./src/FrontEnd/Rename.hs 700
-clobberName :: HsName -> RM SubTable
+clobberName :: Name -> RM SubTable
hunk ./src/FrontEnd/Rename.hs 705
-renameAndQualify :: HsName -> Int -> Module -> HsName
+renameAndQualify :: Name -> Int -> Module -> Name
hunk ./src/FrontEnd/Rename.hs 710
-unRename :: HsName -> HsName
+unRename :: Name -> Name
hunk ./src/FrontEnd/Rename.hs 727
-    getNames :: a -> [HsName]
+    getNames :: a -> [Name]
hunk ./src/FrontEnd/Rename.hs 733
-instance UpdateTable HsName where
+instance UpdateTable Name where
hunk ./src/FrontEnd/Rename.hs 737
-    getNames hsDecl = fsts $ getHsNamesAndASrcLocsFromHsDecl hsDecl
+    getNames hsDecl = fsts $ getNamesAndASrcLocsFromHsDecl hsDecl
hunk ./src/FrontEnd/Rename.hs 741
-    getNames hsStmt = fsts $ getHsNamesAndASrcLocsFromHsStmt hsStmt
+    getNames hsStmt = fsts $ getNamesAndASrcLocsFromHsStmt hsStmt
hunk ./src/FrontEnd/Rename.hs 749
-getHsNamesAndASrcLocsFromHsDecl :: HsDecl -> [(HsName, SrcLoc)]
-getHsNamesAndASrcLocsFromHsDecl d = f d where
+getNamesAndASrcLocsFromHsDecl :: HsDecl -> [(Name, SrcLoc)]
+getNamesAndASrcLocsFromHsDecl d = f d where
hunk ./src/FrontEnd/Rename.hs 806
-getHsNamesAndASrcLocsFromHsStmt :: HsStmt -> [(HsName, SrcLoc)]
-getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc)
-getHsNamesAndASrcLocsFromHsStmt (HsQualifier _hsExp) = []
-getHsNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concat $ map getHsNamesAndASrcLocsFromHsDecl hsDecls
+getNamesAndASrcLocsFromHsStmt :: HsStmt -> [(Name, SrcLoc)]
+getNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc)
+getNamesAndASrcLocsFromHsStmt (HsQualifier _hsExp) = []
+getNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concat $ map getNamesAndASrcLocsFromHsDecl hsDecls
hunk ./src/FrontEnd/Rename.hs 842
+
+class DeNameable a where
+    deName :: Module -> a -> a
+
+instance (Functor f,DeNameable a) => DeNameable (f a) where
+    deName m fx = fmap (deName m) fx
+
+instance DeNameable Name where
+    deName mod name = mapName' fm unRenameString name where
+        fm (Just m) | m == mod = Nothing
+                    | m `elem` removedMods = Nothing
+        fm m = m
+        removedMods = map toModule [
+            "Prelude","Jhc.Basics","Jhc.Prim.IO","Jhc.Type.Word","Jhc.Type.Basic"]
+
+instance DeNameable HsPat where
+    deName mod p = f p where
+        f (HsPVar v) = HsPVar (deName mod v)
+        f (HsPNeg p) = HsPNeg (f p)
+        f (HsPIrrPat p) = HsPIrrPat (deName mod p)
+        f (HsPBangPat p) = HsPBangPat (deName mod p)
+        f (HsPParen p) = HsPParen (f p)
+        f (HsPApp cn pats) = HsPApp (deName mod cn) (deName mod pats)
+        f (HsPList pats) = HsPList (deName mod pats)
+        f (HsPAsPat n p) = HsPAsPat (deName mod n) (deName mod p)
+        f p = p
+
+--instance DeNameable n => DeNameable Located l n where
+--    deName mod p 
+
+instance DeNameable HsAlt where
+    deName _ n = n
+
+instance DeNameable HsExp where
+    deName mod e = f e where
+        dn :: DeNameable b => b -> b
+        dn n = deName mod n
+        f (HsVar hsName) = HsVar (dn hsName)
+        f (HsCon hsName) = HsCon (dn hsName)
+        f (HsLambda srcLoc hsPats hsExp) =
+            HsLambda srcLoc (dn hsPats) (dn hsExp)
+        f (HsCase hsExp hsAlts) =
+            HsCase (dn hsExp) (dn hsAlts)
+        f p = runIdentity $ traverseHsExp (return . dn) p
+--        f (HsDo hsStmts) = do
+--        (ss,()) <- renameHsStmts hsStmts (return ())
+--        doToExp newVar (nameName v_bind) (nameName v_bind_) (nameName v_fail) ss
+--    rename (HsRecConstr hsName hsFieldUpdates) = do
+--        hsName' <- renameValName hsName
+--        hsFieldUpdates' <- rename hsFieldUpdates
+--        fls <- asks envFieldLabels
+--        buildRecConstr fls hsName' (hsFieldUpdates'::[HsFieldUpdate])
+--    rename (HsRecUpdate hsExp hsFieldUpdates) = do
+--        hsExp' <- rename hsExp
+--        hsFieldUpdates' <- rename hsFieldUpdates
+--        fls <- asks envFieldLabels
+--        buildRecUpdate fls hsExp' hsFieldUpdates' -- HsRecConstr hsName' hsFieldUpdates')
+        --return (HsRecUpdate hsExp' hsFieldUpdates')
+--    rename (HsListComp hsExp hsStmts) = do
+--        (ss,e) <- renameHsStmts hsStmts (rename hsExp)
+--        listCompToExp newVar e ss
+--    rename (HsExpTypeSig srcLoc hsExp hsQualType) = do
+--        hsExp' <- rename hsExp
+--        updateWith hsQualType $ do
+--            hsQualType' <- rename hsQualType
+--            return (HsExpTypeSig srcLoc hsExp' hsQualType')
+--    rename (HsAsPat hsName hsExp) = HsAsPat <$> renameValName hsName <*> rename hsExp
+--    rename (HsWildCard sl) = do
+--        withSrcLoc sl $ do
+--            e <- createError HsErrorUnderscore ("_")
+--            return e
hunk ./src/FrontEnd/Syn/Traverse.hs 11
-
hunk ./src/FrontEnd/Syn/Traverse.hs 25
-
hunk ./src/FrontEnd/Syn/Traverse.hs 28
-
hunk ./src/FrontEnd/Syn/Traverse.hs 277
-
-
hunk ./src/FrontEnd/Tc/Main.hs 153
-tiExpr (HsCase e alts) typ = withContext (simpleMsg $ "in the case expression\n   case " ++ render (ppHsExp e) ++ " of ...") $ do
+tiExpr (HsCase e alts) typ = do
+    dn <- getDeName
+    withContext (simpleMsg $ "in the case expression\n   case " ++ render (ppHsExp $ dn e) ++ " of ...") $ do
hunk ./src/FrontEnd/Tc/Main.hs 195
-tiExpr expr@(HsExpTypeSig sloc e qt) typ =  withContext (locMsg sloc "in the annotated expression" $ render $ ppHsExp expr) $ do
+tiExpr expr@(HsExpTypeSig sloc e qt) typ = 
+    deNameContext (Just sloc) "in the annotated expression" expr $ do
hunk ./src/FrontEnd/Tc/Main.hs 223
-tiExpr expr@HsApp {} typ = withContext (makeMsg "in the application" $ render $ ppHsExp $ backToApp h as) $ do
+tiExpr expr@HsApp {} typ = deNameContext Nothing "in the application" (backToApp h as) $ do
hunk ./src/FrontEnd/Tc/Main.hs 233
-tiExpr expr@(HsInfixApp e1 e2 e3) typ = withContext (makeMsg "in the infix application" $ render $ ppHsExp expr) $ do
+tiExpr expr@(HsInfixApp e1 e2 e3) typ = deNameContext Nothing "in the infix application" expr $ do
hunk ./src/FrontEnd/Tc/Main.hs 241
-tiExpr expr@(HsNegApp e) typ = withContext (makeMsg "in the negative expression" $ render $ ppHsExp expr) $ do
+tiExpr expr@(HsNegApp e) typ = deNameContext Nothing "in the negative expression" expr $ do
hunk ./src/FrontEnd/Tc/Main.hs 247
-tiExpr expr@(HsLambda sloc ps e) typ = withContext (locSimple sloc $ "in the lambda expression\n   \\" ++ show (pprint ps:: P.Doc) ++ " -> ...") $ do
+tiExpr expr@(HsLambda sloc ps e) typ = do
+    dn <- getDeName
+    withContext (locSimple sloc $ "in the lambda expression\n   \\" ++ show (pprint (dn ps):: P.Doc) ++ " -> ...") $ do
hunk ./src/FrontEnd/Tc/Main.hs 277
-tiExpr (HsIf e e1 e2) typ = withContext (simpleMsg $ "in the if expression\n   if " ++ show e ++ "...") $ do
+tiExpr (HsIf e e1 e2) typ = do 
+    dn <- getDeName
+    withContext (simpleMsg $ "in the if expression\n   if " ++ show (dn e) ++ "...") $ do
hunk ./src/FrontEnd/Tc/Main.hs 285
-tiExpr tuple@(HsTuple exps@(_:_)) typ = withContext (makeMsg "in the tuple" $ render $ ppHsExp tuple) $ do
+tiExpr tuple@(HsTuple exps@(_:_)) typ = deNameContext Nothing "in the tuple" tuple $ do
hunk ./src/FrontEnd/Tc/Main.hs 290
-tiExpr tuple@(HsUnboxedTuple exps) typ = withContext (makeMsg "in the unboxed tuple" $ render $ ppHsExp tuple) $ do
+tiExpr tuple@(HsUnboxedTuple exps) typ = deNameContext Nothing "in the unboxed tuple" tuple $ do
hunk ./src/FrontEnd/Tc/Main.hs 307
-tiExpr expr@(HsList exps@(_:_)) (TAp tList' v) | tList == tList' = withContext (makeMsg "in the list " $ render $ ppHsExp expr) $ do
+tiExpr expr@(HsList exps@(_:_)) (TAp tList' v) | tList == tList' = deNameContext Nothing "in the list " expr $ do
hunk ./src/FrontEnd/Tc/Main.hs 312
-tiExpr expr@(HsList exps@(_:_)) typ = withContext (makeMsg "in the list " $ render $ ppHsExp expr) $ do
+tiExpr expr@(HsList exps@(_:_)) typ = deNameContext Nothing "in the list " expr $ do
hunk ./src/FrontEnd/Tc/Main.hs 324
-tiExpr expr@(HsLet decls e) typ = withContext (makeMsg "in the let binding" $ render $ ppHsExp expr) $ do
+tiExpr expr@(HsLet decls e) typ = deNameContext Nothing "in the let binding" expr $ do
hunk ./src/FrontEnd/Tc/Main.hs 347
+deNameContext :: Maybe SrcLoc -> String -> HsExp -> Tc a -> Tc a
+deNameContext sl desc e action = do
+    dn <- getDeName
+    let mm = maybe makeMsg locMsg  sl
+    withContext (mm desc (render $ ppHsExp (dn e))) action
+
hunk ./src/FrontEnd/Tc/Module.hs 247
-        tcInfoModName =  show moduleName,
+        tcInfoModName = moduleName,
hunk ./src/FrontEnd/Tc/Monad.hs 1
+{-# LANGUAGE ImpredicativeTypes #-}
hunk ./src/FrontEnd/Tc/Monad.hs 24
+    getDeName,
hunk ./src/FrontEnd/Tc/Monad.hs 26
-    getModName,
hunk ./src/FrontEnd/Tc/Monad.hs 71
+import FrontEnd.Rename(DeNameable(..))
hunk ./src/FrontEnd/Tc/Monad.hs 123
-    tcInfoModName :: String,
+    tcInfoModName :: Module,
hunk ./src/FrontEnd/Tc/Monad.hs 128
+getDeName :: DeNameable n => Tc (n -> n)
+getDeName = do
+    mn <- asks (tcInfoModName . tcInfo)
+    return (\n -> deName mn n)
+
hunk ./src/FrontEnd/Tc/Monad.hs 140
-    local (tcConcreteEnv_u (cenv `Map.union`) . tcMutableEnv_u ((menv `Map.union`) . Map.filterWithKey (\k _ -> k `Map.notMember` cenv))) act
+    local (tcConcreteEnv_u (cenv `Map.union`) . tcMutableEnv_u ((menv `Map.union`) .
+        Map.filterWithKey (\k _ -> k `Map.notMember` cenv))) act
hunk ./src/FrontEnd/Tc/Monad.hs 143
--- | add to the collected environment which will be used to annotate uses of variables with their instantiated types.
--- should contain @-aliases for each use of a polymorphic variable or pattern match.
+-- | add to the collected environment which will be used to annotate uses of
+-- variables with their instantiated types.  should contain @-aliases for each
+-- use of a polymorphic variable or pattern match.
hunk ./src/FrontEnd/Tc/Monad.hs 179
-        tcCollectedEnv = ce,
+        tcCollectedEnv    = ce,
hunk ./src/FrontEnd/Tc/Monad.hs 181
-        tcConcreteEnv = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo,
-        tcMutableEnv = mempty,
-        tcVarnum = vn,
-        tcDiagnostics = [Msg Nothing $ "Compilation of module: " ++ tcInfoModName tcInfo],
-        tcInfo = tcInfo,
-        tcRecursiveCalls = mempty,
-        tcInstanceEnv = makeInstanceEnv (tcInfoClassHierarchy tcInfo),
-        tcCurrentScope = mempty,
-        tcOptions = opt
+        tcConcreteEnv     = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo,
+        tcMutableEnv      = mempty,
+        tcVarnum          = vn,
+        tcDiagnostics     = [Msg Nothing $
+            "Compilation of module: " ++ show (tcInfoModName tcInfo)],
+        tcInfo            = tcInfo,
+        tcRecursiveCalls  = mempty,
+        tcInstanceEnv     = makeInstanceEnv (tcInfoClassHierarchy tcInfo),
+        tcCurrentScope    = mempty,
+        tcOptions         = opt
hunk ./src/FrontEnd/Tc/Monad.hs 221
-getModName :: Tc String
-getModName = asks ( tcInfoModName . tcInfo)
-
hunk ./src/FrontEnd/Tc/Monad.hs 243
-    let Left msg = typeError (Unification $ "attempted to unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2) diagnosis
+    let Left msg = typeError (Unification $ "attempted to unify " ++
+            prettyPrintType t1 ++ " with " ++ prettyPrintType t2) diagnosis
hunk ./src/FrontEnd/Tc/Monad.hs 293
-  inst mm ts is = tickle (inst mm ts :: Type -> Type) is -- (IsIn c t) = IsIn c (inst mm ts t)
+  inst mm ts is = tickle (inst mm ts :: Type -> Type) is
hunk ./src/FrontEnd/Tc/Monad.hs 306
-    Tc $ tell mempty { collectedPreds = [ p | p@IsIn {} <- ps ], constraints = Seq.fromList [ Equality { constraintSrcLoc = sl, constraintType1 = a, constraintType2 = b } | IsEq a b <- ps ] }
+    Tc $ tell mempty { collectedPreds = [ p | p@IsIn {} <- ps ],
+        constraints = Seq.fromList [ Equality { constraintSrcLoc = sl,
+        constraintType1 = a, constraintType2 = b } | IsEq a b <- ps ] }
hunk ./src/FrontEnd/Tc/Monad.hs 314
-listenPreds action = censor (\x -> x { collectedPreds = mempty }) $ listens collectedPreds action
+listenPreds action = censor (\x -> x { collectedPreds = mempty }) $
+    listens collectedPreds action
hunk ./src/FrontEnd/Tc/Monad.hs 318
-listenCPreds action = censor (\x -> x { constraints = mempty, collectedPreds = mempty }) $ listens (\x -> (collectedPreds x,T.toList $ constraints x)) action
+listenCPreds action = censor (\x -> x { constraints = mempty, collectedPreds = mempty }) $
+    listens (\x -> (collectedPreds x,T.toList $ constraints x)) action
hunk ./src/FrontEnd/Tc/Monad.hs 460
-        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "varBind: " ++ pprint u <+> text ":=" <+> prettyPrintType tt
+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "varBind: " ++ pprint u <+>
+            text ":=" <+> prettyPrintType tt
hunk ./src/FrontEnd/Tc/Monad.hs 467
-            Just r -> fail $ "varBind: binding unfree: " ++ tupled [pprint u,prettyPrintType tt,prettyPrintType r]
+            Just r -> fail $ "varBind: binding unfree: " ++
+                tupled [pprint u,prettyPrintType tt,prettyPrintType r]
hunk ./src/FrontEnd/Tc/Monad.hs 505
-pretty  :: PPrint Doc a => a -> String
-pretty x  = show (pprint x :: Doc)
+pretty :: PPrint Doc a => a -> String
+pretty x = show (pprint x :: Doc)
hunk ./src/FrontEnd/Tc/Monad.hs 519
---    addWarning w = liftIO $ processErrors [w]
hunk ./src/FrontEnd/Tc/Monad.hs 538
-    tcInfoEnv = mempty,
-    tcInfoModName = "(unknown)",
-    tcInfoKindInfo = mempty,
+    tcInfoEnv            = mempty,
+    tcInfoModName        = toModule "(unknown)",
+    tcInfoKindInfo       = mempty,
hunk ./src/FrontEnd/Tc/Monad.hs 542
-    tcInfoSigEnv = mempty
+    tcInfoSigEnv         = mempty
hunk ./src/Interactive.hs 220
-        tcInfoModName =  show (stateModule is),
+        tcInfoModName =  (stateModule is),
hunk ./src/Interactive.hs 223
-
hunk ./src/Name/Name.hs 19
+    mapName',
hunk ./src/Name/Name.hs 194
+mapName' :: (Maybe Module -> Maybe Module) -> (String -> String) -> Name -> Name
+mapName' f g n = case nameParts n of
+    (nt,m,i) -> toName nt (f m,g i)