-lintCoreAlts :: CoreCaseAlts
- -> Type -- Type of scrutinee
- -> TyCon -- TyCon pinned on the case
- -> LintM (Maybe Type) -- Type of alternatives
-
-lintCoreAlts (AlgAlts alts deflt) ty tycon
- = panic "CoreLint.lintCoreAlts"
-{- LATER:
- WDP: can't tell what type DNT wants here
- = -- Check tycon is not a primitive tycon
- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
- `seqL`
- -- Check we have a non-abstract data tycon
- addErrIfL (not (isVisibleDataTyCon tycon)) (mkCaseAbstractMsg tycon)
- `seqL`
- lintDeflt deflt ty
- `thenL` \maybe_deflt_ty ->
- mapL (lintAlgAlt ty tycon) alts
- `thenL` \maybe_alt_tys ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
-
-lintCoreAlts (PrimAlts alts deflt) ty tycon
- = -- Check tycon is a primitive tycon
- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
- `seqL`
- mapL (lintPrimAlt ty) alts
- `thenL` \maybe_alt_tys ->
- lintDeflt deflt ty
- `thenL` \maybe_deflt_ty ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
- -- Check the result types
--}
-{-
- `thenL` \ maybe_result_tys ->
- case catMaybes (maybe_result_tys) of
- [] -> returnL Nothing
-
- (first_ty:tys) -> mapL check tys `seqL`
- returnL (Just first_ty)
- where
- check ty = checkTys first_ty ty (mkCaseAltMsg alts)
--}
-
-lintAlgAlt scrut_ty (con,args,rhs)
- = (case maybeAppDataTyCon scrut_ty of
- Nothing ->
- addErrL (mkAlgAltMsg1 scrut_ty)
- Just (tycon, tys_applied, cons) ->
- let
- (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
- in
- checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
- checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
- `seqL`
- mapL check (arg_tys `zipEqual` args) `seqL`
- returnL ()
- ) `seqL`
- addInScopeVars args (
- lintCoreExpr rhs
- )
- where
- check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
-
- -- elem: yes, the elem-list here can sometimes be long-ish,
- -- but as it's use-once, probably not worth doing anything different
- -- We give it its own copy, so it isn't overloaded.
- elem _ [] = False
- elem x (y:ys) = x==y || elem x ys
-
-lintPrimAlt ty alt@(lit,rhs)
- = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
- lintCoreExpr rhs
-
-lintDeflt NoDefault _ = returnL Nothing
-lintDeflt deflt@(BindDefault binder rhs) ty
- = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
- addInScopeVars [binder] (lintCoreExpr rhs)