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

import Control.Applicative
import Control.Monad.Identity
import Control.Monad.RWS
import Control.Monad.Writer
import Data.Char
import Data.Maybe
import Data.List hiding(union)
import qualified Data.Foldable as Seq
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set

import Doc.DocLike(tupled)
import DerivingDrift.Drift
import FrontEnd.Desugar (desugarHsModule,doToExp,listCompToExp)
import FrontEnd.HsSyn
import FrontEnd.SrcLoc hiding(srcLoc)
import qualified FrontEnd.SrcLoc
import FrontEnd.Syn.Traverse
import FrontEnd.Warning
import Name.Name as Name
import Name.Names
import Options
import Support.FreeVars
import Util.Gen
import Util.Inst()
import Util.SetLike
import qualified FrontEnd.HsErrors as HsErrors
import qualified Name.VConsts as V

data FieldMap = FieldMap
    !(Map.Map Name Int)          -- a map of data constructors to their arities
    !(Map.Map Name [(Name,Int)]) -- a map of field labels to ...

instance Monoid FieldMap where
    mempty = FieldMap mempty mempty
    mappend (FieldMap a b) (FieldMap c d) =
        FieldMap (a `mappend` c) (b `mappend` d)

type SubTable = Map.Map Name Name

newtype ScopeState = ScopeState Int

data Context
    = ContextTopLevel
    | ContextInstance !Name
    | ContextLocal
    deriving(Eq)

data Env = Env {
    envModule      :: Module,
    envNameMap     :: Map.Map Name (Either String Name),
    envOptions     :: Opt,
    envFieldLabels :: FieldMap,
    envSrcLoc      :: SrcLoc
    }

addTopLevels :: HsModule -> RM a -> RM a
addTopLevels  hsmod action = do
    mod <- getCurrentModule
    let cdefs = map (\ (x,y,_) -> (x,y)) $ fst $ collectDefsHsModule hsmod
        nmap = foldl f [] (fsts cdefs)
        f r hsName@(getModule -> Just _)
            | Just _ <- V.fromTupname hsName, toModule "Jhc.Prim.Prim" == mod
                = let nn = hsName in (nn,nn):r
            | nameName tc_Arrow == hsName, toModule "Jhc.Prim.Prim" == mod
                = let nn = hsName in (nn,nn):r
            | otherwise = let nn = toUnqualified hsName in (nn,hsName):(hsName,hsName):r
        f r z = let nn = qualifyName mod z 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 (MultiplyDefined n (snds xs))
            (show n ++ " is defined multiple times: " ++ show xs)
    z cdefs
    let amb k x y | x == y = x
        amb k (Right n1) (Right n2) = Left (ambig k [n1,n2])
        amb _ _ l  = l
    local (\e -> e { envNameMap = Map.unionWithKey amb (Map.map Right $ Map.fromList nmap) (envNameMap e) }) action

createSelectors sloc ds = mapM g ns where
    ds' :: [(Name,[(Name,HsBangType)])]
    ds' = [ (c,[(n,t) | (ns,t) <- rs , n <- ns ]) | HsRecDecl { hsConDeclName = c, hsConDeclRecArg = rs } <- ds ]
    ns = sortGroupUnderF fst $ concatMap f ds' -- [  | (c,nts) <- ds' ]
    f (c,nts) = [ (n,(c,i,length nts)) | (n,_) <- nts | i <- [0..]]
    g (n,cs) = do
        var <- clobberedName (toName Val "_sel")
        let f (_,(c,i,l)) = HsMatch sloc n [pat c i l] (HsUnGuardedRhs (HsVar var)) []
            pat c i l = HsPApp c [ if p == i then HsPVar var else HsPWildCard | p <- [0 .. l - 1]]
            els = HsMatch sloc n [HsPWildCard] (HsUnGuardedRhs HsError { hsExpSrcLoc = sloc, hsExpString = show n, hsExpErrorType = HsErrorFieldSelect } ) []
        return $ HsFunBind (map f cs ++ [els]) where

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

runRename :: MonadWarn m => (a -> RM b) -> Opt -> Module -> FieldMap -> [(Name,[Name])] -> a -> m (b,Map.Map Name Name)
runRename doit opt mod fls ns m = mapM_ addWarning errors >> return (renamedMod,reverseMap) where
    nameMap = fromList $ map f ns where
        f (x,[y]) = (x,Right y)
        f (x,ys)  = (x,Left $ ambig x ys)
    startState = ScopeState 1
    startEnv = Env {
        envModule      = mod,
        envNameMap     = nameMap,
        envOptions     = opt,
        envFieldLabels = fls,
        envSrcLoc      = mempty
    }
    (renamedMod, _, (reverseMap,errors)) = runRWS (unRM $ doit m) startEnv startState

{-# NOINLINE renameModule #-}
renameModule :: MonadWarn m => Opt -> FieldMap -> [(Name,[Name])] -> HsModule -> m ((HsModule,[HsDecl]),Map.Map Name Name)
renameModule opt fls ns m = runRename go opt (hsModuleName m) fls (ns ++ driftResolvedNames) m
  where go mod = do
          let renDesugared = renameDecls . desugarHsModule
          rmod <- renDesugared mod
          inst <- hsModuleDecls `fmap` renDesugared mod{hsModuleDecls = driftDerive rmod}
          return (hsModuleDecls_u (++ inst) rmod,inst)

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

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

renameDecls :: HsModule -> RM HsModule
renameDecls mod = do
    withSrcLoc (hsModuleSrcLoc mod) $ do
    addTopLevels mod $ do
    decls' <- renameHsDecls ContextTopLevel (hsModuleDecls mod)
    mapM_ checkExportSpec $ fromMaybe [] (hsModuleExports mod)
    return mod { hsModuleDecls = decls' }

checkExportSpec :: HsExportSpec -> RM ()
checkExportSpec e = f [DataConstructor, TypeConstructor, ClassName] e where
    f _ (HsEVar n) = do check [Val] n
    f dt (HsEAbs n) = do check dt n
    f dt (HsEThingAll n) = do check dt n
    f dt (HsEThingWith n ns) = do
        check dt n
        mapM_ (check [DataConstructor,Val]) ns
    f _ HsEModuleContents {} = return ()
    f _ (HsEQualified nt he) = f [nt] he
    check ts n = do
        nm <- asks envNameMap
        let idef = any isJust (map (flip mlookup nm) $ zipWith toName ts (repeat n))
        unless idef $ do
            sl <- getSrcLoc
            warn sl (UndefinedName n) ("unknown name in export list: " ++ show n)

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

getTypeClassModule :: HsClassHead -> Maybe Module
getTypeClassModule typ = getModule (hsClassHead typ)

qualifyMethodName :: Module -> Name -> Name
qualifyMethodName mod name = quoteName . toName Val $ qualifyName mod name

qualifyInstMethod :: Maybe Module -> HsDecl -> RM HsDecl
qualifyInstMethod Nothing decl = rename decl
qualifyInstMethod (Just moduleName) decl = case decl of
    HsPatBind srcLoc HsPVar {hsPatName = name} rhs decls ->
        rename $ HsPatBind srcLoc (HsPVar {hsPatName = qualifyMethodName moduleName name}) rhs decls
    HsFunBind matches -> rename $ HsFunBind (map f matches) where
        f m@HsMatch { hsMatchName } = m { hsMatchName = qualifyMethodName moduleName hsMatchName }
    _ -> rename decl

renameHsDecls :: Context -> [HsDecl] -> RM [HsDecl]
renameHsDecls c ds = f ds where
    f (d:ds) = do
        d' <- rename d
        when (c == ContextTopLevel) $ HsErrors.hsDeclTopLevel d'
        eds <- g d'
        ds' <- f ds
        return $ d':eds ++ ds'
    f [] = return []
    g HsDataDecl { hsDeclSrcLoc = sloc, hsDeclCons = cs } = createSelectors sloc cs
    g _ = return []

instance Rename HsDecl where
    rename d = withSrcLoc (FrontEnd.SrcLoc.srcLoc d) $ renameHsDecl d

renameHsDecl d = f d where
    f (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) = do
        hsPat'    <- rename hsPat
        updateWithN Val hsDecls $ do
        hsDecls'  <- rename hsDecls
        hsRhs'    <- rename hsRhs
        return (HsPatBind srcLoc hsPat' hsRhs' {-where-} hsDecls')
    f (HsForeignExport a b n t) = do
        n <- renameValName n
        updateWith t $ do
            t <- rename t
            return (HsForeignExport a b n t)
    f (HsForeignDecl a b n t) = do
        n <- renameValName n
        updateWith t $ do
        t <- rename t
        return (HsForeignDecl a b n t)
    f (HsFunBind hsMatches) = do
        hsMatches' <- rename hsMatches
        return (HsFunBind hsMatches')
    f (HsTypeSig srcLoc hsNames hsQualType) = do
        hsNames' <- mapM renameValName hsNames
        updateWith hsQualType $ do
            hsQualType' <- rename hsQualType
            return (HsTypeSig srcLoc hsNames' hsQualType')
    f HsDataDecl { .. } | hsDeclDeclType == DeclTypeKind = do
        hsDeclName <- renameKindName hsDeclName
        unless (null hsDeclArgs) $
            addWarn InvalidDecl "kind declarations can't have arguments."
        when (any isHsRecDecl hsDeclCons) $
            addWarn InvalidDecl "kind declarations can't have records."
        hsDeclCons <- mapM renameKindHsCon hsDeclCons
        unless (null hsDeclDerives) $
            addWarn InvalidDecl "kind declarations can't derive classes"
        unless (null hsDeclContext) $
            addWarn InvalidDecl "kind declarations can't have context"
        return HsDataDecl { .. }
    f HsDataDecl { .. } = do
        hsDeclName <- renameTypeName hsDeclName
        updateWith (map fromTypishHsName hsDeclArgs) $ do
            hsDeclContext <- rename hsDeclContext
            hsDeclArgs <- mapM renameTypeName hsDeclArgs
            hsDeclCons <- rename hsDeclCons
            hsDeclDerives <- mapM (renameName . toName ClassName) hsDeclDerives
            return HsDataDecl { .. }
    f (HsTypeDecl srcLoc name hsNames t) = do
        hsName' <- renameTypeName name
        updateWith (Set.toList $ freeVars hsNames :: [Name]) $ do
            hsNames' <- rename hsNames
            t' <- rename t
            return (HsTypeDecl srcLoc  hsName' hsNames' t')
    f HsTypeFamilyDecl { .. } = do
        hsDeclCName <- renameTypeName hsDeclName
        updateWith (Set.toList $ freeVars hsDeclTArgs :: [Name]) $ do
            hsDeclTArgs <- rename hsDeclTArgs
            return HsTypeFamilyDecl { .. }
    f (HsClassDecl srcLoc classHead hsDecls) = do
        classHead' <- updateWithN TypeVal (hsClassHeadArgs classHead) $ rename classHead
        hsDecls' <- rename hsDecls
        return (HsClassDecl srcLoc classHead' hsDecls')
    f (HsClassAliasDecl srcLoc name args hsContext hsClasses hsDecls) = 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')
    f (HsInstDecl srcLoc classHead hsDecls) = do
        updateWithN TypeVal (hsClassHeadArgs classHead) $ do
        classHead' <- rename classHead
        hsDecls' <- mapM (qualifyInstMethod (getTypeClassModule classHead')) hsDecls
        return (HsInstDecl srcLoc classHead' hsDecls')
    f (HsInfixDecl srcLoc assoc int hsNames) = do
        hsNames' <- mapM renameValName hsNames
        return $ HsInfixDecl srcLoc assoc int hsNames'
    f (HsActionDecl srcLoc pat e) = do
        pat <- rename pat
        e <- rename e
        return (HsActionDecl srcLoc pat e)
    f (HsPragmaProps srcLoc prop hsNames) = do
        hsNames' <- mapM renameValName hsNames
        return (HsPragmaProps  srcLoc prop hsNames')
    f (HsPragmaRules rs) = do
        rs' <- rename rs
        return $ HsPragmaRules rs'
    f prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } = do
        n <- if n == nameName u_instance then return n else renameValName n
        let ns = snub (getNames t)
        updateWith t $ do
            ns' <- mapM renameTypeName ns
            t <- rename t
            m <- getCurrentModule
            i <- newUniq
            let _nt = if null ns' then t else HsTyForall bs (HsQualType [] t)
                bs = [ hsTyVarBind { hsTyVarBindName = n } | n <- ns']
            return prules { hsDeclUniq = (m,i), hsDeclName = n, hsDeclType = t }
    f (HsDefaultDecl sl e) = HsDefaultDecl sl <$> rename e
    f (HsDeclDeriving sl ch) = HsDeclDeriving sl <$> rename ch
    f h = error $ "renameerr: " ++ show h

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

instance Rename HsRule where
    rename prules@HsRule { hsRuleSrcLoc = srcLoc, hsRuleFreeVars = fvs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } = do
        withSrcLoc srcLoc $ do
        updateWith (map fromValishHsName $ fsts fvs) $ do
        subTable'' <- getUpdates (catMaybes $ snds fvs)
        fvs' <- sequence [ liftM2 (,) (renameValName 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' }

instance Rename HsQualType where
    rename (HsQualType hsContext hsType) =
        HsQualType <$> rename hsContext <*> rename hsType

instance Rename HsAsst where
    rename (HsAsst hsName1 hsName2s) = do
        hsName1' <- renameName (toName ClassName hsName1)
        hsName2s' <- mapM renameTypeName hsName2s
        return (HsAsst hsName1' hsName2s')
    rename (HsAsstEq t1 t2) = HsAsstEq <$> rename t1 <*> rename t2

instance Rename HsConDecl where
    --rename cd@(HsConDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclConArg = hsBangTypes }) = do
    rename cd@(HsConDecl {  hsConDeclName = hsName, hsConDeclConArg = hsBangTypes, .. }) = do
        withSrcLoc hsConDeclSrcLoc $ do
        hsName' <- renameValName hsName
        updateWith  (map (toName TypeVal . hsTyVarBindName) hsConDeclExists) $ do
        hsConDeclExists <- rename hsConDeclExists
        hsBangTypes' <- rename hsBangTypes
        return cd { hsConDeclName = hsName', hsConDeclConArg = hsBangTypes', hsConDeclExists }
    rename cd@HsRecDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclRecArg = stuff} = do
        withSrcLoc srcLoc $ do
        hsName' <- renameValName hsName
        updateWith (map (toName TypeVal . hsTyVarBindName) (hsConDeclExists cd)) $ do
        es <- rename (hsConDeclExists cd)
        stuff' <- sequence [ do ns' <- mapM renameName (map (toName FieldLabel) ns); t' <- rename t; return (ns',t')  |  (ns,t) <- stuff]
        return cd { hsConDeclName = hsName', hsConDeclRecArg = stuff', hsConDeclExists = es }

renameKindHsCon HsConDecl { .. } = do
    withSrcLoc hsConDeclSrcLoc $ do
    hsConDeclName <- renameTypeName hsConDeclName
    unless (null hsConDeclExists) $
        addWarn InvalidDecl "kind declarations cannot have existential types"
    let bt e@HsBangedTy {} = do
            addWarn InvalidDecl "strictness annotations not relevant to kind declarations"
            return e
        bt (HsUnBangedTy e) = HsUnBangedTy `liftM` f e
        f (HsTyCon n) = HsTyCon `liftM` renameKindName n
        f e = addWarn InvalidDecl "invalid argument in kind declaration" >> return e
    hsConDeclConArg <- mapM bt hsConDeclConArg
    return HsConDecl { .. }
renameKindHsCon _ = error "Rename.renameKindHsCon: bad."

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 (toName TypeVal) $ map hsTyVarBindName ts)  $ do
        ts' <- rename ts
        v' <- rename v
        return $ HsTyForall ts' v'
    rt (HsTyExists ts v) = do
        updateWith (map (toName TypeVal) $ 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 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) = (,) <$> rename a <*> rename b

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

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' <- renameValName hsName
        updateWithN Val hsPats  $ do
        hsPats' <- rename hsPats
        updateWithN Val 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` renameValName hsName
    rename (HsPInfixApp hsPat1 hsName hsPat2) = HsPInfixApp <$> rename hsPat1 <*> renameValName hsName <*> rename hsPat2
    rename (HsPApp hsName hsPats) = HsPApp <$> renameValName hsName <*> rename hsPats
    rename (HsPRec hsName hsPatFields) = do
        hsName' <- renameValName hsName
        hsPatFields' <- rename hsPatFields
        fls <- asks envFieldLabels
        buildRecPat fls hsName' hsPatFields'
    rename (HsPAsPat hsName hsPat) = HsPAsPat <$> renameValName hsName <*> rename hsPat
    rename (HsPTypeSig sl hsPat qt)  = HsPTypeSig sl <$> rename hsPat <*> rename qt
    rename p = traverseHsPat rename p

buildRecPat :: FieldMap -> Name -> [HsPatField] -> RM HsPat
buildRecPat (FieldMap amp fls) n us = case mlookup (toName DataConstructor n) amp of
    Nothing -> failRename $ "Unknown Constructor: " ++ show n
    Just t -> do
        let f (HsPFieldPat x p) = case  mlookup (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' <- renameName (toName FieldLabel hsName) --renameName hsName gt
        hsPat' <- rename hsPat
        return (HsPFieldPat hsName' hsPat')

instance Rename HsRhs where
    rename (HsUnGuardedRhs hsExp) = HsUnGuardedRhs <$> rename hsExp
    rename (HsGuardedRhss rs) = 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')

f_fromRational = HsVar $ nameName (toUnqualified v_fromRational)

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

instance Rename HsExp where
    rename (HsVar hsName) = HsVar <$> renameValName hsName
    rename (HsCon hsName) = HsCon <$> renameValName hsName
    rename i@(HsLit HsInt {}) = do return i
    rename i@(HsLit HsFrac {}) = do
        z <- rename f_fromRational
        return $ HsParen (HsApp z i)
    rename (HsLambda srcLoc hsPats hsExp) = do
        withSrcLoc srcLoc $ do
        updateWithN Val hsPats $ do
        hsPats' <- rename hsPats
        hsExp' <- rename hsExp
        return (HsLambda srcLoc hsPats' hsExp')
    rename (HsLet hsDecls hsExp) = do
        updateWithN Val hsDecls $ do
        hsDecls' <- rename (expandTypeSigs hsDecls)
        mapM_ HsErrors.hsDeclLocal hsDecls'
        hsExp' <- rename hsExp
        return (HsLet hsDecls' hsExp')
    rename (HsCase hsExp hsAlts) = do HsCase <$> rename hsExp <*> rename hsAlts
    rename (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 (HsEnumFrom hsExp) = rename $ desugarEnum "enumFrom" [hsExp]
    rename (HsEnumFromTo hsExp1 hsExp2) = rename $  desugarEnum "enumFromTo" [hsExp1, hsExp2]
    rename (HsEnumFromThen hsExp1 hsExp2) = rename $ desugarEnum "enumFromThen" [hsExp1, hsExp2]
    rename (HsEnumFromThenTo hsExp1 hsExp2 hsExp3) = rename $  desugarEnum "enumFromThenTo" [hsExp1, hsExp2, hsExp3]
    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
    rename p = traverseHsExp rename p

desugarEnum s as = foldl HsApp (HsVar (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 -> Name -> [HsFieldUpdate] -> RM HsExp
buildRecConstr (FieldMap amp fls) n us = do
    undef <- createError HsErrorUninitializedField "Uninitialized Field"
    case mlookup (toName DataConstructor n) amp of
        Nothing -> failRename $ "Unknown Constructor: " ++ show n
        Just t -> do
            let f (HsFieldUpdate x e) = case  mlookup (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
            return $ foldl HsApp (HsCon n) rs

buildRecUpdate ::  FieldMap -> HsExp -> [HsFieldUpdate] -> RM HsExp
buildRecUpdate (FieldMap amp fls) n us = do
        sl <- getSrcLoc
        let f (HsFieldUpdate x e) = case  mlookup (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 mlookup 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
                    let x = foldl HsApp (HsCon c') [ 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
        updateWithN Val hsPat $ do
        hsPat' <- rename hsPat
        updateWithN Val hsDecls $ do
        hsDecls' <- rename (expandTypeSigs hsDecls)
        mapM_ HsErrors.hsDeclLocal hsDecls'
        hsGuardedAlts' <- rename hsGuardedAlts
        return (HsAlt srcLoc hsPat' hsGuardedAlts' hsDecls')

renameHsStmts :: [HsStmt] -> RM a  -> RM ([HsStmt],a)
renameHsStmts ss fe = f ss [] where
    f (HsGenerator sl p e:ss) rs = do
        e' <- rename e
        updateWith p $ do
          p' <- rename p
          f ss (HsGenerator sl p' e':rs)
    f (s:ss) rs = do
        updateWith s $ do
          s' <- rename s
          f ss (s':rs)
    f [] rs = do
        e <- fe
        return (reverse rs,e)

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' <- renameName hsName gt      -- TODO field names should have own namespace
        hsName' <- renameName (toName FieldLabel hsName)      -- TODO field names should have own namespace
        hsExp' <- rename hsExp
        return (HsFieldUpdate hsName' hsExp')

renameValName :: Name -> RM Name
renameValName hsName = renameName (fromValishHsName hsName)

renameTypeName :: Name -> RM Name
renameTypeName hsName = renameName (fromTypishHsName hsName)

renameKindName :: Name -> RM Name
renameKindName hsName = renameName (toName SortName hsName)

renameName :: Name -> RM Name
-- a few hard coded cases
renameName hsName
    | Just n <- fromQuotedName hsName = return n
    | hsName `elem` [tc_Arrow,dc_Unit,tc_Unit] = return hsName
    | (nt,Just m,i) <- nameParts hsName, '@':_ <- show m = return $ toName nt (m, i)
    | Just _ <- V.fromTupname hsName = return hsName
renameName hsName = do
    subTable <- asks envNameMap
    case mlookup hsName subTable of
        Just (Right name) -> do
            tell (Map.singleton name hsName,mempty)
            return name
        Just (Left err) -> do
            addWarn (UndefinedName hsName) err
            return hsName
        Nothing -> do
            let err = "Unknown name: " ++ show hsName
            addWarn (UndefinedName hsName) err
            return hsName

clobberedName :: Name -> RM Name
clobberedName hsName = do
    unique     <- newUniq
    currModule <- getCurrentModule
    return $ renameAndQualify hsName unique currModule

clobberName :: Name -> RM SubTable
clobberName hsName = do
    hsName' <- clobberedName hsName
    return $ msingleton hsName hsName'

renameAndQualify :: Name -> Int -> Module -> Name
renameAndQualify name unique currentMod = qualifyName currentMod (renameName name unique) where
    renameName n unique = mapName (id,((show unique ++ "_") ++)) n

-- | unRename gets the original identifier name from the renamed version
unRename :: Name -> Name
unRename name = mapName (id,unRenameString) name

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

updateWithN nt x action = getUpdatesN nt x >>= flip withSubTable action
getUpdatesN nt x = unions `fmap` mapM clobberName (map (toName nt) $ getNames x)

updateWith x action = getUpdates x >>= flip withSubTable action
getUpdates x = unions `fmap` mapM clobberName (getNames x)

class UpdateTable a where
    getNames :: a -> [Name]
    getNames a = []

instance UpdateTable a => UpdateTable [a] where
    getNames xs = concatMap getNames xs
instance (UpdateTable a, UpdateTable b) => UpdateTable (a,b) where
    getNames (a,b) = getNames a ++ getNames b

instance UpdateTable Name where
    getNames x | nameType x == QuotedName = []
               | otherwise = [x]

instance UpdateTable HsDecl where
    getNames hsDecl = fsts $ getNamesAndASrcLocsFromHsDecl hsDecl
instance UpdateTable HsPat where
    getNames hsPat = getNamesFromHsPat hsPat
instance UpdateTable HsStmt where
    getNames hsStmt = fsts $ getNamesAndASrcLocsFromHsStmt hsStmt
instance UpdateTable HsQualType where
    getNames (HsQualType _hsContext hsType) = getNames hsType
instance UpdateTable HsType where
    getNames t = execWriter (getNamesFromType t)  where
        getNamesFromType (HsTyVar hsName) = tell [fromTypishHsName hsName]
        getNamesFromType t = traverseHsType_ getNamesFromType t

getNamesAndASrcLocsFromHsDecl :: HsDecl -> [(Name, SrcLoc)]
getNamesAndASrcLocsFromHsDecl d = f d where
    f (HsPatBind srcLoc (HsPVar hsName) _ _) = [(fromValishHsName hsName, srcLoc)]
    f (HsPatBind sloc _ _ _) = error $ "non simple pattern binding found (sloc): " ++ show sloc
    f (HsFunBind (HsMatch { .. }:_)) = [(fromValishHsName hsMatchName,hsMatchSrcLoc)]
    f (HsForeignDecl { .. }) = [(fromValishHsName hsDeclName, hsDeclSrcLoc)]
    f _ = []

-- | Collect all names defined in a module as well as their declaration points
-- and any subnames they might have. In addition, collect the arities of any
-- constructors.

collectDefsHsModule :: HsModule -> ([(Name,SrcLoc,[Name])],[(Name,Int)])
collectDefsHsModule m = (\ (x,y) -> (Seq.toList x,Seq.toList y)) $ execWriter (mapM_ f (hsModuleDecls m)) where
    toName t n = Name.toName t (qualifyName (hsModuleName m) n)
    tellName sl n = tellF [(n,sl,[])]
    tellF xs = tell (Seq.fromList xs,Seq.empty) >> return ()
    tellS xs = tell (Seq.empty,Seq.fromList xs) >> return ()
    f (HsForeignDecl a _ n _)    = tellName a (toName Val n)
    f (HsForeignExport a e _ _)  = tellName a (ffiExportName e)
    f (HsFunBind [])  = return ()
    f (HsFunBind (HsMatch a n _ _ _:_))  = tellName a (toName Val n)
    f (HsPatBind srcLoc p _ _)  = mapM_ (tellName srcLoc) [ (toName Val n) | n <- (getNamesFromHsPat p) ]
    f (HsActionDecl srcLoc p _) = mapM_ (tellName srcLoc) [ (toName Val n) | n <- (getNamesFromHsPat p) ]
    f (HsTypeDecl sl n _ _) = tellName sl (toName TypeConstructor n)
    f HsDataDecl { hsDeclDeclType = DeclTypeKind, hsDeclSrcLoc =sl, hsDeclName = n, hsDeclCons = cs } = do
        tellF $ (toName SortName n,sl,snub [ x |(x,_,_) <- cs']): cs' ; zup cs where
            cs' = concatMap (namesHsConDeclSort' toName) cs
    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 cd@(HsClassDecl sl ch ds) = tellF $ (toName ClassName $ hsClassHead ch,sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]  where
        cs = (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 = (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
            _ -> []

    namesHsConDeclSort' toName c = [dc] where
        dc = (toName TypeConstructor $ hsConDeclName c,sl,[])
        sl = hsConDeclSrcLoc c

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

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

-----------
-- RM Monad
-----------

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)

unRM (RM x) = x

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

instance MonadWarn RM where
    addWarning w = tell (mempty,[w])

instance UniqueProducer RM where
    newUniq = do
        ScopeState u <- get
        modify (\(ScopeState s) -> ScopeState (1 + s))
        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
instance OptionMonad RM where
    getOptions = asks envOptions

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