Allow the old [$foo| ... |] syntax for quasi-quotes

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

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 0744dae..0d7ba6a 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -44,6 +44,7 @@ import TcMType
 import TcHsType
 import TcIface
 import TypeRep
+import InstEnv 
 import Name
 import NameEnv
 import NameSet
@@ -343,7 +344,7 @@ tcBracket brack res_ty
        ; let brack_stage = Brack cur_stage pending_splices lie_var
 
        ; (meta_ty, lie) <- setStage brack_stage $
-                           getConstraints $
+                           captureConstraints $
                            tc_bracket cur_stage brack
 
        ; simplifyBracket lie
@@ -394,7 +395,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)
@@ -486,7 +487,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
@@ -663,7 +664,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).
@@ -708,6 +719,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}
 
 
@@ -786,7 +803,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
@@ -874,6 +891,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
                                  , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
                
   qReify v = reify v
+  qClassInstances = lookupClassInstances
 
        -- For qRecover, discard error messages if 
        -- the recovery action is chosen.  Otherwise
@@ -917,6 +935,33 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou
 
 %************************************************************************
 %*                                                                     *
+           Instance Testing
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+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
+            Right rdr_pred -> do
+        { rn_pred <- rnLPred doc rdr_pred      -- Rename
+        ; kc_pred <- kcHsLPred rn_pred         -- Kind check
+        ; ClassP cls tys <- dsHsLPred kc_pred  -- Type check
+
+       -- Now look up instances
+        ; inst_envs <- tcGetInstEnvs
+        ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
+              dfuns = map is_dfun (map fst matches ++ unifies)
+        ; return (map reifyName dfuns) } }
+  where
+    doc = ptext (sLit "TcSplice.classInstances")
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
                        Reification
 %*                                                                     *
 %************************************************************************
@@ -1103,8 +1148,11 @@ reifyDataCon tys dc
 reifyClass :: Class -> TcM TH.Info
 reifyClass cls 
   = do { cxt <- reifyCxt theta
+        ; inst_envs <- tcGetInstEnvs
+        ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
        ; ops <- mapM reify_op op_stuff
-       ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
+        ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
+       ; return (TH.ClassI dec insts ) }
   where
     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds
@@ -1112,7 +1160,22 @@ reifyClass cls
                          ; return (TH.SigD (reifyName op) ty) }
 
 ------------------------------
+reifyClassInstance :: Instance -> TcM TH.ClassInstance
+reifyClassInstance i
+  = do { cxt <- reifyCxt theta
+       ; thtypes <- reifyTypes types
+       ; return $ (TH.ClassInstance { 
+            TH.ci_tvs = reifyTyVars tvs,
+            TH.ci_cxt = cxt,
+            TH.ci_tys = thtypes,
+            TH.ci_cls = reifyName cls,
+            TH.ci_dfun = reifyName (is_dfun i) }) }
+  where
+     (tvs, theta, cls, types) = instanceHead 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 (TyVarTy tv)     = return (TH.VarT (reifyName tv))