-import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )

--- import GHC.Core.Ppr( pprIds )

-import GHC.Data.Maybe     ( maybeToList, isJust )

-import GHC.Types.Var      ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar )

-                 mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType (tyVarKind bndr)  -- ToDo: right?

-                                        | otherwise    = UnspecArg (idType bndr)

-

-           ; (useful, rule_bndrs, rule_lhs_args, spec_bndrs1, spec_args) <- specHeader env all_call_args

-

---           ; pprTrace "spec_call" (vcat

---                [ text "fun:       "  <+> ppr fn

---                , text "call info: "  <+> ppr _ci

---                , text "useful:    "  <+> ppr useful

---                , text "rule_bndrs:"  <+> ppr rule_bndrs

---                , text "lhs_args:  "  <+> ppr rule_lhs_args

---                , text "spec_bndrs1:" <+> ppr spec_bndrs1

---                , text "spec_args: "  <+> ppr spec_args

---                , text "dx_binds:  "  <+> ppr dx_binds

---                , text "rhs_bndrs"     <+> ppr rhs_bndrs

---                , text "rhs_body"     <+> ppr rhs_body

---                , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)

---                , ppr dx_binds ]) $

---             return ()

-             -- The "1" suffix is before we maybe add the void arg

-           ; (rhs_body', rhs_uds) <- specRhs env rhs_bndrs rhs_body spec_args

-                 spec_rhs1 = mkLams spec_bndrs1 $

-                             wrapDictBindsE dumped_dbs rhs_body'

-                 spec_fn_ty1 = exprType spec_rhs1

-                 add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)

-                 (spec_bndrs, spec_rhs, spec_fn_ty)

-                   | add_void_arg = ( voidPrimId : spec_bndrs1

-                                    , Lam voidArgId spec_rhs1

-                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty1)

-                   | otherwise   = (spec_bndrs1, spec_rhs1, spec_fn_ty1)

-                 join_arity_decr = length rule_lhs_args - length spec_bndrs

-                 spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body

-                 arity_decr     = count isValArg rule_lhs_args - count isId spec_bndrs

-           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info

-                                    (mkVarApps (Var spec_fn) spec_bndrs)

-                                       , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty

-                    , (spec_f_w_arity, spec_rhs) : pairs_acc

-specRhs :: SpecEnv -> [Var] -> CoreExpr -> [CoreExpr]

-        -> SpecM (CoreExpr, UsageDetails)

-specRhs env bndrs body []

-  = specLam env bndrs body

-specRhs env [] body args

-  = do { fresh_dict_id <- newIdBndr "dx" (idType bndr)

-       ; let fresh_dict_id' = fresh_dict_id `addDictUnfolding` arg

-             dict_bind = mkDB (NonRec fresh_dict_id' arg)

-             env2 = env1 { se_subst = Core.extendSubst subst bndr (Var fresh_dict_id')

-                                      `Core.extendSubstInScope` fresh_dict_id' }

-       ; (body', uds) <- specRhs env2 bndrs body args

-   f :: forall a b. (Num a, F a ~ F b) => blah

-   RULE forall (d:Num Int) (g :: F Int ~ F Int).

- * varToCoreExpr generates a Refl

-  | UnspecType Kind

-  | UnspecArg Type

-  ppr (SpecType t)   = text "SpecType" <+> ppr t

-  ppr (UnspecType k) = text "UnspecType"

-  ppr (SpecDict d)   = text "SpecDict" <+> ppr d

-  ppr (UnspecArg t)  = text "UnspecArg"

-

-specArgFreeIds :: SpecArg -> IdSet

-specArgFreeIds (SpecType {})   = emptyVarSet

-specArgFreeIds (SpecDict dx)   = exprFreeIds dx

-specArgFreeIds (UnspecType {}) = emptyVarSet

-specArgFreeIds (UnspecArg {})  = emptyVarSet

-

-specArgFreeVars :: SpecArg -> VarSet

-specArgFreeVars (SpecType ty)   = tyCoVarsOfType ty

-specArgFreeVars (UnspecType ki) = tyCoVarsOfType ki

-specArgFreeVars (SpecDict dx)   = exprFreeVars dx

-specArgFreeVars (UnspecArg ty)  = tyCoVarsOfType ty

-     :: SpecEnv

-specHeader env (SpecType ty : args)

-  = do { -- Find qvars, the type variables to add to the binders for the rule

-         -- Namely those free in `ty` that aren't in scope

-         -- See (MP2) in Note [Specialising polymorphic dictionaries]

-         let in_scope = Core.substInScopeSet (se_subst env)

-             qvars    = scopedSort $

-                        filterOut (`elemInScopeSet` in_scope) $

-                        tyCoVarsOfTypeList ty

-       ; (useful, rule_bs, rule_args, spec_bs, spec_args) <- specHeader env args

-       ; pure ( useful

-              , qvars ++ rule_bs

-              , Type ty : rule_args

-              , qvars ++ spec_bs

-              , Type ty : spec_args

-              )

-       }

-specHeader env (UnspecType kind : args)

-  = do { (useful, rule_bs, rule_es, spec_bs, spec_args)  <- specHeader env' bndrs args

-       ; tv <- newTyVarBndr kind

-       ; pure ( useful

-              , bndr' : rule_bs

-              , varToCoreExpr bndr' : rule_es

-              , bndr' : spec_bs

-              , varToCoreExpr bndr' : spec_args

-              )

-       }

-specHeader env (SpecDict dict_arg : args)

-  | not (isDeadBinder bndr)

-  , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)

-    -- See Note [Weird special case for SpecDict]

-  = do { (_, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args

-       ; new_dict_id <- newIdBndr "dx" (exprType dict_arg)

-       ; let new_dict_expr = varToCoreExpr new_dict_id

-                      -- See Note [Evidence foralls]

-       ; pure ( True      -- Ha!  A useful specialisation!

-              , exprFreeIdsList new_dict_expr ++ rule_bs

-              , new_dict_expr : rule_es

-              , spec_bs

-              , dict_arg : spec_args

-              )

-       }

---   - It's an UnSpecArg, or

---   - It's a dead dictionary

-specHeader env (arg : args)

-    -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead

-  = do { -- see Note [Zap occ info in rule binders]

-       ; (useful, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args

-

-       ; spec_bndr <- case arg of

-                        SpecDict d  -> newIdBndr "dx" (exprType d)

-                        UnspecArg t -> newIdBndr "x"  t

-       ; let bndr_ty = idType bndr'

-

-             -- See Note [Drop dead args from specialisations]

-             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let

-             (mb_spec_bndr, spec_arg)

-                | isDeadBinder bndr

-                , Just lit_expr <- mkLitRubbish bndr_ty

-                = (Nothing, lit_expr)

-                | otherwise

-                = (Just bndr', varToCoreExpr bndr')

-

-       ; pure ( useful

-              , bndr' : rule_bs

-              , varToCoreExpr bndr' : rule_es

-              , case mb_spec_bndr of

-                  Just b  -> b : spec_bs

-                  Nothing -> spec_bs

-              , spec_arg : spec_args

-              )

-       }

--- If we run out of binders, stop immediately

--- See Note [Specialisation Must Preserve Sharing]

-specHeader env [] _ = pure (False, env, [], [], [], [], [], [])

--- Return all remaining binders from the original function. These have the

--- invariant that they should all correspond to unspecialised arguments, so

--- it's safe to stop processing at this point.

-specHeader env bndrs []

-  = pure (False, env', bndrs', [], [], [], [], [])

-  where

-    (env', bndrs') = substBndrs env bndrs

--}

-                                 , ci_fvs  = call_fvs }) }

-    call_fvs = foldr (unionVarSet . free_var_fn) emptyVarSet args

-

-    free_var_fn =

-      if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)

-        then specArgFreeIds

-        else specArgFreeVars

-      = UnspecType (typeKind ty)

-      = = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr)

-      | otherwise = UnspecArg (exprType arg)

-consDictBind :: DictBind -> UsageDetails -> UsageDetails

-consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}

-  = uds { ud_binds = FDB{ fdb_binds = db `consOL` binds

-                        , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }

-

-    go_arg (UnspecType {}) (UnspecType {}) = True

-    go_arg (SpecDict {})   (SpecDict {})   = True

-    go_arg (UnspecArg {})  (UnspecArg {})  = True

-    go_arg _               _               = False

-extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv

-extendTvSubst env tv ty

-  = env { se_subst = Core.extendTvSubst (se_subst env) tv ty }

-newIdBndr :: String -> Type -> SpecM (SpecEnv, CoreBndr)

--- Make up completely fresh binders for the dictionaries

--- Their bindings are going to float outwards

-newIdBndr env@(SE { se_subst = subst }) str ty

-  = do { uniq <- getUniqueM

-       ; return (mkUserLocal (mkVarOcc str) uniq ManyTy ty noSrcSpan) }

-

-newTyVarBndr :: Kind -> SpecM TyVar

-newTyVarBndr kind

-  = do { uniq <- getUniqueM

-       ; let name = mkInternalName uniq (mkTyVarOcc "a") noSrcSpan

-       ; return (mkTyVar name kind }

-extendSubst :: Subst -> Var -> CoreArg -> Subst

-      Type ty     -> assert (isTyVar var) $ extendTvSubst subst var ty

-      Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co

-      _           -> assert (isId    var) $ extendIdSubst subst var arg

-{-

-    do { dflags <- getDynFlags

-       ; case decomposeRuleLhs dflags spec_bndrs (core_app (Var poly_id))

-                                                 (mkVarSet spec_bndrs) of {

-           Left msg -> do { diagnosticDs msg; return Nothing } ;

-           Right (rule_bndrs, poly_id, rule_lhs_args) ->

-

-    do { tracePm "dsSpec(old route)" $

-         vcat [ text "poly_id" <+> ppr poly_id

-              , text "spec_bndrs" <+> ppr spec_bndrs

-              , text "the_call" <+> ppr (core_app (Var poly_id))

-              , text "rule_bndrs" <+> ppr rule_bndrs

-              , text "rule_lhs_args" <+> ppr rule_lhs_args ]

-

-       ; finishSpecPrag (idName poly_id) poly_rhs

-                               rule_bndrs poly_id rule_lhs_args

-                               spec_bndrs core_app spec_inl } } }

--}

-