From 34b88d007f45ba3b66e4a91572bd27d194f93ae9 Mon Sep 17 00:00:00 2001 From: Adam Vogt Date: Thu, 22 May 2014 03:36:27 -0400 Subject: [PATCH] preliminary implementation for #9 as a prepass --- haskell-src-meta.cabal | 6 ++- src/Language/Haskell/Meta/ExtractQQ.hs | 75 ++++++++++++++++++++++++++ src/Language/Haskell/Meta/Parse.hs | 31 +++++++++++ src/Language/Haskell/Meta/SubstQQ.hs | 48 +++++++++++++++++ 4 files changed, 159 insertions(+), 1 deletion(-) create mode 100644 src/Language/Haskell/Meta/ExtractQQ.hs create mode 100644 src/Language/Haskell/Meta/SubstQQ.hs diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal index a96f8e6..4846288 100644 --- a/haskell-src-meta.cabal +++ b/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 diff --git a/src/Language/Haskell/Meta/ExtractQQ.hs b/src/Language/Haskell/Meta/ExtractQQ.hs new file mode 100644 index 0000000..bc287b0 --- /dev/null +++ b/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 + diff --git a/src/Language/Haskell/Meta/Parse.hs b/src/Language/Haskell/Meta/Parse.hs index df86732..9786193 100644 --- a/src/Language/Haskell/Meta/Parse.hs +++ b/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 diff --git a/src/Language/Haskell/Meta/SubstQQ.hs b/src/Language/Haskell/Meta/SubstQQ.hs new file mode 100644 index 0000000..5039e4d --- /dev/null +++ b/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