X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=650c0b40dad6b2889f3bcd005f087fe898ec5384;hb=5479f1a02fae9141c02a7873c57af80323b0fc0d;hp=af4d3205644e5e3ed9b7281648adb37fc5503f7e;hpb=9ffadf219cbc4f8ec57264786df936a3cee88aec;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index af4d320..650c0b4 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -565,7 +565,7 @@ kcTopSpliceType expr
 	; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
 	; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
 
-	; kcHsType hs_ty3 }
+	; kcLHsType hs_ty3 }
 \end{code}
 
 %************************************************************************
@@ -883,7 +883,9 @@ reifyThing (AGlobal (ADataCon dc))
   = do	{ let name = dataConName dc
 	; ty <- reifyType (idType (dataConWrapId dc))
 	; fix <- reifyFixity name
-	; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
+	; return (TH.DataConI (reifyName name) ty 
+                              (reifyName (dataConOrigTyCon dc)) fix) 
+        }
 
 reifyThing (ATcId {tct_id = id, tct_type = ty}) 
   = do	{ ty1 <- zonkTcType ty	-- Make use of all the info we have, even
@@ -902,13 +904,26 @@ reifyThing (AThing {}) = panic "reifyThing AThing"
 ------------------------------
 reifyTyCon :: TyCon -> TcM TH.Info
 reifyTyCon tc
-  | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2 		  False)
-  | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+  | isFunTyCon tc  
+  = return (TH.PrimTyConI (reifyName tc) 2 		  False)
+  | isPrimTyCon tc 
+  = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+  | isOpenTyCon tc
+  = let flavour = reifyFamFlavour tc
+        tvs     = tyConTyVars tc
+        kind    = tyConKind tc
+        kind'
+          | isLiftedTypeKind kind = Nothing
+          | otherwise             = Just $ reifyKind kind
+    in
+    return (TH.TyConI $
+              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc 
        ; rhs' <- reifyType rhs
        ; return (TH.TyConI $ 
-		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') 
+       }
 
 reifyTyCon tc
   = do 	{ cxt <- reifyCxt (tyConStupidTheta tc)
@@ -918,7 +933,7 @@ reifyTyCon tc
 	      r_tvs  = reifyTyVars tvs
 	      deriv = []	-- Don't know about deriving
 	      decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
-		   | otherwise	   = TH.DataD    cxt name r_tvs cons 	  deriv
+		   | otherwise	   = TH.DataD    cxt name r_tvs cons 	    deriv
 	; return (TH.TyConI decl) }
 
 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
@@ -940,7 +955,7 @@ reifyDataCon tys dc
 	  else
 	     return (TH.NormalC name (stricts `zip` arg_tys)) }
   | otherwise
-  = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:") 
+  = failWithTc (ptext (sLit "Can't reify a GADT data constructor:") 
 		<+> quotes (ppr dc))
 
 ------------------------------
@@ -970,23 +985,55 @@ reifyType (PredTy {}) = panic "reifyType PredTy"
 
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
-reifyCxt :: [PredType] -> TcM [TH.Type]
+
+reifyKind :: Kind -> TH.Kind
+reifyKind  ki
+  = let (kis, ki') = splitKindFunTys ki
+        kis_rep    = map reifyKind kis
+        ki'_rep    = reifyNonArrowKind ki'
+    in
+    foldl TH.ArrowK ki'_rep kis_rep
+  where
+    reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
+                        | otherwise          = pprPanic "Exotic form of kind" 
+                                                        (ppr k)
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
 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
+reifyFamFlavour :: TyCon -> TH.FamFlavour
+reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
+                   | isOpenTyCon    tc = TH.DataFam
+                   | otherwise         
+                   = panic "TcSplice.reifyFamFlavour: not a type family"
+
+reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
+reifyTyVars = map reifyTyVar
+  where
+    reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
+                  | otherwise             = TH.KindedTV name (reifyKind kind)
+      where
+        kind = tyVarKind tv
+        name = reifyName tv
 
 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 reify_tc_app tc tys = do { tys' <- reifyTypes tys 
 			 ; return (foldl TH.AppT (TH.ConT tc) tys') }
 
-reifyPred :: TypeRep.PredType -> TcM TH.Type
-reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
+reifyPred :: TypeRep.PredType -> TcM TH.Pred
+reifyPred (ClassP cls tys) 
+  = do { tys' <- reifyTypes tys 
+       ; return $ TH.ClassP (reifyName cls) tys'
+       }
 reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
-reifyPred (EqPred {})      = panic "reifyPred EqPred"
+reifyPred (EqPred ty1 ty2) 
+  = do { ty1' <- reifyType ty1
+       ; ty2' <- reifyType ty2
+       ; return $ TH.EqualP ty1' ty2'
+       }
 
 
 ------------------------------