Byte Template Quasiquoter and classes for builders

Co-authored-by: Eric Demko <edemko@layer3com.com>
Co-authored-by: Andrew Martin <andrew.thaddeus@gmail.com>

bytebuild.cabal

@@ -37,8 +37,11 @@ flag checked
 library
   exposed-modules:
     Data.Bytes.Builder
+    Data.Bytes.Builder.Class
+    Data.Bytes.Builder.Template
     Data.Bytes.Builder.Unsafe
     Data.Bytes.Builder.Bounded
+    Data.Bytes.Builder.Bounded.Class
     Data.Bytes.Builder.Bounded.Unsafe
   reexported-modules:
     Data.Bytes.Chunks
@@ -46,11 +49,13 @@ library
     , base >=4.12.0.0 && <5
     , byteslice >=0.2.5 && <0.3
     , bytestring >=0.10.8.2 && <0.11
+    , haskell-src-meta >=0.8
     , integer-logarithms >=1.0.3 && <1.1
     , natural-arithmetic >=0.1 && <0.2
     , primitive-offset >=0.2 && <0.3
     , primitive-unlifted >=0.1.2 && <0.2
     , run-st >=0.1 && <0.2
+    , template-haskell >=2.16
     , text-short >=0.1.3 && <0.2
     , wide-word >=0.1.0.9 && <0.2
   if flag(checked)
@@ -82,6 +87,7 @@ test-suite test
     , primitive-unlifted >=0.1.2
     , quickcheck-classes >=0.6.4
     , quickcheck-instances >=0.3.22
+    , text-short
     , tasty >=1.2.3 && <1.3
     , tasty-hunit >=0.10.0.2 && <0.11
     , tasty-quickcheck >=0.10.1 && <0.11

src/Data/Bytes/Builder/Bounded/Class.hs

@@ -0,0 +1,79 @@
+{-# language DataKinds #-}
+{-# language TypeFamilies #-}
+
+module Data.Bytes.Builder.Bounded.Class
+  ( ToBoundedBuilder(..)
+  ) where
+
+import Data.Int
+import Data.Word
+
+import qualified Data.Bytes.Builder.Bounded as Bounded
+import qualified GHC.TypeNats as GHC
+
+-- | Variant of To that can be encoded as a builder. Human-readable encodings
+-- are used when possible. For example, numbers are encoded an ascii-encoded
+-- decimal characters. UTF-8 is preferred for textual types. For types
+-- that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes
+-- are preserved.
+--
+-- The goal of this typeclass is to reduce the size of builders produced
+-- by quasiquotation.
+class ToBoundedBuilder a where
+  type BoundedBuilderLength a :: GHC.Nat
+  toBuilder :: a -> Bounded.Builder (BoundedBuilderLength a)
+
+-- | Identity
+instance ToBoundedBuilder (Bounded.Builder n) where
+  type BoundedBuilderLength (Bounded.Builder n) = n
+  toBuilder = id
+
+-- | Uses @int64Dec@.
+instance ToBoundedBuilder Int64 where
+  type BoundedBuilderLength Int64 = 20
+  toBuilder = Bounded.int64Dec
+
+-- | Uses @int32Dec@.
+instance ToBoundedBuilder Int32 where
+  type BoundedBuilderLength Int32 = 11
+  toBuilder = Bounded.int32Dec
+
+-- | Uses @int16Dec@.
+instance ToBoundedBuilder Int16 where
+  type BoundedBuilderLength Int16 = 6
+  toBuilder = Bounded.int16Dec
+
+-- | Uses @int8Dec@.
+instance ToBoundedBuilder Int8 where
+  type BoundedBuilderLength Int8 = 4
+  toBuilder = Bounded.int8Dec
+
+-- | Uses @intDec@.
+instance ToBoundedBuilder Int where
+  type BoundedBuilderLength Int = 20
+  toBuilder = Bounded.intDec
+
+-- | Uses @word64Dec@.
+instance ToBoundedBuilder Word64 where
+  type BoundedBuilderLength Word64 = 19
+  toBuilder = Bounded.word64Dec
+
+-- | Uses @word32Dec@.
+instance ToBoundedBuilder Word32 where
+  type BoundedBuilderLength Word32 = 10
+  toBuilder = Bounded.word32Dec
+
+-- | Uses @word16Dec@.
+instance ToBoundedBuilder Word16 where
+  type BoundedBuilderLength Word16 = 5
+  toBuilder = Bounded.word16Dec
+
+-- | Uses @word8Dec@.
+instance ToBoundedBuilder Word8 where
+  type BoundedBuilderLength Word8 = 3
+  toBuilder = Bounded.word8Dec
+
+-- | Uses @wordDec@.
+instance ToBoundedBuilder Word where
+  type BoundedBuilderLength Word = 19
+  toBuilder = Bounded.wordDec

src/Data/Bytes/Builder/Class.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Data.Bytes.Builder.Class
+  ( ToBuilder(..)
+  ) where
+
+import Data.Bytes (Bytes)
+import Data.Bytes.Builder (Builder)
+import Data.ByteString.Short (ShortByteString)
+import Data.Int
+import Data.Primitive.ByteArray (ByteArray)
+import Data.Text.Short (ShortText)
+import Data.Word
+
+import qualified Data.Bytes.Builder as Builder
+
+-- | Types that can be encoded as a builder. Human-readable encodings
+-- are used when possible. For example, numbers are encoded an ascii-encoded
+-- decimal characters. UTF-8 is preferred for textual types. For types
+-- that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes
+-- are preserved.
+--
+-- The goal of this typeclass is to reduce the size of builders produced
+-- by quasiquotation.
+class ToBuilder a where
+  toBuilder :: a -> Builder
+
+-- | Identity
+instance ToBuilder Builder where
+  toBuilder = id
+
+-- | Uses @bytes@.
+instance ToBuilder Bytes where
+  toBuilder = Builder.bytes
+
+-- | Uses @byteArray@
+instance ToBuilder ByteArray where
+  toBuilder = Builder.byteArray
+
+-- | Uses @shortByteString@
+instance ToBuilder ShortByteString where
+  toBuilder = Builder.shortByteString
+
+-- | Uses @shortTextUtf8@.
+instance ToBuilder ShortText where
+  toBuilder = Builder.shortTextUtf8
+
+-- | Uses @stringUtf8@
+instance ToBuilder String where
+  toBuilder = Builder.stringUtf8
+
+-- | Uses @int64Dec@.
+instance ToBuilder Int64 where
+  toBuilder = Builder.int64Dec
+
+-- | Uses @int32Dec@.
+instance ToBuilder Int32 where
+  toBuilder = Builder.int32Dec
+
+-- | Uses @int16Dec@.
+instance ToBuilder Int16 where
+  toBuilder = Builder.int16Dec
+
+-- | Uses @int8Dec@.
+instance ToBuilder Int8 where
+  toBuilder = Builder.int8Dec
+
+-- | Uses @intDec@.
+instance ToBuilder Int where
+  toBuilder = Builder.intDec
+
+-- | Uses @word64Dec@.
+instance ToBuilder Word64 where
+  toBuilder = Builder.word64Dec
+
+-- | Uses @word32Dec@.
+instance ToBuilder Word32 where
+  toBuilder = Builder.word32Dec
+
+-- | Uses @word16Dec@.
+instance ToBuilder Word16 where
+  toBuilder = Builder.word16Dec
+
+-- | Uses @word8Dec@.
+instance ToBuilder Word8 where
+  toBuilder = Builder.word8Dec
+
+-- | Uses @wordDec@.
+instance ToBuilder Word where
+  toBuilder = Builder.wordDec
+
+-- | uses @doubleDec@
+instance ToBuilder Double where
+  toBuilder = Builder.doubleDec

src/Data/Bytes/Builder/Template.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Bytes.Builder.Template
+  ( templ
+  ) 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
+
+
+templ :: QuasiQuoter
+templ = QuasiQuoter
+  { quoteExp = templExp
+  , quotePat = notHandled "patterns"
+  , quoteType = notHandled "types"
+  , quoteDec = notHandled "declarations"
+  }
+  where
+  notHandled things _ = fail $
+    things ++ "are not handled by the byte template quasiquoter"
+
+templExp :: String -> Q Exp
+templExp inp = do
+  checkOverloadedStrings
+  rawParts <- case parse inp of
+    Left err -> fail err
+    Right [] -> fail "empty template"
+    Right v -> pure v
+  let expParts = compile <$> rawParts
+  foldl1 (\e1 e2 -> [| $e1 <> $e2 |]) expParts
+
+checkOverloadedStrings :: Q ()
+checkOverloadedStrings = do
+  olEnabled <- TH.isExtEnabled TH.OverloadedStrings
+  when (not olEnabled) $
+    fail "Byte templates require the OverloadedStrings extension enabled."
+
+type Template = [TemplPart]
+data TemplPart
+  = Literal String
+  | Splice String
+
+compile :: TemplPart -> Q Exp
+compile (Literal lit) =
+  let bytes = SBS.unpack . TS.toShortByteString . TS.pack $ lit
+      strExp = litE . stringPrimL $ bytes
+      strLen = litE . integerL . fromIntegral $ length bytes
+   in [|Builder.cstringLen (Ptr $(strExp), $(strLen))|]
+compile (Splice str) = case parseExp str of
+  Left err -> fail err
+  Right hs -> [|toBuilder $(pure hs)|]
+
+parse :: String -> Either String Template
+parse = partsLoop
+  where
+  partsLoop "" = do
+    pure []
+  partsLoop ('`':inp) = do
+    (!spl, !rest) <- spliceLoop inp
+    (Splice spl:) <$> partsLoop rest
+  partsLoop inp = do
+    (!lit, !rest) <- litLoop "" inp
+    (Literal lit:) <$> partsLoop rest
+  litLoop :: String -> String -> Either String (String, String)
+  litLoop !acc rest@"" = pure (reverse acc, rest)
+  litLoop !acc rest@('`':_) = pure (reverse acc, rest)
+  litLoop !acc ('\\':next) = do
+    (c, rest) <- parseEscape next
+    litLoop (c:acc) rest
+  litLoop !acc (c:rest) = litLoop (c:acc) rest
+  spliceLoop :: String -> Either String (String, String)
+  spliceLoop inp = case break (== '`') inp of
+    ([], _) -> Left "internal error"
+    (hs, '`':rest) -> pure (hs, rest)
+    (_, _:_) -> Left "internal error"
+    (_, []) -> Left "unterminated interpolation"
+  parseEscape :: String -> Either String (Char, String)
+  parseEscape "" = Left "incomplete escape"
+  parseEscape ('\\':rest) = pure ('\\', rest)
+  parseEscape ('`':rest) = pure ('`', rest)
+  parseEscape ('\'':rest) = pure ('\'', rest)
+  parseEscape ('\"':rest) = pure ('\"', rest)
+  parseEscape ('0':rest) = pure ('\0', rest)
+  parseEscape ('a':rest) = pure ('\a', rest)
+  parseEscape ('b':rest) = pure ('\b', rest)
+  parseEscape ('f':rest) = pure ('\f', rest)
+  parseEscape ('n':rest) = pure ('\n', rest)
+  parseEscape ('r':rest) = pure ('\r', rest)
+  parseEscape ('t':rest) = pure ('\t', rest)
+  parseEscape ('v':rest) = pure ('\v', rest)
+  parseEscape (c:_) = Left $ "unrecognized escape: \\" ++ [c]

test/Main.hs

@@ -1,8 +1,9 @@
 {-# language BangPatterns #-}
 {-# language NumericUnderscores #-}
+{-# language OverloadedStrings #-}
+{-# language QuasiQuotes #-}
 {-# language ScopedTypeVariables #-}
 {-# language TypeApplications #-}
-{-# language OverloadedStrings #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -11,28 +12,32 @@ import Prelude hiding (replicate)
 import Control.Applicative (liftA2)
 import Control.Monad.ST (runST)
 import Data.Bytes.Builder
+import Data.Bytes.Builder.Template (templ)
 import Data.Bytes.Types (MutableBytes(MutableBytes))
-import Data.Primitive (PrimArray)
-import Data.Word
 import Data.Char (ord,chr)
 import Data.IORef (IORef,newIORef,readIORef,writeIORef)
+import Data.Maybe (fromMaybe)
 import Data.Primitive (ByteArray)
+import Data.Primitive (PrimArray)
+import Data.Text.Short (ShortText)
 import Data.WideWord (Word128(Word128),Word256(Word256))
+import Data.Word
 import Numeric.Natural (Natural)
-import Test.Tasty (defaultMain,testGroup,TestTree)
 import Test.QuickCheck ((===),Arbitrary)
 import Test.QuickCheck.Instances.Natural ()
-import Text.Printf (printf)
+import Test.Tasty (defaultMain,testGroup,TestTree)
 import Test.Tasty.HUnit ((@=?))
+import Text.Printf (printf)
 
 import qualified Arithmetic.Nat as Nat
 import qualified Data.Bits as Bits
-import qualified Data.Bytes.Builder.Bounded as Bounded
 import qualified Data.Bytes as Bytes
+import qualified Data.Bytes.Builder as Builder
+import qualified Data.Bytes.Builder.Bounded as Bounded
+import qualified Data.Bytes.Chunks as Chunks
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Lazy.Char8 as LB
-import qualified Data.Bytes.Chunks as Chunks
 import qualified Data.List as L
 import qualified Data.Primitive as PM
 import qualified Data.Text as T
@@ -286,6 +291,28 @@ tests = testGroup "Tests"
           , 0x00 : 0x09 : map c2w "listening"
           ] @=? map Exts.toList (Exts.toList res)
     ]
+  , testGroup "bytes templates"
+    [ THU.testCase "A" $ do
+        let name = Just ("foo" :: ShortText)
+            msgBuilder = [templ|Hello `fromMaybe "World" name`!\n|]
+            msg = Chunks.concat . Builder.run 200 $ msgBuilder
+         in Bytes.fromAsciiString "Hello foo!\n" @=? msg
+    , THU.testCase "B" $ do
+        let one = "foo" :: ShortText
+            two = "bar" :: String
+            msgBuilder = [templ|`one``two`|]
+            msg = Chunks.concat . Builder.run 200 $ msgBuilder
+         in Bytes.fromAsciiString "foobar" @=? msg
+    , THU.testCase "C" $ do
+        let msgBuilder = [templ|a backtick for you: \`|]
+            msg = Chunks.concat . Builder.run 200 $ msgBuilder
+         in Bytes.fromAsciiString "a backtick for you: `" @=? msg
+    , THU.testCase "D" $ do
+        let i = 137 :: Int
+            msgBuilder = [templ|there are `i` lights!|]
+            msg = Chunks.concat . Builder.run 200 $ msgBuilder
+         in Bytes.fromAsciiString "there are 137 lights!" @=? msg
+    ]
   ]
 
 bytesOntoRef ::