-------------------------------------------------------------------------------
-- |
-- Module      :  System.Hardware.Haskino.ShallowDeepPlugin.BindChangeArgPass
-- Copyright   :  (c) University of Kansas
-- License     :  BSD3
-- Stability   :  experimental
--
-- Local bind argument and return type change pass
-- Performs the following transformations:
--
-- forall (f :: ExprB a,b,c,d => a -> ... -> c -> d)
--  f :: a -> ... -> c -> d
--    =
--  f_deep :: Expr a  -> ... -> Expr c -> Expr d
--
-- It does this by changing the types of the argument and return
-- of the function, and then replacing occurance of one of
-- the arguments in the body of the function with 'rep' applied to the
-- argument.  To change the type of the body, it applies a 'rep <$>'
-- to the last expresion of the bind chain for the local bind.
--
-- Once this new deep function has been created with a body
-- that is a transformed version of the shallow function's body,
-- the shallow function body may be rewritten in terms of the
-- deep version:
--
-- f = abs_ <$> f_deep (rep_ a) ... (rep_ c)
--
-- (Note:  In creating the deep function, any arguments
--  that are not of the ExprB type will be left unchanged.)
--
-- The next transformation is to transform any applications of the
-- transformed functions in other binds with:
--   forall (f: a -> .. b -> Arduino a).
--   f aa .. ab
--     =
--   abs_ <$> f_deep (rep aa) .. (rep ab)
--
-- Note, the above transformations allow the transformation to
-- work across multiple Haskell modules.  The shallow versions
-- will be used by the Haskell typechecking on modules that are
-- dependednt on the trnasformed one, while calls in the body
-- of local functions which call functions in the external module
-- will be transformed to use exported deep versions.
--
-- The data structure commProcList is used to list deep versions
-- of the DSL commands/procedures, so that the transformation does
-- not attempt to look for these in an external transformed module.
-------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Hardware.Haskino.ShallowDeepPlugin.BindChangeArgPass (bindChangeArgRetAppPass) where

import           Avail
import           Control.Monad.State
import           CoreMonad
import           Data.List
import           Data.List.Split
import qualified Data.Map             as M
import           GhcPlugins

import System.Hardware.Haskino.ShallowDeepPlugin.Utils

-- ToDo: Cleanup and Unify
comProcList :: [String]
comProcList = [ "systemReset"
              , "setPinModeE"
              , "digitalWriteE"
              , "digitalPortWriteE"
              , "analogWriteE"
              , "toneE"
              , "noToneE"
              , "i2cWriteE"
              , "i2cConfigE"
              , "serialBeginE"
              , "serialEndE"
              , "serialWriteE"
              , "serialWriteListE"
              , "stepperSetSpeedE"
              , "servoDetachE"
              , "servoWriteE"
              , "servoWriteMicrosE"
              , "createTaskE"
              , "deleteTaskE"
              , "scheduleTaskE"
              , "attachIntE"
              , "detachIntE"
              , "interrupts"
              , "noInterrupts"
              , "scheduleReset"
              , "giveSemE"
              , "takeSemE"
              , "loopE"
              , "forInE"
              , "writeRemoteRefE"
              , "modifyRemoteRefE"
              , "queryFirmwareE"
              , "queryProcessorE"
              , "microsE"
              , "millisE"
              , "delayMillisE"
              , "delayMicrosE"
              , "digitalReadE"
              , "digitalPortReadE"
              , "analogReadE"
              , "i2CReadE"
              , "serialAvailableE"
              , "serialReadE"
              , "serialReadListE"
              , "stepper2PinE"
              , "stepper4PinE"
              , "stepperStepE"
              , "servoAttachE"
              , "servoAttachMinMaxE"
              , "servoReadE"
              , "servoReadMicrosE"
              , "queryAllTasksE"
              , "queryTaskE"
              , "bootTaskE"
              , "readRemoteRefE"
              , "newRemoteRefE"
              , "ifThenElseBoolE"
              , "ifThenElseWord8E"
              , "ifThenElseWord16E"
              , "ifThenElseWord32E"
              , "ifThenElseInt8E"
              , "ifThenElseInt16E"
              , "ifThenElseInt32E"
              , "ifThenElseIntE"
              , "ifThenElseL8E"
              , "ifThenElseFloatE"
              , "ifThenElseUnitE"
              , "ifThenElseW8Unit"
              , "ifThenElseW8W8"
              , "ifThenElseUnitUnit"
              , "ifThenElseUnitBool"
              , "ifThenElseUnitW8"
              , "ifThenElseUnitW16"
              , "ifThenElseUnitW32"
              , "ifThenElseUnitI8"
              , "ifThenElseUnitI16"
              , "ifThenElseUnitI32"
              , "ifThenElseUnitI"
              , "ifThenElseUnitL8"
              , "ifThenElseUnitFloat"
              , "ifThenElseBoolUnit"
              , "ifThenElseBoolBool"
              , "ifThenElseBoolW8"
              , "ifThenElseBoolW16"
              , "ifThenElseBoolW32"
              , "ifThenElseBoolI8"
              , "ifThenElseBoolI16"
              , "ifThenElseBoolI32"
              , "ifThenElseBoolI"
              , "ifThenElseBoolL8"
              , "ifThenElseBoolFloat"
              , "ifThenElseW8Unit"
              , "ifThenElseW8Bool"
              , "ifThenElseW8W8"
              , "ifThenElseW8W16"
              , "ifThenElseW8W32"
              , "ifThenElseW8I8"
              , "ifThenElseW8I16"
              , "ifThenElseW8I32"
              , "ifThenElseW8I"
              , "ifThenElseW8L8"
              , "ifThenElseW8Float"
              , "ifThenElseW16Unit"
              , "ifThenElseW16Bool"
              , "ifThenElseW16W8"
              , "ifThenElseW16W16"
              , "ifThenElseW16W32"
              , "ifThenElseW16I8"
              , "ifThenElseW16I16"
              , "ifThenElseW16I32"
              , "ifThenElseW16I"
              , "ifThenElseW16L8"
              , "ifThenElseW16Float"
              , "ifThenElseW32Unit"
              , "ifThenElseW32Bool"
              , "ifThenElseW32W8"
              , "ifThenElseW32W16"
              , "ifThenElseW32W32"
              , "ifThenElseW32I8"
              , "ifThenElseW32I16"
              , "ifThenElseW32I32"
              , "ifThenElseW32I"
              , "ifThenElseW32L8"
              , "ifThenElseW32Float"
              , "ifThenElseI8Unit"
              , "ifThenElseI8Bool"
              , "ifThenElseI8W8"
              , "ifThenElseI8W16"
              , "ifThenElseI8W32"
              , "ifThenElseI8I8"
              , "ifThenElseI8I16"
              , "ifThenElseI8I32"
              , "ifThenElseI8I"
              , "ifThenElseI8L8"
              , "ifThenElseI8Float"
              , "ifThenElseI16Unit"
              , "ifThenElseI16Bool"
              , "ifThenElseI16W8"
              , "ifThenElseI16W16"
              , "ifThenElseI16W32"
              , "ifThenElseI16I8"
              , "ifThenElseI16I16"
              , "ifThenElseI16I32"
              , "ifThenElseI16I"
              , "ifThenElseI16L8"
              , "ifThenElseI16Float"
              , "ifThenElseI32Unit"
              , "ifThenElseI32Bool"
              , "ifThenElseI32W8"
              , "ifThenElseI32W16"
              , "ifThenElseI32W32"
              , "ifThenElseI32I8"
              , "ifThenElseI32I16"
              , "ifThenElseI32I32"
              , "ifThenElseI32I"
              , "ifThenElseI32L8"
              , "ifThenElseI32Float"
              , "ifThenElseIUnit"
              , "ifThenElseIBool"
              , "ifThenElseIW8"
              , "ifThenElseIW16"
              , "ifThenElseIW32"
              , "ifThenElseII8"
              , "ifThenElseII16"
              , "ifThenElseII32"
              , "ifThenElseII"
              , "ifThenElseIL8"
              , "ifThenElseIFloat"
              , "ifThenElseL8Unit"
              , "ifThenElseL8Bool"
              , "ifThenElseL8W8"
              , "ifThenElseL8W16"
              , "ifThenElseL8W32"
              , "ifThenElseL8I8"
              , "ifThenElseL8I16"
              , "ifThenElseL8I32"
              , "ifThenElseL8I"
              , "ifThenElseL8L8"
              , "ifThenElseL8Float"
              , "ifThenElseFloatUnit"
              , "ifThenElseFloatBool"
              , "ifThenElseFloatW8"
              , "ifThenElseFloatW16"
              , "ifThenElseFloatW32"
              , "ifThenElseFloatI8"
              , "ifThenElseFloatI16"
              , "ifThenElseFloatI32"
              , "ifThenElseFloatI"
              , "ifThenElseFloatL8"
              , "ifThenElseFloatFloat"
              , "iterateUnitUnitE"
              , "iterateUnitBoolE"
              , "iterateUnitW8E"
              , "iterateUnitW16E"
              , "iterateUnitW32E"
              , "iterateUnitI8E"
              , "iterateUnitI16E"
              , "iterateUnitI32E"
              , "iterateUnitIE"
              , "iterateUnitL8E"
              , "iterateUnitFloatE"
              , "iterateBoolUnitE"
              , "iterateBoolBoolE"
              , "iterateBoolW8E"
              , "iterateBoolW16E"
              , "iterateBoolW32E"
              , "iterateBoolI8E"
              , "iterateBoolI16E"
              , "iterateBoolI32E"
              , "iterateBoolIE"
              , "iterateBoolL8E"
              , "iterateBoolFloatE"
              , "iterateW8UnitE"
              , "iterateW8BoolE"
              , "iterateW8W8E"
              , "iterateW8W16E"
              , "iterateW8W32E"
              , "iterateW8I8E"
              , "iterateW8I16E"
              , "iterateW8I32E"
              , "iterateW8IE"
              , "iterateW8L8E"
              , "iterateW8FloatE"
              , "iterateW16UnitE"
              , "iterateW16BoolE"
              , "iterateW16W8E"
              , "iterateW16W16E"
              , "iterateW16W32E"
              , "iterateW16I8E"
              , "iterateW16I16E"
              , "iterateW16I32E"
              , "iterateW16IE"
              , "iterateW16L8E"
              , "iterateW16FloatE"
              , "iterateW32UnitE"
              , "iterateW32BoolE"
              , "iterateW32W8E"
              , "iterateW32W16E"
              , "iterateW32W32E"
              , "iterateW32I8E"
              , "iterateW32I16E"
              , "iterateW32I32E"
              , "iterateW32IE"
              , "iterateW32L8E"
              , "iterateW32FloatE"
              , "iterateI8UnitE"
              , "iterateI8BoolE"
              , "iterateI8W8E"
              , "iterateI8W16E"
              , "iterateI8W32E"
              , "iterateI8I8E"
              , "iterateI8I16E"
              , "iterateI8I32E"
              , "iterateI8IE"
              , "iterateI8L8E"
              , "iterateI8FloatE"
              , "iterateI16UnitE"
              , "iterateI16BoolE"
              , "iterateI16W8E"
              , "iterateI16W16E"
              , "iterateI16W32E"
              , "iterateI16I8E"
              , "iterateI16I16E"
              , "iterateI16I32E"
              , "iterateI16IE"
              , "iterateI16L8E"
              , "iterateI16FloatE"
              , "iterateI32UnitE"
              , "iterateI32BoolE"
              , "iterateI32W8E"
              , "iterateI32W16E"
              , "iterateI32W32E"
              , "iterateI32I8E"
              , "iterateI32I16E"
              , "iterateI32I32E"
              , "iterateI32IE"
              , "iterateI32L8E"
              , "iterateI32FloatE"
              , "iterateIUnitE"
              , "iterateIBoolE"
              , "iterateIW8E"
              , "iterateIW16E"
              , "iterateIW32E"
              , "iterateII8E"
              , "iterateII16E"
              , "iterateII32E"
              , "iterateIIE"
              , "iterateIL8E"
              , "iterateIFloatE"
              , "iterateL8UnitE"
              , "iterateL8BoolE"
              , "iterateL8W8E"
              , "iterateL8W16E"
              , "iterateL8W32E"
              , "iterateL8I8E"
              , "iterateL8I16E"
              , "iterateL8I32E"
              , "iterateL8IE"
              , "iterateL8L8E"
              , "iterateL8FloatE"
              , "iterateFloatUnitE"
              , "iterateFloatBoolE"
              , "iterateFloatW8E"
              , "iterateFloatW16E"
              , "iterateFloatW32E"
              , "iterateFloatI8E"
              , "iterateFloatI16E"
              , "iterateFloatI32E"
              , "iterateFloatIE"
              , "iterateFloatL8E"
              , "iterateFloatFloatE"
              , "liftIO"
              , "debugE"
              , "debugListen"
              , "die"
              ]

data BindEnv
    = BindEnv
      { pluginModGuts   :: ModGuts,
        args            :: [CoreBndr],
        shallowDeepMap  :: M.Map Id Id,
        shallowDeepMaps :: [M.Map Id Id]
      }

newtype BindM a = BindM { runBindM :: StateT BindEnv CoreM a }
    deriving (Functor, Applicative, Monad
             ,MonadIO, MonadState BindEnv)

instance PassCoreM BindM where
  liftCoreM m = BindM $ lift m
  getModGuts = gets pluginModGuts

deepSuffix :: String
deepSuffix = "_deep'"

ghcGenPrefix :: String
ghcGenPrefix = "$"

isNotGhcGenId :: Id -> Bool
isNotGhcGenId i = not $ isPrefixOf ghcGenPrefix $ last $ splitOn "." (varString i)
    
bindChangeArgRetAppPass :: ModGuts -> CoreM ModGuts
bindChangeArgRetAppPass guts = do
    (bindsL', s) <- (\x -> (runStateT (runBindM $ (mapM changeArgBind) x) (BindEnv guts [] M.empty []))) (mg_binds guts)
    let availNames' = nameSetElems $ availsToNameSet $ mg_exports guts
    let shallowDeepMap' = M.filterWithKey (keyExported availNames') (shallowDeepMap s)
    let es = M.elems $ shallowDeepMap'
    let guts' = guts { mg_binds = concat bindsL', mg_exports = mg_exports guts ++ (map (Avail NotPatSyn)(map varName es)) }
    bindsOnlyPass (\x -> fst <$> (runStateT (runBindM $ (mapM changeAppBind) x) (BindEnv guts' [] (shallowDeepMap s) []))) guts'
  where
    keyExported :: [Name] -> Id  -> Id -> Bool
    keyExported ns sId _ = (varName sId) `elem` ns

changeArgBind :: CoreBind -> BindM [CoreBind]
changeArgBind bndr@(NonRec b e) = do
  -- Only do top level binds, as some Core binds appear in mg_binds, but are
  -- not top level. This could cause translation of elements of a non-ExprB
  -- data type instantiation, which is not what we want.
  if isBindTopLevel b && isNotGhcGenId b
  then do
    ides <- changeSubBind b e
    let bs = map (\ide -> NonRec (fst ide) (snd ide)) ides
    return bs
  else return [bndr]
changeArgBind (Rec bs) = do
  (nrbs', rbs') <- changeArgBind' bs
  return $ nrbs' ++ [Rec rbs']

changeArgBind' :: [(Id, CoreExpr)] -> BindM ([CoreBind], [(Id, CoreExpr)])
changeArgBind' [] = return ([], [])
changeArgBind' ((b, e) : bs) = do
  ides <- if isNotGhcGenId b
          then changeSubBind b e
          else return [(b,e)]
  (nrbs', rbs') <- changeArgBind' bs
  if length ides == 1
  then do
    return (nrbs', ides ++ rbs')
  else do
    let [nrb, rb] = ides
    let (b', e')  = nrb
    return ((NonRec b' e') : nrbs', rb : rbs')

changeSubBind :: Id -> CoreExpr -> BindM [(Id, CoreExpr)]
changeSubBind b e = do
  let (argTys, retTy) = splitFunTys $ varType b
  let (ls,e') = collectLets e
  let (bs, e'') = collectBinders e'
  let tyCon_m = splitTyConApp_maybe retTy
  isRetTyExprClass <- isExprClassType retTy
  isArgTyExprClass <- anyExprClassType argTys
  monadTyConId <- thNameToTyCon monadTyConTH
  case tyCon_m of
      -- We are looking for return types of Arduino a where a
      --  is one of our Expr types.
      Just (retTyCon, [retTy']) | retTyCon == monadTyConId -> do
          isRetTyExprClass' <- isExprClassType retTy'
          if isRetTyExprClass'
          then do
              -- Calculate which args we should translate, only
              -- ones of our languages expression types
              xlats <- mapM isExprClassType argTys
              -- Change the binds and arg types to Expr a
              zipBsArgTys <- mapM changeArg (zip3 bs argTys xlats)
              let (bs', argTys') = unzip zipBsArgTys

              -- Put arg names to translate in body into state
              let (bs'', _) = unzip $ filter snd $ zip bs' xlats
              s <- get
              put s{args = bs''}

              -- Change any apps of the changed args in the body
              e''' <- changeArgAppsExpr e''

              -- Generate args for new shallow body
              deepArgs <- mapM repShallowArg $ zip (map Var bs) xlats

              -- Change return type
              exprTyCon <- thNameToTyCon exprTyConTH
              let exprTyConApp = mkTyConApp exprTyCon [retTy']

              -- Change the return
              e'''' <- fmapRepBindReturn e'''

              -- Create a new top level bind type with the deep tyep
              bDeep <- modId b deepSuffix
              let b' = setVarType bDeep $ mkFunTys argTys' (mkTyConApp retTyCon [exprTyConApp])

              -- Apply the abs <$> to the new shallow body
              let shallowE = mkCoreApps (Var b') deepArgs
              isExpr <- isExprClassType retTy'
              absE <- if isExpr
                      then fmapAbsExpr (mkTyConTy retTyCon) retTy' shallowE
                      else return shallowE

              -- Put id pair into state
              s' <- get
              put s'{shallowDeepMap = M.insert b b' (shallowDeepMap s')}

              return [(b, mkLams bs absE), (b', mkLets ls $ mkLams bs' e'''')]
          else return [(b, e)]
      -- We are looking for return types of ExprB a => a
      _ | isRetTyExprClass -> do
          -- Calculate which args we should translate, only
          -- ones of our languages expression types
          xlats <- mapM isExprClassType argTys
          -- Change the binds and arg types to Expr a
          zipBsArgTys <- mapM changeArg (zip3 bs argTys xlats)
          let (bs', argTys') = unzip zipBsArgTys

          -- Put arg names to translate in body into state
          let (bs'', _) = unzip $ filter snd $ zip bs' xlats
          s <- get
          put s{args = bs''}

          -- Change any apps of the changed args in the body
          e''' <- changeArgAppsExpr e''

          -- Generate args for new shallow body
          deepArgs <- mapM repShallowArg $ zip (map Var bs) xlats

          -- Change return type
          exprTyCon <- thNameToTyCon exprTyConTH
          let exprTyConApp = mkTyConApp exprTyCon [retTy]

          -- Change the return
          e'''' <- repExpr e'''

          -- Create a new top level bind type with the deep tyep
          bDeep <- modId b deepSuffix
          let b' = setVarType bDeep $ mkFunTys argTys' exprTyConApp

          -- Apply the abs <$> to the new shallow body
          let shallowE = mkCoreApps (Var b') deepArgs
          absE <- absExpr shallowE

          -- Put id pair into state
          s' <- get
          put s'{shallowDeepMap = M.insert b b' (shallowDeepMap s')}

          return [(b, mkLams bs absE), (b', mkLets ls $ mkLams bs' e'''')]
      -- We are looking for argument types of ExprB a => a with
      --   a return type that is not tyExprClass.
      --_ | isArgTyExprClass -> do
      --    xlatWarning ""
      --    return [(b, e)]
      _ -> do
        return [(b, e)]

changeArg :: (CoreBndr, Type, Bool) -> BindM (CoreBndr, Type)
changeArg (b, ty, p) = do
  if p then do
    let tyCon_m = splitTyConApp_maybe ty
    case tyCon_m of
      Just (_, []) -> do
          -- Lookup the GHC type constructor of Expr
          exprTyCon <- thNameToTyCon exprTyConTH
          -- Make the type of the Expr for the specified type
          let ty' = mkTyConApp exprTyCon [ty]
          let b' = setVarType b ty'
          return (b', ty')
      Just (_, [_]) -> do
          -- Lookup the GHC type constructor of Expr
          exprTyCon <- thNameToTyCon exprTyConTH
          -- Make the type of the Expr for the specified type
          let ty' = mkTyConApp exprTyCon [ty]
          let b' = setVarType b ty'
          return (b', ty')
      _       -> return (b, ty)
  else return (b, ty)

repShallowArg :: (CoreExpr, Bool) -> BindM CoreExpr
repShallowArg (e, p) =
  if p then do
    e' <- repExpr e
    return e'
  else return e

changeArgAppsExpr :: CoreExpr -> BindM CoreExpr
changeArgAppsExpr e = do
  s <- get
  case e of
    -- Replace any occurances of the parameters "p" with "abs_ p"
    Var v | v `elem` (args s) -> absVar v
    Var v -> return $ Var v
    Lit l -> return $ Lit l
    Type ty -> return $ Type ty
    Coercion co -> return $ Coercion co
    App e1 e2 -> do
      e1' <- changeArgAppsExpr e1
      e2' <- changeArgAppsExpr e2
      return $ App e1' e2'
    Lam tb el -> do
      e' <- changeArgAppsExpr el
      return $ Lam tb e'
    Let bind body -> do
      bind' <- case bind of
                  (NonRec v el) -> do
                    e' <- changeArgAppsExpr el
                    return $ NonRec v e'
                  (Rec rbs) -> do
                    rbs' <- changeArgAppsExpr' rbs
                    return $ Rec rbs'
      body' <- changeArgAppsExpr body
      return $ Let bind' body'
    Case ec tb ty alts -> do
      e' <- changeArgAppsExpr ec
      alts' <- changeArgAppsExprAlts alts
      return $ Case e' tb ty alts'
    Tick t et -> do
      e' <- changeArgAppsExpr et
      return $ Tick t e'
    Cast ec co -> do
      e' <- changeArgAppsExpr ec
      return $ Cast e' co

changeArgAppsExpr' :: [(Id, CoreExpr)] -> BindM [(Id, CoreExpr)]
changeArgAppsExpr' [] = return []
changeArgAppsExpr' ((b, e) : bs) = do
  e' <- changeArgAppsExpr e
  bs' <- changeArgAppsExpr' bs
  return $ (b, e') : bs'

changeArgAppsExprAlts :: [GhcPlugins.Alt CoreBndr] -> BindM [GhcPlugins.Alt CoreBndr]
changeArgAppsExprAlts [] = return []
changeArgAppsExprAlts ((ac, b, a) : as) = do
  a' <- changeArgAppsExpr a
  bs' <- changeArgAppsExprAlts as
  return $ (ac, b, a') : bs'

changeAppBind :: CoreBind -> BindM CoreBind
changeAppBind (NonRec b e) = do
  let (bs, e') = collectBinders e
  s <- get
  put s{args = bs}
  e'' <- changeAppExpr e'
  let e''' = mkLams bs e''
  return (NonRec b e''')
changeAppBind (Rec bs) = do
  bs' <- changeAppBind' bs
  return $ Rec bs'

changeAppBind' :: [(Id, CoreExpr)] -> BindM [(Id, CoreExpr)]
changeAppBind' [] = return []
changeAppBind' ((b, e) : bs) = do
  let (lbs, e') = collectBinders e
  s <- get
  put s{args = lbs}
  e'' <- changeAppExpr e'
  let e''' = mkLams lbs e''
  bs' <- changeAppBind' bs
  return $ (b, e''') : bs'

findDeepId :: Id -> BindM (Maybe Id)
findDeepId v = do
  s <- get
  let sdMap = shallowDeepMap s
  let sdMaps = shallowDeepMaps s
  if v `M.member` sdMap
    then return $ Just $ sdMap M.! v
    else case findDeepId' v sdMaps of
      Nothing -> stringToId_maybe $ (varString v) ++ deepSuffix
      Just v' -> return $ Just v'
  where
    findDeepId' :: Id -> [M.Map Id Id] -> Maybe Id
    findDeepId' _ []      = Nothing
    findDeepId' v' (m:ms) = if v' `M.member` m then Just $ m M.! v' else findDeepId' v' ms

changeAppExpr :: CoreExpr -> BindM CoreExpr
changeAppExpr e = do
  monadTyConId <- thNameToTyCon monadTyConTH
  s <- get
  case e of
    Var v -> do
      let tyCon_m = splitTyConApp_maybe $ varType v
      let defaultRet = return $ Var v
      let vs = varString v
      isRetTyExprClass <- isExprClassType $ varType v
      if isSuffixOf deepSuffix vs || isPrefixOf ghcGenPrefix vs || vs `elem` comProcList
      then defaultRet
      else case tyCon_m of
          Just (retTyCon, [retTy']) | retTyCon == monadTyConId -> do
              v_m <- findDeepId v
              case v_m of
                Just v' -> fmapAbsExpr (mkTyConTy retTyCon) retTy' (Var v')
                Nothing -> defaultRet
          _ | isRetTyExprClass -> do
              v_m <- findDeepId v
              case v_m of
                Just v' -> absExpr (Var v')
                Nothing -> defaultRet
          _ -> defaultRet
    Lit l -> return $ Lit l
    Type ty -> return $ Type ty
    Coercion co -> return $ Coercion co
    App e1 e2 -> do
      let (b, args') = collectArgs e
      let (argTys, retTy) = splitFunTys $ exprType b
      let tyCon_m = splitTyConApp_maybe retTy
      let defaultRet = do
            e1' <- changeAppExpr e1
            e2' <- changeAppExpr e2
            return $ App e1' e2'
      case b of
        Var vb -> do
          let vbs = varString vb
          isRetTyExprClass <- isExprClassType retTy
          if isSuffixOf deepSuffix vbs || isPrefixOf ghcGenPrefix vbs || vbs `elem` comProcList
          then defaultRet
          else case tyCon_m of
                Just (retTyCon, [retTy']) | retTyCon == monadTyConId -> do
                    vb_m <- findDeepId vb
                    case vb_m of
                      Just vb' -> do
                        -- Calculate which args we should translate, only
                        -- ones of our languages expression types
                        xlats <- mapM isExprClassType argTys
                        -- Recursively translate inside of args.
                        args'' <- mapM changeAppExpr args'
                        args''' <- mapM repShallowArg $ zip args'' xlats
                        let e' = mkCoreApps (Var vb') args'''
                        isExpr <- isExprClassType retTy'
                        absE <- if isExpr
                                then fmapAbsExpr (mkTyConTy retTyCon) retTy' e'
                                else return e'
                        return $ absE
                      -- TBD Print warning?
                      Nothing -> defaultRet
                _ | isRetTyExprClass -> do
                    vb_m <- findDeepId vb
                    case vb_m of
                      Just vb' -> do
                        -- Calculate which args we should translate, only
                        -- ones of our languages expression types
                        xlats <- mapM isExprClassType argTys
                        -- Recursively translate inside of args.
                        args'' <- mapM changeAppExpr args'
                        args''' <- mapM repShallowArg $ zip args'' xlats
                        let e' = mkCoreApps (Var vb') args'''
                        absExpr e'
                      Nothing -> defaultRet
                _ -> defaultRet
        _ -> defaultRet
    Lam tb el -> do
      e' <- changeAppExpr el
      return $ Lam tb e'
    Let bind body -> do
      put s {shallowDeepMap  = M.empty,
             shallowDeepMaps = shallowDeepMap s : shallowDeepMaps s}
      e' <- case bind of
              (NonRec lb le) -> do
                ides <- changeSubBind lb le
                body' <- changeAppExpr body
                case ides of
                  [(_b1,_e1),(b2,e2)] -> do
                    e2' <- changeAppExpr e2
                    -- ToDo:  Do we need to retain shallow vesion of
                    -- let expression?  It's never called after
                    -- transformation.
                    -- return $ Let (NonRec b2 e2') (Let (NonRec b1 e1) body')
                    return $ Let (NonRec b2 e2') body'
                  [(b1,e1)]         -> do
                    e1' <- changeAppExpr e1
                    return $ Let (NonRec b1 e1') body'
                  -- This case should not happen
                  _ -> return e
              (Rec rbs) -> do
                (_nrbs', rbs') <- changeArgBind' rbs
                rbs'' <- changeAppExpr' rbs'
                body' <- changeAppExpr body
                return $ Let (Rec rbs'') body'
      s' <- get
      put s' {shallowDeepMap  = head $ shallowDeepMaps s',
              shallowDeepMaps = tail $ shallowDeepMaps s'}
      return e'
    Case ec tb ty alts -> do
      e' <- changeAppExpr ec
      alts' <- changeAppExprAlts alts
      return $ Case e' tb ty alts'
    Tick t et -> do
      e' <- changeAppExpr et
      return $ Tick t e'
    Cast ec co -> do
      e' <- changeAppExpr ec
      return $ Cast e' co

changeAppExpr' :: [(Id, CoreExpr)] -> BindM [(Id, CoreExpr)]
changeAppExpr' [] = return []
changeAppExpr' ((b, e) : bs) = do
  e' <- changeAppExpr e
  bs' <- changeAppExpr' bs
  return $ (b, e') : bs'

changeAppExprAlts :: [GhcPlugins.Alt CoreBndr] -> BindM [GhcPlugins.Alt CoreBndr]
changeAppExprAlts [] = return []
changeAppExprAlts ((ac, b, a) : as) = do
  a' <- changeAppExpr a
  bs' <- changeAppExprAlts as
  return $ (ac, b, a') : bs'
