[project @ 2004-11-18 00:56:18 by igloo]

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

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 89d4a7a..31dfd31 100644 (file)
--- 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