Add quasi-quotation, courtesy of Geoffrey Mainland

[ghc-hetmet.git] / compiler / deSugar / DsMeta.hs

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 457bb09..42e96bf 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -22,8 +22,9 @@
 
 module DsMeta( dsBracket, 
               templateHaskellNames, qTyConName, nameTyConName,
-              liftName, expQTyConName, decQTyConName, typeQTyConName,
-              decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
+              liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
+              decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
+              quoteExpName, quotePatName
                ) where
 
 #include "HsVersions.h"
@@ -424,7 +425,7 @@ repTy (HsForAllTy _ tvs ctxt ty)  =
 
 repTy (HsTyVar n)
   | isTvOcc (nameOccName n)       = do 
-                                     tv1 <- lookupBinder n
+                                     tv1 <- lookupTvOcc n
                                      repTvar tv1
   | otherwise                    = do 
                                      tc1 <- lookupOcc n
@@ -790,7 +791,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
                do { xs <- repLPs ps; body <- repLE e; repLam xs body })
       ; wrapGenSyns ss lam }
 
-repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
+repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
 
   
 -----------------------------------------------------------------------------
@@ -831,8 +832,8 @@ repP (ConPatIn dc details)
                                 p2' <- repLP p2;
                                 repPinfix p1' con_str p2' }
    }
-repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
-repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
+repP p@(NPat l (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
        -- The problem is to do with scoped type variables.
        -- To implement them, we have to implement the scoping rules
@@ -917,6 +918,18 @@ lookupOcc n
                Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) 
     }
 
+lookupTvOcc :: Name -> DsM (Core TH.Name)
+-- Type variables can't be staged and are not lexically scoped in TH
+lookupTvOcc n  
+  = do {  mb_val <- dsLookupMetaEnv n ;
+          case mb_val of
+               Just (Bound x)  -> return (coreVar x)
+               other           -> failWithDs msg
+    }
+  where
+    msg = vcat  [ ptext SLIT("Illegal lexically-scoped type variable") <+> quotes (ppr n)
+               , ptext SLIT("Lexically scoped type variables are not supported by Template Haskell") ]
+
 globalVar :: Name -> DsM (Core TH.Name)
 -- Not bound by the meta-env
 -- Could be top-level; or could be local
@@ -1277,9 +1290,9 @@ mk_string s   = do string_ty <- lookupType stringTyConName
                    return $ HsString s
 
 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
-repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
-repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
-repOverloadedLiteral (HsIsString s _)   = do { lit <- mk_string   s; repLiteral lit }
+repOverloadedLiteral (HsIntegral i _ _)   = do { lit <- mk_integer  i; repLiteral lit }
+repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit }
+repOverloadedLiteral (HsIsString s _ _)   = do { lit <- mk_string   s; repLiteral lit }
        -- The type Rational will be in the environment, becuase 
        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
        -- and rationalL is sucked in when any TH stuff is used
@@ -1413,11 +1426,15 @@ templateHaskellNames = [
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
-    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
+    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
+
+    -- Quasiquoting
+    quoteExpName, quotePatName]
 
 thSyn :: Module
 thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax")
 thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib")
+qqLib = mkTHModule FSLIT("Language.Haskell.TH.Quote")
 
 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
 
@@ -1425,6 +1442,7 @@ libFun = mk_known_key_name OccName.varName thLib
 libTc  = mk_known_key_name OccName.tcName  thLib
 thFun  = mk_known_key_name OccName.varName thSyn
 thTc   = mk_known_key_name OccName.tcName  thSyn
+qqFun  = mk_known_key_name OccName.varName qqLib
 
 -------------------- TH.Syntax -----------------------
 qTyConName        = thTc FSLIT("Q")            qTyConKey
@@ -1591,6 +1609,10 @@ fieldExpQTyConName      = libTc FSLIT("FieldExpQ")      fieldExpQTyConKey
 patQTyConName           = libTc FSLIT("PatQ")           patQTyConKey
 fieldPatQTyConName      = libTc FSLIT("FieldPatQ")      fieldPatQTyConKey
 
+-- quasiquoting
+quoteExpName       = qqFun FSLIT("quoteExp") quoteExpKey
+quotePatName       = qqFun FSLIT("quotePat") quotePatKey
+
 --     TyConUniques available: 100-129
 --     Check in PrelNames if you want to change this
 
@@ -1757,3 +1779,7 @@ threadsafeIdKey = mkPreludeMiscIdUnique 307
 -- data FunDep = ...
 funDepIdKey = mkPreludeMiscIdUnique 320
 
+-- quasiquoting
+quoteExpKey = mkPreludeMiscIdUnique 321
+quotePatKey = mkPreludeMiscIdUnique 322
+