From 6001fb63aaa1cdce1c672a2cf8dfd83bf82e3ecc Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Tue, 26 Mar 2019 21:48:08 -0400 Subject: Initial commit. --- primitive-structs.cabal | 70 ++++++++++++++++++++++ src/Data/Primitive/ByteArray/Util.hs | 71 ++++++++++++++++++++++ src/Data/Primitive/Struct.hs | 112 +++++++++++++++++++++++++++++++++++ src/Text/XXD.hs | 48 +++++++++++++++ 4 files changed, 301 insertions(+) create mode 100644 primitive-structs.cabal create mode 100644 src/Data/Primitive/ByteArray/Util.hs create mode 100644 src/Data/Primitive/Struct.hs create mode 100644 src/Text/XXD.hs diff --git a/primitive-structs.cabal b/primitive-structs.cabal new file mode 100644 index 0000000..1572554 --- /dev/null +++ b/primitive-structs.cabal @@ -0,0 +1,70 @@ +cabal-version: >=1.10 + +-- Initial package description 'primitive-structs.cabal' generated by +-- 'cabal init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: primitive-structs + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Mutable structs based on the primitive package ByteArray interface. + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Joe Crayne + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: joe@jerkface.net + +-- A copyright notice. +-- copyright: + +category: Data + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: CHANGELOG.md + + +library + -- Modules exported by the library. + exposed-modules: Data.Primitive.Struct, Data.Primitive.ByteArray.Util, Text.XXD + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + other-extensions: AllowAmbiguousTypes, CPP, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, KindSignatures, MagicHash, RankNTypes + + -- Other library packages from which modules are imported. + build-depends: base >=4.11 && <4.12, primitive >=0.6 && <0.7, tagged >=0.8 && <0.9, bytestring >=0.10 && <0.11, memory >=0.14 && <0.15 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + diff --git a/src/Data/Primitive/ByteArray/Util.hs b/src/Data/Primitive/ByteArray/Util.hs new file mode 100644 index 0000000..83a2e7d --- /dev/null +++ b/src/Data/Primitive/ByteArray/Util.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +module Data.Primitive.ByteArray.Util where + +import GHC.Exts (Ptr(..)) +import GHC.TypeLits +import Control.Monad.Primitive +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Data.Primitive.Addr +import Data.Primitive.Types +import Data.Primitive.ByteArray +import Data.Word +import Foreign.Ptr + +newtype Offset (n :: Nat) = Offset Int + +offset :: KnownNat n => Offset n +offset = let k = Offset $ fromIntegral $ natVal k in k + +(+.) :: Offset j -> Offset k -> Offset (j + k) +Offset j +. Offset k = Offset (j + k) + + +type family SizeOf a :: Nat + +class IsMultipleOf (n::Nat) (k::Nat) + +instance n ~ (q * k) => IsMultipleOf n k + +writeAtByte :: ( Prim a + , PrimMonad m +#if __GLASGOW_HASKELL__ >= 802 + , IsMultipleOf n (SizeOf a) +#endif + ) => MutableByteArray (PrimState m) -> Offset n -> a -> m () +writeAtByte buf (Offset offset) a = writeByteArray buf (div offset $ (sizeOf a)) a +{-# INLINE writeAtByte #-} + +readAtByte :: forall a m n. + ( Prim a + , PrimMonad m +#if __GLASGOW_HASKELL__ >= 802 + , IsMultipleOf n (SizeOf a) +#endif + ) => MutableByteArray (PrimState m) -> Offset n -> m a +readAtByte buf (Offset offset) = readByteArray buf (div offset $ (sizeOf (undefined :: a))) +{-# INLINE readAtByte #-} + +writeStringAt :: PrimMonad m => MutableByteArray s -> Int -> B.ByteString -> m (Ptr a) +writeStringAt src o bsname = do + (p,cnt) <- unsafeIOToPrim $ B.unsafeUseAsCStringLen bsname return + let nptr = ptr (mutableByteArrayContents src) `plusPtr` o + copyAddr (adr nptr) (adr p) cnt + writeOffAddr (adr nptr) cnt (0 :: Word8) + return nptr + +ptr :: Addr -> Ptr a +ptr (Addr a) = Ptr a + +adr :: Ptr a -> Addr +adr (Ptr a) = Addr a + diff --git a/src/Data/Primitive/Struct.hs b/src/Data/Primitive/Struct.hs new file mode 100644 index 0000000..154b750 --- /dev/null +++ b/src/Data/Primitive/Struct.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Primitive.Struct where + +import Control.Monad.Primitive +import Data.Primitive.ByteArray +import Data.Primitive.ByteArray.Util +import Data.Primitive.Types +import Data.Tagged +import Data.Typeable +import Foreign.Ptr +import Foreign.Storable +import GHC.TypeLits + +newtype Field tag typ n = Field (Offset n) + +data Struct m base tag = Struct + { structOffset :: !(Offset base) + , structArray :: !(MutableByteArray (PrimState m)) + } + +newStruct :: forall tag m. (KnownNat (SizeOf tag), PrimMonad m) => m (Struct m 0 tag) +newStruct = Struct (Offset 0) <$> newPinnedByteArray (fromIntegral sz) + where + sz = natVal (Proxy :: Proxy (SizeOf tag)) + +newtype Nested tag subtag n = Nested (Offset n) + +class IsStruct m p where + type BaseOffset p :: Nat + type NestedStruct m p (offset::Nat) subtag + + setField :: ( Prim a +#if __GLASGOW_HASKELL__ >= 802 + , IsMultipleOf ((BaseOffset p) + k) (SizeOf a) +#endif + ) => p tag -> Field tag a k -> a -> m () + + getField :: ( Prim a +#if __GLASGOW_HASKELL__ >= 802 + , IsMultipleOf ((BaseOffset p) + k) (SizeOf a) +#endif + ) => p tag -> Field tag a k -> m a + + nestedField :: p tag -> Field tag subtag k -> proxy m -> NestedStruct m p k subtag + +class IsField (lbl::Symbol) tag where + type FieldOffset lbl tag :: Nat + type FieldType lbl tag + field :: p tag -> Field tag (FieldType lbl tag) (FieldOffset lbl tag) + +set :: forall lbl tag m p. (IsField lbl tag, IsStruct m p, Prim (FieldType lbl tag), +#if __GLASGOW_HASKELL__ >= 802 + IsMultipleOf (BaseOffset p + FieldOffset lbl tag) (SizeOf (FieldType lbl tag)) +#endif + ) => + p tag -> FieldType lbl tag -> m () +set p a = setField p (field @lbl p) a +{-# INLINE set #-} + +get :: forall lbl tag m p. (IsField lbl tag, IsStruct m p, Prim (FieldType lbl tag), +#if __GLASGOW_HASKELL__ >= 802 + IsMultipleOf (BaseOffset p + FieldOffset lbl tag) (SizeOf (FieldType lbl tag)) +#endif + ) => + p tag -> m (FieldType lbl tag) +get p = getField p (field @lbl p) +{-# INLINE get #-} + + +modify :: forall lbl tag m p. + ( Monad m + , IsField lbl tag + , IsStruct m p + , Prim (FieldType lbl tag) +#if __GLASGOW_HASKELL__ >= 802 + , IsMultipleOf (BaseOffset p + FieldOffset lbl tag) (SizeOf (FieldType lbl tag)) +#endif + ) => p tag -> (FieldType lbl tag -> FieldType lbl tag) -> m () +modify p f = get @lbl p >>= set @lbl p . f + +nested :: forall lbl m p tag. (IsField lbl tag, IsStruct m p) => + p tag + -> NestedStruct m p (FieldOffset lbl tag) (FieldType lbl tag) +nested p = nestedField p (field @lbl p) (Proxy @m) + +instance PrimMonad m => IsStruct m (Struct m base) where + type BaseOffset (Struct m base) = base + type NestedStruct m (Struct m base) j t = Struct m (base + j) t + setField (Struct o c) (Field field) value = writeAtByte c (o +. field) value + getField (Struct o c) (Field field) = readAtByte c (o +. field) + nestedField (Struct base ary) (Field offset) _ = Struct (base +. offset) ary + +instance IsStruct IO Ptr where + type BaseOffset Ptr = 0 + type NestedStruct IO Ptr j t = Ptr t + setField ptr (Field (Offset o)) value = poke (ptr `plusPtr` o) $ PrimStorable value + getField ptr (Field (Offset o)) = getPrimStorable <$> peek (ptr `plusPtr` o) + nestedField ptr (Field (Offset offset)) _ = castPtr (plusPtr ptr offset) + +withPointer :: Struct IO base tag -> (Ptr tag -> IO x) -> IO x +withPointer (Struct (Offset off) ary) f = do + x <- f (ptr (mutableByteArrayContents ary) `plusPtr` off) + seq ary $ return x diff --git a/src/Text/XXD.hs b/src/Text/XXD.hs new file mode 100644 index 0000000..77606bf --- /dev/null +++ b/src/Text/XXD.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Text.XXD (xxd, xxd2) where + +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteArray as BA +import Data.Word +import Data.Bits +import Data.Char +import Text.Printf + +nibble :: Word8 -> Char +nibble b = intToDigit (fromIntegral (b .&. 0x0F)) + +nibbles :: ByteArrayAccess ba => ba -> String +nibbles xs = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte]) + $ BA.unpack xs + +xxd0 :: (ByteArrayAccess ba) => (forall b. ByteArrayAccess b => b -> String) -> Int -> ba -> [String] +xxd0 tr offset bs | BA.null bs = [] +xxd0 tr offset bs = printf "%03x: %s%s" offset (nibbles xs) (tr xs) + : xxd0 tr (offset + BA.length xs) bs' + where + (xs,bs') = splitAtView 16 bs + +splitAtView :: (ByteArrayAccess ba) => Int -> ba -> (BA.View ba, BA.View ba) +splitAtView n bs = (BA.takeView bs n, BA.dropView bs n) + +xxd :: ByteArrayAccess a => Int -> a -> [String] +xxd = xxd0 (const "") + +-- | like xxd, but also shows ascii +xxd2 :: ByteArrayAccess a => Int -> a -> [String] +xxd2 = xxd0 withAscii + +withAscii :: ByteArrayAccess a => a -> [Char] +withAscii row = replicate (50 - 3 * BA.length row) ' ' ++ myunpack row + where + myunpack s = map word8tochar (BA.unpack s) + where word8tochar w | (w .&. 0x80 /= 0) = '.' + word8tochar w = let c = chr (fromIntegral w) + in if isPrint c then c else '.' + +{- +main = do + bs <- B.getContents + mapM_ putStrLn $ xxd2 0 bs + -} -- cgit v1.2.3