Support code for quasi-quotation feature

This patch supports the quasi-quotation feature.  Here's the relevant
parts from the message in the big compiler patch:

  Fri Jan 18 14:55:03 GMT 2008  simonpj@microsoft.com
    * Add quasi-quotation, courtesy of Geoffrey Mainland
  
  This patch adds quasi-quotation, as described in
    "Nice to be Quoted: Quasiquoting for Haskell"
  	(Geoffrey Mainland, Haskell Workshop 2007)
  Implemented by Geoffrey and polished by Simon.

...snip...
  
  * There is an accompanying patch to the template-haskell library. This
    involves one interface change:
  	currentModule :: Q String
    is replaced by
  	location :: Q Loc
    where Loc is a data type defined in TH.Syntax thus:
        data Loc
          = Loc { loc_filename :: String
  	      , loc_package  :: String
  	      , loc_module   :: String
  	      , loc_start    :: CharPos
  	      , loc_end      :: CharPos }
  
        type CharPos = (Int, Int)	-- Line and character position
   
    So you get a lot more info from 'location' than from 'currentModule'.
    The location you get is the location of the splice.
    
    This works in Template Haskell too of course, and lets a TH program
    generate much better error messages.
  
  * There's also a new module in the template-haskell package called 
    Language.Haskell.TH.Quote, which contains support code for the
    quasi-quoting feature.

4 files changed, 98 insertions, 22 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 16ef073e8b..b3a83ffe3c 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -3,11 +3,11 @@
 module Language.Haskell.TH(
 	-- The monad and its operations
 	Q, runQ, 
-	report,		-- :: Bool -> String -> Q ()
-	recover, 	-- :: Q a -> Q a -> Q a
-	reify, 		-- :: Name -> Q Info
-	currentModule, 	-- :: Q String
-	runIO, 		-- :: IO a -> Q a
+	report,		  -- :: Bool -> String -> Q ()
+	recover, 	  -- :: Q a -> Q a -> Q a
+	reify, 		  -- :: Name -> Q Info
+	location,	  -- :: Q Location
+	runIO, 		  -- :: IO a -> Q a
 
 	-- Names
 	Name, 
@@ -22,7 +22,7 @@ module Language.Haskell.TH(
 	Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
 	Lit(..), Pat(..), FieldExp, FieldPat, 
 	Strict(..), Foreign(..), Callconv(..), Safety(..), FunDep(..),
-	Info(..), 
+	Info(..), Loc(..),
 	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
 
 	-- Library functions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Quasi.hs b/libraries/template-haskell/Language/Haskell/TH/Quasi.hs
new file mode 100644
index 0000000000..6027177d59
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/Quasi.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
+module Language.Haskell.TH.Quasi(
+	QuasiQuoter(..),
+        dataToQa, dataToExpQ, dataToPatQ
+    ) where
+
+import Data.Generics
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+
+data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp,
+                                 quotePat :: String -> Q Pat }
+
+dataToQa  ::  forall a k q. Data a
+          =>  (Name -> k)
+          ->  (Lit -> Q q)
+          ->  (k -> [Q q] -> Q q)
+          ->  (forall a . Data a => a -> Maybe (Q q))
+          ->  a
+          ->  Q q
+dataToQa mkCon mkLit appCon antiQ t =
+    case antiQ t of
+      Nothing ->
+          case constrRep constr of
+            AlgConstr _  ->
+                appCon con conArgs
+            IntConstr n ->
+                mkLit $ integerL n
+            FloatConstr n ->
+                mkLit $ rationalL (toRational n)
+            StringConstr (c:_) ->
+                mkLit $ charL c
+        where
+          constr :: Constr
+          constr = toConstr t
+          constrName :: Constr -> String
+          constrName k =
+              case showConstr k of
+                "(:)"  -> ":"
+                name   -> name
+          con :: k
+          con = mkCon (mkName (constrName constr))
+          conArgs :: [Q q]
+          conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
+
+      Just y -> y
+
+-- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same
+-- value. It takes a function to handle type-specific cases.
+dataToExpQ  ::  Data a
+            =>  (forall a . Data a => a -> Maybe (Q Exp))
+            ->  a
+            ->  Q Exp
+dataToExpQ = dataToQa conE litE (foldl appE)
+
+-- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same
+-- value. It takes a function to handle type-specific cases.
+dataToPatQ  ::  Data a
+            =>  (forall a . Data a => a -> Maybe (Q Pat))
+            ->  a
+            ->  Q Pat
+dataToPatQ = dataToQa id litP conP
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 1258ffeda2..a63d77b173 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -26,11 +26,11 @@ module Language.Haskell.TH.Syntax(
 
 	Q, runQ, 
 	report,	recover, reify,
-	currentModule, runIO,
+	location, runIO,
 
 	-- Names
 	Name(..), mkName, newName, nameBase, nameModule,
-    showName, showName', NameIs(..),
+        showName, showName', NameIs(..),
 
 	-- The algebraic data types
 	Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), 
@@ -38,7 +38,7 @@ module Language.Haskell.TH.Syntax(
 	Lit(..), Pat(..), FieldExp, FieldPat, 
 	Strict(..), Foreign(..), Callconv(..), Safety(..),
 	StrictType, VarStrictType, FunDep(..),
-	Info(..), 
+	Info(..), Loc(..), CharPos,
 	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
 
 	-- Internal functions
@@ -80,7 +80,7 @@ class (Monad m, Functor m) => Quasi m where
  
 	-- Inspect the type-checker's environment
   qReify :: Name -> m Info
-  qCurrentModule :: m String
+  qLocation :: m Loc
 
 	-- Input/output (dangerous)
   qRunIO :: IO a -> m a
@@ -105,9 +105,9 @@ instance Quasi IO where
   qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
   qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
 
-  qReify v       = badIO "reify"
-  qCurrentModule = badIO "currentModule"
-  qRecover a b   = badIO "recover"	-- Maybe we could fix this?
+  qReify v     = badIO "reify"
+  qLocation    = badIO "currentLocation"
+  qRecover a b = badIO "recover"	-- Maybe we could fix this?
 
   qRunIO m = m
   
@@ -156,10 +156,10 @@ recover (Q r) (Q m) = Q (qRecover r m)
 reify :: Name -> Q Info
 reify v = Q (qReify v)
 
--- | 'currentModule' gives you the name of the module in which this 
+-- | 'location' gives you the 'Location' at which this
 -- computation is spliced.
-currentModule :: Q String
-currentModule = Q qCurrentModule
+location :: Q Loc
+location = Q qLocation
 
 -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
 -- Take care: you are guaranteed the ordering of calls to 'runIO' within 
@@ -172,12 +172,12 @@ runIO :: IO a -> Q a
 runIO m = Q (qRunIO m)
 
 instance Quasi Q where
-  qNewName        = newName
-  qReport 	 = report
-  qRecover  	 = recover 
-  qReify    	 = reify
-  qCurrentModule = currentModule
-  qRunIO         = runIO
+  qNewName  = newName
+  qReport   = report
+  qRecover  = recover 
+  qReify    = reify
+  qLocation = location
+  qRunIO    = runIO
 
 
 ----------------------------------------------------
@@ -524,6 +524,19 @@ mk_tup_name n_commas space
 
 
 
+-----------------------------------------------------
+--		Locations
+-----------------------------------------------------
+
+data Loc
+  = Loc { loc_filename :: String
+	, loc_package  :: String
+	, loc_module   :: String
+	, loc_start    :: CharPos
+	, loc_end      :: CharPos }
+
+type CharPos = (Int, Int)	-- Line and character position
+
 
 -----------------------------------------------------
 --
diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal
index e4de59dad5..2dfef4b873 100644
--- a/libraries/template-haskell/template-haskell.cabal
+++ b/libraries/template-haskell/template-haskell.cabal
@@ -12,6 +12,7 @@ exposed-modules:
     Language.Haskell.TH.PprLib,
     Language.Haskell.TH.Ppr,
     Language.Haskell.TH.Lib,
+    Language.Haskell.TH.Quote,
     Language.Haskell.TH
 -- We need to set the package name to template-haskell (without a
 -- version number) as it's magic.