QuasiText.hs

{-# LANGUAGE ExistentialQuantification, TemplateHaskell, QuasiQuotes, OverloadedStrings, FlexibleInstances, UndecidableInstances, IncoherentInstances #-}
-- |
-- A simple 'QuasiQuoter' for 'Text' strings. Note that to use 'embed' you need to use the OverloadedStrings extension.

module Text.QuasiText (embed, Chunk (..), getChunks) where
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Language.Haskell.TH
import Language.Haskell.Meta (parseExp)

import Data.Attoparsec.Text
import qualified Data.Text as T 
import Data.Text (Text)
import Data.Char

import Data.Monoid
import Control.Applicative
                        
instance Lift Text where
    lift = litE . stringL . T.unpack

data Chunk 
    = T Text -- ^ text
    | E Text -- ^ expression
    | V Text -- ^ value
  deriving (Show, Eq)

class Textish a where
    toText :: a -> Text

instance Textish Text where
    {-# INLINE toText #-}
    toText x = x

instance Textish [Char] where
    {-# INLINE toText #-}
    toText x = T.pack x

instance Show a => Textish a where 
    {-# INLINE toText #-}
    toText x = T.pack (show x)

-- | A simple 'QuasiQuoter' to interpolate 'Text' into other pieces of 'Text'. 
-- Expressions can be embedded using $(expr), and values can be interpolated 
-- with $name. Inside $( )s, if you have a string of ambiguous type, it will 
-- default to the Show instance for toText, which will escape unicode 
-- characters in the string, and add quotes around them.

embed :: QuasiQuoter
embed = QuasiQuoter
    { quoteExp = \s -> 
        let chunks = flip map (getChunks (T.pack s)) $ \c ->
                    case c of
                        T t -> [| t |]

                        E t -> case parseExp (T.unpack t) of
                            Left  e -> error e
                            Right e -> appE [| toText |] (return e)

                        V t -> appE [| toText |] (global (mkName (T.unpack t)))

        in appE [| T.concat |] (listE chunks)
    }

-- | Create 'Chunk's without any TH.
getChunks :: Text -> [Chunk]
getChunks i = case parseOnly parser (T.strip i) of
        Right m -> m
        _       -> error "Unclosed parenthesis."

  where
    parenthesis '(' = True
    parenthesis ')' = True
    parenthesis _   = False

    parseExpression :: Int -> Parser [Text]
    parseExpression level = do
        expr  <- takeTill parenthesis
        paren <- anyChar
        case paren of
            ')' | level <= 0 -> return [expr]
                | otherwise  -> do
                    next <- parseExpression (level - 1)
                    return ([expr, ")"] ++ next)

            '(' -> do
                next <- parseExpression (level + 1)
                return ([expr, "("] ++ next)

            _ -> return [expr, T.singleton paren]

    parser :: Parser [Chunk]
    parser = fmap concat $ flip manyTill (endOfInput <|> endOfLine) $ do
        text <- takeTill (== '$')
        end  <- atEnd
        if end
            then return [T text]
            else do
                char '$'
                next <- anyChar
                case next of
                    -- opening an experssion
                    '(' -> do
                        expr <- T.concat <$> parseExpression 0
                        return [T text, E expr]

                    -- escaped '$' 
                    '$' -> return [T (text <> "$")]

                    -- value
                    _ -> do
                        name <- takeTill (not . isAlphaNum)
                        return [T text, V (T.cons next name)]