- rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
- mkNewTypeBody tycon (head arg_tys) (Var dict_id)
- | otherwise = mkLams tyvars $ Lam dict_id $
- Case (Var dict_id) dict_id (idType the_arg_id)
- [(DataAlt data_con, arg_ids, Var the_arg_id)]
-
-mkNewTypeBody tycon result_ty result_expr
- -- Adds a coerce where necessary
- -- Used for both wrapping and unwrapping
- | isRecursiveTyCon tycon -- Recursive case; use a coerce
- = Note (Coerce result_ty (exprType result_expr)) result_expr
- | otherwise -- Normal case
- = result_expr
+ rhs = mkLams tyvars (Lam dict_id rhs_body)
+ rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
+ | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
+ [(DataAlt data_con, arg_ids, Var the_arg_id)]
+
+wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+-- The wrapper for the data constructor for a newtype looks like this:
+-- newtype T a = MkT (a,Int)
+-- MkT :: forall a. (a,Int) -> T a
+-- MkT = /\a. \(x:(a,Int)). x `cast` CoT a
+-- where CoT is the coercion TyCon assoicated with the newtype
+--
+-- The call (wrapNewTypeBody T [a] e) returns the
+-- body of the wrapper, namely
+-- e `cast` CoT [a]
+--
+-- For non-recursive newtypes, GHC currently treats them like type
+-- synonyms, so no cast is necessary. This function is the only
+-- place in the compiler that generates
+--
+wrapNewTypeBody tycon args result_expr
+-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
+ = Cast result_expr co
+-- | otherwise
+-- = result_expr
+ where
+ co = mkTyConApp (newTyConCo tycon) args
+
+unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+unwrapNewTypeBody tycon args result_expr
+-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
+ = Cast result_expr sym_co
+-- | otherwise
+-- = result_expr
+ where
+ sym_co = mkSymCoercion co
+ co = mkTyConApp (newTyConCo tycon) args
+
+-- Old Definition of mkNewTypeBody
+-- Used for both wrapping and unwrapping
+--mkNewTypeBody tycon result_ty result_expr
+-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
+-- = Note (Coerce result_ty (exprType result_expr)) result_expr
+-- | otherwise -- Normal case
+-- = result_expr