X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSplice.lhs;h=31dfd3141aceab76bf17d4fea054de3cc8bc9aa3;hb=ff845ab59d1d465d874d3908fd0cdd61b8594da2;hp=89d4a7aed19f238a5cfd18763e3f6502c85c16f7;hpb=204105777c7a67e99ccdc88106255bb83a033f1c;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 89d4a7a..31dfd31 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -30,7 +30,7 @@ import TcSimplify	( tcSimplifyTop, tcSimplifyBracket )
 import TcUnify		( Expected, zapExpectedTo, zapExpectedType )
 import TcType		( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
 import TcEnv		( spliceOK, tcMetaTy, bracketOK )
-import TcMType		( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
+import TcMType		( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
 import TcHsType		( tcHsSigType, kcHsType )
 import TcIface		( tcImportDecl )
 import TypeRep		( Type(..), PredType(..), TyThing(..) )	-- For reification
@@ -43,10 +43,12 @@ import Var		( Id, TyVar, idType )
 import Module		( moduleUserString, mkModuleName )
 import TcRnMonad
 import IfaceEnv		( lookupOrig )
-import Class		( Class, classBigSig )
-import TyCon		( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons )
+import Class		( Class, classExtraBigSig )
+import TyCon		( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn, 
+			  isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs )
 import DataCon		( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, 
-			  dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix )
+			  dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, 
+			  isVanillaDataCon )
 import Id		( idName, globalIdDetails )
 import IdInfo		( GlobalIdDetails(..) )
 import TysWiredIn	( mkListTy )
@@ -62,6 +64,7 @@ import FastString	( LitString )
 
 import GHC.Base		( unsafeCoerce#, Int#, Int(..) )	-- Should have a better home in the module hierarchy
 import Monad 		( liftM )
+import Maybes		( orElse )
 
 #ifdef GHCI
 import FastString	( mkFastString )
@@ -126,8 +129,8 @@ tc_bracket (VarBr v)
 	-- Result type is Var (not Q-monadic)
 
 tc_bracket (ExpBr expr) 
-  = newTyVarTy liftedTypeKind	`thenM` \ any_ty ->
-    tcCheckRho expr any_ty	`thenM_`
+  = newTyFlexiVarTy liftedTypeKind	`thenM` \ any_ty ->
+    tcCheckRho expr any_ty		`thenM_`
     tcMetaTy expQTyConName
 	-- Result type is Expr (= Q Exp)
 
@@ -137,7 +140,7 @@ tc_bracket (TypBr typ)
 	-- Result type is Type (= Q Typ)
 
 tc_bracket (DecBr decls)
-  = tcTopSrcDecls decls		`thenM_`
+  = tcTopSrcDecls [{- no boot-names -}] decls		`thenM_`
 	-- Typecheck the declarations, dicarding the result
 	-- We'll get all that stuff later, when we splice it in
 
@@ -156,7 +159,7 @@ tc_bracket (DecBr decls)
 
 \begin{code}
 tcSpliceExpr (HsSplice name expr) res_ty
-  = addSrcSpan (getLoc expr) 	$
+  = setSrcSpan (getLoc expr) 	$
     getStage		`thenM` \ level ->
     case spliceOK level of {
 	Nothing 	-> failWithTc (illegalSplice level) ;
@@ -256,7 +259,7 @@ Very like splicing an expression, but we don't yet share code.
 
 \begin{code}
 kcSpliceType (HsSplice name hs_expr)
-  = addSrcSpan (getLoc hs_expr) $ do 	
+  = setSrcSpan (getLoc hs_expr) $ do 	
 	{ level <- getStage
 	; case spliceOK level of {
 		Nothing 	-> failWithTc (illegalSplice level) ;
@@ -565,20 +568,22 @@ reifyTyCon tc
 	; rhs' <- reifyType rhs
 	; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 
-  | isNewTyCon tc
-  = do 	{ cxt <- reifyCxt (tyConTheta tc)
-	; con <- reifyDataCon (head (tyConDataCons tc))
-	; return (TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
-			      con [{- Don't know about deriving -}]) }
-
-  | otherwise	-- Algebraic
-  = do	{ cxt <- reifyCxt (tyConTheta tc)
-	; cons <- mapM reifyDataCon (tyConDataCons tc)
-	; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
-			      cons [{- Don't know about deriving -}]) }
+reifyTyCon tc
+  = case algTyConRhs tc of
+      NewTyCon data_con _ _ 
+	-> do	{ con <- reifyDataCon data_con
+		; return (TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc))
+				      con [{- Don't know about deriving -}]) }
+
+      DataTyCon mb_cxt cons _
+	-> do	{ cxt <- reifyCxt (mb_cxt `orElse` [])
+		; cons <- mapM reifyDataCon (tyConDataCons tc)
+		; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
+				      cons [{- Don't know about deriving -}]) }
 
 reifyDataCon :: DataCon -> TcM TH.Con
 reifyDataCon dc
+  | isVanillaDataCon dc
   = do 	{ arg_tys <- reifyTypes (dataConOrigArgTys dc)
 	; let stricts = map reifyStrict (dataConStrictMarks dc)
 	      fields  = dataConFieldLabels dc
@@ -594,15 +599,19 @@ reifyDataCon dc
 	     return (TH.InfixC (s1,a1) name (s1,a2))
 	  else
 	     return (TH.NormalC name (stricts `zip` arg_tys)) }
+  | otherwise
+  = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:") 
+		<+> quotes (ppr dc))
 
 ------------------------------
 reifyClass :: Class -> TcM TH.Dec
 reifyClass cls 
   = do	{ cxt <- reifyCxt theta
 	; ops <- mapM reify_op op_stuff
-	; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) ops) }
+	; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
   where
-    (tvs, theta, _, op_stuff) = classBigSig cls
+    (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls
+    fds' = map reifyFunDep fds
     reify_op (op, _) = do { ty <- reifyType (idType op)
 			  ; return (TH.SigD (reifyName op) ty) }
 
@@ -610,7 +619,6 @@ reifyClass cls
 reifyType :: TypeRep.Type -> TcM TH.Type
 reifyType (TyVarTy tv)	    = return (TH.VarT (reifyName tv))
 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
-reifyType (NewTcApp tc tys) = reify_tc_app (reifyName tc) tys
 reifyType (NoteTy _ ty)     = reifyType ty
 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
@@ -622,6 +630,9 @@ reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
 reifyTypes = mapM reifyType
 reifyCxt   = mapM reifyPred
 
+reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
+reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
+
 reifyTyVars :: [TyVar] -> [TH.Name]
 reifyTyVars = map reifyName