X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=6da5741037196fb8207de34c47ce44994914899a;hp=d232eface3707218615cfeb712384245e9f46983;hb=HEAD;hpb=7f021f25e4c1b8546e346501ae34f1126755b739

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index d232efa..6da5741 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -71,6 +71,7 @@ import SrcLoc
 import Outputable
 import Util		( dropList )
 import Data.List	( mapAccumL )
+import Pair
 import Unique
 import Data.Maybe
 import BasicTypes
@@ -896,13 +897,17 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
   qReport False msg = addReport (text msg) empty
 
   qLocation = do { m <- getModule
-		 ; l <- getSrcSpanM
-		 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
-				  , TH.loc_module   = moduleNameString (moduleName m)
-				  , TH.loc_package  = packageIdString (modulePackageId m)
-				  , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
-				  , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
-		
+                 ; l <- getSrcSpanM
+                 ; r <- case l of
+                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+                                                    (ppr l)
+                        RealSrcSpan s -> return s
+                 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+                                  , TH.loc_module   = moduleNameString (moduleName m)
+                                  , TH.loc_package  = packageIdString (modulePackageId m)
+                                  , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+                                  , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }
+
   qReify v = reify v
   qClassInstances = lookupClassInstances
 
@@ -1066,8 +1071,9 @@ reifyThing (AGlobal (AnId id))
 	    _             -> return (TH.VarI     v ty Nothing fix)
     }
 
-reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
-reifyThing (AGlobal (AClass cls)) = reifyClass cls
+reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc
+reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
+reifyThing (AGlobal (AClass cls))  = reifyClass cls
 reifyThing (AGlobal (ADataCon dc))
   = do	{ let name = dataConName dc
 	; ty <- reifyType (idType (dataConWrapId dc))
@@ -1091,12 +1097,24 @@ reifyThing (ATyVar tv ty)
 reifyThing (AThing {}) = panic "reifyThing AThing"
 
 ------------------------------
+reifyAxiom :: CoAxiom -> TcM TH.Info
+reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
+  | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+  = do { args' <- mapM reifyType args
+       ; rhs'  <- reifyType rhs
+       ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') }
+  | otherwise
+  = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax 
+              <+> dcolon <+> pprEqPred (Pair lhs rhs))
+
 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))
+
   | isFamilyTyCon tc
   = let flavour = reifyFamFlavour tc
         tvs     = tyConTyVars tc
@@ -1107,6 +1125,7 @@ reifyTyCon tc
     in
     return (TH.TyConI $
               TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc 
        ; rhs' <- reifyType rhs
@@ -1114,7 +1133,7 @@ reifyTyCon tc
 		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') 
        }
 
-reifyTyCon tc
+  | otherwise
   = do 	{ cxt <- reifyCxt (tyConStupidTheta tc)
 	; let tvs = tyConTyVars tc
 	; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)