Major refactoring of the type inference engine

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

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index aa5e9a1..cc18707 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -343,16 +343,17 @@ tcBracket brack res_ty
        ; lie_var <- getConstraintVar
        ; let brack_stage = Brack cur_stage pending_splices lie_var
 
-       ; (meta_ty, lie) <- setStage brack_stage $
-                           getConstraints $
-                           tc_bracket cur_stage brack
-
-       ; simplifyBracket lie
-
-       -- Make the expected type have the right shape
-       ; _ <- unifyType meta_ty res_ty
-
-       -- Return the original expression, not the type-decorated one
+          -- We want to check that there aren't any constraints that
+          -- can't be satisfied (e.g. Show Foo, where Foo has no Show
+          -- 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 }
+
+        -- Return the original expression, not the type-decorated one
        ; pendings <- readMutVar pending_splices
        ; return (noLoc (HsBracketOut brack pendings)) }
 
@@ -395,7 +396,7 @@ tc_bracket _ (DecBrG decls)
 
 tc_bracket _ (PatBr pat)
   = do { any_ty <- newFlexiTyVarTy liftedTypeKind
-       ; _ <- tcPat ThPatQuote pat any_ty unitTy $ 
+       ; _ <- tcPat ThPatQuote pat any_ty $ 
                return ()
        ; tcMetaTy patQTyConName }
        -- Result type is PatQ (= Q Pat)
@@ -487,7 +488,7 @@ tcTopSpliceExpr tc_action
                    -- if the type checker fails!
     setStage Splice $ 
     do {    -- Typecheck the expression
-         (expr', lie) <- getConstraints tc_action
+         (expr', lie) <- captureConstraints tc_action
         
        -- Solve the constraints
        ; const_binds <- simplifyTop lie
@@ -664,7 +665,17 @@ runQuasiQuote :: Outputable hs_syn
               -> MetaOps th_syn hs_syn 
               -> RnM hs_syn
 runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
-  = do { quoter' <- lookupOccRn quoter
+  = do  {     -- Drop the leading "$" from the quoter name, if present
+              -- This is old-style syntax, now deprecated
+              -- NB: when removing this backward-compat, remove
+              --     the matching code in Lexer.x (around line 310)
+          let occ_str = occNameString (rdrNameOcc quoter)
+        ; quoter <- ASSERT( not (null occ_str) )  -- Lexer ensures this
+                    if head occ_str /= '$' then return quoter
+                    else do { addWarn (deprecatedDollar quoter)
+                            ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }
+
+        ; quoter' <- lookupOccRn quoter
                -- We use lookupOcc rather than lookupGlobalOcc because in the
                -- erroneous case of \x -> [x| ...|] we get a better error message
                -- (stage restriction rather than out of scope).
@@ -709,6 +720,12 @@ quoteStageError :: Name -> SDoc
 quoteStageError quoter
   = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
          nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
+
+deprecatedDollar :: RdrName -> SDoc
+deprecatedDollar quoter
+  = hang (ptext (sLit "Deprecated syntax:"))
+       2 (ptext (sLit "quasiquotes no longer need a dollar sign:")
+          <+> ppr quoter)
 \end{code}
 
 
@@ -787,7 +804,7 @@ runMeta show_code run_and_convert expr
        ; hsc_env <- getTopEnv
        ; src_span <- getSrcSpanM
        ; either_hval <- tryM $ liftIO $
-                        HscMain.compileExpr hsc_env src_span ds_expr
+                        HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
        ; case either_hval of {
            Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
            Right hval -> do
@@ -927,8 +944,8 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou
 lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name]
 lookupClassInstances c ts
    = do { loc <- getSrcSpanM
-        ; case convertToHsPred loc (TH.ClassP c ts) of
-            Left msg -> failWithTc msg
+        ; case convertToHsPred loc (TH.ClassP c ts) of {
+            Left msg -> failWithTc msg;
             Right rdr_pred -> do
         { rn_pred <- rnLPred doc rdr_pred      -- Rename
         ; kc_pred <- kcHsLPred rn_pred         -- Kind check
@@ -938,7 +955,7 @@ lookupClassInstances c ts
         ; inst_envs <- tcGetInstEnvs
         ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
               dfuns = map is_dfun (map fst matches ++ unifies)
-        ; return (map reifyName dfuns) } }
+        ; return (map reifyName dfuns) } } }
   where
     doc = ptext (sLit "TcSplice.classInstances")
 \end{code}