preliminary implementation for bmillwood#9 as a prepass

haskell-src-meta.cabal

@@ -22,7 +22,9 @@ library
                    haskell-src-exts == 1.15.*,
                    pretty >= 1.0 && < 1.2,
                    syb >= 0.1 && < 0.5,
-                   th-orphans >= 0.5 && < 0.9
+                   th-orphans >= 0.5 && < 0.9,
+                   mtl,
+                   containers
 
   if impl(ghc >= 7.4)
     Build-depends: template-haskell >= 2.7 && < 2.10
@@ -42,6 +44,8 @@ library
   hs-source-dirs:  src
   exposed-modules: Language.Haskell.Meta
                    Language.Haskell.Meta.Parse
+                   Language.Haskell.Meta.ExtractQQ
+                   Language.Haskell.Meta.SubstQQ
                    Language.Haskell.Meta.Parse.Careful
                    Language.Haskell.Meta.Syntax.Translate
                    Language.Haskell.TH.Instances.Lift

src/Language/Haskell/Meta/ExtractQQ.hs

@@ -0,0 +1,75 @@
+module Language.Haskell.Meta.ExtractQQ where
+
+import Data.Generics
+import Language.Haskell.Exts
+import Control.Monad.State
+import qualified Language.Haskell.TH as TH
+import Language.Haskell.TH.Quote
+import Data.Map (Map)
+import qualified Data.Map as M
+
+uniqueStr = "fns6LODHO5Czm0KSz4Do"
+uniqueVar ls = Ident (uniqueStr ++ show (length ls))
+
+
+type QQResult = ([TH.Exp], [TH.Pat], [TH.Type], [TH.Dec])
+
+initQQResult :: QQResult
+initQQResult = ([],[],[],[])
+
+
+extractQQ :: Data a => Map String QuasiQuoter -> a -> TH.Q (a, QQResult)
+extractQQ qqs ast = runStateT (everywhereM quasiT =<< everywhereM decT ast) 
+                        initQQResult
+ where
+
+  getQQ :: (MonadTrans t, Monad m)
+      => (QuasiQuoter -> a -> m b)
+      -> String
+      -> a
+      -> Maybe (t m b)
+  getQQ extractQ q body = do
+      quoter <- M.lookup q qqs
+      Just (lift (extractQ quoter body))
+
+  -- decT done first because of overlap with QuasiQuote
+  quasiT, decT :: GenericM (StateT QQResult TH.Q)
+  quasiT = mkM expT `extM` patT
+
+  -- quasiquotes in types cannot be parsed yet:
+  -- https://github.com/haskell-suite/haskell-src-exts/issues/117
+
+  decT = mkM $ \ xs -> fmap concat $ mapM (\x -> case x of
+      SpliceDecl loc (QuasiQuote q body)
+        | Just runQQ <- getQQ quoteDec q body -> do
+            bodies <- runQQ
+            forM bodies $ \ body' -> do
+              (e,p,t,d) <- get
+              put (e,p,t,body' : d)
+              return (PatBind loc
+                            (PVar (uniqueVar d))
+                            Nothing
+                            (UnGuardedRhs
+                              (Var (UnQual (uniqueVar d))))
+                              (BDecls []))
+      _ -> return [x])
+    xs
+
+  patT x = case x of
+      PQuasiQuote q body
+        | Just runQQ <- getQQ quotePat q body -> do
+            body' <- runQQ
+            (e,p,t,d) <- get
+            put (e,body' : p,t,d)
+            return (PVar (uniqueVar p))
+      _ -> return x
+
+  expT x = case x of
+      QuasiQuote q body
+        | Just runQQ <- getQQ quoteExp q body -> do
+            body' <- runQQ
+            (e,p,t,d) <- get
+            put (body' : e, p, t, d)
+            return (Var (UnQual (uniqueVar e)))
+      _ -> return x
+

src/Language/Haskell/Meta/Parse.hs

@@ -13,6 +13,13 @@ module Language.Haskell.Meta.Parse (
   parseExp,
   parseType,
   parseDecs,
+
+  parseDecsQQ,
+  parseExpQQ,
+  parsePatQQ,
+  extractQQ,
+  substQQ,
+
   myDefaultParseMode,
   myDefaultExtensions,
   parseResultToEither,
@@ -35,6 +42,12 @@ import Language.Haskell.Exts.Extension
 import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat)
 import Language.Haskell.Exts.Pretty
 
+
+import Language.Haskell.Meta.SubstQQ (substQQ)
+import Language.Haskell.Meta.ExtractQQ (extractQQ)
+import Data.Map (Map)
+import Language.Haskell.TH.Quote (QuasiQuoter)
+
 -----------------------------------------------------------------------------
 
 -- * template-haskell
@@ -51,6 +64,24 @@ parseType = either Left (Right . toType) . parseHsType
 parseDecs :: String -> Either String [Dec]
 parseDecs  = either Left (Right . toDecs) . parseHsDecls
 
+
+
+parseDecsQQ :: ParseMode -> Map String QuasiQuoter -> String -> Q [Dec]
+parseDecsQQ parseMode qqs str = either fail (substExtract (toDecs . moduleDecls) qqs)
+    $ parseResultToEither (parseModuleWithMode parseMode str)
+
+parseExpQQ :: ParseMode -> Map String QuasiQuoter -> String -> Q Exp
+parseExpQQ parseMode qqs str = either fail (substExtract toExp qqs)
+    $ parseResultToEither (parseExpWithMode parseMode str)
+
+parsePatQQ :: ParseMode -> Map String QuasiQuoter -> String -> Q Pat
+parsePatQQ parseMode qqs str = either fail (substExtract toPat qqs)
+    $ parseResultToEither (parsePatWithMode parseMode str)
+
+substExtract translate qqs ast = do
+    (ast', ranQQ) <- extractQQ qqs ast
+    return $ substQQ ranQQ (translate ast')
+
 -----------------------------------------------------------------------------
 
 {-# DEPRECATED myDefaultParseMode, myDefaultExtensions

src/Language/Haskell/Meta/SubstQQ.hs

@@ -0,0 +1,48 @@
+module Language.Haskell.Meta.SubstQQ where
+
+import Language.Haskell.Meta.ExtractQQ
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Generics
+
+import qualified Data.IntMap as M
+import Data.IntMap (IntMap)
+import Text.Read
+
+import Data.List
+
+
+lookupN :: Name -> IntMap e -> Maybe e
+lookupN (Name (OccName s) NameS) m
+  | Just n <- readMaybe =<< stripPrefix uniqueStr s = M.lookup n m
+lookupN _ _ = Nothing
+
+expUpdate :: QQResult -> Exp -> Exp
+expUpdate (es, _, _, _) =
+    let m :: IntMap Exp
+        m = M.fromList $ zip [0 .. ] (reverse es)
+    in \x -> case x of
+               VarE n | Just e' <- lookupN n m -> e'
+               _ -> x
+
+patUpdate :: QQResult -> Pat -> Pat
+patUpdate (_, ps, _, _) =
+    let m :: IntMap Pat
+        m = M.fromList $ zip [0 .. ] (reverse ps)
+    in \x -> case x of
+               VarP n | Just e' <- lookupN n m -> e'
+               _ -> x
+
+decUpdate :: QQResult -> Dec -> Dec
+decUpdate (_, _, _, ds) =
+    let m :: IntMap Dec
+        m = M.fromList $ zip [0 .. ] (reverse ds)
+  in \x -> case x of
+             ValD (VarP n) _ _ | Just e' <- lookupN n m -> e'
+             _ -> x
+
+
+substQQ :: Data a => QQResult -> a -> a
+substQQ qqr =  everywhere (mkT (patUpdate qqr) `extT` expUpdate qqr)
+            .  everywhere (mkT (decUpdate qqr))
+-- two traversals because the dec overlaps with the others