{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Quasiquotation for byte builders.
module Data.Bytes.Builder.Template
  ( bldr
  ) where

import Control.Monad (when)
import Data.Bytes.Builder.Class (toBuilder)
import GHC.Ptr (Ptr(Ptr))
import Language.Haskell.Meta.Parse (parseExp)
import Language.Haskell.TH (Q,Exp)
import Language.Haskell.TH.Lib (integerL,stringPrimL,litE)
import Language.Haskell.TH.Quote (QuasiQuoter(..))

import qualified Data.Bytes.Builder as Builder
import qualified Data.ByteString.Short as SBS
import qualified Data.Text.Short as TS
import qualified Language.Haskell.TH as TH

-- | A quasiquoter for builders. Haskell expressions are interpolated
-- with backticks, and the @ToBuilder@ class is used to convert them
-- to builders. Several common escape sequences for whitespace and
-- control characters are recongized. Consider the following expression,
-- where the binding @partition@ has type @Word32@:
--
-- > [templ|[WARN] Partition `partition` has invalid data.\n|]
--
-- This expression has type @Builder@ and expands to:
--
-- > Builder.cstringLen (Ptr "[WARN] Partition "#, 17) <>
-- > Builder.toBuilder partition <>
-- > Builder.cstringLen (Ptr " has invalid data.\n"#, 19)
--
-- The @ToBuilder@ instance for @Word32@ uses decimal encoding, so this
-- would result in the following if @partition@ was 42 (with a newline
-- character at the end):
--
-- > [WARN] Partition 42 has invalid data.
--
-- In the future, a more sophisticated @bbldr@ variant will be added
-- that will support expressions where the maximum length of the entire
-- builder can be computed at compile time. 
bldr :: QuasiQuoter
bldr :: QuasiQuoter
bldr = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
templExp
  , quotePat :: String -> Q Pat
quotePat = forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
notHandled String
"patterns"
  , quoteType :: String -> Q Type
quoteType = forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
notHandled String
"types"
  , quoteDec :: String -> Q [Dec]
quoteDec = forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
notHandled String
"declarations"
  }
  where
  notHandled :: String -> p -> m a
notHandled String
things p
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
    String
things forall a. [a] -> [a] -> [a]
++ String
"are not handled by the byte template quasiquoter"

templExp :: String -> Q Exp
templExp :: String -> Q Exp
templExp String
inp = do
  Q ()
checkOverloadedStrings
  Template
rawParts <- case String -> Either String Template
parse String
inp of
    Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty template"
    Right Template
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Template
v
  let expParts :: [Q Exp]
expParts = TemplPart -> Q Exp
compile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template
rawParts
  forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
e1 Q Exp
e2 -> [| $e1 <> $e2 |]) [Q Exp]
expParts

checkOverloadedStrings :: Q ()
checkOverloadedStrings :: Q ()
checkOverloadedStrings = do
  Bool
olEnabled <- Extension -> Q Bool
TH.isExtEnabled Extension
TH.OverloadedStrings
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
olEnabled) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Byte templates require the OverloadedStrings extension enabled."

type Template = [TemplPart]
data TemplPart
  = Literal String
  | Splice String

compile :: TemplPart -> Q Exp
compile :: TemplPart -> Q Exp
compile (Literal String
lit) =
  let bytes :: [Word8]
bytes = ShortByteString -> [Word8]
SBS.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> ShortByteString
TS.toShortByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShortText
TS.pack forall a b. (a -> b) -> a -> b
$ String
lit
      strExp :: Q Exp
strExp = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Lit
stringPrimL forall a b. (a -> b) -> a -> b
$ [Word8]
bytes
      strLen :: Q Exp
strLen = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
bytes
   in [|Builder.cstringLen (Ptr $(strExp), $(strLen))|]
compile (Splice String
str) = case String -> Either String Exp
parseExp String
str of
  Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right Exp
hs -> [|toBuilder $(pure hs)|]

parse :: String -> Either String Template
parse :: String -> Either String Template
parse = String -> Either String Template
partsLoop
  where
  partsLoop :: String -> Either String Template
partsLoop String
"" = do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  partsLoop (Char
'`':String
inp) = do
    (!String
spl, !String
rest) <- String -> Either String (String, String)
spliceLoop String
inp
    (String -> TemplPart
Splice String
splforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String Template
partsLoop String
rest
  partsLoop String
inp = do
    (!String
lit, !String
rest) <- String -> String -> Either String (String, String)
litLoop String
"" String
inp
    (String -> TemplPart
Literal String
litforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String Template
partsLoop String
rest
  litLoop :: String -> String -> Either String (String, String)
  litLoop :: String -> String -> Either String (String, String)
litLoop !String
acc rest :: String
rest@String
"" = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse String
acc, String
rest)
  litLoop !String
acc rest :: String
rest@(Char
'`':String
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse String
acc, String
rest)
  litLoop !String
acc (Char
'\\':String
next) = do
    (Char
c, String
rest) <- String -> Either String (Char, String)
parseEscape String
next
    String -> String -> Either String (String, String)
litLoop (Char
cforall a. a -> [a] -> [a]
:String
acc) String
rest
  litLoop !String
acc (Char
c:String
rest) = String -> String -> Either String (String, String)
litLoop (Char
cforall a. a -> [a] -> [a]
:String
acc) String
rest
  spliceLoop :: String -> Either String (String, String)
  spliceLoop :: String -> Either String (String, String)
spliceLoop String
inp = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'`') String
inp of
    ([], String
_) -> forall a b. a -> Either a b
Left String
"internal error"
    (String
hs, Char
'`':String
rest) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
hs, String
rest)
    (String
_, Char
_:String
_) -> forall a b. a -> Either a b
Left String
"internal error"
    (String
_, []) -> forall a b. a -> Either a b
Left String
"unterminated interpolation"
  parseEscape :: String -> Either String (Char, String)
  parseEscape :: String -> Either String (Char, String)
parseEscape String
"" = forall a b. a -> Either a b
Left String
"incomplete escape"
  parseEscape (Char
'\\':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\\', String
rest)
  parseEscape (Char
'`':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'`', String
rest)
  parseEscape (Char
'\'':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\'', String
rest)
  parseEscape (Char
'\"':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\"', String
rest)
  parseEscape (Char
'0':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\0', String
rest)
  parseEscape (Char
'a':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\a', String
rest)
  parseEscape (Char
'b':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\b', String
rest)
  parseEscape (Char
'f':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\f', String
rest)
  parseEscape (Char
'n':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\n', String
rest)
  parseEscape (Char
'r':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\r', String
rest)
  parseEscape (Char
't':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\t', String
rest)
  parseEscape (Char
'v':String
rest) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'\v', String
rest)
  parseEscape (Char
c:String
_) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"unrecognized escape: \\" forall a. [a] -> [a] -> [a]
++ [Char
c]