Format.hs

{-|
Module      : Data.Format
Description : QuasiQuoters for simple string interpolation.
Copyright   : (c) Moritz Clasmeier, 2017-2018
License     : BSD3
Maintainer  : mtesseract@silverratio.net
Stability   : experimental
Portability : POSIX
-}

{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE RecursiveDo          #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Data.Format
  ( fmt
  , fmtConcat
  ) where

import           Control.Applicative
import           Data.Char
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import qualified Data.Text.Lazy              as Text.Lazy
import           Language.Haskell.Meta.Parse
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax
import           Text.Earley

-- | This is just 'mconcat', reexported under a specialized name in
-- order to avoid namespace clashes.
fmtConcat :: Monoid a => [a] -> a
fmtConcat = mconcat

-- | Type class which needs to be implemented by types that should be
-- usable for format string interpolation. For most types the this
-- class is simply implemented in terms of 'show'. But for
-- human-readable strings (e.g. 'String', 'Text'), the format
-- representation is simply the string itself, not its 'show'-image
-- (which adds quotation characters).
class Format a where
  formatText :: a -> Text

instance Format Int where
  formatText = tshow

instance Format String where
  formatText = Text.pack

instance Format Double where
  formatText = tshow

instance Format Float where
  formatText = tshow

instance Format Integer where
  formatText = tshow

instance Format Text where
  formatText = id

instance Format Text.Lazy.Text where
  formatText = Text.Lazy.toStrict

instance Format Bool where
  formatText = tshow

tshow :: Show a => a -> Text
tshow = Text.pack . show

data Fmt = Literal String
         | Identifier String
         | Expression String
  deriving (Show, Eq)

-- | Quasi Quoter for format strings. Examples:
--
-- Examples:
--
-- >>> let answer = 42 in [fmt|What is the answer to universe, life and everything? It's $answer!|]
-- "What is the answer to universe, life and everything? It's 42!"
--
-- >>> let toggle = True in [fmt|The toggle is switched ${if toggle then ("on" :: Text) else "off"}|]
-- "The toggle is switched on"
--
-- >>> let timeDelta = 60 in [fmt|Request latency: ${timeDelta}ms|]
-- "Request latency: 60ms"
fmt :: QuasiQuoter
fmt = QuasiQuoter { quoteExp = parseFormatStringQ
                  , quotePat = undefined
                  , quoteType = undefined
                  , quoteDec = undefined
                  }

instance Lift Fmt where
  lift (Literal s)    = stringE s
  lift (Identifier s) =
    lookupValueName s >>= \case
      Just v  -> (return . formatTextEmbed . VarE) v
      Nothing -> fail $ "Not in scope: '" ++ s ++ "'"
  lift (Expression s) = either fail (return . formatTextEmbed) (parseExp s)

formatTextEmbed :: Exp -> Exp
formatTextEmbed expr = AppE (VarE 'formatText) expr

newtype FmtString = FmtString [Fmt]

instance Lift FmtString where
  lift (FmtString fmts) = do
    fmtExprs <- Prelude.mapM lift fmts
    return $ AppE (VarE 'fmtConcat) (ListE fmtExprs)

-- | Parse the provided format string as a Template Haskell
-- expression.
parseFormatStringQ :: String -> Q Exp
parseFormatStringQ s =
  let parseResult = FmtString (parseFormatString s)
  in  [| parseResult |]

-- | Parse the provided format string as a list of 'Fmt' values.
parseFormatString :: String -> [Fmt]
parseFormatString s =
  case fullParses (parser fmtParser) s of
    ([], Report { unconsumed = "" }) ->
      []
    ([uniqueResult], Report { unconsumed = "" }) ->
      uniqueResult
    _ ->
      fail "Parse failure"

-- | Earley parser for the grammar of format strings.
fmtParser :: Grammar r (Prod r String Char [Fmt])
fmtParser = mdo
  -- Initial rule.
  start <- rule $ interpolationOrLiteral

  -- Either parse an interpolation or a non-empty string literal next.
  interpolationOrLiteral <- rule $
    interpolationThenRest
    <|> literalThenRest

  -- Parse an interpolation next (either `$foo$` or `${foo}`).
  interpolationThenRest <- rule $
    interpolationSimpleThenRest
    <|> interpolationDelimitedThenRest

  -- Parse a simple interpolation next (i.e. `$foo`).
  interpolationSimpleThenRest <- rule $
    (Identifier <$> interpolationSimple) `apCons` delimLiteralThenRest
    <|> (Identifier <$> interpolationSimple) `apCons` interpolationThenRest
    <|> (Identifier <$> interpolationSimple) `apCons` pure []

  -- Parse a delimited interpolation next (i.e. `${foo}`).
  interpolationDelimitedThenRest <- rule $
    (Expression <$> interpolationDelimited) `apCons` interpolationOrLiteral
    <|> (Expression <$> interpolationDelimited) `apCons` pure []

  -- Parse a single character literal which marks the beginning of a
  -- string literal and can be used to end a previous simple
  -- interpolation (e.g. whitspace, comma).
  delimLiteral <- rule $ Literal <$>
    (satisfy (\c -> not (identifierChar c) && c /= '$')) `apCons` strChars

  -- Parse a string literal next which starts with a delimiting character.
  delimLiteralThenRest <- rule $
    delimLiteral `apCons` interpolationThenRest
    <|> delimLiteral `apCons` (pure [])

  -- Parse a string literal next.
  literalThenRest <- rule $
    (Literal <$> literal) `apCons` pure []
    <|> (Literal <$> literal) `apCons` interpolationThenRest

  -- Parse a single Haskell variable name next.
  identifier <- rule $
    satisfy initialIdentifierChar `apCons` many (satisfy identifierChar)

  -- Parse a simple interpolation next.
  interpolationSimple <- rule $ token '$' *> identifier

  -- Parse a delimited interpolation next.
  interpolationDelimited <- rule $ token '$' *> token '{' *> expression <* token '}'

  -- Parses a single string literal character. Supports escaping.
  strChar <- rule $
    satisfy (`Prelude.notElem` ['$', '\\'])
    <|> token '\\' *> satisfy (const True)

  -- Possibly potentially empty string literal.
  strChars <- rule $ many strChar

  -- Nonempty string literal
  literal <- rule $ strChar `apCons` strChars

  -- Parse a expression, i.e. something contained between "${" and "}".
  expression <- rule $ some (satisfy (/= '}'))

  return start

  where apCons = liftA2 (:)

-- | Return True if the given character can be part of a Haskell
-- variable name, False otherwise.
identifierChar :: Char -> Bool
identifierChar c = isLower c || isUpper c || c `Prelude.elem` ['\'', '_']

-- | Return True if the given character can be the initial character
-- of a Haskell variable name.
initialIdentifierChar :: Char -> Bool
initialIdentifierChar c = isLower c || c == '_'