-lintStgExpr (StgLam _ bndrs _)
- = addErrL (ptext SLIT("Unexpected StgLam") <+> ppr bndrs) `thenL_`
- returnL Nothing
-
-lintStgExpr (StgLet binds body)
- = lintStgBinds binds `thenL` \ binders ->
- addLoc (BodyOfLetRec binders) (
- addInScopeVars binders (
- lintStgExpr body
- ))
-
-lintStgExpr (StgLetNoEscape _ _ binds body)
- = lintStgBinds binds `thenL` \ binders ->
- addLoc (BodyOfLetRec binders) (
- addInScopeVars binders (
- lintStgExpr body
- ))
-
-lintStgExpr (StgSCC _ expr) = lintStgExpr expr
-
-lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts)
- = lintStgExpr scrut `thenMaybeL` \ _ ->
-
- (case alts_type of
- AlgAlt tc -> check_bndr tc
- PrimAlt tc -> check_bndr tc
- UbxTupAlt tc -> check_bndr tc
- PolyAlt -> returnL ()
- ) `thenL_`
-
- (trace (showSDoc (ppr e)) $
- -- we only allow case of tail-call or primop.
- (case scrut of
- StgApp _ _ -> returnL ()
- StgConApp _ _ -> returnL ()
- StgOpApp _ _ _ -> returnL ()
- other -> addErrL (mkCaseOfCaseMsg e)) `thenL_`
-
- addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
- )
+lintStgExpr (StgLam _ bndrs _) = do
+ addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs)
+ return Nothing
+
+lintStgExpr (StgLet binds body) = do
+ binders <- lintStgBinds binds
+ addLoc (BodyOfLetRec binders) $
+ addInScopeVars binders $
+ lintStgExpr body
+
+lintStgExpr (StgLetNoEscape _ _ binds body) = do
+ binders <- lintStgBinds binds
+ addLoc (BodyOfLetRec binders) $
+ addInScopeVars binders $
+ lintStgExpr body
+
+lintStgExpr (StgSCC _ expr) = lintStgExpr expr
+
+lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
+ _ <- MaybeT $ lintStgExpr scrut
+
+ MaybeT $ liftM Just $
+ case alts_type of
+ AlgAlt tc -> check_bndr tc
+ PrimAlt tc -> check_bndr tc
+ UbxTupAlt tc -> check_bndr tc
+ PolyAlt -> return ()
+
+ MaybeT $ do
+ -- we only allow case of tail-call or primop.
+ case scrut of
+ StgApp _ _ -> return ()
+ StgConApp _ _ -> return ()
+ StgOpApp _ _ _ -> return ()
+ _ -> addErrL (mkCaseOfCaseMsg e)
+
+ addInScopeVars [bndr] $
+ lintStgAlts alts scrut_ty