[generate reverse name map during renaming
John Meacham <john@repetae.net>**20120205110857
 Ignore-this: 7b2a4371766f7f09d1c05999e2d58349
] hunk ./src/FrontEnd/Class.hs 34
+import Data.Maybe
hunk ./src/FrontEnd/Class.hs 52
-import Maybe
hunk ./src/FrontEnd/Class.hs 55
-import Support.CanType
hunk ./src/FrontEnd/Class.hs 59
-import Util.HasSize
hunk ./src/FrontEnd/Class.hs 102
-newClassRecord c = ClassRecord {
-    className = c,
-    classSrcLoc = bogusASrcLoc,
-    classSupers = [],
-    classArgs = [],
-    classAssumps = [],
-    classAlias = Nothing,
-    classAssocs = []
-    }
-
hunk ./src/FrontEnd/Class.hs 149
-aHsTypeSigToAssumps kt sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where
+aHsTypeSigToAssumps kt ~sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where
hunk ./src/FrontEnd/Class.hs 153
-qualifyMethod [HsAsst c [n]] (HsTypeSig sloc names (HsQualType oc t))
+qualifyMethod ~[HsAsst c [n]] ~(HsTypeSig sloc names (HsQualType oc t))
hunk ./src/FrontEnd/Class.hs 208
-addInstanceToHierarchy inst@Inst { instHead = cntxt :=> IsIn className _ } (CH r i) =
+addInstanceToHierarchy inst@Inst { instHead = cntxt :=> ~(IsIn className _) } (CH r i) =
hunk ./src/FrontEnd/Class.hs 223
-   where
-   (cntxt, (className, cargs@[convertedArgType])) = chToClassHead kt qType
+   where (cntxt, (className, [convertedArgType])) = chToClassHead kt qType
hunk ./src/FrontEnd/Class.hs 261
-    tsubst na vv v = applyTyvarMap [(na,vv)] v
hunk ./src/FrontEnd/Class.hs 299
-    --(HsTyApp (HsTyCon className) _) = classApp
-    className = hsClassHead
hunk ./src/FrontEnd/Class.hs 456
-ensureNotDup :: Monad m => SrcLoc -> Inst -> [Inst] -> m [Inst]
-ensureNotDup sl i is = f i is where
-    f i (i':is') | instHead i == instHead i' = case instDerived i && instDerived i' of
-        True -> return is
-        False -> failSl sl $ "Duplicate Instance: " ++ show i ++ "\nPrevious instance declared at " ++ show (instSrcLoc i')
-    f i (_:is') = f i is'
-    f i [] = return $ i:is
-
hunk ./src/FrontEnd/Class.hs 461
-groupStringsToWidth width ss
-   = groupStringsToWidth' width (accLen 0 ss)
-   where
+groupStringsToWidth width ss = groupStringsToWidth' width (accLen 0 ss) where
hunk ./src/FrontEnd/Exports.hs 4
-module FrontEnd.Exports(determineExports,ModInfo(..),modInfoHsModule_s) where
+module FrontEnd.Exports(determineExports,ModInfo(..)) where
hunk ./src/FrontEnd/Exports.hs 7
-import Data.Monoid
hunk ./src/FrontEnd/Exports.hs 9
+import Data.Monoid
hunk ./src/FrontEnd/Exports.hs 32
+    modInfoReverseMap :: Map.Map Name Name,
hunk ./src/FrontEnd/Exports.hs 35
-   {-! derive: update !-}
hunk ./src/FrontEnd/FrontEnd.hs 23
-         putStrLn $ " ---- Definitions for" <+> show (modInfoName m) <+> "----";
-         mapM_ print ( modInfoDefs m)
-    ms <- determineExports [ (x,y,z) | (x,(y,z)) <- Map.toList $ hoDefs htc] (Map.toList $ hoExports htc) ms
+         putStrLn $ " ---- Definitions for" <+> show (modInfoName m) <+> "----"
+         mapM_ print (modInfoDefs m)
+    ms <- determineExports [ (x,y,z) |
+        (x,(y,z)) <- Map.toList $ hoDefs htc] (Map.toList $ hoExports htc) ms
hunk ./src/FrontEnd/FrontEnd.hs 30
-    --opt <- case fileOptions (hsModuleOptions m) of
-    --    Just o -> return o
-    --    Nothing -> warn (srcLoc m) "unknown-option" ("Unknown OPTIONS in pragma module" <+> fromModule (hsModuleName m) <+>  show (hsModuleOptions m)) >> return options
hunk ./src/FrontEnd/FrontEnd.hs 38
+        modInfoReverseMap = error "modInfoReverseMap",
hunk ./src/FrontEnd/Rename.hs 56
-    | ContextInstance Name
+    | ContextInstance !Name
hunk ./src/FrontEnd/Rename.hs 80
-        z ns = mapM mult (filter (\x -> length x > 1) $ groupBy (\a b -> fst a == fst b) (sort ns))
-        mult xs@(~((n,sl):_)) = warn sl (MultiplyDefined n (snds xs)) (show n ++ " is defined multiple times: " ++ show xs)
+        z ns = mapM mult (filter (\x -> length x > 1) $
+            groupBy (\a b -> fst a == fst b) (sort ns))
+        mult xs@(~((n,sl):_)) = warn sl (MultiplyDefined n (snds xs))
+            (show n ++ " is defined multiple times: " ++ show xs)
hunk ./src/FrontEnd/Rename.hs 88
-
-    local ( \e -> e { envNameMap = Map.unionWithKey amb (Map.map Right $ Map.fromList nmap) (envNameMap e) }) action
+    local (\e -> e { envNameMap = Map.unionWithKey amb (Map.map Right $ Map.fromList nmap) (envNameMap e) }) action
hunk ./src/FrontEnd/Rename.hs 104
-runRename :: MonadWarn m => (a -> RM a) -> Opt -> Module -> FieldMap -> [(Name,[Name])] -> a -> m a
-runRename doit opt mod fls ns m = mapM_ addWarning errors >> return renamedMod where
+runRename :: MonadWarn m => (a -> RM a) -> Opt -> Module -> FieldMap -> [(Name,[Name])] -> a -> m (a,Map.Map Name Name)
+runRename doit opt mod fls ns m = mapM_ addWarning errors >> return (renamedMod,reverseMap) where
hunk ./src/FrontEnd/Rename.hs 109
-
hunk ./src/FrontEnd/Rename.hs 117
-    (renamedMod, _, errors) = runRWS (unRM $ doit m) startEnv startState
+    (renamedMod, _, (reverseMap,errors)) = runRWS (unRM $ doit m) startEnv startState
hunk ./src/FrontEnd/Rename.hs 120
-renameModule :: MonadWarn m => Opt -> FieldMap -> [(Name,[Name])] -> HsModule -> m HsModule
+renameModule :: MonadWarn m => Opt -> FieldMap -> [(Name,[Name])] -> HsModule -> m (HsModule, Map.Map Name Name)
hunk ./src/FrontEnd/Rename.hs 125
-renameStatement fls ns modName stmt = runRename rename options modName fls ns stmt
+renameStatement fls ns modName stmt = fst `liftM` runRename rename options modName fls ns stmt
hunk ./src/FrontEnd/Rename.hs 128
-withSubTable st action = local ( \e -> e { envNameMap = Map.map Right st `union` envNameMap e }) action
+withSubTable st action = local (\e -> e { envNameMap = Map.map Right st `union` envNameMap e }) action
hunk ./src/FrontEnd/Rename.hs 159
-getTypeClassModule :: HsQualType -> Maybe Module
-getTypeClassModule typ =
-   case hsQualTypeType typ of
-      HsTyApp cls arg -> getModule (hsTypeName cls)
-      _ -> error "instance must consist of a type class application"
+--getTypeClassModule :: HsQualType -> Maybe Module
+--getTypeClassModule typ =
+--   case hsQualTypeType typ of
+--      HsTyApp cls arg -> getModule (hsTypeName cls)
+--      _ -> error "instance must consist of a type class application"
+getTypeClassModule :: HsClassHead -> Maybe Module
+getTypeClassModule typ = getModule (hsClassHead typ)
hunk ./src/FrontEnd/Rename.hs 171
-{- |
-This renaming shall help accepting an instance declaration like
-
-> import qualified Custom
->
-> instance Custom.Class T where
->    methodA = ...
->    methodB = ...
-
-by translating it to
-
-> instance Custom.Class T where
->    Custom.methodA = ...
->    Custom.methodB = ...
-
-I don't know, whether this also works if you do
-
-> import qualified Custom hiding (methodA, methodB, )
--}
hunk ./src/FrontEnd/Rename.hs 261
-        --doesClassMakeSense hsQualType'
hunk ./src/FrontEnd/Rename.hs 279
-            hsDecls
-           --map (qualifyInstMethod (getTypeClassModule hsQualType)) hsDecls
+            --hsDecls
+           map (qualifyInstMethod (getTypeClassModule classHead')) hsDecls
hunk ./src/FrontEnd/Rename.hs 330
-doesClassMakeSense :: HsQualType -> RM ()
-doesClassMakeSense (HsQualType _ type_) = case type_ of
-    (HsTyApp (HsTyCon _) (HsTyVar _)) -> return ()
-    (HsTyApp (HsTyApp _ _) _)         -> failRename "Multiparameter typeclasses not supported"
-    (HsTyCon _)                       -> failRename "Typeclass with no parameters"
-    _                                 -> failRename $ "Invalid type in class declaration: "++show type_
-
-renameClassHead :: HsQualType -> RM HsQualType
-renameClassHead (HsQualType hsContext hsType) = do
-    ctx <- rename hsContext
-    typ <- case hsType of
-        HsTyApp (HsTyCon n) t -> do
-            n <- renameName $ toName ClassName n
-            t <- rename t
-            return (HsTyApp (HsTyCon n) t)
-        HsTyApp (HsTyApp _ _) _   -> do
-            failRename "Multiparameter typeclasses not supported"
-            rename hsType
-        HsTyCon {}  -> do
-            failRename "Typeclass with no parameters"
-            rename hsType
-        _   -> do
-            failRename $ "Invalid type in class declaration: " ++ show hsType
-            rename hsType
-    return (HsQualType ctx typ)
-
hunk ./src/FrontEnd/Rename.hs 650
-        Just (Right name) -> return name
+        Just (Right name) -> do
+            tell (Map.singleton name hsName,mempty)
+            return name
hunk ./src/FrontEnd/Rename.hs 786
-newtype RM a = RM (RWS Env [Warning] ScopeState a)
-    deriving(Monad,Functor,MonadReader Env, MonadWriter [Warning], MonadState ScopeState)
+newtype RM a = RM (RWS Env (Map.Map Name Name,[Warning]) ScopeState a)
+    deriving(Monad,Functor,MonadReader Env, MonadWriter (Map.Map Name Name,[Warning]), MonadState ScopeState)
hunk ./src/FrontEnd/Rename.hs 796
-    addWarning w = tell [w]
+    addWarning w = tell (mempty,[w])
hunk ./src/FrontEnd/Tc/Module.hs 64
-        allDefs = [ (x,z) | (x,_,z) <- concat $ map modInfoDefs ms, nameType x == DataConstructor ]
-        ans = Map.fromList $ sortGroupUnderFG fst snd $ concat [ [ (y,(x,i)) |  y <- ys | i <- [0..] ]  | (x,ys) <-  allDefs ]
+        allDefs = [ (x,z) | (x,_,z) <- concat $ map modInfoDefs ms,
+            nameType x == DataConstructor ]
+        ans = Map.fromList $ sortGroupUnderFG fst snd $ concat
+            [ [ (y,(x,i)) |  y <- ys | i <- [0..] ]  | (x,ys) <-  allDefs ]
hunk ./src/FrontEnd/Tc/Module.hs 80
-    let (mod',errs) = runWriter $ renameModule (modInfoOptions m) defs (modInfoImport m)  mod
+    let ((mod',rmap),errs) = runWriter $
+            renameModule (modInfoOptions m) defs (modInfoImport m)  mod
hunk ./src/FrontEnd/Tc/Module.hs 85
-    return $ (modInfoHsModule_s mod' m,errs)
+    return $ (m { modInfoReverseMap = rmap, modInfoHsModule = mod' },errs)
hunk ./src/FrontEnd/Tc/Module.hs 108
-    f HsDataDecl { hsDeclCons = cs } = return $ DatMany [ (hsConDeclName c, (length . hsConDeclArgs) c) | c <- cs]
+    f HsDataDecl { hsDeclCons = cs } = return $
+        DatMany [ (hsConDeclName c, (length . hsConDeclArgs) c) | c <- cs]
hunk ./src/FrontEnd/Tc/Module.hs 120
-    let thisFixityMap = buildFixityMap (concat [ filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])
+    let thisFixityMap = buildFixityMap . concat $
+            [filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]
hunk ./src/FrontEnd/Tc/Module.hs 123
-    thisTypeSynonyms <- declsToTypeSynonyms (hoTypeSynonyms htc) $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]
+    thisTypeSynonyms <- declsToTypeSynonyms (hoTypeSynonyms htc) $ concat
+        [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]
hunk ./src/FrontEnd/Tc/Module.hs 128
-            \z -> return (modInfoHsModule_s ( z) x)
+            \z -> return x { modInfoHsModule = z }
hunk ./src/FrontEnd/Tc/Module.hs 164
-                f (sl,c,t) = emptyInstance { instSrcLoc = sl, instDerived = True, instHead = [] :=> IsIn c (TCon (Tycon t kindStar)) }
+                f (sl,c,t) = emptyInstance {
+                    instSrcLoc = sl,
+                    instDerived = True,
+                    instHead = [] :=> IsIn c (TCon (Tycon t kindStar))
+                    }
hunk ./src/FrontEnd/Tc/Module.hs 182
-    let myClassAssumps = concat  [ classAssumps as | as <- classRecords cHierarchyWithInstances ]
-        instanceEnv   = Map.fromList instAssumps
+    let myClassAssumps = concat [ classAssumps as | as <- classRecords cHierarchyWithInstances ]
+        instanceEnv = Map.fromList instAssumps
hunk ./src/FrontEnd/Tc/Module.hs 185
-        classEnv  = Map.fromList $ [ (x,y) | (x,y) <- myClassAssumps, x `elem` classDefs  ]
-        (liftedInstances,instAssumps) =  mconcatMap (instanceToTopDecls kindInfo cHierarchyWithInstances) ds -- rInstDecls
+        classEnv = Map.fromList $ [ (x,y) | (x,y) <- myClassAssumps, x `elem` classDefs  ]
+        (liftedInstances,instAssumps) = mconcatMap
+            (instanceToTopDecls kindInfo cHierarchyWithInstances) ds
hunk ./src/FrontEnd/Tc/Module.hs 227
-        putStrLn $ PPrint.render $ pprintEnvMap (sigEnv `mappend` localDConsEnv `mappend` hoAssumps htc)
+        putStrLn $ PPrint.render $ pprintEnvMap
+            (sigEnv `mappend` localDConsEnv `mappend` hoAssumps htc)
hunk ./src/FrontEnd/Tc/Module.hs 233
-        tcInfoEnv = hoAssumps htc `mappend` localDConsEnv, -- (importVarEnv `mappend` globalDConsEnv),
+        tcInfoEnv = hoAssumps htc `mappend` localDConsEnv,
hunk ./src/FrontEnd/Tc/Module.hs 258
-        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |  (n,s) <- Map.toList (if verbose2 then localVarEnv else trimEnv localVarEnv)]
+        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |
+            (n,s) <- Map.toList (if verbose2 then localVarEnv else trimEnv localVarEnv)]
hunk ./src/FrontEnd/Tc/Module.hs 266
-    let pragmaProps = fromList $ Map.toList $ Map.fromListWith mappend [ (toName Name.Val x,fromList $ readProp w) |  HsPragmaProps _ w xs <- ds, x <- xs ]
+    let pragmaProps = fromList $ Map.toList $ Map.fromListWith mappend
+            [(toName Name.Val x,fromList $ readProp w) | HsPragmaProps _ w xs <- ds, x <- xs]