Initial commit

.github/workflows/tests.yml

@@ -0,0 +1,54 @@
+name: Tests
+
+on:
+  pull_request:
+  push:
+    branches:
+    - main
+  workflow_dispatch:
+
+# As of 7 July 2023, ubuntu-latest, windows-latest and macos-latest come
+# with Stack 2.11.1.
+
+jobs:
+  build:
+    name: CI
+    runs-on: ${{ matrix.os }}
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+        - ubuntu-latest
+        stack-yaml:
+        - stack-ghc-8.10.7.yaml
+        - stack-ghc-9.0.2.yaml
+        - stack-ghc-9.2.8.yaml
+        - stack-ghc-9.4.5.yaml
+        - stack-ghc-9.6.2.yaml
+        include:
+        - os: macos-latest
+          stack-yaml: stack-ghc-9.4.5.yaml
+        - os: windows-latest
+          stack-yaml: stack-ghc-9.4.5.yaml
+    steps:
+    - name: Clone project
+      uses: actions/checkout@v3
+    - name: Cache dependencies on Unix-like OS
+      if: startsWith(runner.os, 'Linux') || startsWith(runner.os, 'macOS')
+      uses: actions/cache@v3
+      with:
+        path: ~/.stack
+        key: ${{ runner.os }}-${{ matrix.stack-yaml }}
+    - name: Cache dependencies on Windows
+      if: startsWith(runner.os, 'Windows')
+      uses: actions/cache@v3
+      with:
+        path: |
+           ~\AppData\Roaming\stack
+           ~\AppData\Local\Programs\stack
+        key: ${{ runner.os }}-${{ matrix.stack-yaml }}
+    - name: Build
+      shell: bash
+      run: |
+        set -ex
+        stack test --stack-yaml ${{ matrix.stack-yaml }} --haddock --no-haddock-deps

.gitignore

@@ -0,0 +1,2 @@
+# Haskell Tool Stack-related
+.stack-work/

CHANGELOG.md

@@ -0,0 +1,11 @@
+# Changelog for `static-bytes`
+
+All notable changes to this project will be documented in this file.
+
+The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to the
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+
+## 0.1.0 - 2023-07-07
+
+* Spin out module `Pantry.Internal.StaticBytes` from package `pantry-0.8.3`.

LICENSE

@@ -0,0 +1,28 @@
+BSD 3-Clause License
+
+Copyright (c) 2015-2023, Stack contributors
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1,4 @@
+# static-bytes
+
+A Haskell library providing types representing 8, 16, 32, 64 or 128 bytes of
+data.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

package.yaml

@@ -0,0 +1,40 @@
+name:        static-bytes
+version:     0.1.0
+synopsis:    A Haskell library providing types representing 8, 16, 32, 64 or 128
+             bytes of data.
+description: Please see the README on GitHub at <https://github.com/commercialhaskell/static-bytes#readme>
+category:    Data
+author:      Michael Snoyman
+maintainer:  Mike Pilgrem <[email protected]>
+copyright:   2018-2023 FP Complete
+license:     BSD3
+github:      commercialhaskell/static-bytes
+
+extra-source-files:
+- README.md
+- CHANGELOG.md
+
+dependencies:
+- base >= 4.12 && < 5
+- bytestring
+- memory
+- primitive
+- rio
+- vector
+
+ghc-options:
+- -Wall
+
+library:
+  source-dirs: src
+
+tests:
+  spec:
+    build-tools: hspec-discover
+    source-dirs: test
+    main: Spec.hs
+    dependencies:
+    - QuickCheck
+    - hspec
+    - static-bytes
+    - text

src/Data/StaticBytes.hs

@@ -0,0 +1,246 @@
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveDataTypeable  #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Data.StaticBytes
+  ( Bytes8
+  , Bytes16
+  , Bytes32
+  , Bytes64
+  , Bytes128
+  , DynamicBytes
+  , StaticBytes
+  , StaticBytesException (..)
+  , toStaticExact
+  , toStaticPad
+  , toStaticTruncate
+  , toStaticPadTruncate
+  , fromStatic
+  ) where
+
+import           Data.Bits
+import           Data.ByteArray
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as B
+import qualified Data.Primitive.ByteArray as BA
+import qualified Data.Vector.Primitive as VP
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Unboxed.Base as VU
+import           Foreign.ForeignPtr
+import           Foreign.Ptr
+import           Foreign.Storable
+import           RIO hiding ( words )
+import           System.IO.Unsafe ( unsafePerformIO )
+
+-- | A type representing 8 bytes of data.
+newtype Bytes8 = Bytes8 Word64
+  deriving (Eq, Ord, Generic, NFData, Hashable, Data)
+
+instance Show Bytes8 where
+  show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString)
+
+-- | A type representing 16 bytes of data.
+data Bytes16 = Bytes16 !Bytes8 !Bytes8
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing 32 bytes of data.
+data Bytes32 = Bytes32 !Bytes16 !Bytes16
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing 64 bytes of data.
+data Bytes64 = Bytes64 !Bytes32 !Bytes32
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing 128 bytes of data.
+data Bytes128 = Bytes128 !Bytes64 !Bytes64
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing exceptions thrown by functions expecting data of a
+-- fixed number of bytes.
+data StaticBytesException
+  = NotEnoughBytes
+  | TooManyBytes
+  deriving (Eq, Show, Typeable)
+
+instance Exception StaticBytesException
+
+-- All lengths below are given in bytes
+
+class DynamicBytes dbytes where
+  lengthD :: dbytes -> Int
+  -- Yeah, it looks terrible to use a list here, but fusion should kick in
+  withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a
+  -- | May throw a runtime exception if invariants are violated!
+  fromWordsD :: Int -> [Word64] -> dbytes
+
+fromWordsForeign ::
+     (ForeignPtr a -> Int -> b)
+  -> Int
+  -> [Word64]
+  -> b
+fromWordsForeign wrapper len words0 = unsafePerformIO $ do
+  fptr <- B.mallocByteString len
+  withForeignPtr fptr $ \ptr -> do
+    let loop _ [] = pure ()
+        loop off (w:ws) = do
+          pokeElemOff (castPtr ptr) off w
+          loop (off + 1) ws
+    loop 0 words0
+  pure $ wrapper fptr len
+
+withPeekForeign ::
+     (ForeignPtr a, Int, Int)
+  -> ((Int -> IO Word64) -> IO b)
+  -> IO b
+withPeekForeign (fptr, off, len) inner =
+  withForeignPtr fptr $ \ptr -> do
+    let f off'
+          | off' >= len = pure 0
+          | off' + 8 > len = do
+              let loop w64 i
+                    | off' + i >= len = pure w64
+                    | otherwise = do
+                        w8 :: Word8 <- peekByteOff ptr (off + off' + i)
+                        let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64
+                        loop w64' (i + 1)
+              loop 0 0
+          | otherwise = peekByteOff ptr (off + off')
+    inner f
+
+instance DynamicBytes B.ByteString where
+  lengthD = B.length
+  fromWordsD = fromWordsForeign (`B.fromForeignPtr` 0)
+  withPeekD = withPeekForeign . B.toForeignPtr
+
+instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where
+  lengthD = VS.length
+  fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0
+  withPeekD = withPeekForeign . VS.unsafeToForeignPtr
+
+instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where
+  lengthD = VP.length
+  fromWordsD len words0 = unsafePerformIO $ do
+    ba <- BA.newByteArray len
+    let loop _ [] =
+          VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba
+        loop i (w:ws) = do
+          BA.writeByteArray ba i w
+          loop (i + 1) ws
+    loop 0 words0
+  withPeekD (VP.Vector off len ba) inner = do
+    let f off'
+          | off' >= len = pure 0
+          | off' + 8 > len = do
+              let loop w64 i
+                    | off' + i >= len = pure w64
+                    | otherwise = do
+                        let w8 :: Word8 = BA.indexByteArray ba (off + off' + i)
+                        let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64
+                        loop w64' (i + 1)
+              loop 0 0
+          | otherwise = pure $ BA.indexByteArray ba (off + (off' `div` 8))
+    inner f
+
+instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where
+  lengthD = VU.length
+  fromWordsD len words = VU.V_Word8 (fromWordsD len words)
+  withPeekD (VU.V_Word8 v) = withPeekD v
+
+class StaticBytes sbytes where
+  lengthS :: proxy sbytes -> Int -- use type level literals instead?
+  -- difference list
+  toWordsS :: sbytes -> [Word64] -> [Word64]
+  usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes
+
+instance StaticBytes Bytes8 where
+  lengthS _ = 8
+  toWordsS (Bytes8 w) = (w:)
+  usePeekS off f = Bytes8 <$> f off
+
+instance StaticBytes Bytes16 where
+  lengthS _ = 16
+  toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f
+
+instance StaticBytes Bytes32 where
+  lengthS _ = 32
+  toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f
+
+instance StaticBytes Bytes64 where
+  lengthS _ = 64
+  toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f
+
+instance StaticBytes Bytes128 where
+  lengthS _ = 128
+  toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f
+
+instance ByteArrayAccess Bytes8 where
+  length _ = 8
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes16 where
+  length _ = 16
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes32 where
+  length _ = 32
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes64 where
+  length _ = 64
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes128 where
+  length _ = 128
+  withByteArray = withByteArrayS
+
+withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a
+withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString)
+
+toStaticExact ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> Either StaticBytesException sbytes
+toStaticExact dbytes =
+  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of
+    LT -> Left NotEnoughBytes
+    GT -> Left TooManyBytes
+    EQ -> Right (toStaticPadTruncate dbytes)
+
+toStaticPad ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> Either StaticBytesException sbytes
+toStaticPad dbytes =
+  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of
+    GT -> Left TooManyBytes
+    _  -> Right (toStaticPadTruncate dbytes)
+
+toStaticTruncate ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> Either StaticBytesException sbytes
+toStaticTruncate dbytes =
+  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of
+    LT -> Left NotEnoughBytes
+    _  -> Right (toStaticPadTruncate dbytes)
+
+toStaticPadTruncate ::
+     (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> sbytes
+toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0))
+
+fromStatic ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => sbytes
+  -> dbytes
+fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS

stack-ghc-8.10.7.yaml

@@ -0,0 +1 @@
+resolver: lts-18.28 # GHC 8.10.7