[project @ 1996-04-30 17:34:02 by partain]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreLint.lhs

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index dc2b61a..e2c8269 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -32,12 +32,12 @@ import PrimOp               ( primOpType, PrimOp(..) )
 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, tyConFamilySize )
-import TyVar           ( getTyVarKind, GenTyVar{-instances-} )
+import TyVar           ( tyVarKind, GenTyVar{-instances-} )
 import UniqSet         ( emptyUniqSet, mkUniqSet, intersectUniqSets,
                          unionUniqSets, elementOfUniqSet, UniqSet(..)
                        )
@@ -184,6 +184,9 @@ lintCoreExpr :: CoreExpr -> LintM (Maybe Type)      -- Nothing if error found
 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
+lintCoreExpr (Coerce _ ty expr)
+  = _trace "lintCoreExpr:Coerce" $
+    lintCoreExpr expr `seqL` returnL (Just ty)
 
 lintCoreExpr (Let binds body)
   = lintCoreBinding binds `thenL` \binders ->
@@ -218,14 +221,11 @@ lintCoreExpr (Lam (ValBinder var) expr)
 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 ->
-   -- Check that it is a data type
-   case maybeAppDataTyCon ty of
-     Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing
-     Just(tycon, _, _) -> lintCoreAlts alts ty tycon
+   lintCoreAlts alts ty
 \end{code}
 
 %************************************************************************
@@ -270,19 +270,31 @@ lintCoreArg _ e ty (VarArg v)
       _ -> 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 == argty_kind
+-- SUSPICIOUS! (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}
@@ -296,20 +308,20 @@ lintCoreArg _ e ty (UsageArg u)
 \begin{code}
 lintCoreAlts :: CoreCaseAlts
             -> Type                    -- Type of scrutinee
-            -> TyCon                   -- TyCon pinned on the case
+--          -> TyCon                   -- TyCon pinned on the case
             -> LintM (Maybe Type)      -- Type of alternatives
 
-lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
+lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
   = -- Check tycon is not a primitive tycon
-    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
-    `seqL`
+--    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
+--    `seqL`
     -- Check we are scrutinising a proper datatype
     -- (ToDo: robustify)
-    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
-    `seqL`
+--    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
+--    `seqL`
     lintDeflt deflt ty
     `thenL` \maybe_deflt_ty ->
-    mapL (lintAlgAlt ty tycon) alts
+    mapL (lintAlgAlt ty {-tycon-}) alts
     `thenL` \maybe_alt_tys ->
     -- Check the result types
     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
@@ -320,10 +332,10 @@ lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
        where
          check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 
-lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
+lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
   = -- Check tycon is a primitive tycon
-    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
-    `seqL`
+--    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
+--    `seqL`
     mapL (lintPrimAlt ty) alts
     `thenL` \maybe_alt_tys ->
     lintDeflt deflt ty
@@ -337,7 +349,7 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
        where
          check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 
-lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
+lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
   = (case maybeAppDataTyCon scrut_ty of
       Nothing ->
         addErrL (mkAlgAltMsg1 scrut_ty)
@@ -568,9 +580,9 @@ mkAppMsg fun arg expr sty
              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
-  = ppAboves [ppStr "Illegal type application:",
+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)]