-- Bind these src-level vars, returning the
                       -- rep-level vars to bind in the pattern

mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
mkDataConRep dflags fam_envs wrap_name data_con
  | not wrapper_reqd
  = return NoDataConRep

  | otherwise
  = do { wrap_args <- mapM newLocal wrap_arg_tys
       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
                                 initial_wrap_app

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
                         `setArityInfo`         wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
                         `setInlinePragInfo`    alwaysInlinePragma
                         `setUnfoldingInfo`     wrap_unf
                         `setStrictnessInfo`    wrap_sig
                             -- We need to get the CAF info right here because TidyPgm
                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                             -- so it not make sure that the CAF info is sane

             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
             wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
             mk_dmd str | isBanged str = evalDmd
                        | otherwise    = topDmd
                 -- The Cpr info can be important inside INLINE rhss, where the
                 -- wrapper constructor isn't inlined.
                 -- And the argument strictness can be important too; we
                 -- may not inline a contructor when it is partially applied.
                 -- For example:
                 --      data W = C !Int !Int !Int
                 --      ...(let w = C x in ...(w p q)...)...
                 -- we want to see that w is strict in its two arguments

             wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
                        wrap_body

       ; return (DCR { dcr_wrap_id = wrap_id
                     , dcr_boxer   = mk_boxer boxers
                     , dcr_arg_tys = rep_tys
                     , dcr_stricts = rep_strs
                     , dcr_bangs   = dropList ev_tys wrap_bangs }) }

  where
    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
    res_ty_args  = substTyVars (mkTopTvSubst eq_spec) univ_tvs
    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
    wrap_ty      = dataConUserType data_con
    ev_tys       = eqSpecPreds eq_spec ++ theta
    all_arg_tys  = ev_tys                         ++ orig_arg_tys
    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
             -- The wrap_args are the arguments *other than* the eq_spec
             -- Because we are going to apply the eq_spec args manually in the
             -- wrapper

    (wrap_bangs, rep_tys_w_strs, wrappers)
       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
    (unboxers, boxers) = unzip wrappers
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
                && (any isBanged orig_bangs   -- Some forcing/unboxing
                                              -- (includes eq_spec)
                    || isFamInstTyCon tycon)  -- Cast result

    initial_wrap_app = Var (dataConWorkId data_con)
                      `mkTyApps`  res_ty_args
                      `mkVarApps` ex_tvs
                      `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
                        -- Dont box the eq_spec coercions since they are
                        -- marked as HsUnpack by mk_dict_strict_mark

    mk_boxer :: [Boxer] -> DataConBoxer
    mk_boxer boxers = DCB (\ ty_args src_vars ->
                      do { let ex_vars = takeList ex_tvs src_vars
                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
                               subst2 = extendTvSubstList subst1 ex_tvs
                                                          (mkTyVarTys ex_vars)
                         ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars)
                         ; return (ex_vars ++ rep_ids, binds) } )

    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
    go subst (UnitBox : boxers) (src_var : src_vars)
      = do { (rep_ids2, binds) <- go subst boxers src_vars
           ; return (src_var : rep_ids2, binds) }
    go subst (Boxer boxer : boxers) (src_var : src_vars)
      = do { (rep_ids1, arg)  <- boxer subst
           ; (rep_ids2, binds) <- go subst boxers src_vars
           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)

    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
    mk_rep_app [] con_app
      = return con_app
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

-------------------------
mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
mkDataConRep dflags fam_envs wrap_name data_con
  | not wrapper_reqd
  = return NoDataConRep

  | otherwise
  = do { wrap_args <- mapM newLocal wrap_arg_tys
       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
                                 initial_wrap_app

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
                         `setArityInfo`         wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
                         `setInlinePragInfo`    alwaysInlinePragma
                         `setUnfoldingInfo`     wrap_unf
                         `setStrictnessInfo`    wrap_sig
                             -- We need to get the CAF info right here because TidyPgm
                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                             -- so it not make sure that the CAF info is sane

             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
             wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
             mk_dmd str | isBanged str = evalDmd
                        | otherwise    = topDmd
                 -- The Cpr info can be important inside INLINE rhss, where the
                 -- wrapper constructor isn't inlined.
                 -- And the argument strictness can be important too; we
                 -- may not inline a contructor when it is partially applied.
                 -- For example:
                 --      data W = C !Int !Int !Int
                 --      ...(let w = C x in ...(w p q)...)...
                 -- we want to see that w is strict in its two arguments

             wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
                        wrap_body

       ; return (DCR { dcr_wrap_id = wrap_id
                     , dcr_boxer   = mk_boxer boxers
                     , dcr_arg_tys = rep_tys
                     , dcr_stricts = rep_strs
                     , dcr_bangs   = dropList ev_tys wrap_bangs }) }

  where
    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
    res_ty_args  = substTyVars (mkTopTvSubst eq_spec) univ_tvs
    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
    wrap_ty      = dataConUserType data_con
    ev_tys       = eqSpecPreds eq_spec ++ theta
    all_arg_tys  = ev_tys                         ++ orig_arg_tys
    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
             -- The wrap_args are the arguments *other than* the eq_spec
             -- Because we are going to apply the eq_spec args manually in the
             -- wrapper

    (wrap_bangs, rep_tys_w_strs, wrappers)
       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
    (unboxers, boxers) = unzip wrappers
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
                && (any isBanged orig_bangs   -- Some forcing/unboxing
                                              -- (includes eq_spec)
                    || isFamInstTyCon tycon)  -- Cast result

    initial_wrap_app = Var (dataConWorkId data_con)
                      `mkTyApps`  res_ty_args
                      `mkVarApps` ex_tvs
                      `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
                        -- Dont box the eq_spec coercions since they are
                        -- marked as HsUnpack by mk_dict_strict_mark

    mk_boxer :: [Boxer] -> DataConBoxer
    mk_boxer boxers = DCB (\ ty_args src_vars ->
                      do { let ex_vars = takeList ex_tvs src_vars
                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
                               subst2 = extendTvSubstList subst1 ex_tvs
                                                          (mkTyVarTys ex_vars)
                         ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars)
                         ; return (ex_vars ++ rep_ids, binds) } )

    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
    go subst (UnitBox : boxers) (src_var : src_vars)
      = do { (rep_ids2, binds) <- go subst boxers src_vars
           ; return (src_var : rep_ids2, binds) }
    go subst (Boxer boxer : boxers) (src_var : src_vars)
      = do { (rep_ids1, arg)  <- boxer subst
           ; (rep_ids2, binds) <- go subst boxers src_vars
           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)

    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
    mk_rep_app [] con_app
      = return con_app
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

-------------------------
mkDataConRep dflags fam_envs wrap_name data_con
  | not wrapper_reqd
  = return NoDataConRep

  | otherwise
  = do { wrap_args <- mapM newLocal wrap_arg_tys
       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
                                 initial_wrap_app

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
                         `setArityInfo`         wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
                         `setInlinePragInfo`    alwaysInlinePragma
                         `setUnfoldingInfo`     wrap_unf
                         `setStrictnessInfo`    wrap_sig
                             -- We need to get the CAF info right here because TidyPgm
                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                             -- so it not make sure that the CAF info is sane

             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
             wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
             mk_dmd str | isBanged str = evalDmd
                        | otherwise    = topDmd
                 -- The Cpr info can be important inside INLINE rhss, where the
                 -- wrapper constructor isn't inlined.
                 -- And the argument strictness can be important too; we
                 -- may not inline a contructor when it is partially applied.
                 -- For example:
                 --      data W = C !Int !Int !Int
                 --      ...(let w = C x in ...(w p q)...)...
                 -- we want to see that w is strict in its two arguments

             wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
                        wrap_body

       ; return (DCR { dcr_wrap_id = wrap_id
                     , dcr_boxer   = mk_boxer boxers
                     , dcr_arg_tys = rep_tys
                     , dcr_stricts = rep_strs
                     , dcr_bangs   = dropList ev_tys wrap_bangs }) }

  where
    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
    res_ty_args  = substTyVars (mkTopTvSubst eq_spec) univ_tvs
    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
    wrap_ty      = dataConUserType data_con
    ev_tys       = eqSpecPreds eq_spec ++ theta
    all_arg_tys  = ev_tys                         ++ orig_arg_tys
    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
             -- The wrap_args are the arguments *other than* the eq_spec
             -- Because we are going to apply the eq_spec args manually in the
             -- wrapper

    (wrap_bangs, rep_tys_w_strs, wrappers)
       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
    (unboxers, boxers) = unzip wrappers
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
                && (any isBanged orig_bangs   -- Some forcing/unboxing
                                              -- (includes eq_spec)
                    || isFamInstTyCon tycon)  -- Cast result

    initial_wrap_app = Var (dataConWorkId data_con)
                      `mkTyApps`  res_ty_args
                      `mkVarApps` ex_tvs
                      `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
                        -- Dont box the eq_spec coercions since they are
                        -- marked as HsUnpack by mk_dict_strict_mark

    mk_boxer :: [Boxer] -> DataConBoxer
    mk_boxer boxers = DCB (\ ty_args src_vars ->
                      do { let ex_vars = takeList ex_tvs src_vars
                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
                               subst2 = extendTvSubstList subst1 ex_tvs
                                                          (mkTyVarTys ex_vars)
                         ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars)
                         ; return (ex_vars ++ rep_ids, binds) } )

    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
    go subst (UnitBox : boxers) (src_var : src_vars)
      = do { (rep_ids2, binds) <- go subst boxers src_vars
           ; return (src_var : rep_ids2, binds) }
    go subst (Boxer boxer : boxers) (src_var : src_vars)
      = do { (rep_ids1, arg)  <- boxer subst
           ; (rep_ids2, binds) <- go subst boxers src_vars
           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)

    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
    mk_rep_app [] con_app
      = return con_app
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

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