import CoreSyn
import DsMonad
-import DsBinds ( dsMonoBinds )
+import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall )
import DsListComp ( dsListComp )
-- Ordinary case for bindings
dsLet (MonoBind binds sigs is_rec) body
- = dsMonoBinds False binds [] `thenDs` \ prs ->
+ = dsMonoBinds NoSccs binds [] `thenDs` \ prs ->
case is_rec of
Recursive -> returnDs (Let (Rec prs) body)
NonRecursive -> returnDs (foldr mk_let body prs)
= returnDs (mkLit (NoRepStr str stringTy))
dsExpr (HsLitOut (HsLitLit str) ty)
- = returnDs ( mkConApp data_con [mkLit (MachLitLit str prim_ty)] )
+ = case (maybeBoxedPrimType ty) of
+ Just (boxing_data_con, prim_ty) ->
+ returnDs ( mkConApp boxing_data_con [mkLit (MachLitLit str prim_ty)] )
+ _ ->
+ pprError "ERROR:"
+ (vcat
+ [ hcat [ text "Cannot see data constructor of ``literal-literal''s type: "
+ , text "value:", quotes (quotes (ptext str))
+ , text "; type: ", ppr ty
+ ]
+ , text "Try compiling with -fno-prune-tydecls."
+ ])
+
where
(data_con, prim_ty)
= case (maybeBoxedPrimType ty) of
getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
returnDs (Note (SCC (mkUserCC cc mod_name group_name)) core_expr)
--- special case to handle unboxed tuple patterns
+-- special case to handle unboxed tuple patterns.
dsExpr (HsCase discrim matches@[Match _ [TuplePat ps boxed] _ _] src_loc)
- | all var_pat ps
+ | not boxed && all var_pat ps
= putSrcLocDs src_loc $
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->