lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message)
-- Returns (warnings, errors)
lintCoreBindings binds
- = initL (lint_binds binds)
- where
+ = initL $
+ addLoc TopLevelBindings $
+ addInScopeVars binders $
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
-- into use 'unexpectedly'
- lint_binds binds = addLoc TopLevelBindings $
- addInScopeVars (bindersOfBinds binds) $
- mapM lint_bind binds
+ do { checkL (null dups) (dupVars dups)
+ ; checkL (null ext_dups) (dupExtVars ext_dups)
+ ; mapM lint_bind binds }
+ where
+ binders = bindersOfBinds binds
+ (_, dups) = removeDups compare binders
+
+ -- dups_ext checks for names with different uniques
+ -- but but the same External name M.n. We don't
+ -- allow this at top level:
+ -- M.n{r3} = ...
+ -- M.n{r29} = ...
+ -- becuase they both get the same linker symbol
+ ext_dups = snd (removeDups ord_ext (map Var.varName binders))
+ ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
+ , Just m2 <- nameModule_maybe n2
+ = compare (m1, nameOccName n1) (m2, nameOccName n2)
+ | otherwise = LT
lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
= do { checkL (not (var == oneTupleDataConId))
(ptext (sLit "Illegal one-tuple"))
- ; checkDeadIdOcc var
+ ; checkL (not (var `hasKey` wildCardKey))
+ (ptext (sLit "Occurence of a wild-card binder") <+> ppr var)
+ -- See Note [WildCard binders] in SimplEnv
+
+ ; checkDeadIdOcc var
; var' <- lookupIdInScope var
- ; return (idType var')
- }
+ ; return (idType var') }
lintCoreExpr (Lit lit)
= return (literalType lit)
= lintCoreExpr expr
lintCoreExpr (Let (NonRec tv (Type ty)) body)
- = -- See Note [Type let] in CoreSyn
- do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
- ; ty' <- lintInTy ty
+ | isTyVar tv
+ = -- See Note [Linting type lets]
+ do { ty' <- addLoc (RhsOf tv) $ lintInTy ty
; lintTyBndr tv $ \ tv' ->
addLoc (BodyOfLetRec [tv]) $
extendSubstL tv' ty' $ do
-- take advantage of it in the body
; lintCoreExpr body } }
+ | isCoVar tv
+ = do { co <- applySubst ty
+ ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
+ ; lintTyBndr tv $ \ tv' ->
+ addLoc (BodyOfLetRec [tv]) $ do
+ { let (t1,t2) = coVarKind tv'
+ ; checkTys s1 t1 (mkTyVarLetErr tv ty)
+ ; checkTys s2 t2 (mkTyVarLetErr tv ty)
+ ; lintCoreExpr body } }
+
+ | otherwise
+ = failWithL (mkTyVarLetErr tv ty) -- Not quite accurate
+
lintCoreExpr (Let (NonRec bndr rhs) body)
= do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
; addLoc (BodyOfLetRec [bndr])
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
- do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
+ do { checkL (null dups) (dupVars dups)
+ ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
+ (_, dups) = removeDups compare bndrs
lintCoreExpr e@(App fun arg)
= do { fun_ty <- lintCoreExpr fun
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
- lintBinders [var] $ \[var'] ->
- do { body_ty <- lintCoreExpr expr
+ lintBinders [var] $ \ vars' ->
+ do { let [var'] = vars'
+ ; body_ty <- lintCoreExpr expr
; if isId var' then
return (mkFunTy (idType var') body_ty)
else
Just (tycon, _)
| debugIsOn &&
isAlgTyCon tycon &&
- not (isOpenTyCon tycon) &&
+ not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
null (tyConDataCons tycon) ->
pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
-- This can legitimately happen for type families
lintAltBinders scrut_ty con_ty []
= checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
lintAltBinders scrut_ty con_ty (bndr:bndrs)
- | isTyVar bndr
+ | isTyCoVar bndr
= do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
; lintAltBinders scrut_ty con_ty' bndrs }
| otherwise
\end{code}
\begin{code}
-checkKinds :: Var -> OutType -> LintM ()
+checkKinds :: OutVar -> OutType -> LintM ()
-- Both args have had substitution applied
checkKinds tyvar arg_ty
-- Arg type might be boxed for a function with an uncommitted
, nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
-------------------
-lintCoercion :: OutType -> LintM (OutType, OutType)
+lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType)
-- Check the kind of a coercion term, returning the kind
-lintCoercion ty@(TyVarTy tv)
+lintCoercion co
+ = addLoc (InCoercion co) $ lintCoercion' co
+
+lintCoercion' ty@(TyVarTy tv)
= do { checkTyVarInScope tv
; if isCoVar tv then return (coVarKind tv)
else return (ty, ty) }
-lintCoercion ty@(AppTy ty1 ty2)
+lintCoercion' ty@(AppTy ty1 ty2)
= do { (s1,t1) <- lintCoercion ty1
; (s2,t2) <- lintCoercion ty2
; check_co_app ty (typeKind s1) [s2]
- ; return (AppTy s1 s2, AppTy t1 t2) }
+ ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
-lintCoercion ty@(FunTy ty1 ty2)
+lintCoercion' ty@(FunTy ty1 ty2)
= do { (s1,t1) <- lintCoercion ty1
; (s2,t2) <- lintCoercion ty2
; check_co_app ty (tyConKind funTyCon) [s1, s2]
; return (FunTy s1 s2, FunTy t1 t2) }
-lintCoercion ty@(TyConApp tc tys)
+lintCoercion' ty@(TyConApp tc tys)
| Just (ar, desc) <- isCoercionTyCon_maybe tc
= do { unless (tys `lengthAtLeast` ar) (badCo ty)
; (s,t) <- lintCoTyConApp ty desc (take ar tys)
; check_co_app ty (tyConKind tc) ss
; return (TyConApp tc ss, TyConApp tc ts) }
-lintCoercion ty@(PredTy (ClassP cls tys))
+lintCoercion' ty@(PredTy (ClassP cls tys))
= do { (ss,ts) <- mapAndUnzipM lintCoercion tys
; check_co_app ty (tyConKind (classTyCon cls)) ss
; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) }
-lintCoercion (PredTy (IParam n p_ty))
+lintCoercion' (PredTy (IParam n p_ty))
= do { (s,t) <- lintCoercion p_ty
; return (PredTy (IParam n s), PredTy (IParam n t)) }
-lintCoercion ty@(PredTy (EqPred {}))
+lintCoercion' ty@(PredTy (EqPred {}))
= failWithL (badEq ty)
-lintCoercion (ForAllTy tv ty)
+lintCoercion' (ForAllTy tv ty)
| isCoVar tv
= do { (co1, co2) <- lintSplitCoVar tv
; (s1,t1) <- lintCoercion co1
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
| TopLevelBindings
| InType Type -- Inside a type
+ | InCoercion Coercion -- Inside a type
\end{code}
addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars vars m
- | null dups
= LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs)
- | otherwise
- = failWithL (dupVars dups)
- where
- (_, dups) = removeDups compare vars
addInScopeVar :: Var -> LintM a -> LintM a
addInScopeVar var m
= (noSrcLoc, empty)
dumpLoc (InType ty)
= (noSrcLoc, text "In the type" <+> quotes (ppr ty))
+dumpLoc (InCoercion ty)
+ = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty))
pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
+mkTyVarLetErr :: TyVar -> Type -> Message
+mkTyVarLetErr tyvar ty
+ = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
+ hang (ptext (sLit "Type/coercion variable:"))
+ 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+ hang (ptext (sLit "Arg type/coercion:"))
+ 4 (ppr ty)]
+
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
= vcat [ptext (sLit "Kinds don't match in type application:"),
dupVars vars
= hang (ptext (sLit "Duplicate variables brought into scope"))
2 (ppr vars)
+
+dupExtVars :: [[Name]] -> Message
+dupExtVars vars
+ = hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
+ 2 (ppr vars)
\end{code}
projects / ghc-hetmet.git / blobdiff