    {-# LANGUAGE DeriveDataTypeable, QuasiQuotes #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.StringTemplate.QQ
    -- Copyright   :  (c) Sterling Clover 2009
    -- License     :  BSD 3 Clause
    -- Maintainer  :  s.clover@gmail.com
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- This module provides stmp, a quasi-quoter for StringTemplate expressions.
    -- Quoted templates are guaranteed syntactically well-formed at compile time,
    -- and antiquotation (of identifiers only) is provided by backticks.
    -- Usage: @ let var = [0,1,2] in toString [$stmp|($\`var\`; separator = ', '$)|] === \"(0, 1, 2)\"@
    -----------------------------------------------------------------------------

    module Text.StringTemplate.QQ (stmp) where

    import qualified Language.Haskell.TH as TH
    import Language.Haskell.TH.Quote
    import Text.StringTemplate.Base
    import qualified Data.Set as S

    quoteTmplExp :: String -> TH.ExpQ
    quoteTmplPat :: String -> TH.PatQ

    stmp :: QuasiQuoter
    stmp :: QuasiQuoter
    stmp = QuasiQuoter {quoteExp :: String -> Q Exp
    quoteExp = String -> Q Exp
    quoteTmplExp, quotePat :: String -> Q Pat
    quotePat = String -> Q Pat
    quoteTmplPat}

    quoteTmplPat :: String -> Q Pat
    quoteTmplPat = String -> String -> Q Pat
    forall a. HasCallStack => String -> a
    error String
    "Cannot apply stmp quasiquoter in patterns"
    quoteTmplExp :: String -> Q Exp
    quoteTmplExp String
    s = Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    tmpl
      where
        vars :: [String]
    vars = case (Char, Char)
    -> String -> Either ParseError ([String], [String], [String])
    parseSTMPNames (Char
    '$',Char
    '$') String
    s of
                 Right ([String]
    xs,[String]
    _,[String]
    _) -> [String]
    xs
                 Left  ParseError
    err -> String -> [String]
    forall a. String -> [a]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> [String]) -> String -> [String]
    forall a b. (a -> b) -> a -> b
    $ ParseError -> String
    forall a. Show a => a -> String
    show ParseError
    err
        base :: Exp
    base  = Exp -> Exp -> Exp
    TH.AppE (Name -> Exp
    TH.VarE (String -> Name
    TH.mkName String
    "Text.StringTemplate.newSTMP")) (Lit -> Exp
    TH.LitE (String -> Lit
    TH.StringL String
    s))
        tmpl :: Exp
    tmpl  = (String -> Exp -> Exp) -> Exp -> Set String -> Exp
    forall a b. (a -> b -> b) -> b -> Set a -> b
    S.foldr String -> Exp -> Exp
    addAttrib Exp
    base (Set String -> Exp) -> Set String -> Exp
    forall a b. (a -> b) -> a -> b
    $ [String] -> Set String
    forall a. Ord a => [a] -> Set a
    S.fromList [String]
    vars
        addAttrib :: String -> Exp -> Exp
    addAttrib String
    var = Exp -> Exp -> Exp
    TH.AppE
            (Exp -> Exp -> Exp
    TH.AppE (Exp -> Exp -> Exp
    TH.AppE (Name -> Exp
    TH.VarE (String -> Name
    TH.mkName String
    "Text.StringTemplate.setAttribute"))
                              (Lit -> Exp
    TH.LitE (String -> Lit
    TH.StringL (Char
    '`' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    var String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "`"))))
                     (Name -> Exp
    TH.VarE (String -> Name
    TH.mkName  String
    var)))