------------------------------------------------------------------
-- |
-- Module      :  Yhc.Core.MapNames
-- Copyright   :  (c) Dmitry Golubovsky, 2007              
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Rename all functions and data constructors given a map of names
------------------------------------------------------------------

module Yhc.Core.MapNames (
  mapFunNames,
  mapDataNames,
  mapConNames) where

import Yhc.Core
import Data.Maybe
import qualified Data.Map as M

-- |Rename all functions in the Core given the map of old to new names.

mapFunNames :: M.Map CoreFuncName CoreFuncName -> Core -> Core

mapFunNames funmap core = mapFunDefs funmap $ mapUnderCore mapfun core where
  mapfun (CoreFun s) = let ns = M.lookup s funmap in CoreFun $ fromMaybe s ns
  mapfun z = z

mapFunDefs dmap core = core {coreFuncs = mpfd} where
  mpfd = map mpof $ coreFuncs core
  mpof func = let old = coreFuncName func
                  new = fromMaybe old $ M.lookup old dmap
              in  func {coreFuncName = new}


-- |Rename all data objects (LHS of data XXX) given the map of old to new names.

mapDataNames :: M.Map CoreDataName CoreDataName -> Core -> Core

mapDataNames dmap core = core {coreDatas = mpdd} where
  mpdd = map mpod $ coreDatas core
  mpod dtdf = let old = coreDataName dtdf
                  new = fromMaybe old $ M.lookup old dmap
              in  dtdf {coreDataName = new}

-- |Rename all data constructors in the Core given the map of old to new names.

mapConNames :: M.Map CoreCtorName CoreCtorName -> Core -> Core

mapConNames conmap core = mapConDefs conmap $ mapUnderCore mapcon core where
  mapcon (CoreCon s) = let ns = M.lookup s conmap in CoreCon $ fromMaybe s ns
  mapcon (CoreCase expr alts) = CoreCase (mapcon expr) (map (mapalt conmap) alts) where 
    mapalt conmap (altpat, altexpr) = (mappat conmap altpat, mapcon altexpr) where
      mappat conmap (PatCon s cvs) = 
        let ns = M.lookup s conmap in PatCon (fromMaybe s ns) cvs
      mappat _ x = x
  mapcon z = z

mapConDefs cmap core = core {coreDatas = mpcd} where
  mpcd = map mapcons $ coreDatas core
  mapcons cdata = cdata {coreDataCtors = map mpod $ coreDataCtors cdata}
  mpod ctor = let old = coreCtorName ctor
                  new = fromMaybe old $ M.lookup old cmap
              in  ctor {coreCtorName = new}