module FrontEnd.Rename(unRename, collectDefsHsModule, renameModule, FieldMap, renameStatement ) where

import Char
import Control.Monad.Identity
import Control.Monad.RWS
import Control.Monad.State
import Control.Monad.Writer
import Control.Applicative
import Data.Monoid
import List
import Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Traversable as T


import Doc.DocLike(tupled)
import FrontEnd.Desugar (doToExp)
import FrontEnd.SrcLoc hiding(srcLoc)
import FrontEnd.Syn.Traverse
import FrontEnd.Utils
import FrontEnd.HsSyn
import Name.Name as Name hiding(qualifyName)
import Name.Names
import Support.FreeVars
import Util.Gen
import Util.Inst()
import FrontEnd.Warning
import qualified FrontEnd.HsErrors as HsErrors
import qualified Name.VConsts as V

type FieldMap =  (Map.Map Name Int,Map.Map Name [(Name,Int)])

--------------------------------------------------------------------------------

-- a 'Substitution Table' which is a map from old names to new names
-- All names in the current scope are stored in here, with their renamings

type SubTable = Map.Map HsName HsName

-- an Identifier Table is a map from renamed names to that identifier's source
-- location and binding type


-- the monadic state

data ScopeState = ScopeState {
    unique         :: !Int,
    globalSubTable :: Map.Map HsName HsName,  -- Current substition
    typeSubTable   :: Map.Map HsName HsName,  -- type substition table
    errorTable     :: Map.Map HsName String,  -- special error message. else it's just unknown.
    fieldLabels    :: FieldMap
    }


data Env = Env {
    envSubTable  :: Map.Map HsName HsName,  -- all these need to go away
    envNameSpace :: [NameType],
    envModule  :: Module,
    envNameMap :: Map.Map Name (Either String Name),
    envSrcLoc  :: SrcLoc
}

instance Applicative RM where
    pure = return
    (<*>) = ap

newtype RM a = RM (RWS Env [Warning] ScopeState a)
    deriving(Monad,Functor,MonadReader Env, MonadWriter [Warning], MonadState ScopeState)

unRM (RM x) = x

instance MonadWarn RM where
    addWarning w = tell [w]

instance UniqueProducer RM where
    newUniq = do
        u <- gets unique
        modify (\state -> state {unique = (unique state) + 1})
        return u


getCurrentModule :: RM Module
getCurrentModule = asks envModule

instance MonadSrcLoc RM where
    getSrcLoc = asks envSrcLoc
instance MonadSetSrcLoc RM where
    withSrcLoc sl a = local (\s -> s { envSrcLoc = sl `mappend` envSrcLoc s}) a



addTopLevels ::  [HsDecl]  -> RM a -> RM a
addTopLevels  hsDecls action = do
    mod <- getCurrentModule
    let (ns,ts) = mconcat (map namesHsDecl hsDecls)
        nm = Map.fromList $ foldl f [] (fsts ns)
        tm = Map.fromList $ foldl f [] (fsts ts)
        f r hsName@Qual {}
            | Just _ <- V.fromTupname hsName, Module "Lhc.Basics" <- mod
                = let nn = hsName in (nn,nn):r
            | nameName tc_Arrow == hsName, Module "Lhc.Basics" == mod
                = let nn = hsName in (nn,nn):r
            | otherwise = error $ "strong bad: " ++ show hsName
        f r z@(UnQual n) = let nn = Qual mod n in (z,nn):(nn,nn):r
        z ns = mapM mult (filter (\x -> length x > 1) $ groupBy (\a b -> fst a == fst b) (sort ns))
        mult xs@(~((n,sl):_)) = warn sl "multiply-defined" (show n ++ " is defined multiple times: " ++ show xs )
    z ns >> z ts
    modify (\s -> s { globalSubTable = nm `Map.union` globalSubTable s })
    modify (\s -> s { typeSubTable = tm `Map.union` typeSubTable s })
    action


ambig x ys = "Ambiguous Name: " ++ show x ++ "\nCould refer to: " ++ tupled (map show ys)

runRename :: MonadWarn m => (a -> RM a) -> Module -> FieldMap -> [(Name,[Name])] -> a -> m a
runRename doit mod fls ns m = mapM_ addWarning errors >> return renamedMod where
    initialGlobalSubTable = Map.fromList [ (x,y) | ((typ,x),[y]) <- ns', typ == Val || typ == DataConstructor ]
    initialTypeSubTable = Map.fromList [ (x,y) | ((typ,x),[y]) <- ns', typ == TypeConstructor || typ == ClassName ]
    nameMap = Map.fromList $ map f ns where
        f (x,[y]) = (x,Right y)
        f (x,ys)  = (x,Left $ ambig x ys)
    ns' = map fn ns
    fn (n,ns) = (fromName n, map nameName ns)

    errorTab =  Map.fromList [ (x,ambig x ys) | ((typ,x),ys@(_:_:_)) <- ns' ]

    startState = ScopeState {
        typeSubTable   = initialTypeSubTable,
        errorTable     = errorTab,
        unique         = 1,   -- start the counting at 1
        globalSubTable = initialGlobalSubTable,
        fieldLabels    = fls
        }
    startEnv = Env {
        envSubTable = initialGlobalSubTable,
        envNameSpace = [Val,DataConstructor],
        envModule = mod,
        envNameMap  = nameMap,
        envSrcLoc = mempty
    }
    (renamedMod, _, errors) = runRWS (unRM $ doit m) startEnv startState

{-# NOINLINE renameModule #-}
renameModule :: MonadWarn m => FieldMap -> [(Name,[Name])] -> HsModule -> m HsModule
renameModule fls ns m = runRename renameDecls (hsModuleName m) fls ns m

{-# NOINLINE renameStatement #-}
renameStatement :: MonadWarn m => FieldMap -> [(Name,[Name])] -> Module -> HsStmt -> m HsStmt
renameStatement fls ns modName stmt = runRename rename modName fls ns stmt

renameOld :: (SubTable -> RM a) -> RM a
renameOld rm = asks envSubTable >>= rm

withSubTable :: SubTable -> RM a -> RM a
withSubTable st action = local ( \e -> e { envSubTable = st `Map.union` envSubTable e }) action



renameDecls :: HsModule -> RM HsModule
renameDecls tidy = do
        addTopLevels (hsModuleDecls tidy) $ do
        gst <- gets globalSubTable
        withSubTable gst $ do
        decls' <- rename (hsModuleDecls tidy)
        mapM_ HsErrors.hsDeclTopLevel decls'
        return tidy { hsModuleDecls = decls' }


expandTypeSigs :: [HsDecl] -> [HsDecl]
expandTypeSigs ds =  (concatMap f ds) where
    f (HsTypeSig sl ns qt) =  [ HsTypeSig sl [n] qt | n <- ns]
    f d = return d

instance Rename HsDecl where
    rename (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) = do
        withSrcLoc srcLoc $ do
        hsPat'    <- rename hsPat
        updateWith hsDecls $ do
        hsDecls'  <- rename hsDecls
        hsRhs'    <- rename hsRhs
        return (HsPatBind srcLoc hsPat' hsRhs' {-where-} hsDecls')

    rename (HsForeignExport a b n t) = do
        withSrcLoc a $ do
        n <- rename n
        updateWith t $ do
            t <- rename t
            return (HsForeignExport a b n t)

    rename (HsForeignDecl a b n t) = do
        withSrcLoc a $ do
        n <- rename n
        updateWith t $ do
        t <- rename t
        return (HsForeignDecl a b n t)

    rename (HsFunBind hsMatches) = do
        hsMatches' <- rename hsMatches
        return (HsFunBind hsMatches')

    rename (HsTypeSig srcLoc hsNames hsQualType) = do
        withSrcLoc srcLoc $ do
        hsNames' <- rename hsNames
        updateWith hsQualType $ do
        hsQualType' <- rename hsQualType
        return (HsTypeSig srcLoc hsNames' hsQualType')
    rename dl@HsDataDecl { hsDeclSrcLoc = srcLoc, hsDeclContext = hsContext, hsDeclName = hsName, hsDeclArgs = hsNames1, hsDeclCons = hsConDecls, hsDeclDerives = hsNames2 } = do
        withSrcLoc srcLoc $ do
        hsName' <- renameTypeName hsName
        updateWith hsNames1 $ do
        hsContext' <- rename hsContext
        hsNames1' <- rename hsNames1
        hsConDecls' <- rename hsConDecls
        -- don't need to rename the hsNames2 as it is just a list of TypeClasses
        hsNames2' <- mapM renameTypeName hsNames2
        return dl { hsDeclContext = hsContext', hsDeclName = hsName', hsDeclArgs = hsNames1', hsDeclCons = hsConDecls', hsDeclDerives = hsNames2' }
    rename (HsTypeDecl srcLoc name hsNames t) = do
        withSrcLoc srcLoc $ do
        hsName' <- renameTypeName name
        updateWith (Set.toList $ freeVars hsNames :: [HsName]) $ do
            hsNames' <- rename hsNames
            t' <- rename t
            return (HsTypeDecl srcLoc  hsName' hsNames' t')
    rename (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) = do
        withSrcLoc srcLoc $ do
        hsName' <- renameTypeName hsName
        updateWith hsNames1 $ do
        hsContext' <- rename hsContext
        hsNames1' <- rename hsNames1
        hsConDecl' <- rename hsConDecl
        -- don't need to rename the hsNames2 as it is just a list of TypeClasses
        hsNames2' <- mapM renameTypeName hsNames2
        return (HsNewTypeDecl srcLoc hsContext' hsName' hsNames1' hsConDecl' hsNames2')
    rename (HsClassDecl srcLoc hsQualType hsDecls) = do
        withSrcLoc srcLoc $ do
        hsQualType' <- updateWith hsQualType  $ rename hsQualType
        doesClassMakeSense hsQualType'
        hsDecls' <- rename hsDecls
        return (HsClassDecl srcLoc hsQualType' hsDecls')
    rename (HsClassAliasDecl srcLoc name args hsContext hsClasses hsDecls) = do
        withSrcLoc srcLoc $ do
        name' <- renameTypeName name
        updateWith args $ do
        args' <- mapM rename args
        hsContext' <- rename hsContext
        hsClasses' <- rename hsClasses
        hsDecls' <- rename hsDecls
        return (HsClassAliasDecl srcLoc name' args' hsContext' hsClasses' hsDecls')
    rename (HsInstDecl srcLoc hsQualType hsDecls) = do
        withSrcLoc srcLoc $ do
        updateWith hsQualType $ do
        hsQualType' <- rename hsQualType
        hsDecls' <- rename hsDecls
        return (HsInstDecl srcLoc hsQualType' hsDecls')
    rename (HsInfixDecl srcLoc assoc int hsNames) = do
        withSrcLoc srcLoc $ do
        hsNames' <- rename hsNames
        return $ HsInfixDecl srcLoc assoc int hsNames'
    rename (HsActionDecl srcLoc pat e) = do
        withSrcLoc srcLoc $ do
        pat <- rename pat
        e <- rename e
        return (HsActionDecl srcLoc pat e)
    rename (HsPragmaProps srcLoc prop hsNames) = do
        withSrcLoc srcLoc $ do
        hsNames' <- rename hsNames
        return (HsPragmaProps  srcLoc prop hsNames')
    rename (HsPragmaRules rs) = do
        rs' <- rename rs
        return $ HsPragmaRules rs'
    rename prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } = do
        withSrcLoc srcLoc $ do
        n <- rename n
        t <- rename t
        m <- getCurrentModule
        i <- newUniq
        return prules { hsDeclUniq = (m,i), hsDeclName = n, hsDeclType = t }
    rename (HsDefaultDecl sl e) = HsDefaultDecl sl <$> rename e
    rename (HsDeclDeriving sl ch) = HsDeclDeriving sl <$> rename ch
    rename h = error $ "renameerr: " ++ show h


instance Rename HsClassHead where
    rename (HsClassHead cx n ts) = do
        updateWith ts $ HsClassHead <$> rename cx <*> renameTypeName n <*> rename ts



instance Rename HsRule where
    rename prules@HsRule { hsRuleSrcLoc = srcLoc, hsRuleFreeVars = fvs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } = do
        withSrcLoc srcLoc $ do
        updateWith (fsts fvs) $ do
        subTable'' <- getUpdates (catMaybes $ snds fvs)
        fvs' <- sequence [ liftM2 (,) (rename x) (withSubTable subTable'' $ rename y)| (x,y) <- fvs]
        e1' <- rename e1
        e2' <- rename e2
        m <- getCurrentModule
        i <- newUniq
        return prules {  hsRuleUniq = (m,i), hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' }

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_

instance Rename HsQualType where
    rename (HsQualType hsContext hsType) = return HsQualType `ap` rename hsContext `ap` rename hsType


instance Rename HsAsst where
    rename (HsAsst hsName1  hsName2s) = do
        hsName1' <- renameTypeName hsName1
        hsName2s' <- mapM renameTypeName hsName2s
        return (HsAsst hsName1' hsName2s')
    rename (HsAsstEq t1 t2) = return HsAsstEq `ap` rename t1 `ap` rename t2


instance Rename HsConDecl where
    rename cd@(HsConDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclConArg = hsBangTypes }) = do
        withSrcLoc srcLoc $ do
        hsName' <- rename hsName
        updateWith  (map hsTyVarBindName (hsConDeclExists cd)) $ do
        es <- rename (hsConDeclExists cd)
        hsBangTypes' <- rename hsBangTypes
        return cd { hsConDeclName = hsName', hsConDeclConArg = hsBangTypes', hsConDeclExists = es }
    rename cd@HsRecDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclRecArg = stuff} = do
        withSrcLoc srcLoc $ do
        hsName' <- rename hsName
        subTable <- asks envSubTable
        updateWith (map hsTyVarBindName (hsConDeclExists cd)) $ do
        es <- rename (hsConDeclExists cd)
        stuff' <- sequence [ do ns' <- rename ns; t' <- withSubTable subTable $ rename t; return (ns',t')  |  (ns,t) <- stuff]
        return cd { hsConDeclName = hsName', hsConDeclRecArg = stuff', hsConDeclExists = es }


instance Rename HsBangType where
    rename (HsBangedTy t) = HsBangedTy `fmap` rename t
    rename (HsUnBangedTy t) = HsUnBangedTy `fmap` rename t

instance Rename HsType where
    rename t = do
        t <- renameHsType' True t
        HsErrors.hsType t
        return t

renameHsType' dovar t = pp (rt t) where
    rt :: HsType -> RM HsType
    rt (HsTyVar hsName) | dovar = do
        hsName' <- renameTypeName hsName
        return (HsTyVar hsName')
    rt v@(HsTyVar _)   = return v

    rt (HsTyCon hsName) = do
        hsName' <- renameTypeName hsName
        return (HsTyCon hsName')
    rt (HsTyForall ts v) = do
        updateWith (map hsTyVarBindName ts)  $ do
        ts' <- rename ts
        v' <- rename v
        return $ HsTyForall ts' v'
    rt (HsTyExists ts v) = do
        updateWith (map hsTyVarBindName ts) $ do
        ts' <- rename ts
        v' <- rename v
        return $ HsTyExists ts' v'
    rt ty = traverseHsType (renameHsType' dovar) ty
    pp t | not dovar = t
    pp t = t


class UpdateTable a where
    updateWith :: a -> RM b -> RM b
    updateWith x action = getUpdates x >>= flip withSubTable action

    getUpdates :: a -> RM SubTable
    getUpdates x = Map.unions `fmap` mapM clobberName (getNames x)

    getNames :: a -> [HsName]
    getNames a = []


instance UpdateTable a => UpdateTable [a] where
    getUpdates xs = Map.unions `fmap` mapM getUpdates xs
    getNames xs = concatMap getNames xs

instance UpdateTable HsName where
    getNames x = [x]

class Rename a where
    rename :: a -> RM a
    rename x = return x


instance Rename x => Rename (Located x) where
    rename (Located sl x) = Located sl `fmap` rename x

instance Rename SrcLoc where

instance Rename a => Rename [a] where
    rename xs = mapM rename xs



instance (Rename a,Rename b) => Rename (a,b) where
    rename (a,b) = return (,) `ap` rename a `ap` rename b


instance Rename a => Rename (Maybe a) where
    rename Nothing = return Nothing
    rename (Just x) = fmap Just $ rename x



instance Rename HsExp where
    rename d = renameOld (renameHsExp d)



instance Rename HsTyVarBind where
    rename tvb@HsTyVarBind { hsTyVarBindName = n } = do
        n' <- renameTypeName n
        return tvb { hsTyVarBindName = n' }

-- note that for renameHsMatch, the 'wheres' dominate the 'pats'

instance Rename HsMatch where
    rename (HsMatch srcLoc hsName hsPats hsRhs {-where-} hsDecls) = do
        withSrcLoc srcLoc $ do
        hsName' <- rename hsName
        updateWith hsPats  $ do
        hsPats' <- rename hsPats
        updateWith hsDecls $ do
        hsDecls' <- rename (expandTypeSigs hsDecls)
        mapM_ HsErrors.hsDeclLocal hsDecls'
        hsRhs' <- rename hsRhs
        return (HsMatch srcLoc hsName' hsPats' hsRhs' {-where-} hsDecls')


instance Rename HsPat where
    rename (HsPVar hsName) = HsPVar `fmap` rename hsName
    rename (HsPInfixApp hsPat1 hsName hsPat2)  = return HsPInfixApp `ap` rename hsPat1 `ap` rename hsName `ap` rename hsPat2
    rename (HsPApp hsName hsPats) = HsPApp <$> rename hsName <*> rename hsPats
    rename (HsPRec hsName hsPatFields) = do
        hsName' <- rename hsName
        hsPatFields' <- rename hsPatFields
        fls <- gets fieldLabels
        buildRecPat fls hsName' hsPatFields'
    rename (HsPAsPat hsName hsPat) = HsPAsPat <$> rename hsName <*> rename hsPat
    rename (HsPTypeSig sl hsPat qt)  = HsPTypeSig sl <$> rename hsPat <*> rename qt
    rename p = traverseHsPat rename p

buildRecPat :: FieldMap -> HsName -> [HsPatField] -> RM HsPat
buildRecPat (amp,fls) n us = case Map.lookup (toName DataConstructor n) amp of
    Nothing -> failRename $ "Unknown Constructor: " ++ show n
    Just t -> do
        let f (HsPFieldPat x p) = case  Map.lookup (toName FieldLabel x) fls of
                Nothing -> failRename $ "Field Label does not exist: " ++ show x
                Just cs -> case lookup n [ (nameName x,(y)) | (x,y) <- cs ] of
                    Nothing -> failRename $ "Field Label does not belong to constructor: " ++ show (x,n)
                    Just i -> return (i,HsPParen p)
        fm <- mapM f us
        let g i | Just e <- lookup i fm = return e
                | otherwise = do
                    v <- newVar
                    return $ HsPVar v
        rs <- mapM g [0 .. t - 1 ]
        return $ HsPApp n rs


instance Rename HsPatField where
    rename (HsPFieldPat hsName hsPat) = do
        gt <- gets globalSubTable      -- field names are not shadowed by local definitions.
        hsName' <- renameHsName hsName gt
        hsPat' <- rename hsPat
        return (HsPFieldPat hsName' hsPat')


instance Rename HsRhs where
    rename (HsUnGuardedRhs hsExp) = fmap HsUnGuardedRhs $ rename hsExp
    rename (HsGuardedRhss rs) = fmap HsGuardedRhss $ rename rs

instance Rename HsGuardedRhs where
    rename (HsGuardedRhs srcLoc hsExp1 hsExp2) = do
        withSrcLoc srcLoc $ do
        hsExp1' <- rename hsExp1
        hsExp2' <- rename hsExp2
        return (HsGuardedRhs srcLoc hsExp1' hsExp2')


uqFuncNames :: V.FuncNames HsName
Identity uqFuncNames = T.mapM (return . nameName . toUnqualified) sFuncNames

func_fromRational = (HsVar $ V.func_fromRational uqFuncNames)

newVar = do
    unique <- newUniq
    mod <- getCurrentModule
    let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromHsName hsName' -} ++ "_var@"))
    return hsName''

wrapInAsPat e = do
    unique <- newUniq
    mod <- getCurrentModule
    let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromHsName hsName' -} ++ "_as@"))
    return (HsAsPat hsName''  e )

renameHsExp :: HsExp -> SubTable -> RM HsExp
renameHsExp (HsVar hsName) subTable = do
    hsName' <- renameHsName hsName subTable
    return (HsVar hsName')
renameHsExp (HsCon hsName) subTable = do
    hsName' <- renameHsName hsName subTable
    wrapInAsPat (HsCon hsName')

renameHsExp i@(HsLit (HsInt _num)) _st = do return i
renameHsExp i@(HsLit (HsFrac _)) st = do
    z <- renameHsExp func_fromRational st
    return $ HsParen (HsApp z i)
renameHsExp (HsLambda srcLoc hsPats hsExp) subTable = do
    withSrcLoc srcLoc $ do
    updateWith hsPats $ do
    hsPats' <- rename hsPats
    hsExp' <- rename hsExp
    return (HsLambda srcLoc hsPats' hsExp')
renameHsExp (HsLet hsDecls hsExp) subTable = do
    updateWith hsDecls $ do
    hsDecls' <- rename (expandTypeSigs hsDecls)
    mapM_ HsErrors.hsDeclLocal hsDecls'
    hsExp' <- rename hsExp
    return (HsLet hsDecls' hsExp')
renameHsExp (HsCase hsExp hsAlts) subTable = do
    hsExp' <- rename hsExp
    hsAlts' <- rename hsAlts
    return (HsCase hsExp' hsAlts')
renameHsExp (HsDo hsStmts) subTable = do
    e <- doToExp hsStmts
    rename e
renameHsExp (HsList hsExps) subTable = do
    unique <- newUniq
    hsExps' <- rename hsExps
    mod <- getCurrentModule
    let hsName' = Qual mod (HsIdent $ show unique ++ "_as@")
    return (HsAsPat hsName' $ HsList hsExps')
renameHsExp (HsRecConstr hsName hsFieldUpdates) subTable = do
    hsName' <- renameHsName hsName subTable  -- do I need to change this name?
    hsFieldUpdates' <- rename hsFieldUpdates
    fls <- gets fieldLabels
    buildRecConstr fls (hsName':: HsName) (hsFieldUpdates'::[HsFieldUpdate]) -- HsRecConstr hsName' hsFieldUpdates')
renameHsExp (HsRecUpdate hsExp hsFieldUpdates) subTable = do
    hsExp' <- renameHsExp hsExp subTable
    hsFieldUpdates' <- rename hsFieldUpdates
    fls <- gets fieldLabels
    buildRecUpdate fls hsExp' hsFieldUpdates' -- HsRecConstr hsName' hsFieldUpdates')
    --return (HsRecUpdate hsExp' hsFieldUpdates')
renameHsExp (HsEnumFrom hsExp) subTable = do
    let x = desugarEnum "enumFrom" [hsExp]
    hsExp' <- renameHsExp x subTable
    return ( hsExp')
renameHsExp (HsEnumFromTo hsExp1 hsExp2) subTable = do
    let x = desugarEnum "enumFromTo" [hsExp1, hsExp2]
    hsExp' <- renameHsExp x subTable
    return ( hsExp')
renameHsExp (HsEnumFromThen hsExp1 hsExp2) subTable = do
    let x = desugarEnum "enumFromThen" [hsExp1, hsExp2]
    hsExp' <- renameHsExp x subTable
    return ( hsExp')
renameHsExp (HsEnumFromThenTo hsExp1 hsExp2 hsExp3) subTable = do
    let x = desugarEnum "enumFromThenTo" [hsExp1, hsExp2, hsExp3]
    hsExp' <- renameHsExp x subTable
    return ( hsExp')
renameHsExp (HsListComp hsExp hsStmts) subTable = do
    (hsStmts',subTable') <- renameHsStmts hsStmts subTable
    hsExp' <- renameHsExp hsExp subTable'
    return (HsListComp hsExp' hsStmts')
renameHsExp (HsExpTypeSig srcLoc hsExp hsQualType) subTable = do
    hsExp' <- renameHsExp hsExp subTable
    updateWith hsQualType $ do
    hsQualType' <- rename hsQualType
    return (HsExpTypeSig srcLoc hsExp' hsQualType')
renameHsExp (HsAsPat hsName hsExp) subTable = do
    hsName' <- renameHsName hsName subTable
    hsExp' <- renameHsExp hsExp subTable
    return (HsAsPat hsName' hsExp')
renameHsExp (HsWildCard sl) _ = do
    withSrcLoc sl $ do
    e <- createError HsErrorUnderscore ("_")
    return e
renameHsExp p subTable = traverseHsExp (flip renameHsExp subTable) p

desugarEnum s as = foldl HsApp (HsVar (nameName $ toName Val s)) as


createError et s = do
    sl <- getSrcLoc
    return $ HsError { hsExpSrcLoc = sl, hsExpErrorType = et, hsExpString = (show sl ++ ": " ++ s) }

failRename s = do
    sl <- getSrcLoc
    fail (show sl ++ ": " ++ s)


buildRecConstr ::  FieldMap -> HsName -> [HsFieldUpdate] -> RM HsExp
buildRecConstr (amp,fls) n us = do
    undef <- createError HsErrorUninitializedField "Uninitialized Field"
    case Map.lookup (toName DataConstructor n) amp of
        Nothing -> failRename $ "Unknown Constructor: " ++ show n
        Just t -> do
            let f (HsFieldUpdate x e) = case  Map.lookup (toName FieldLabel x) fls of
                    Nothing -> failRename $ "Field Label does not exist: " ++ show x
                    Just cs -> case lookup n [ (nameName x,(y)) | (x,y) <- cs ] of
                        Nothing -> failRename $ "Field Label does not belong to constructor: " ++ show (x,n)
                        Just i -> return (i,hsParen e)
            fm <- mapM f us
            let rs = map g [0 .. t - 1 ]
                g i | Just e <- lookup i fm = e
                    | otherwise = undef
            con <- wrapInAsPat (HsCon n)
            return $ foldl HsApp con rs

buildRecUpdate ::  FieldMap -> HsExp -> [HsFieldUpdate] -> RM HsExp
buildRecUpdate (amp,fls) n us = do
        sl <- getSrcLoc
        let f (HsFieldUpdate x e) = case  Map.lookup (toName FieldLabel x) fls of
                Nothing -> failRename $ "Field Label does not exist: " ++ show x
                Just cs -> return [ (x,(y,hsParen e)) | (x,y) <- cs ]
        fm <- liftM concat $ mapM f us
        let fm' = sortGroupUnderFG fst snd fm
        let g (c,zs) = case Map.lookup c amp of
                Nothing -> failRename $ "Unknown Constructor: " ++ show n
                Just t -> do
                    vars <- replicateM t newVar
                    let vars' = (map HsVar vars)
                    let c' = nameName c
                    con <- wrapInAsPat (HsCon c')
                    let x = foldl HsApp con [ maybe v id (lookup i zs) | v <- vars' | i <- [ 0 .. t - 1] ]
                    return $ HsAlt sl (HsPApp c' (map HsPVar vars))  (HsUnGuardedRhs x) []
        as <- mapM g fm'
        pe <- createError HsErrorRecordUpdate "Record Update Error"
        return $ HsCase n (as ++ [HsAlt sl HsPWildCard (HsUnGuardedRhs pe) []])


instance Rename HsAlt where
    rename (HsAlt srcLoc hsPat hsGuardedAlts {-where-} hsDecls) = withSrcLoc srcLoc $ do
        updateWith hsPat $ do
        hsPat' <- rename hsPat
        updateWith hsDecls $ do
        hsDecls' <- rename (expandTypeSigs hsDecls)
        mapM_ HsErrors.hsDeclLocal hsDecls'
        hsGuardedAlts' <- rename hsGuardedAlts
        return (HsAlt srcLoc hsPat' hsGuardedAlts' hsDecls')




-- renameHsStmts is trickier than you would expect because
-- the statements are only in scope after they have been declared
-- and thus the subTable must be more carefully threaded through

-- the updated subTable is returned at the end because it is needed by
-- the first section of a list comprehension.

renameHsStmts :: [HsStmt] -> SubTable -> RM (([HsStmt],SubTable))
renameHsStmts (hsStmt:hsStmts) subTable = do
    updateWith hsStmt $ do
      subTable' <- getUpdates hsStmt
      withSubTable subTable' $ do
      hsStmt' <- withSubTable subTable' $ rename hsStmt
      (hsStmts',subTable'') <- renameHsStmts hsStmts subTable'
      return ((hsStmt':hsStmts'),subTable'')
renameHsStmts [] subTable = do
      return ([],subTable)

instance Rename HsStmt where
    rename (HsGenerator srcLoc hsPat hsExp) = do
        hsExp' <- rename hsExp
        hsPat' <- rename hsPat
        return (HsGenerator srcLoc hsPat' hsExp')
    rename (HsQualifier hsExp) = do
        hsExp' <- rename hsExp
        return (HsQualifier hsExp')
    rename (HsLetStmt hsDecls) = do
        hsDecls' <- rename (expandTypeSigs hsDecls)
        mapM_ HsErrors.hsDeclLocal hsDecls'
        return (HsLetStmt hsDecls')



instance Rename HsFieldUpdate where
    rename (HsFieldUpdate hsName hsExp) = do
        gt <- gets globalSubTable              -- field names are global and not shadowed
        hsName' <- renameHsName hsName gt      -- TODO field names should have own namespace
        hsExp' <- rename hsExp
        return (HsFieldUpdate hsName' hsExp')



instance Rename HsName where
    rename n = renameOld $ renameHsName n

renameTypeName n = renameOld $ renameTypeHsName n

-- This looks up a replacement name in the subtable.
-- Regardless of whether the name is found, if it's not qualified
-- it will be qualified with the current module's prefix.
renameHsName :: HsName -> SubTable -> RM (HsName)
renameHsName hsName subTable
    | nameName tc_Arrow == hsName = return hsName
    | Qual (Module ('@':m)) (HsIdent i) <- hsName = return $ Qual (Module m) (HsIdent i)
renameHsName hsName subTable = case Map.lookup hsName subTable of
    Just name@(Qual _ _) -> return name
    Just _ -> error "renameHsName"
    Nothing
        | Just n <- V.fromTupname hsName -> return hsName
        | otherwise -> do
            sl <- getSrcLoc
            et <- gets errorTable
            let err = case Map.lookup hsName et of {
                Just s -> s;
                Nothing -> "Unknown name: " ++ show hsName }
            warn sl "undefined-name" err
            -- e <- createError ("Undefined Name: " ++ show hsName)
            return $ hsName
            --return (Qual modName name)

renameTypeHsName hsName subTable  =  gets typeSubTable  >>= \t -> case Map.lookup hsName t of
    Just _ -> renameHsName hsName t
    Nothing -> renameHsName hsName subTable

clobberName :: HsName -> RM SubTable
clobberName hsName = do
    unique     <- newUniq
    currModule <- getCurrentModule
    let hsName'     = renameAndQualify hsName unique currModule
    return $ Map.singleton hsName hsName'


renameAndQualify :: HsName -> Int -> Module -> HsName
renameAndQualify name unique currentMod
    = case renameName name unique of
           UnQual name' -> Qual currentMod name'
           qual_name    -> qual_name

-- renames a haskell name with its unique number
renameName :: HsName -> Int -> HsName
renameName n unique = hsNameIdent_u (hsIdentString_u ((show unique ++ "_") ++)) n

-- | unRename gets the original identifier name from the renamed version

unRename :: HsName -> HsName
unRename name
   = case isRenamed name of
          False -> name
          True  -> case name of
                      UnQual i   -> UnQual   $ unrenameIdent i
                      Qual mod i -> Qual mod $ unrenameIdent i

unrenameIdent :: HsIdentifier -> HsIdentifier
unrenameIdent = hsIdentString_u unRenameString

isRenamed :: HsName -> Bool
isRenamed (UnQual i)    = isIdentRenamed i
isRenamed (Qual _mod i) = isIdentRenamed i

-- an identifier is renamed if it starts with one or more digits
-- such an identifier would normally be illegal in Haskell
isIdentRenamed :: HsIdentifier -> Bool
isIdentRenamed i = not $ null $ takeWhile isDigit $ hsIdentString i




unRenameString :: String -> String
unRenameString s = (dropUnderscore . dropDigits) s where
   dropUnderscore ('_':rest) = rest
   dropUnderscore otherList = otherList
   dropDigits = dropWhile isDigit



--------------------------------------------------------
----This section of code updates the current SubTable to reflect the present scope

instance UpdateTable HsDecl where
    getNames hsDecl = fsts $  getHsNamesAndASrcLocsFromHsDecl hsDecl

instance UpdateTable HsPat where
    getNames hsPat = getNamesFromHsPat hsPat

instance UpdateTable HsStmt where
    getNames hsStmt = fsts $  getHsNamesAndASrcLocsFromHsStmt hsStmt



getHsNamesAndASrcLocsFromHsDecl :: HsDecl -> [(HsName, SrcLoc)]
getHsNamesAndASrcLocsFromHsDecl (HsPatBind srcLoc (HsPVar hsName) _ _) = [(hsName, srcLoc)]
getHsNamesAndASrcLocsFromHsDecl (HsPatBind sloc _ _ _) = error $ "non simple pattern binding found (sloc): " ++ show sloc
getHsNamesAndASrcLocsFromHsDecl (HsFunBind hsMatches) = getHsNamesAndASrcLocsFromHsMatches hsMatches
getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ n _) = [(n,a)]
getHsNamesAndASrcLocsFromHsDecl _otherHsDecl = []

getHsNamesAndASrcLocsFromHsMatches :: [HsMatch] -> [(HsName, SrcLoc)]
getHsNamesAndASrcLocsFromHsMatches [] = []
getHsNamesAndASrcLocsFromHsMatches (hsMatch:_hsMatches) = getHsNamesAndASrcLocsFromHsMatch hsMatch

getHsNamesAndASrcLocsFromHsMatch :: HsMatch -> [(HsName, SrcLoc)]
getHsNamesAndASrcLocsFromHsMatch (HsMatch srcLoc hsName _ _ _) = [(hsName, srcLoc)]


-- | Collect all names defined in a module as well as their declaration points and
-- any subnames they might have.

collectDefsHsModule :: HsModule -> ([(Name,SrcLoc,[Name])],[(Name,Int)])
collectDefsHsModule m = execWriter (mapM_ f (hsModuleDecls m)) where
    --g (b,n,sl,ns) = (b,mod n, sl, map mod ns)
    mod = qualifyName (hsModuleName m)
    toName t n = Name.toName t (mod n)
    -- f :: HsDecl -> Writer [(Name,SrcLoc,[Name])] ()
    tellF xs = tell (xs,[]) >> return ()
    tellS xs = tell ([],xs) >> return ()
    f (HsForeignDecl a _ n _)  = tellF [(toName Val n,a,[])]
    f (HsForeignExport a e _ _)  = tellF [(ffiExportName e,a,[])]
    f (HsFunBind [])  = return ()
    f (HsFunBind (HsMatch a n _ _ _:_))  = tellF [(toName Val n,a,[])]
    f (HsPatBind srcLoc p _ _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getNamesFromHsPat p) ]
    f (HsActionDecl srcLoc p _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getNamesFromHsPat p) ]
    f (HsTypeDecl sl n _ _) = tellF [(toName TypeConstructor n,sl,[])]
    f HsDataDecl { hsDeclSrcLoc =sl, hsDeclName = n, hsDeclCons = cs } = do
        tellF $ (toName TypeConstructor n,sl,snub [ x |(x,_,_) <- cs']): cs' ; zup cs where
            cs' = concatMap (namesHsConDecl' toName) cs
    f (HsNewTypeDecl sl _ n _ c _) = do tellF $ (toName TypeConstructor n,sl,snub [ x |(x,_,_) <- cs']): cs' ; zup [c] where
        cs' = namesHsConDecl' toName c
    f cd@(HsClassDecl sl _ ds) = tellF $ (toName Name.ClassName (nameName z),sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]  where
        z = case maybeGetDeclName cd of
            Just x | nameType x == ClassName -> x
            _ -> error "not a class name"
        cs = fst (mconcatMap (namesHsDeclTS' toName) ds)
    f cad@(HsClassAliasDecl { hsDeclSrcLoc = sl, hsDeclName = n, hsDeclDecls = ds }) 
           = tellF $ (toName Name.ClassName n,sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]
        where 
          cs = fst (mconcatMap (namesHsDeclTS' toName) ds)

    f _ = return ()
    zup cs = tellS (map g cs) where
        g ca = (toName DataConstructor (hsConDeclName ca), length $ hsConDeclArgs ca)

namesHsConDecl' toName c = ans where
    dc = (toName DataConstructor $ hsConDeclName c,sl,fls')
    sl = hsConDeclSrcLoc c
    ans = dc : [ (toName Val n,sl,[]) |  n <- fls ]  ++  [ (n,sl,[]) |  n <- fls' ]
    fls' = map (toName FieldLabel) fls
    fls = case c of
        HsRecDecl { hsConDeclRecArg = ra } -> concatMap fst ra -- (map (rtup (hsConDeclSrcLoc c). toName FieldLabel) . fst) ra
        _ -> []

namesHsDeclTS' toName (HsTypeSig sl ns _) = ((map (rtup sl . toName Val) ns),[])
namesHsDeclTS' toName (HsTypeDecl sl n _ _) = ([(toName TypeConstructor n,sl)],[])
namesHsDeclTS' _ _ = ([],[])


namesHsDecl :: HsDecl -> ([(HsName, SrcLoc)],[(HsName, SrcLoc)])
namesHsDecl (HsForeignDecl a _ n _)  = ([(n,a)],[])
namesHsDecl (HsFunBind hsMatches)  = (getHsNamesAndASrcLocsFromHsMatches hsMatches, [])
namesHsDecl (HsPatBind srcLoc p _ _) = (map (rtup srcLoc) (getNamesFromHsPat p),[])
namesHsDecl (HsTypeDecl sl n _ _) = ([],[(n,sl)])
namesHsDecl HsDataDecl { hsDeclSrcLoc = sl, hsDeclName = n, hsDeclCons = cs } = ( (concatMap namesHsConDecl cs) ,[(n,sl)])
namesHsDecl (HsNewTypeDecl sl _ n _ c _) = ( (namesHsConDecl c),[(n,sl)])
namesHsDecl cd@(HsClassDecl sl _ ds) = (mconcatMap namesHsDeclTS ds) `mappend` ([],[(nameName z,sl)]) where
    z = case maybeGetDeclName cd of
        Just x | nameType x == ClassName -> x
        --       | otherwise ->  parseName ClassName (show x ++ show (nameType x))
        _ -> error "really not a class name"
namesHsDecl _ = mempty

namesHsDeclTS (HsTypeSig sl ns _) = ((map (rtup sl) ns),[])
namesHsDeclTS _ = ([],[])

namesHsConDecl c = (hsConDeclName c,hsConDeclSrcLoc c) : case c of
    -- HsRecDecl { hsConDeclRecArg = ra } -> concatMap (map (rtup (hsConDeclSrcLoc c)) . fst) ra
    _ -> []

getHsNamesAndASrcLocsFromHsStmt :: HsStmt -> [(HsName, SrcLoc)]
getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc)
getHsNamesAndASrcLocsFromHsStmt (HsQualifier _hsExp) = []
getHsNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concat $ map getHsNamesAndASrcLocsFromHsDecl hsDecls


instance UpdateTable HsQualType where
    getNames (HsQualType _hsContext hsType) = getNames hsType

instance UpdateTable HsType where
    getNames t = execWriter (getNamesFromType t)  where
        getNamesFromType (HsTyVar hsName) = tell [hsName]
        getNamesFromType t = traverseHsType_ getNamesFromType t


qualifyName :: Module -> HsName -> HsName
qualifyName _ name@(Qual {}) = name
qualifyName mod (UnQual name) = Qual mod name