Extend Class.Class to include the TyCons of ATs

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

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index f1e8c56..1d17c4d 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -55,6 +55,8 @@ import Id             ( idName, globalIdDetails )
 import IdInfo          ( GlobalIdDetails(..) )
 import TysWiredIn      ( mkListTy )
 import DsMeta          ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
+import DsExpr          ( dsLExpr )
+import DsMonad         ( initDsTc )
 import ErrUtils                ( Message )
 import SrcLoc          ( SrcSpan, noLoc, unLoc, getLoc )
 import Outputable
@@ -368,17 +370,14 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
        -> LHsExpr Id           -- Of type X
        -> TcM hs_syn           -- Of type t
 runMeta convert expr
-  = do { hsc_env <- getTopEnv
-       ; tcg_env <- getGblEnv
-       ; this_mod <- getModule
-       ; let type_env = tcg_type_env tcg_env
-             rdr_env  = tcg_rdr_env tcg_env
+  = do {       -- Desugar
+         ds_expr <- initDsTc (dsLExpr expr)
 
        -- Compile and link it; might fail if linking fails
+       ; hsc_env <- getTopEnv
+       ; src_span <- getSrcSpanM
        ; either_hval <- tryM $ ioToTcRn $
-                        HscMain.compileExpr 
-                                     hsc_env this_mod 
-                                     rdr_env type_env expr
+                        HscMain.compileExpr hsc_env src_span ds_expr
        ; case either_hval of {
            Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
            Right hval -> do
@@ -568,9 +567,9 @@ reifyThing (AGlobal (ADataCon dc))
        ; fix <- reifyFixity name
        ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
 
-reifyThing (ATcId id _ _) 
-  = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
-                                       -- though it may be incomplete
+reifyThing (ATcId {tct_id = id, tct_type = ty}) 
+  = do { ty1 <- zonkTcType ty  -- Make use of all the info we have, even
+                               -- though it may be incomplete
        ; ty2 <- reifyType ty1
        ; fix <- reifyFixity (idName id)
        ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
@@ -586,9 +585,12 @@ reifyTyCon tc
   | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2              False)
   | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
   | isSynTyCon tc
-  = do { let (tvs, rhs) = synTyConDefn tc
-       ; rhs' <- reifyType rhs
-       ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+  = case synTyConDefn tc of
+      Nothing         -> noTH SLIT("type family") (ppr tc)
+      Just (tvs, rhs) -> 
+        do { rhs' <- reifyType rhs
+          ; return (TH.TyConI $ 
+                      TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 
 reifyTyCon tc
   = do         { cxt <- reifyCxt (tyConStupidTheta tc)
@@ -629,7 +631,7 @@ reifyClass cls
        ; ops <- mapM reify_op op_stuff
        ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
   where
-    (tvs, fds, theta, _, op_stuff) = classExtraBigSig 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) }