-        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,

-import GHC.Types.Id.Info (IdDetails(..))

-import GHC.Types.Var( EvVar )

-                           , spe_inl   = inl

-       ; dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call }

-dsSpec_help poly_nm poly_id poly_rhs inl orig_bndrs ds_call

-  = do {

-       -- Simplify the (desugared) call; see wrinkle (SP1)

-       -- in Note [Desugaring new-form SPECIALISE pragmas]

-       ; dflags  <- getDynFlags

-       ; let simpl_opts = initSimpleOpts dflags

-             core_call  = simpleOptExprNoInline simpl_opts ds_call

-

-       ; case decomposeCall poly_id core_call of {

-            Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)

-                           ; return Nothing } ;

-

-    do { let locals = mkVarSet orig_bndrs `extendVarSetList` bindersOfBinds binds

-             rn_binds = getRenamings orig_bndrs binds rule_bndrs

-             spec_binds = pickSpecBinds is_local (mkVarSet rule_bndrs)

-                                        (rn_binds ++ binds)

-             mk_spec_body fn_body = mkLets spec_binds  $

-              , text "core_call" <+> ppr core_call

-              , text "rule_bndrs" <+> ppr rule_bndrs

-       ; finishSpecPrag poly_nm poly_rhs

-                        rule_bndrs poly_id rule_lhs_args

-                        spec_bndrs mk_spec_body inl } } }

-               -> Maybe ( [CoreBind]

-                        , [CoreExpr] )  -- Args of the call

-decomposeCall poly_id binds

-  = go [] binds

-    go acc (Let bind body)

-      = go (bind:acc) body

-       , Just e <- lookupVarEnv renamings v

-       = extendVarEnv renamings b (mkCastMCo e (mkSymMCo mco))

-{-

-grabSpecBinds :: (Var -> Bool) -> VarSet -> [CoreBind]

-              -> ([CoreBind], [CoreBind])

-grabSpecBinds is_local rule_bndrs rev_binds

-   = (reverse rename_binds, spec_binds)

-  where

-    (known_bndrs, (rename_binds, other_binds))

-        = get_renamings rule_bndrs ([],[]) rev_binds

-    spec_binds = pick_spec_binds known_bndrs other_binds

-

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

-    get_renamings :: VarSet  -- Variables bound by a successful match on the call

-                  -> ([CoreBind],[CoreBind])   -- Accumulating parameter, in order

-                  -> [CoreBind]     -- Reversed, innermost first

-                  -> ( VarSet

-                     , ([CoreBind]    -- Renamings, in order

-                     ,  [CoreBind]))  -- Other bindings, in order

-    get_renamings bndrs acc [] = (bndrs, acc)

-

-    get_renamings bndrs (rn_binds, other_binds) (bind : binds)

-      | NonRec d r <- bind

-      , d `elemVarSet` bndrs

-      , Just (v, mco) <- getCastedVar r

-      , is_local v

-      , let flipped_bind = NonRec v (mkCastMCo (Var d) (mkSymMCo mco))

-      = get_renamings (bndrs `extendVarSet` v)

-                      (flipped_bind:rn_binds, other_binds)

-                      binds

-      | otherwise

-      = get_renamings bndrs

-                     (rn_binds, bind:other_binds)

-                     binds

-

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

-    pick_spec_binds :: VarSet -> [CoreBind] -> [CoreBind]

-    pick_spec_binds _ [] = []

-    pick_spec_binds known_bndrs (bind:binds)

-      | all keep_me (rhssOfBind bind)

-      , let known_bndrs' = known_bndrs `extendVarSetList` bindersOf bind

-      = bind : pick_spec_binds known_bndrs' binds

-      | otherwise

-      = pick_spec_binds known_bndrs binds

-      where

-        keep_me rhs = isEmptyVarSet (exprSomeFreeVars bad_var rhs)

-        bad_var v = is_local v && not (v `elemVarSet` known_bndrs)

--}

-{-

-  where

-    go :: VarSet        -- Quantified variables, or dependencies thereof

-       -> [CoreBind]    -- Reversed list of constant evidence bindings

-       -> CoreExpr

-       -> Maybe (IdSet, [CoreBind], [CoreExpr])

-    go qevs acc (Cast e _)

-      = go qevs acc e

-    go qevs acc (Let bind e)

-      | not (all (isPredTy . varType) bndrs)

-        -- A normal 'let' is too complicated

-        -- But we definitely include quantified constraints

-        -- E.g. this is fine:  let (d :: forall a. Eq a => Eq (f a) = d2)

-      = Nothing

-

-      -- (a) (1) in Note [prepareSpecLHS]

-      | all (transfer_to_spec_rhs qevs) $

-        rhssOfBind bind            -- One of the `const_binds`

-      = go qevs (bind:acc) e

-

-      -- (a) (2) in Note [prepareSpecLHS]

-      | otherwise

-      = go (qevs `extendVarSetList` bndrs) acc e

-      where

-        bndrs = bindersOf bind

-

-    go qevs acc e

-      | (Var fun, args) <- collectArgs e

-      -- (a) (3) in Note [prepareSpecLHS]

-      = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $

-        Just (qevs, reverse acc, args)

-      | otherwise

-      = Nothing

-

-    transfer_to_spec_rhs qevs rhs

-      where

-        is_quant_id v = isId v && v `elemVarSet` qevs

-      -- See (a) (2) in Note [prepareSpecLHS]

--}

-

-finishSpecPrag :: Name -> CoreExpr                    -- RHS to specialise

-               -> [Var] -> Id -> [CoreExpr]           -- RULE LHS pattern

-               -> [Var] -> (CoreExpr -> CoreExpr) -> InlinePragma   -- Specialised form

-               -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))

-finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_lhs_args

-                                spec_bndrs mk_spec_body spec_inl

-  | Just reason <- mb_useless

-  = do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason

-       ; if uselessSpecialisePragmaKeepAnyway reason

-         then Just <$> finish_prag

-         else return Nothing }

-

-  | otherwise

-  = Just <$> finish_prag

-

-  where

-    -- The RULE looks like

-    --    RULE "USPEC" forall rule_bndrs. f rule_lhs_args = $sf spec_bndrs

-    -- The specialised function looks like

-    --    $sf spec_bndrs = mk_spec_body <f's original rhs>

-    -- We also use mk_spec_body to specialise the methods in f's stable unfolding

-    -- NB: spec_bindrs is a subset of rule_bndrs

-    finish_prag

-      = do { this_mod <- getModule

-           ; uniq     <- newUnique

-           ; dflags   <- getDynFlags

-           ; let poly_name  = idName poly_id

-                 spec_occ   = mkSpecOcc (getOccName poly_name)

-                 spec_name  = mkInternalName uniq spec_occ (getSrcSpan poly_name)

-

-                 simpl_opts = initSimpleOpts dflags

-                 fn_unf     = realIdUnfolding poly_id

-                 spec_unf   = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf

-                 spec_id    = mkLocalId spec_name ManyTy spec_ty

-                                -- Specialised binding is toplevel, hence Many.

-                                `setInlinePragma` specFunInlinePrag poly_id id_inl spec_inl

-                                `setIdUnfolding`  spec_unf

-

-                 rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")

-                                   poly_id rule_bndrs rule_lhs_args

-                                   (mkVarApps (Var spec_id) spec_bndrs)

-

-                 rule_ty  = exprType (mkApps (Var poly_id) rule_lhs_args)

-                 spec_ty  = mkLamTypes spec_bndrs rule_ty

-                 spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs)

-

-           ; dsWarnOrphanRule rule

-

-           ; tracePm "dsSpec" (vcat

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

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

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

-           ; return (unitOL (spec_id, spec_rhs), rule) }

-                -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because

-                --     makeCorePair overwrites the unfolding, which we have

-                --     just created using specUnfolding

-

-    -- Is this SPECIALISE pragma useless?

-    mb_useless :: Maybe UselessSpecialisePragmaReason

-    mb_useless

-      | isJust (isClassOpId_maybe poly_id)

-      -- There is no point in trying to specialise a class op

-      -- Moreover, classops don't (currently) have an inl_sat arity set

-      -- (it would be Just 0) and that in turn makes makeCorePair bleat

-      = Just UselessSpecialiseForClassMethodSelector

-

-      | no_act_spec, isNeverActive rule_act

-      -- Function is NOINLINE, and the specialisation inherits that

-      -- See Note [Activation pragmas for SPECIALISE]

-      = Just UselessSpecialiseForNoInlineFunction

-

-      | all is_nop_arg rule_lhs_args, not (isInlinePragma spec_inl)

-      -- The specialisation does nothing.

-      -- But don't complain if it is SPECIALISE INLINE (#4444)

-      = Just UselessSpecialiseNoSpecialisation

-

-      | otherwise

-      = Nothing

-

-    -- See Note [Activation pragmas for SPECIALISE]

-    -- no_act_spec is True if the user didn't write an explicit

-    -- phase specification in the SPECIALISE pragma

-    id_inl        = idInlinePragma poly_id

-    inl_prag_act  = inlinePragmaActivation id_inl

-    spec_prag_act = inlinePragmaActivation spec_inl

-    no_act_spec = case inlinePragmaSpec spec_inl of

-                    NoInline _   -> isNeverActive  spec_prag_act

-                    Opaque _     -> isNeverActive  spec_prag_act

-                    _            -> isAlwaysActive spec_prag_act

-    rule_act | no_act_spec = inl_prag_act    -- Inherit

-             | otherwise   = spec_prag_act   -- Specified by user

-

-    is_nop_arg (Type {})     = True

-    is_nop_arg (Coercion {}) = True

-    is_nop_arg (Cast e _)    = is_nop_arg e

-    is_nop_arg (Tick _ e)    = is_nop_arg e

-    is_nop_arg (Var x)       = x `elem` spec_bndrs

-    is_nop_arg _             = False

-

-    is_dfun = case idDetails poly_id of

-      DFunId {} -> True

-      _ -> False

-