packages feed

bytes-patterns (empty) → 0.1.0.0

raw patch · 5 files changed

+235/−0 lines, 5 filesdep +basedep +bytes-patternsdep +byteslice

Dependencies added: base, bytes-patterns, byteslice, tasty, tasty-hunit, template-haskell

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for bytes-patterns++## 0.1.0.0 -- 2024-02-07++* First version.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2020 Zachary Churchill++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ bytes-patterns.cabal view
@@ -0,0 +1,46 @@+cabal-version:   2.4+name:            bytes-patterns+version:         0.1.0.0+synopsis:        Template haskell macro for casing on Bytes+description:     Provides template haskell macros for casing on Bytes.+homepage:        https://github.com/byteverse/bytes-patterns+bug-reports:     https://github.com/byteverse/bytes-patterns/issues+license:         MIT+license-file:    LICENSE+author:          Zachary Churchill+maintainer:      amartin@layer3com.com+copyright:       2024 Andrew Martin+category:        Data+extra-doc-files: CHANGELOG.md+tested-with:     GHC ==9.4.8 || ==9.6.3 || ==9.8.1++common build-settings+  default-language: Haskell2010+  ghc-options:      -Wall -Wunused-packages++library+  import:          build-settings+  exposed-modules: Data.Bytes.Patterns+  ghc-options:     -O2+  build-depends:+    , base              >=4.13.0.0 && <5+    , byteslice+    , template-haskell++  hs-source-dirs:  src++test-suite test+  import:         build-settings+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  build-depends:+    , base+    , bytes-patterns+    , byteslice+    , tasty+    , tasty-hunit++source-repository head+  type:     git+  location: git://github.com/byteverse/bytes-patterns.git
+ src/Data/Bytes/Patterns.hs view
@@ -0,0 +1,118 @@+{-# 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 bs = do+  let bsByLength = groupBy (\a b -> length a == length b) bs+  mconcat <$> traverse makeBytesPatternsEqualLen bsByLength++makeBytesPatternsEqualLen :: [String] -> Q [Dec]+makeBytesPatternsEqualLen bs = do+  let len = length bs+      checkHash = (if len < 3 then CheckHash else NoHash)+  mconcat <$> traverse (makeBytesPattern checkHash) bs++makeBytesPattern :: CheckHash -> String -> Q [Dec]+makeBytesPattern checkHash s = do+  -- name <- newName $ (toUpper $ head s) : tail s+  fnName <- newName $ "is" <> camelCase s+  pure+    [ PragmaD $ InlineP fnName Inline FunLike AllPhases+    , SigD fnName $ ArrowT `AppT` ConT ''Bytes.Bytes `AppT` ConT ''Bool+    , FunD fnName [Clause [VarP x] (NormalB expr) []]+    -- doesn't inline :^(+    -- , PatSynSigD name (ConT ''Bytes.Bytes)+    -- , PatSynD name (PrefixPatSyn []) Unidir $ ViewP (VarE fnName) (ConP 'True [])+    ]+ where+  x :: Name+  x = mkName "x"+  bytes@(BytesT.Bytes _ _ len) = Latin1.fromString s+  checkHashExp = case checkHash of+    CheckHash ->+      LitE (IntegerL $ fromIntegral $ Bytes.fnv1a64 bytes)+        === (VarE 'Bytes.fnv1a64 `AppE` VarE x)+    NoHash -> ConE 'True+  expr :: Exp+  expr =+    ( LitE (IntegerL $ fromIntegral len)+        === (VarE 'Bytes.length `AppE` VarE x)+    )+      &&& checkHashExp+      &&& ParensE (equalsN len s `AppE` VarE x)++equalsN :: Int -> String -> Exp+equalsN len s = case len of+  1 -> unroll s $ VarE 'Latin1.equals1+  2 -> unroll s $ VarE 'Latin1.equals2+  3 -> unroll s $ VarE 'Latin1.equals3+  4 -> unroll s $ VarE 'Latin1.equals4+  5 -> unroll s $ VarE 'Latin1.equals5+  6 -> unroll s $ VarE 'Latin1.equals6+  7 -> unroll s $ VarE 'Latin1.equals7+  8 -> unroll s $ VarE 'Latin1.equals8+  _ -> VarE 'Bytes.equalsCString `AppE` (ConE 'Ptr `AppE` cstring s)+ where+  unroll [] _ = error "bug in `bytes-patterns`: unroll"+  unroll [c] e = e `AppE` LitE (CharL c)+  unroll (x : xs) e = foldl' (\acc c -> acc `AppE` LitE (CharL c)) (e `AppE` LitE (CharL x)) xs+  cstring x = LitE $ StringPrimL $ fmap c2w x++{- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and+silently truncates to 8 bits Chars > '\255'.+-}+c2w :: Char -> Word8+c2w = fromIntegral . ord+{-# INLINE c2w #-}++{-# INLINE (&&&) #-}+(&&&) :: Exp -> Exp -> Exp+a &&& b =+  InfixE+    (Just $ ParensE a)+    (VarE '(&&))+    (Just $ ParensE b)++{-# INLINE (===) #-}+(===) :: Exp -> Exp -> Exp+a === b =+  InfixE+    (Just $ ParensE a)+    (VarE '(==))+    (Just $ ParensE b)++camelCase :: String -> String+camelCase = u . applyFirst toUpper+ where+  u [] = []+  u (x : xs)+    | isSpace x = toUpper x : u xs+    | otherwise = x : u xs++applyFirst :: (Char -> Char) -> String -> String+applyFirst _ [] = []+applyFirst f [x] = [f x]+applyFirst f (x : xs) = f x : xs
+ test/Main.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Data.Bytes.Patterns+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Bytes.Text.Ascii as Ascii++makeBytesPatterns+  [ "f"+  , "fo"+  , "foo"+  , "foob"+  , "fooba"+  , "foobar"+  , "foobarb"+  , "foobarba"+  , "foobarbaz"+  ]++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [unitTests]++unitTests :: TestTree+unitTests =+  testGroup+    "Unit tests"+    [ assertBoolTest "f" $ isF $ Ascii.fromString "f"+    , assertBoolTest "fo" $ isFo $ Ascii.fromString "fo"+    , assertBoolTest "foo" $ isFoo $ Ascii.fromString "foo"+    , assertBoolTest "foob" $ isFoob $ Ascii.fromString "foob"+    , assertBoolTest "fooba" $ isFooba $ Ascii.fromString "fooba"+    , assertBoolTest "foobar" $ isFoobar $ Ascii.fromString "foobar"+    , assertBoolTest "foobarb" $ isFoobarb $ Ascii.fromString "foobarb"+    , assertBoolTest "foobarba" $ isFoobarba $ Ascii.fromString "foobarba"+    , assertBoolTest "foobarbaz" $ isFoobarbaz $ Ascii.fromString "foobarbaz"+    ]+ where+  assertBoolTest x b = testCase x $ assertBool x b