import ListSetOps
import FastString
import StaticFlags
-
-import Data.Char
\end{code}
selectMatchVars ps = mapM selectMatchVar ps
selectMatchVar :: Pat Id -> DsM Id
-selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var) = return var
+selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat var) = return var
selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
+selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
-- OK, better make up one...
\end{code}
| otherwise
= CanFail
- wild_var = mkWildId (idType var)
sorted_alts = sortWith get_tag match_alts
get_tag (con, _, _) = dataConTag con
mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
- return (Case (Var var) wild_var ty (mk_default fail ++ alts))
+ return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
mk_alt fail (con, args, MatchResult _ body_fn) = do
body <- body_fn fail
mk_parrCase fail = do
lengthP <- dsLookupGlobalId lengthPName
alt <- unboxAlt
- return (Case (len lengthP) (mkWildId intTy) ty [alt])
+ return (mkWildCase (len lengthP) intTy ty [alt])
where
elemTy = case splitTyConApp (idType var) of
(_, [elemTy]) -> elemTy
l <- newSysLocalDs intPrimTy
indexP <- dsLookupGlobalId indexPName
alts <- mapM (mkAlt indexP) sorted_alts
- return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
+ return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
where
- wild = mkWildId intPrimTy
dft = (DEFAULT, [], fail)
--
-- each alternative matches one array length (corresponding to one
\begin{code}
mkErrorAppDs :: Id -- The error function
-> Type -- Type to which it should be applied
- -> String -- The error message string to pass
+ -> SDoc -- The error message string to pass
-> DsM CoreExpr
mkErrorAppDs err_id ty msg = do
src_loc <- getSrcSpanDs
let
- full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
+ full_msg = showSDoc (hcat [ppr src_loc, text "|", msg])
core_msg = Lit (mkMachString full_msg)
-- mkMachString returns a result of type String#
return (mkApps (Var err_id) [Type ty, core_msg])
-- For the error message we make one error-app, to avoid duplication.
-- But we need it at different types... so we use coerce for that
- err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat))
+ err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat)
err_var <- newSysLocalDs unitTy
binds <- mapM (mk_bind val_var err_var) binders
return ( (val_var, val_expr) :
| otherwise = do
- error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
+ error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
tuple_var <- newSysLocalDs tuple_ty
let