+ -- get pattern binders with types appropriately instantiated
+ arg_uniqs = map mkBuiltinUnique [arg_base..]
+ (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con res_tys
+
+ rebox_base = arg_base + length ex_tvs + length co_tvs + length arg_vs
+ rebox_uniqs = map mkBuiltinUnique [rebox_base..]
+
+ -- data T :: *->* where T1 { fld :: Maybe b } -> T [b]
+ -- Hence T1 :: forall a b. (a=[b]) => b -> T a
+ -- fld :: forall b. T [b] -> Maybe b
+ -- fld = /\b.\(t:T[b]). case t of
+ -- T1 b' (c : [b]=[b']) (x:Maybe b')
+ -- -> x `cast` Maybe (sym (right c))
+
+ Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+ (co_fn, res_ty) = refineType refinement (idType the_arg_id)
+ -- Generate the refinement for b'=b,
+ -- and apply to (Maybe b'), to get (Maybe b)
+
+ rhs = case co_fn of
+ WpCo co -> Cast (Var the_arg_id) co
+ id_co -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
+
+ field_vs = filter (not . isPredTy . idType) arg_vs
+ the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
+ field_lbls = dataConFieldLabels data_con
+
+ error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg
+ full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
+
+-- unbox a product type...
+-- we will recurse into newtypes, casting along the way, and unbox at the
+-- first product data constructor we find. e.g.
+--
+-- data PairInt = PairInt Int Int
+-- newtype S = MkS PairInt
+-- newtype T = MkT S
+--
+-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
+-- ids, we get (modulo int passing)
+--
+-- case (e `cast` CoT) `cast` CoS of
+-- PairInt a b -> body [a,b]
+--
+-- The Ints passed around are just for creating fresh locals
+unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
+unboxProduct i arg arg_ty body
+ = result
+ where
+ result = mkUnpackCase the_id arg con_args boxing_con rhs
+ (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
+ ([the_id], i') = mkLocals i [arg_ty]
+ (con_args, i'') = mkLocals i' tys
+ rhs = body i'' con_args
+
+mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+-- (mkUnpackCase x e args Con body)
+-- returns
+-- case (e `cast` ...) of bndr { Con args -> body }
+--
+-- the type of the bndr passed in is irrelevent
+mkUnpackCase bndr arg unpk_args boxing_con body
+ = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
+ where
+ (cast_arg, bndr_ty) = go (idType bndr) arg
+ go ty arg
+ | (tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
+ , isNewTyCon tycon && not (isRecursiveTyCon tycon)
+ = go (newTyConInstRhs tycon tycon_args)
+ (unwrapNewTypeBody tycon tycon_args arg)
+ | otherwise = (arg, ty)
+
+-- ...and the dual
+reboxProduct :: [Unique] -- uniques to create new local binders
+ -> Type -- type of product to box
+ -> ([Unique], -- remaining uniques
+ CoreExpr, -- boxed product
+ [Id]) -- Ids being boxed into product
+reboxProduct us ty
+ = let
+ (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
+
+ us' = dropList con_arg_tys us
+
+ arg_ids = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+
+ bind_rhs = mkProductBox arg_ids ty