X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=fcf329b8cb9d586f39d28566f9e32f7a88419d15;hp=11288dc6d8500b614208e0309cd3023131b69f1b;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hpb=8f53119f5772a8c8dc9fd08065cc86df7a4f0b26

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 11288dc..fcf329b 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -16,7 +16,7 @@ module TcHsType (
 	
 		-- Typechecking kinded types
 	tcHsKindedContext, tcHsKindedType, tcHsBangType,
-	tcTyVarBndrs, dsHsType, tcLHsConResTy,
+	tcTyVarBndrs, dsHsType, 
 	tcDataKindSig, ExpKind(..), EkCtxt(..),
 
 		-- Pattern type signatures
@@ -394,6 +394,9 @@ kc_hs_type (HsAppTy ty1 ty2) = do
 kc_hs_type (HsPredTy pred)
   = wrongPredErr pred
 
+kc_hs_type (HsCoreTy ty)
+  = return (HsCoreTy ty, typeKind ty)
+
 kc_hs_type (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names         $ \ tv_names' ->
     do	{ ctxt' <- kcHsContext context
@@ -419,12 +422,12 @@ kc_hs_type ty@(HsRecTy _)
       -- should have been removed by now
 
 #ifdef GHCI	/* Only if bootstrapped */
-kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
+kc_hs_type (HsSpliceTy sp fvs _) = kcSpliceType sp fvs
 #else
 kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
 #endif
 
-kc_hs_type (HsSpliceTyOut {}) = panic "kc_hs_type"	-- Should not happen at all
+kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type"	-- Eliminated by renamer
 
 -- remove the doc nodes here, no need to worry about the location since
 -- its the same for a doc node and it's child type node
@@ -623,11 +626,12 @@ ds_type (HsForAllTy _ tv_names ctxt ty)
 ds_type (HsDocTy ty _)  -- Remove the doc comment
   = dsHsType ty
 
-ds_type (HsSpliceTyOut kind) 
+ds_type (HsSpliceTy _ _ kind) 
   = do { kind' <- zonkTcKindToKind kind
        ; newFlexiTyVarTy kind' }
 
-ds_type (HsSpliceTy {}) = panic "ds_type"
+ds_type (HsQuasiQuoteTy {}) = panic "ds_type"	-- Eliminated by renamer
+ds_type (HsCoreTy ty)       = return ty
 
 dsHsTypes :: [LHsType Name] -> TcM [Type]
 dsHsTypes arg_tys = mapM dsHsType arg_tys
@@ -682,35 +686,7 @@ dsHsPred (HsIParam name ty)
        }
 \end{code}
 
-GADT constructor signatures
-
 \begin{code}
-tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
-tcLHsConResTy (L span res_ty)
-  = setSrcSpan span $
-    case get_args res_ty [] of
-	   (HsTyVar tc_name, args) 
-	      -> do { args' <- mapM dsHsType args
-		    ; thing <- tcLookup tc_name
-		    ; case thing of
-		        AGlobal (ATyCon tc) -> return (tc, args')
-		        _ -> failWithTc (badGadtDecl res_ty) }
-	   _ -> failWithTc (badGadtDecl res_ty)
-  where
-	-- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe
-	-- because that causes a black hole, and for good reason.  Building
-	-- the type means expanding type synonyms, and we can't do that
-	-- inside the "knot".  So we have to work by steam.
-    get_args (HsAppTy (L _ fun) arg)   args = get_args fun (arg:args)
-    get_args (HsParTy (L _ ty))        args = get_args ty  args
-    get_args (HsOpTy ty1 (L _ tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
-    get_args ty                        args = (ty, args)
-
-badGadtDecl :: HsType Name -> SDoc
-badGadtDecl ty
-  = hang (ptext (sLit "Malformed constructor result type:"))
-       2 (ppr ty)
-
 addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a
 	-- Wrap a context around only if we want to show that contexts.  
 addKcTypeCtxt (L _ (HsPredTy _)) thing = thing
@@ -733,14 +709,14 @@ kcHsTyVars :: [LHsTyVarBndr Name]
 	   -> ([LHsTyVarBndr Name] -> TcM r) 	-- These binders are kind-annotated
 						-- They scope over the thing inside
 	   -> TcM r
-kcHsTyVars tvs thing_inside  = do
-    bndrs <- mapM (wrapLocM kcHsTyVar) tvs
-    tcExtendKindEnvTvs bndrs (thing_inside bndrs)
+kcHsTyVars tvs thing_inside
+  = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs
+       ; tcExtendKindEnvTvs kinded_tvs thing_inside }
 
 kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
 	-- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it	
-kcHsTyVar (UserTyVar name)        = KindedTyVar name <$> newKindVar
-kcHsTyVar (KindedTyVar name kind) = return (KindedTyVar name kind)
+kcHsTyVar (UserTyVar name _)  = UserTyVar name <$> newKindVar
+kcHsTyVar tv@(KindedTyVar {}) = return tv
 
 ------------------
 tcTyVarBndrs :: [LHsTyVarBndr Name] 	-- Kind-annotated binders, which need kind-zonking
@@ -752,10 +728,9 @@ tcTyVarBndrs bndrs thing_inside = do
     tyvars <- mapM (zonk . unLoc) bndrs
     tcExtendTyVarEnv tyvars (thing_inside tyvars)
   where
-    zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind
-				      ; return (mkTyVar name kind') }
-    zonk (UserTyVar name) = WARN( True, ptext (sLit "Un-kinded tyvar") <+> ppr name )
-			    return (mkTyVar name liftedTypeKind)
+    zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind
+				    ; return (mkTyVar name kind') }
+    zonk (KindedTyVar name kind) = return (mkTyVar name kind)
 
 -----------------------------------
 tcDataKindSig :: Maybe Kind -> TcM [TyVar]
@@ -865,9 +840,9 @@ tcHsPatSigType ctxt hs_ty
 		-- should be bound by the pattern signature
  	  in_scope <- getInLocalScope
 	; let span = getLoc hs_ty
-	      sig_tvs = [ L span (UserTyVar n) 
-			| n <- nameSetToList (extractHsTyVars hs_ty),
-			  not (in_scope n) ]
+	      sig_tvs = userHsTyVarBndrs $ map (L span) $ 
+			filterOut in_scope $
+                        nameSetToList (extractHsTyVars hs_ty)
 
 	; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
 	; checkValidType ctxt sig_ty