import CoreSyn
import Bag
-import Kind ( Kind{-instance-} )
+import Kind ( isSubKindOf, Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId,
- getInstantiatedDataConSig, GenId{-instances-}
+ dataConArgTys, GenId{-instances-}
)
-import Outputable ( Outputable(..) )
+import Maybes ( catMaybes )
+import Name ( isLocallyDefined, getSrcLoc )
+import Outputable ( Outputable(..){-instance * []-} )
import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar, TyCon )
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc )
import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
- isPrimType,getTypeKind,instantiateTy,
+ isPrimType,typeKind,instantiateTy,
mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
- maybeAppDataTyCon, eqTy )
-import TyCon ( isPrimTyCon,isVisibleDataTyCon )
-import TyVar ( getTyVarKind, GenTyVar{-instances-} )
+ maybeAppDataTyCon, eqTy
+ )
+import TyCon ( isPrimTyCon, tyConFamilySize )
+import TyVar ( tyVarKind, GenTyVar{-instances-} )
import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
- unionUniqSets, elementOfUniqSet, UniqSet(..) )
+ unionUniqSets, elementOfUniqSet, UniqSet(..)
+ )
import Unique ( Unique )
import Usage ( GenUsage )
import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
msg sty,
ppStr "*** Offending Program ***",
- ppAboves
- (map (pprCoreBinding sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (ppr sty))
- binds),
+ ppAboves (map (pprCoreBinding sty) binds),
ppStr "*** End of Offense ***"
])
where
lintCoreExpr (Lam (TyBinder tyvar) expr)
= lintCoreExpr expr `thenMaybeL` \ty ->
returnL (Just(mkForAllTy tyvar ty))
- -- TODO: Should add in-scope type variable at this point
+ -- ToDo: Should add in-scope type variable at this point
lintCoreExpr e@(Case scrut alts)
= lintCoreExpr scrut `thenMaybeL` \ty ->
_ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
- = -- TODO: Check that ty is well-kinded and has no unbound tyvars
+ = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
`seqL`
case (getForAllTy_maybe ty) of
- Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
- returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
- _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
+ Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
+
+ Just (tyvar,body) ->
+ let
+ tyvar_kind = tyVarKind tyvar
+ argty_kind = typeKind arg_ty
+ in
+ if (tyvar_kind `isSubKindOf` argty_kind
+ || argty_kind `isSubKindOf` tyvar_kind) then
+ returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
+ else
+ pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
+ addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
lintCoreArg _ e ty (UsageArg u)
- = -- TODO: Check that usage has no unbound usage variables
+ = -- ToDo: Check that usage has no unbound usage variables
case (getForAllUsageTy ty) of
Just (uvar,bounds,body) ->
- -- TODO Check argument satisfies bounds
+ -- ToDo: Check argument satisfies bounds
returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
_ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
\end{code}
-> 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
+lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
= -- 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)
+ -- Check we are scrutinising a proper datatype
+ -- (ToDo: robustify)
+ addErrIfL (not (tyConFamilySize tycon >= 1)) (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)
+ -- Check the result types
+ case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
+ [] -> returnL Nothing
-lintCoreAlts (PrimAlts alts deflt) ty tycon
+ (first_ty:tys) -> mapL check tys `seqL`
+ returnL (Just first_ty)
+ where
+ check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
+
+lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
= -- Check tycon is a primitive tycon
addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
`seqL`
`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
+ case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
[] -> returnL Nothing
(first_ty:tys) -> mapL check tys `seqL`
returnL (Just first_ty)
where
- check ty = checkTys first_ty ty (mkCaseAltMsg alts)
--}
+ check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-lintAlgAlt scrut_ty (con,args,rhs)
+lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (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
+ arg_tys = dataConArgTys con tys_applied
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
mkCaseAbstractMsg :: TyCon -> ErrMsg
mkCaseAbstractMsg tycon sty
- = ppAbove (ppStr "An algebraic case on an abstract type:")
+ = ppAbove (ppStr "An algebraic case on some weird type:")
(ppr sty tycon)
mkDefltMsg :: CoreCaseDefault -> ErrMsg
ppHang (ppStr "Arg type:") 4 (ppr sty arg),
ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
-mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
-mkTyAppMsg ty arg expr sty
- = panic "mkTyAppMsg"
-{-
- = ppAboves [ppStr "Illegal type application:",
- ppHang (ppStr "Exp type:") 4 (ppr sty exp),
- ppHang (ppStr "Arg type:") 4 (ppr sty arg),
+mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
+mkTyAppMsg msg ty arg expr sty
+ = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
+ ppHang (ppStr "Exp type:") 4 (ppr sty ty),
+ ppHang (ppStr "Arg type:") 4 (ppr sty arg),
ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
--}
mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
mkUsageAppMsg ty u expr sty
projects / ghc-hetmet.git / blobdiff