Initial commit.

4 files changed, 301 insertions, 0 deletions

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
+    -}