Fix GADT refinement fix-pointing, add ASSERTs and a WARN, make type equality function...

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 8aeab69..9747c22 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -48,7 +48,8 @@ import TcRules                ( tcRules )
 import TcForeign       ( tcForeignImports, tcForeignExports )
 import TcInstDcls      ( tcInstDecls1, tcInstDecls2 )
 import TcIface         ( tcExtCoreBindings, tcHiBootIface )
-import IfaceSyn                ( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) )
+import MkIface         ( tyThingToIfaceDecl )
+import IfaceSyn                ( checkBootDecl, IfaceExtName(..) )
 import TcSimplify      ( tcSimplifyTop )
 import TcTyClsDecls    ( tcTyAndClassDecls )
 import LoadIface       ( loadOrphanModules )
@@ -87,7 +88,7 @@ import HsSyn          ( HsStmtContext(..), Stmt(..), HsExpr(..),
                          HsLocalBinds(..), HsValBinds(..),
                          LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
                          collectLStmtsBinders, collectLStmtBinders, nlVarPat,
-                         mkFunBind, placeHolderType, noSyntaxExpr )
+                         mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp )
 import RdrName         ( GlobalRdrElt(..), globalRdrEnvElts,
                          unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
 import RnSource                ( addTcgDUs )
@@ -96,9 +97,11 @@ import TcHsType              ( kcHsType )
 import TcMType         ( zonkTcType, zonkQuantifiedTyVar )
 import TcMatches       ( tcStmts, tcDoStmt )
 import TcSimplify      ( tcSimplifyInteractive, tcSimplifyInfer )
+import TcGadt          ( emptyRefinement )
 import TcType          ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
                          isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
 import TcEnv           ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
+import TypeRep         ( TyThing(..) )
 import RnTypes         ( rnLHsType )
 import Inst            ( tcGetInstEnvs )
 import InstEnv         ( classInstances, instEnvElts )
@@ -111,9 +114,9 @@ import MkId         ( unsafeCoerceId )
 import TyCon           ( tyConName )
 import TysWiredIn      ( mkListTy, unitTy )
 import IdInfo          ( GlobalIdDetails(..) )
-import Kind            ( Kind )
+import {- Kind parts of -} Type                ( Kind )
 import Var             ( globaliseId )
-import Name            ( nameModule, isBuiltInSyntax, isInternalName )
+import Name            ( isBuiltInSyntax, isInternalName )
 import OccName         ( isTcOcc )
 import NameEnv         ( delListFromNameEnv )
 import PrelNames       ( iNTERACTIVE, ioTyConName, printName, itName, 
@@ -123,13 +126,14 @@ import HscTypes           ( InteractiveContext(..),
                          Dependencies(..) )
 import BasicTypes      ( Fixity, RecFlag(..) )
 import SrcLoc          ( unLoc )
+import Data.Maybe      ( isNothing )
 #endif
 
 import FastString      ( mkFastString )
 import Util            ( sortLe )
 import Bag             ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
 
-import Data.Maybe      ( isJust, isNothing )
+import Data.Maybe      ( isJust )
 \end{code}
 
 
@@ -426,6 +430,7 @@ tc_rn_src_decls boot_details ds
        -- Rename the splice expression, and get its supporting decls
        (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
        failIfErrsM ;   -- Don't typecheck if renaming failed
+       rnDump (ppr rn_splice_expr) ;
 
        -- Execute the splice
        spliced_decls <- tcSpliceDecls rn_splice_expr ;
@@ -979,6 +984,8 @@ tcGhciStmts stmts
            io_ty     = mkTyConApp ioTyCon [] ;
            ret_ty    = mkListTy unitTy ;
            io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+           tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts 
+                                       (emptyRefinement, io_ret_ty) ;
 
            names = map unLoc (collectLStmtsBinders stmts) ;
 
@@ -993,17 +1000,16 @@ tcGhciStmts stmts
                -- then the type checker would instantiate x..z, and we wouldn't
                -- get their *polymorphic* values.  (And we'd get ambiguity errs
                -- if they were overloaded, since they aren't applied to anything.)
-           mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) 
+           mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
                                    (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
-           mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+           mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
                                 (nlHsVar id) 
         } ;
 
        -- OK, we're ready to typecheck the stmts
        traceTc (text "tcs 2") ;
-       ((tc_stmts, ids), lie) <- getLIE $ 
-                                 tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
-                                 mappM tcLookupId names ;
+       ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+                                          mappM tcLookupId names ;
                                        -- Look up the names right in the middle,
                                        -- where they will all be in scope