combineGRHSMatchResults,
combineMatchResults,
- dsExprToAtom,
+ dsExprToAtom, SYN_IE(DsCoreArg),
mkCoAlgCaseMatchResult,
- mkAppDs, mkConDs, mkPrimDs,
+ mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
mkCoPrimCaseMatchResult,
mkFailurePair,
mkSelectorBinds,
mkTupleBind,
mkTupleExpr,
- selectMatchVars
+ selectMatchVars,
+ showForErr
) where
-import Ubiq
-import DsLoop ( match, matchSimply )
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
- Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
-import TcHsSyn ( TypecheckedPat(..) )
+ Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
+import TcHsSyn ( SYN_IE(TypecheckedPat) )
import DsHsSyn ( outPatType )
import CoreSyn
import DsMonad
-import CoreUtils ( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp )
-import PrelInfo ( stringTy )
-import Id ( idType, getInstantiatedDataConSig, mkTupleCon,
- DataCon(..), DictVar(..), Id(..), GenId )
-import TyCon ( mkTupleTyCon )
-import Type ( mkTyVarTy, mkRhoTy, mkFunTys,
- applyTyCon, getAppDataTyCon )
-import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
-import Util ( panic, assertPanic )
-
-isUnboxedDataType = panic "DsUtils.isUnboxedDataType"
-quantifyTy = panic "DsUtils.quantifyTy"
-splitDictType = panic "DsUtils.splitDictType"
-mkCoTyApps = panic "DsUtils.mkCoTyApps"
+import CoreUtils ( coreExprType, mkCoreIfThenElse )
+import PprStyle ( PprStyle(..) )
+import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
+import Pretty ( ppShow )
+import Id ( idType, dataConArgTys, mkTupleCon,
+-- pprId{-ToDo:rm-},
+ SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
+import Literal ( Literal(..) )
+import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
+import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
+ mkTheta, isUnboxedType, applyTyCon, getAppTyCon
+ )
+import TysPrim ( voidTy )
+import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
+import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import Usage ( SYN_IE(UVar) )
+--import PprCore{-ToDo:rm-}
+--import PprType--ToDo:rm
+--import Pretty--ToDo:rm
+--import TyVar--ToDo:rm
+--import Unique--ToDo:rm
\end{code}
%************************************************************************
mkCoAlgCaseMatchResult :: Id -- Scrutinee
-> [(DataCon, [Id], MatchResult)] -- Alternatives
-> DsM MatchResult
+
mkCoAlgCaseMatchResult var alts
+ | isNewTyCon tycon -- newtype case; use a let
+ = ASSERT( newtype_sanity )
+ returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
+
+ | otherwise -- datatype case
= -- Find all the constructors in the type which aren't
-- explicitly mentioned in the alternatives:
case un_mentioned_constructors of
-- We need to build new locals for the args of the constructor,
-- and figuring out their types is somewhat tiresome.
let
- (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
+ arg_tys = dataConArgTys con tycon_arg_tys
in
newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
(mk_case alts (\fail_expr -> BindDefault wild fail_expr))
cxt1)
where
+ -- Common stuff
scrut_ty = idType var
- (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
+ (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $
+ getAppTyCon scrut_ty
+
+ -- Stuff for newtype
+ (con_id, arg_ids, match_result) = head alts
+ arg_id = head arg_ids
+ coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
+ (idType arg_id)
+ (Var var))
+ newtype_sanity = null (tail alts) && null (tail arg_ids)
+
+ -- Stuff for data types
+ data_cons = tyConDataCons tycon
un_mentioned_constructors
= uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
%************************************************************************
\begin{code}
-dsExprToAtom :: CoreExpr -- The argument expression
+dsExprToAtom :: DsCoreArg -- The argument expression
-> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
-- and delivering an expression E
-> DsM CoreExpr -- Either E or let x=arg-expr in E
-dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
-dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
+dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
+dsExprToAtom (TyArg t) continue_with = continue_with (TyArg t)
+dsExprToAtom (LitArg l) continue_with = continue_with (LitArg l)
+
+dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v)
+dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v)
-dsExprToAtom arg_expr continue_with
+dsExprToAtom (VarArg arg_expr) continue_with
= let
ty = coreExprType arg_expr
in
newSysLocalDs ty `thenDs` \ arg_id ->
continue_with (VarArg arg_id) `thenDs` \ body ->
returnDs (
- if isUnboxedDataType ty
+ if isUnboxedType ty
then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
else Let (NonRec arg_id arg_expr) body
)
-dsExprsToAtoms :: [CoreExpr]
+dsExprsToAtoms :: [DsCoreArg]
-> ([CoreArg] -> DsM CoreExpr)
-> DsM CoreExpr
-dsExprsToAtoms [] continue_with
- = continue_with []
+dsExprsToAtoms [] continue_with = continue_with []
dsExprsToAtoms (arg:args) continue_with
= dsExprToAtom arg $ \ arg_atom ->
%* *
%************************************************************************
-Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
-world.
\begin{code}
-mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
+type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
+
+mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
+mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
+mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
-mkAppDs fun tys arg_exprs
- = dsExprsToAtoms arg_exprs $ \ vals ->
- returnDs (mkApp fun [] tys vals)
+mkAppDs fun args
+ = dsExprsToAtoms args $ \ atoms ->
+ returnDs (mkGenApp fun atoms)
-mkConDs con tys arg_exprs
- = dsExprsToAtoms arg_exprs $ \ vals ->
- returnDs (mkCon con [] tys vals)
+mkConDs con args
+ = dsExprsToAtoms args $ \ atoms ->
+ returnDs (Con con atoms)
-mkPrimDs op tys arg_exprs
- = dsExprsToAtoms arg_exprs $ \ vals ->
- returnDs (mkPrim op [] tys vals)
+mkPrimDs op args
+ = dsExprsToAtoms args $ \ atoms ->
+ returnDs (Prim op atoms)
+\end{code}
+
+\begin{code}
+showForErr :: Outputable a => a -> String -- Boring but useful
+showForErr thing = ppShow 80 (ppr PprForUser thing)
+
+mkErrorAppDs :: Id -- The error function
+ -> Type -- Type to which it should be applied
+ -> String -- The error message string to pass
+ -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg
+ = getSrcLocDs `thenDs` \ (file, line) ->
+ let
+ full_msg = file ++ "|" ++ line ++ "|" ++msg
+ msg_lit = NoRepStr (_PK_ full_msg)
+ in
+ returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
\end{code}
%************************************************************************
-> DsM [(Id,CoreExpr)]
mkSelectorBinds tyvars pat locals_and_globals val_expr
- = getSrcLocDs `thenDs` \ (src_file, src_line) ->
-
- if is_simple_tuple_pat pat then
+ = if is_simple_tuple_pat pat then
mkTupleBind tyvars [] locals_and_globals val_expr
else
- newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the string
- let
- src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
- error_string = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
- error_msg = mkErrorApp res_ty str_var error_string
- in
+ mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
mkTupleBind tyvars [] locals_and_globals tuple_expr
where
\begin{code}
mkTupleBind tyvars dicts local_global_prs tuple_expr
- = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
+ = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
+
+ newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
zipWithDs (mk_selector (Var tuple_var))
local_global_prs
globals = [global | (local,global) <- local_global_prs]
no_of_binders = length local_global_prs
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
tuple_var_ty :: Type
tuple_var_ty
- = case (quantifyTy tyvars (mkRhoTy theta
- (applyTyCon (mkTupleTyCon no_of_binders)
- (map idType locals)))) of
- (_{-tossed templates-}, ty) -> ty
+ = mkForAllTys tyvars $
+ mkRhoTy theta $
+ applyTyCon (mkTupleTyCon no_of_binders)
+ (map idType locals)
where
- theta = map (splitDictType . idType) dicts
+ theta = mkTheta (map idType dicts)
mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
returnDs (
global,
mkLam tyvars dicts (
- mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
- binders selected)
+ mkTupleSelector
+ (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
+ (map VarArg dicts))
+ binders
+ selected)
)
-
-mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
-mkApp_XX expr [] = expr
-mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
\end{code}
-
-
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
has only one element, it is the identity function.
\begin{code}
only boxed types can be let-bound, we just turn the fail into a function
for the primitive case:
\begin{verbatim}
- let fail.33 :: () -> Int#
+ let fail.33 :: Void -> Int#
fail.33 = \_ -> error "Help"
in
case x of
p1 -> ...
- p2 -> fail.33 ()
- p3 -> fail.33 ()
+ p2 -> fail.33 void
+ p3 -> fail.33 void
p4 -> ...
\end{verbatim}
CoreExpr) -- Either the fail variable, or fail variable
-- applied to unit tuple
mkFailurePair ty
- | isUnboxedDataType ty
- = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
- newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
+ | isUnboxedType ty
+ = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
+ newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
returnDs (\ body ->
NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
- App (Var fail_fun_var) (VarArg unit_id))
+ App (Var fail_fun_var) (VarArg voidId))
| otherwise
= newFailLocalDs ty `thenDs` \ fail_var ->
returnDs (\ body -> NonRec fail_var body, Var fail_var)
+\end{code}
+
-unit_id :: Id -- out here to avoid CAF (sigh)
-unit_id = mkTupleCon 0
-unit_ty :: Type
-unit_ty = idType unit_id
-\end{code}
projects / ghc-hetmet.git / blobdiff