module Data.String.QM
( qq
, qm
, qn
, qt
, qtl
, qtb
, module TT
)
where
import Prelude
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.ByteString.Char8 as Strict (ByteString,
unpack)
import Data.ByteString.Lazy.Char8 as Lazy (ByteString,
unpack)
import Data.Char (isAlpha, isAlphaNum)
import Data.Maybe
import Data.Monoid (Monoid (..), (<>))
import Data.Text as T (Text, unpack)
import qualified Data.Text.Internal.Builder as B
import qualified Data.Text.Internal.Builder.Functions as B
import Data.Text.Lazy as LazyT (Text, unpack)
import GHC.Exts (IsString (..))
import qualified Language.Haskell.TH as TH
import Data.Text.ToText as TT
import Data.Text.ToTextBuilder as TT
data StringPart = Literal String | AntiQuote String deriving Show
qq :: QuasiQuoter
qq = QuasiQuoter
{ quoteExp = ls
, quotePat = return . expandIntoCons
, quoteType = \_ -> fail "illegal raw string QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail "illegal raw string QuasiQuote (allowed as expression only, used as a declaration)"
}
qm :: QuasiQuoter
qm = QuasiQuoter (makeExpr . parseQM [])
(error "Cannot use qm as a pattern")
(error "Cannot use qm as a type")
(error "Cannot use qm as a dec")
qn :: QuasiQuoter
qn = QuasiQuoter (makeExpr . parseQN [])
(error "Cannot use qm as a pattern")
(error "Cannot use qm as a type")
(error "Cannot use qm as a dec")
qt :: QuasiQuoter
qt = QuasiQuoter (makeExprT . parseQN [])
(error "Cannot use qm as a pattern")
(error "Cannot use qm as a type")
(error "Cannot use qm as a dec")
qtl :: QuasiQuoter
qtl = QuasiQuoter (makeExprTL . parseQN [])
(error "Cannot use qm as a pattern")
(error "Cannot use qm as a type")
(error "Cannot use qm as a dec")
qtb :: QuasiQuoter
qtb = QuasiQuoter (makeExprTB . parseQN [])
(error "Cannot use qm as a pattern")
(error "Cannot use qm as a type")
(error "Cannot use qm as a dec")
parseQM a [] = [Literal (reverse a)]
parseQM a ('\\':x:xs) = parseQM (x:a) xs
parseQM a "\\" = parseQM ('\\':a) []
parseQM a ('$':'{':xs) = Literal (reverse a) : unQM [] xs
parseQM a ('$':x:xs) | x == '_' || isAlpha x =
Literal (reverse a) : AntiQuote (x:pre) : parseQM [] post
where
(pre, post) = span isIdent xs
parseQM a (x:xs) = parseQM (x:a) xs
unQM a ('\\':x:xs) = unQM (x:a) xs
unQM a "\\" = unQM ('\\':a) []
unQM a ('}':xs) = AntiQuote (reverse a) : parseQM [] xs
unQM a (x:xs) = unQM (x:a) xs
parseQN a [] = [Literal (reverse a)]
parseQN a ('\\':x:xs) = parseQN (x:a) xs
parseQN a "\\" = parseQN ('\\':a) []
parseQN a ('$':'{':xs) = Literal (reverse a) : unQN [] xs
parseQN a (x:xs) = parseQN (x:a) xs
unQN a ('\\':x:xs) = unQN (x:a) xs
unQN a "\\" = unQN ('\\':a) []
unQN a ('}':xs) = AntiQuote (reverse a) : parseQN [] xs
unQN a (x:xs) = unQN (x:a) xs
makeExpr [] = ls ""
makeExpr (Literal a:xs) = TH.appE [| (++) a |]
$ makeExpr xs
makeExpr (AntiQuote a:xs) = TH.appE [| (++) $(varE (mkName a)) |]
$ makeExpr xs
makeExprT [] = ls ""
makeExprT (Literal a:xs) = TH.appE [| (<>) a |]
$ makeExprT xs
makeExprT (AntiQuote a:xs) = TH.appE [| (<>) (toText $(varE (mkName a))) |]
$ makeExprT xs
makeExprTL [] = ls ""
makeExprTL (Literal a:xs) = TH.appE [| (<>) a |]
$ makeExprTL xs
makeExprTL (AntiQuote a:xs) = TH.appE [| (<>) (toLazyText $(varE (mkName a))) |]
$ makeExprTL xs
makeExprTB [] = ls ""
makeExprTB (Literal a:xs) = TH.appE [| (B.<>) (B.fromLazyText a) |]
$ makeExprTB xs
makeExprTB (AntiQuote a:xs) = TH.appE [| (B.<>) (toTextBuilder $(varE (mkName a))) |]
$ makeExprTB xs
ls = return . TH.LitE . TH.StringL
isIdent '_' = True
isIdent '\'' = True
isIdent x = isAlphaNum x
expandIntoCons [c] = LitP (CharL c)
expandIntoCons (c:cs) = InfixP (LitP (CharL c)) '(:) (expandIntoCons cs)