fix haddock submodule pointer

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

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 2e81314..6da5741 100644 (file)
--- 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
@@ -348,10 +349,22 @@ tcBracket brack res_ty
           -- instance), but we aren't otherwise interested in the
           -- results. Nor do we care about ambiguous dictionaries etc.
           -- We will type check this bracket again at its usage site.
-       ; _ <- newImplication BracketSkol [] [] $
-              setStage brack_stage $
-              do { meta_ty <- tc_bracket cur_stage brack
-                 ; unifyType meta_ty res_ty }
+         --
+         -- We build a single implication constraint with a BracketSkol;
+         -- that in turn tells simplifyCheck to report only definite
+         -- errors
+       ; (_,lie) <- captureConstraints $
+                   newImplication BracketSkol [] [] $
+                   setStage brack_stage $
+                   do { meta_ty <- tc_bracket cur_stage brack
+                      ; unifyType meta_ty res_ty }
+
+          -- It's best to simplify the constraint now, even though in 
+         -- principle some later unification might be useful for it,
+         -- because we don't want these essentially-junk TH implication
+         -- contraints floating around nested inside other constraints
+         -- See for example Trac #4949
+       ; _ <- simplifyTop lie
 
         -- Return the original expression, not the type-decorated one
        ; pendings <- readMutVar pending_splices
@@ -374,7 +387,7 @@ tc_bracket outer_stage (VarBr name)         -- Note [Quoting names]
        }
 
 tc_bracket _ (ExpBr expr) 
-  = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+  = do { any_ty <- newFlexiTyVarTy openTypeKind
        ; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
        ; tcMetaTy expQTyConName }
        -- Result type is ExpQ (= Q Exp)
@@ -395,7 +408,7 @@ tc_bracket _ (DecBrG decls)
        ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
 
 tc_bracket _ (PatBr pat)
-  = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+  = do { any_ty <- newFlexiTyVarTy openTypeKind
        ; _ <- tcPat ThPatQuote pat any_ty $ 
                return ()
        ; tcMetaTy patQTyConName }
@@ -884,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
 
@@ -1054,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))
@@ -1079,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
@@ -1095,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
@@ -1102,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)
@@ -1177,7 +1208,7 @@ reifyClassInstance i
 reifyType :: TypeRep.Type -> TcM TH.Type
 -- Monadic only because of failure
 reifyType ty@(ForAllTy _ _)        = reify_for_all ty
-reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty          -- Types like ((?x::Int) => Char -> Char)
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)
 reifyType (TyVarTy tv)     = return (TH.VarT (reifyName tv))
 reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here
 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }