{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE ViewPatterns #-}

module Data.Bytes.Patterns
  ( makeBytesPatterns
  ) where

import Data.Char (isSpace, ord, toUpper)
import Data.List
import Data.Word (Word8)
import GHC.Exts (Ptr (Ptr))
import Language.Haskell.TH

import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Text.Latin1 as Latin1
import qualified Data.Bytes.Types as BytesT

data CheckHash
  = CheckHash
  | NoHash

{- | only use functions generated by this macro in the same case
generated functions follow the format "isFooBarBaz"
replacing spaces with camel case
-}
makeBytesPatterns :: [String] -> Q [Dec]
makeBytesPatterns :: [String] -> Q [Dec]
makeBytesPatterns [String]
bs = do
  let bsByLength :: [[String]]
bsByLength = (String -> String -> Bool) -> [String] -> [[String]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\String
a String
b -> String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
b) [String]
bs
  [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([String] -> Q [Dec]) -> [[String]] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [String] -> Q [Dec]
makeBytesPatternsEqualLen [[String]]
bsByLength

makeBytesPatternsEqualLen :: [String] -> Q [Dec]
makeBytesPatternsEqualLen :: [String] -> Q [Dec]
makeBytesPatternsEqualLen [String]
bs = do
  let len :: Int
len = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
bs
      checkHash :: CheckHash
checkHash = (if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 then CheckHash
CheckHash else CheckHash
NoHash)
  [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Q [Dec]) -> [String] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (CheckHash -> String -> Q [Dec]
makeBytesPattern CheckHash
checkHash) [String]
bs

makeBytesPattern :: CheckHash -> String -> Q [Dec]
makeBytesPattern :: CheckHash -> String -> Q [Dec]
makeBytesPattern CheckHash
checkHash String
s = do
  -- name <- newName $ (toUpper $ head s) : tail s
  Name
fnName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"is" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
camelCase String
s
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
fnName Inline
Inline RuleMatch
FunLike Phases
AllPhases
    , Name -> Type -> Dec
SigD Name
fnName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Type
ArrowT Type -> Type -> Type
`AppT` Name -> Type
ConT ''Bytes.Bytes Type -> Type -> Type
`AppT` Name -> Type
ConT ''Bool
    , Name -> [Clause] -> Dec
FunD Name
fnName [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB Exp
expr) []]
    -- doesn't inline :^(
    -- , PatSynSigD name (ConT ''Bytes.Bytes)
    -- , PatSynD name (PrefixPatSyn []) Unidir $ ViewP (VarE fnName) (ConP 'True [])
    ]
 where
  x :: Name
  x :: Name
x = String -> Name
mkName String
"x"
  bytes :: Bytes
bytes@(BytesT.Bytes ByteArray
_ Int
_ Int
len) = String -> Bytes
Latin1.fromString String
s
  checkHashExp :: Exp
checkHashExp = case CheckHash
checkHash of
    CheckHash
CheckHash ->
      Lit -> Exp
LitE (Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ Bytes -> Word64
Bytes.fnv1a64 Bytes
bytes)
        Exp -> Exp -> Exp
=== (Name -> Exp
VarE 'Bytes.fnv1a64 Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x)
    CheckHash
NoHash -> Name -> Exp
ConE 'True
  expr :: Exp
  expr :: Exp
expr =
    ( Lit -> Exp
LitE (Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        Exp -> Exp -> Exp
=== (Name -> Exp
VarE 'Bytes.length Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x)
    )
      Exp -> Exp -> Exp
&&& Exp
checkHashExp
      Exp -> Exp -> Exp
&&& Exp -> Exp
ParensE (Int -> String -> Exp
equalsN Int
len String
s Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x)

equalsN :: Int -> String -> Exp
equalsN :: Int -> String -> Exp
equalsN Int
len String
s = case Int
len of
  Int
1 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals1
  Int
2 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals2
  Int
3 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals3
  Int
4 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals4
  Int
5 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals5
  Int
6 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals6
  Int
7 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals7
  Int
8 -> String -> Exp -> Exp
unroll String
s (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'Latin1.equals8
  Int
_ -> Name -> Exp
VarE 'Bytes.equalsCString Exp -> Exp -> Exp
`AppE` (Name -> Exp
ConE 'Ptr Exp -> Exp -> Exp
`AppE` String -> Exp
cstring String
s)
 where
  unroll :: String -> Exp -> Exp
unroll [] Exp
_ = String -> Exp
forall a. HasCallStack => String -> a
error String
"bug in `bytes-patterns`: unroll"
  unroll [Char
c] Exp
e = Exp
e Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Char -> Lit
CharL Char
c)
  unroll (Char
x : String
xs) Exp
e = (Exp -> Char -> Exp) -> Exp -> String -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
acc Char
c -> Exp
acc Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Char -> Lit
CharL Char
c)) (Exp
e Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Char -> Lit
CharL Char
x)) String
xs
  cstring :: String -> Exp
cstring String
x = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
StringPrimL ([Word8] -> Lit) -> [Word8] -> Lit
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Word8
c2w String
x

{- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and
silently truncates to 8 bits Chars > '\255'.
-}
c2w :: Char -> Word8
c2w :: Char -> Word8
c2w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
{-# INLINE c2w #-}

{-# INLINE (&&&) #-}
(&&&) :: Exp -> Exp -> Exp
Exp
a &&& :: Exp -> Exp -> Exp
&&& Exp
b =
  Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
ParensE Exp
a)
    (Name -> Exp
VarE '(&&))
    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
ParensE Exp
b)

{-# INLINE (===) #-}
(===) :: Exp -> Exp -> Exp
Exp
a === :: Exp -> Exp -> Exp
=== Exp
b =
  Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
ParensE Exp
a)
    (Name -> Exp
VarE '(==))
    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
ParensE Exp
b)

camelCase :: String -> String
camelCase :: String -> String
camelCase = String -> String
u (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
applyFirst Char -> Char
toUpper
 where
  u :: String -> String
u [] = []
  u (Char
x : String
xs)
    | Char -> Bool
isSpace Char
x = Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
u String
xs
    | Bool
otherwise = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
u String
xs

applyFirst :: (Char -> Char) -> String -> String
applyFirst :: (Char -> Char) -> String -> String
applyFirst Char -> Char
_ [] = []
applyFirst Char -> Char
f [Char
x] = [Char -> Char
f Char
x]
applyFirst Char -> Char
f (Char
x : String
xs) = Char -> Char
f Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs