packed-data 0.1.0.3 → 0.2.0.0
raw patch · 36 files changed
+865/−360 lines, 36 filesdep +linear-base
Dependencies added: linear-base
Files
- Changelog.md +13/−0
- README.md +14/−3
- benchmark/tree/AST.hs +6/−5
- benchmark/tree/Build.hs +5/−4
- benchmark/tree/Increment.hs +13/−14
- benchmark/tree/List.hs +1/−5
- benchmark/tree/Sum.hs +13/−3
- benchmark/tree/Traversals.hs +4/−4
- examples/Increment.hs +9/−7
- examples/Pack.hs +4/−8
- examples/Traversal.hs +18/−8
- examples/Unpack.hs +1/−1
- packed-data.cabal +30/−12
- src/Data/Packed.hs +68/−5
- src/Data/Packed/FieldSize.hs +67/−24
- src/Data/Packed/Instances.hs +0/−16
- src/Data/Packed/Internal.hs +22/−0
- src/Data/Packed/Needs.hs +165/−32
- src/Data/Packed/Packable.hs +6/−7
- src/Data/Packed/Packed.hs +0/−11
- src/Data/Packed/Reader.hs +138/−76
- src/Data/Packed/Skippable.hs +2/−2
- src/Data/Packed/TH.hs +7/−1
- src/Data/Packed/TH/Case.hs +26/−35
- src/Data/Packed/TH/PackCon.hs +6/−6
- src/Data/Packed/TH/Pattern.hs +132/−0
- src/Data/Packed/TH/RepackCon.hs +11/−9
- src/Data/Packed/TH/Start.hs +3/−5
- src/Data/Packed/TH/Transform.hs +31/−21
- src/Data/Packed/TH/Write.hs +1/−1
- src/Data/Packed/TH/WriteCon.hs +7/−6
- src/Data/Packed/Unpackable.hs +22/−14
- src/Tree.hs +0/−9
- test/PackedTest/CaseTest.hs +1/−1
- test/PackedTest/IdentityTest.hs +17/−3
- test/PackedTest/PackTest.hs +2/−2
+ Changelog.md view
@@ -0,0 +1,13 @@+[0.2.0.0] — July 2025 ++* __Breaking Changes__:+ * Complete rewrite of the 'NeedsBuilder'+ * Please refer to the examples to see how to build packed data+ * Dropping support for GHC < 9.10. + * 'NeedsBuilder' relies on linear types and type inference is broken before that version++* Features:+ * 'PackedReader' has been rewritten, however the API should be retro-compatible+ * The code generator defines pattern synonyms, allowing one to pattern-match on packed data using a native 'case' expression+ * Refer to the examples (e.g. Sum) to see how it works+ * The generated 'case' functions are still generated, but they use these pattern synonyms under the hood
README.md view
@@ -25,6 +25,7 @@ ```haskell import qualified Data.Packed.Reader as R+import Data.Packed.Reader import Data.Packed data Tree a = Leaf a | Node (Tree a) (Tree a)@@ -32,6 +33,7 @@ $(mkPacked ''Tree '[]) -- Compute sum of values in the tree+-- Using the generated 'caseTree' function sumPacked :: PackedReader '[Tree Int] r Int sumPacked = caseTree -- Generated by Template Haskell@@ -45,7 +47,16 @@ let !res = left + right R.return res )+-- Alternatively, you can use generated pattern synonyms+sumPacked = PackedReader $ \case+ PackedLeaf l -> reader `with` l+ PackedNode n -> threadedWith n $ R.do+ !left <- sumPacked2+ !right <- sumPacked2+ let !res = left + right+ R.return res + getSum :: Packed '[Tree Int] -> IO Int getSum = runReader sumPacked @@ -62,10 +73,10 @@ To run benchmarks, run the following command: ```-stack bench+stack bench packed-data:bench:tree-bench # Saves the report as CSV-stack bench --ba --csv bench.csv+stack bench packed-data:bench:tree-bench --ba --csv bench.csv # Saves the report, and runs a specific test-stach bench --ba '--csv bench.csv sums'+stach bench packed-data:bench:tree-bench --ba '--csv bench.csv sums' ```
benchmark/tree/AST.hs view
@@ -37,7 +37,7 @@ (depthGroupName n) [ envWithCleanup (c_build_ast $ fromIntegral n) c_free_ast $ bench cTestName . nfAppIO c_eval , bench nativeTestName $ nf eval nativeAST- , bench packedTestName $ nfAppIO (runReader evalPacked) packedAST+ , bench packedTestName $ nf (runReader evalPacked) packedAST , bench packedWithUnpackTestName $ whnf (eval . fst . unpack) packedAST , bench nonMonadicPackedTestName $ nfAppIO evalPackedNonMonadic packedAST ]@@ -54,7 +54,7 @@ evalPacked :: PackedReader '[AST] r Int32 evalPacked = caseAST- reader+ (reader R.>>= \(!n) -> R.return n) (opLambda (+)) (opLambda (-)) (opLambda (*))@@ -64,9 +64,10 @@ (Int32 -> Int32 -> Int32) -> PackedReader '[AST, AST] r Int32 opLambda f = R.do- left <- evalPacked- right <- evalPacked- R.return (f left right)+ !left <- evalPacked+ !right <- evalPacked+ let !res = f left right+ R.return res evalPackedNonMonadic :: Packed (AST ': r) -> IO Int32 evalPackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)
benchmark/tree/Build.hs view
@@ -30,7 +30,7 @@ bgroup (depthGroupName n) [ bench nativeTestName $ nf buildNativeTree n- , bench packedTestName $ nf (\p -> finish (buildPackedTree p)) n+ , bench packedTestName $ nf (runBuilder . buildPackedTree) n ] buildNativeTree :: Int -> Tree1 Int@@ -39,8 +39,9 @@ where !subTree = buildNativeTree (n - 1) -buildPackedTree :: Int -> Needs '[] '[Tree1 Int]-buildPackedTree 0 = withEmptyNeeds (writeConLeaf1 (1 :: Int))-buildPackedTree n = withEmptyNeeds (startNode1 N.>> applyNeeds subTree N.>> applyNeeds subTree)+buildPackedTree :: Int -> NeedsBuilder (Tree1 Int ': r) '[Tree1 Int] r '[Tree1 Int]+buildPackedTree 0 = writeConLeaf1 (1 :: Int)+buildPackedTree n = \needs -> startNode1 needs N.>>= subTree N.>>= subTree where+ subTree :: NeedsBuilder (Tree1 Int ': r1) '[Tree1 Int] r1 '[Tree1 Int] !subTree = buildPackedTree (n - 1)
benchmark/tree/Increment.hs view
@@ -9,7 +9,6 @@ import Criterion.Main import Data.List (intercalate) import Data.Packed-import Data.Packed.Needs (applyNeeds) import qualified Data.Packed.Needs as N import qualified Data.Packed.Reader as R import Data.Void@@ -50,11 +49,11 @@ , bench nativeTestName $ nf increment nativeTree , bench (intercalate "-" [packedTestName, "needsbuilder"]) $- nfAppIO incrementPackedRunner packedTree+ nf incrementPackedRunner packedTree , bench (intercalate "-" ["unpack", "repack"]) $ nf (pack . increment . fst . unpack) packedTree , bench (intercalate "-" [packedTestName, "rebuild-repack"]) $- nfAppIO repackingIncrementPackedRunner packedTree+ nf repackingIncrementPackedRunner packedTree ] where !packedTree = pack nativeTree@@ -68,12 +67,10 @@ !res2 = increment t2 -- Produces an needsbuilder for a tree alread incremented, and finishes it-incrementPackedRunner :: Packed '[Tree1 Int] -> IO (Packed '[Tree1 Int])-incrementPackedRunner packed = do- (!needs, _) <- runReader incrementPacked packed- return $ finish needs+incrementPackedRunner :: Packed '[Tree1 Int] -> Packed '[Tree1 Int]+incrementPackedRunner packed = runBuilder . fst $ runReader incrementPacked packed -incrementPacked :: PackedReader '[Tree1 Int] r (Needs '[] '[Tree1 Int])+incrementPacked :: PackedReader '[Tree1 Int] r (N.NeedsBuilder (Tree1 Int ': r1) '[Tree1 Int] r1 '[Tree1 Int]) incrementPacked = transformTree1 ( R.do@@ -83,7 +80,7 @@ ( R.do left <- incrementPacked right <- incrementPacked- R.return (applyNeeds left N.>> applyNeeds right)+ R.return (left N.>=> right) ) buildNativeTree :: Int -> Tree1 Int@@ -93,11 +90,13 @@ !subTree = buildNativeTree (n - 1) -- Produces an unpacked tree alread incremented, and packs it-repackingIncrementPackedRunner :: Packed '[Tree1 Int] -> IO (Packed '[Tree1 Int])-repackingIncrementPackedRunner packed = do- (!tree, _) <- runReader repackingIncrementPacked packed- let !repacked = pack tree- return repacked+repackingIncrementPackedRunner :: Packed '[Tree1 Int] -> Packed '[Tree1 Int]+repackingIncrementPackedRunner packed =+ let+ (!tree, _) = runReader repackingIncrementPacked packed+ !repacked = pack tree+ in+ repacked repackingIncrementPacked :: PackedReader '[Tree1 Int] r (Tree1 Int) repackingIncrementPacked =
benchmark/tree/List.hs view
@@ -5,13 +5,9 @@ import Control.DeepSeq import Criterion.Main-import qualified Data.ByteString.Internal as BS import Data.Packed-import Data.Packed.Needs (Needs (Needs))-import qualified Data.Packed.Needs as N import qualified Data.Packed.Reader as R import Foreign-import Utils import Prelude hiding (sum) data Tree1 a = Leaf1 | Node1 (Tree1 a) a (Tree1 a)@@ -23,7 +19,7 @@ $(mkPacked ''Tree1 [InsertFieldSize]) benchmark :: [Int] -> Benchmark-benchmark depths =+benchmark _ = bgroup "list" []
benchmark/tree/Sum.hs view
@@ -1,5 +1,15 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CApiFFI #-}+{-# LANGUAGE ExtendedLiterals #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}+{-# LANGUAGE ViewPatterns #-} module Sum (benchmark) where @@ -8,7 +18,7 @@ import Data.Packed import qualified Data.Packed.Reader as R import Data.Void (Void)-import Foreign+import Foreign hiding (with) import Foreign.C import Foreign.ForeignPtr.Unsafe import GHC.IO@@ -39,9 +49,9 @@ (depthGroupName n) [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $ bench cTestName . nfAppIO c_sum , bench nativeTestName $ nf sum nativeTree- , bench packedTestName $ whnfAppIO (R.runReader sumPacked) packedTree+ , bench packedTestName $ whnf (R.runReader sumPacked) packedTree , bench packedWithUnpackTestName $ whnf (sum . fst . unpack) packedTree- , bench packedWithFieldSizeTestName $ whnfAppIO (R.runReader sumPacked2) packedTree2+ , bench packedWithFieldSizeTestName $ whnf (R.runReader sumPacked2) packedTree2 , bench nonMonadicPackedTestName $ nfAppIO sumPackedNonMonadic packedTree , bench nonMonadicPackedWithSizeTestName $ nfAppIO sumPackedNonMonadic2 packedTree2 ]
benchmark/tree/Traversals.hs view
@@ -43,11 +43,11 @@ (depthGroupName n) [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $ bench cTestName . nfAppIO c_get_right_most , bench nativeTestName $ nf getRightMostNodeNative nativeTree- , bench packedTestName $ nfAppIO (runReader getRightMostNodePacked) packedTree+ , bench packedTestName $ nf (runReader getRightMostNodePacked) packedTree , bench packedWithUnpackTestName $ whnf (getRightMostNodeNative . fst . unpack) packedTree , bench nonMonadicPackedTestName $ nfAppIO getRightMostNodePackedNonMonadic packedTree , bench packedWithFieldSizeTestName $- nfAppIO (runReader getRightMostNodePacked2) packedTreeWithSize+ nf (runReader getRightMostNodePacked2) packedTreeWithSize , bench nonMonadicPackedWithSizeTestName $ nfAppIO getRightMostNodePacked2NonMonadic packedTreeWithSize ] where@@ -128,10 +128,10 @@ bgroup (depthGroupName n) [ bench nativeTestName $ nf (containsNative value) nativeTree- , bench packedTestName $ nfAppIO (runReader (containsPacked value)) packedTree+ , bench packedTestName $ nf (runReader (containsPacked value)) packedTree , bench nonMonadicPackedTestName $ nfAppIO (containsNonMonadic value) packedTree , bench packedWithFieldSizeTestName $- nfAppIO (runReader (containsPacked2 value)) packedTreeWithSize+ nf (runReader (containsPacked2 value)) packedTreeWithSize , bench nonMonadicPackedWithSizeTestName $ nfAppIO (containsNonMonadic2 value) packedTreeWithSize ] where
examples/Increment.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+ -- | Showcase how to 'mutate' packed data module Increment (incrementRunner) where @@ -9,13 +13,11 @@ $(mkPacked ''Tree []) -incrementRunner :: Packed '[Tree Int] -> IO (Packed '[Tree Int])-incrementRunner p = do- (incremented, _) <- runReader incrementPacked p- return $ finish incremented+incrementRunner :: Packed '[Tree Int] -> Packed '[Tree Int]+incrementRunner p = runBuilder . fst $ runReader incrementPacked p --- The workhouse of the incrementation-incrementPacked :: PackedReader '[Tree Int] r (Needs '[] '[Tree Int])+-- -- The workhouse of the incrementation+incrementPacked :: PackedReader '[Tree Int] r (NeedsBuilder (Tree Int ': r1) '[Tree Int] r1 '[Tree Int]) incrementPacked = transformTree ( R.do@@ -25,5 +27,5 @@ ( R.do left <- incrementPacked right <- incrementPacked- R.return (applyNeeds left N.>> applyNeeds right)+ R.return (\needs -> left needs N.>>= right) )
examples/Pack.hs view
@@ -10,13 +10,9 @@ myTree :: Tree Int myTree = Node (Leaf 1) (Leaf 2) -packedTree :: Packed '[Tree Int]-packedTree = pack myTree- buildTree :: Packed '[Tree Int] buildTree =- finish $- withEmptyNeeds $ N.do- startNode- startLeaf N.>> write (1 :: Int)- startLeaf N.>> write 2+ runBuilder $ \needs -> N.do+ node <- startNode needs+ leaf1 <- startLeaf node N.>>= write (1 :: Int)+ startLeaf leaf1 N.>>= write 2
examples/Traversal.hs view
@@ -3,6 +3,7 @@ module Traversal () where import Data.Packed+import Data.Packed.Reader import qualified Data.Packed.Reader as R import Tree @@ -14,21 +15,30 @@ packedTree :: Packed '[Tree Int] packedTree = pack myTree -sumPacked :: PackedReader '[Tree Int] r Int-sumPacked =+-- The two following functions do the same thing++sumPacked1 :: PackedReader '[Tree Int] r Int+sumPacked1 = caseTree ( R.do !n <- reader R.return n ) ( R.do- !left <- sumPacked- !right <- sumPacked+ !left <- sumPacked1+ !right <- sumPacked1 let !res = left + right R.return res ) -runSum :: IO Int-runSum = do- (res, _) <- runReader sumPacked packedTree- return res+sumPacked2 :: PackedReader '[Tree Int] r Int+sumPacked2 = PackedReader $ \case+ PackedLeaf l -> reader `with` l+ PackedNode n -> threadedWith n $ R.do+ !left <- sumPacked2+ !right <- sumPacked2+ let !res = left + right+ R.return res++runSum :: Int+runSum = fst $ runReader sumPacked1 packedTree
examples/Unpack.hs view
@@ -12,4 +12,4 @@ packedTree = pack myTree unpackedTree :: Tree Int-unpackedTree = fst $ unpack packedTree+unpackedTree = fst . unpack $ packedTree
packed-data.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: packed-data-version: 0.1.0.3+version: 0.2.0.0 description: Build, traverse and deserialise packed data in Haskell category: Data homepage: https://github.com/Arthi-chaud/packed-haskell#readme@@ -17,14 +17,11 @@ license-file: LICENSE build-type: Simple tested-with:- GHC ==9.2.8- , GHC ==9.4.8- , GHC ==9.6.6- , GHC ==9.8.4- , GHC ==9.10.1+ GHC ==9.10.1 , GHC ==9.12.1 extra-source-files: README.md+ Changelog.md source-repository head type: git@@ -35,18 +32,19 @@ Data.Packed Data.Packed.Reader Data.Packed.Needs- Data.Packed.Instances Data.Packed.TH Data.Packed.TH.Utils Data.Packed.Skippable- other-modules: Data.Packed.FieldSize+ other-modules:+ Data.Packed.Internal Data.Packed.Packable Data.Packed.Packed Data.Packed.TH.Case Data.Packed.TH.Flag Data.Packed.TH.Packable Data.Packed.TH.PackCon+ Data.Packed.TH.Pattern Data.Packed.TH.Read Data.Packed.TH.RepackCon Data.Packed.TH.Skip@@ -58,7 +56,6 @@ Data.Packed.TH.WriteCon Data.Packed.Unpackable Data.Packed.Utils- Tree Paths_packed_data autogen-modules: Paths_packed_data@@ -74,13 +71,16 @@ TemplateHaskellQuotes TupleSections QualifiedDo+ ViewPatterns+ PatternSynonyms+ UnboxedTuples ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 , bytestring >=0.11.0.0 && <0.13- , bytestring-strict-builder >=0.4.5 && <0.5 , deepseq >=1.4.6.1 && <1.6 , extra >=1.0 && <2.0+ , linear-base >=0.4.0 && <0.5.0 , mtl >=2.2.2 && <2.4 , template-haskell >=2.18.0.0 && <=2.24.0.0 default-language: Haskell2010@@ -108,7 +108,10 @@ TemplateHaskellQuotes TupleSections QualifiedDo- ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -Wno-unused-top-binds+ ViewPatterns+ PatternSynonyms+ UnboxedTuples+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -Wno-unused-top-binds -Wno-orphans build-depends: base >=4.7 && <5 , packed-data@@ -138,6 +141,9 @@ TemplateHaskellQuotes TupleSections QualifiedDo+ ViewPatterns+ PatternSynonyms+ UnboxedTuples ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints build-depends: base >=4.7 && <5@@ -166,6 +172,9 @@ TemplateHaskellQuotes TupleSections QualifiedDo+ ViewPatterns+ PatternSynonyms+ UnboxedTuples ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints build-depends: base >=4.7 && <5@@ -194,6 +203,9 @@ TemplateHaskellQuotes TupleSections QualifiedDo+ ViewPatterns+ PatternSynonyms+ UnboxedTuples ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints build-depends: aeson@@ -227,6 +239,9 @@ TemplateHaskellQuotes TupleSections QualifiedDo+ ViewPatterns+ PatternSynonyms+ UnboxedTuples ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints build-depends: base >=4.7 && <5@@ -266,6 +281,9 @@ TemplateHaskellQuotes TupleSections QualifiedDo+ ViewPatterns+ PatternSynonyms+ UnboxedTuples ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints cc-options: -O2 include-dirs:
src/Data/Packed.hs view
@@ -1,3 +1,70 @@+-- |+--+-- Packed data is data serialised into a binary format that is usable as-is, meaning there is no need to parse it to be able to use it. Another perk of such format is that it can be stored in files easily.+--+-- `packed-data` allows using packed data type-safely, without explicit pointer arithmetic.+--+-- Check out examples here: https://github.com/Arthi-chaud/packed-data/tree/main/examples+--+-- Example of a tree traversal:+--+-- @+-- {-# LANGUAGE DataKinds #-}+-- {-# LANGUAGE TypeOperators #-}+-- {-# LANGUAGE KindSignatures #-}+-- {-# LANGUAGE LambdaCase #-}+-- {-# LANGUAGE GADTs #-}+-- {-# LANGUAGE LambdaCase #-}+-- {-# LANGUAGE TemplateHaskell #-}+-- {-# LANGUAGE TemplateHaskellQuotes #-}+-- {-# LANGUAGE TupleSections #-}+-- {-# LANGUAGE QualifiedDo #-}+-- {-# LANGUAGE ViewPatterns #-}+-- {-# LANGUAGE PatternSynonyms #-}+-- {-# LANGUAGE UnboxedTuples #-}+--+-- import Data.Packed+-- import Data.Packed.Reader+-- import qualified Data.Packed.Reader as R+--+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- \$('Data.Packed.mkPacked' ''Tree [])+--+-- myTree :: Tree Int+-- myTree = Node (Leaf 1) (Leaf 2)+--+-- packedTree :: 'Data.Packed.Packed' '[Tree Int]+-- packedTree = 'pack' myTree+--+-- -- The two following functions do th same thing+--+-- sumPacked1 :: 'Data.Packed.Reader.PackedReader' '[Tree Int] r Int+-- sumPacked1 =+-- caseTree -- Generated+-- ( R.do+-- !n <- 'reader'+-- R.'Data.Packed.Reader.return' n+-- )+-- ( R.do+-- !left <- sumPacked1+-- !right <- sumPacked1+-- let !res = left + right+-- R.'Data.Packed.Reader.return' res+-- )+--+-- -- The patterns 'PackedLead' and 'PackedNode' are generated+-- sumPacked2 :: 'Data.Packed.Reader.PackedReader' '[Tree Int] r Int+-- sumPacked2 = 'Data.Packed.Reader.mkPackedReader' $ \case+-- PackedLeaf l -> 'reader' `Data.Packed.Reader.with` l+-- PackedNode n -> 'Data.Packed.Reader.threadedWith' n $ R.do+-- !left <- sumPacked2+-- !right <- sumPacked2+-- let !res = left + right+-- R.'return' res+--+-- runSum :: Int+-- runSum = fst $ 'Data.Packed.Reader.runReader' sumPacked1 packedTree+-- @ module Data.Packed ( -- * Classes Packable (..),@@ -9,9 +76,8 @@ -- * Needs Needs,- withEmptyNeeds,+ runBuilder, writeWithFieldSize,- finish, unsafeCastNeeds, -- * Packed@@ -20,9 +86,7 @@ isolate, fromPacked, unsafeToPacked,- unsafeToPacked', unsafeCastPacked,- getPtr, -- * PackedReader PackedReader,@@ -41,7 +105,6 @@ ) where import Data.Packed.FieldSize-import Data.Packed.Instances () import Data.Packed.Needs import Data.Packed.Packable import Data.Packed.Packed
src/Data/Packed/FieldSize.hs view
@@ -1,4 +1,10 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UnboxedTuples #-} module Data.Packed.FieldSize ( FieldSize (..),@@ -10,12 +16,11 @@ applyNeedsWithFieldSize, ) where -import ByteString.StrictBuilder (builderLength)-import Control.Monad+import qualified Control.Functor.Linear as L+import Control.Monad.Identity (Identity (Identity)) import qualified Data.ByteString as BS-import Data.Int (Int32)+import Data.Packed.Internal import Data.Packed.Needs-import qualified Data.Packed.Needs as N import Data.Packed.Packable import Data.Packed.Packed import Data.Packed.Reader hiding (return)@@ -24,21 +29,29 @@ import Data.Packed.Unpackable import Foreign.Ptr import Foreign.Storable+import GHC.Exts+import GHC.Int+import qualified System.IO.Linear as L+import Unsafe.Linear import Prelude hiding (read) -- | Type representation for the size of a packed data. -- The size is in bytes. -- -- __Note__: Take a look at the 'Data.Packed.TH.PackingFlag's to understand how to use it-newtype FieldSize = FieldSize Int32+newtype FieldSize = FieldSize Int32 deriving (Num, Enum, Real, Ord, Eq) +deriving instance Integral FieldSize+ instance {-# OVERLAPPING #-} Packable FieldSize where- write (FieldSize value) = mkNeedsBuilder unsafeCastNeeds N.>> write value+ write (FieldSize value) needs = write value (unsafeCastNeeds needs) instance {-# OVERLAPPING #-} Unpackable FieldSize where- reader = mkPackedReader $ \packed l -> do- (fieldSize, rest, l1) <- runPackedReader reader packed l- return (FieldSize fieldSize, rest, l1)+ reader = mkPackedReader $ \pf ->+ let+ Identity !(!fieldSize, !pf1) = runReaderStep reader (castPackedFragment pf)+ in+ return (FieldSize fieldSize, pf1) instance {-# OVERLAPPING #-} Skippable FieldSize where skip = unsafeSkipN (sizeOf (1 :: Int32))@@ -55,10 +68,12 @@ -- | Allows skipping over a field without having to unpack it skipWithFieldSize :: PackedReader '[FieldSize, a] r ()-skipWithFieldSize = mkPackedReader $ \packed l -> do- (FieldSize s, packed1, l1) <- runPackedReader reader packed l- let size64 = fromIntegral s- return ((), packed1 `plusPtr` size64, l1 - size64)+skipWithFieldSize = mkPackedReader $ \pf ->+ let+ Identity !(FieldSize s, PF packed1 l1) = runReaderStep reader pf+ !size64 = fromIntegral s+ in+ return ((), PF (packed1 `plusPtr` size64) (l1 - size64)) {-# INLINE writeWithFieldSize #-} @@ -66,15 +81,41 @@ -- -- Note: Universal quantifier is nedded for GHC < 9.10, because of ScopedTypeVariables writeWithFieldSize :: forall a r t. (Packable a) => a -> NeedsWriter' '[FieldSize, a] r t-writeWithFieldSize a = write (FieldSize size) N.>> applyNeeds aNeeds- where- size = fromIntegral (builderLength aBuilder)- aNeeds :: Needs '[] '[a]- aNeeds@(Needs aBuilder) = withEmptyNeeds (write a)+writeWithFieldSize a = withFieldSize (write a) +{-# INLINE withFieldSize #-}+withFieldSize :: NeedsBuilder (a ': r) t r t -> NeedsBuilder (FieldSize ': a ': r) t r t+withFieldSize cont needs = L.do+ let !indirectionSize = sizeOf (0 :: Int32)+ -- Reallocating the buffer so that the fieldsize can fit+ !newNeeds <- guardRealloc indirectionSize needs+ -- Get the position of the buffer where the FS will be+ let !(# fieldSizeOffset, newNeeds1 #) = getOffset newNeeds+ -- Shift the cursor+ !writtenNeeds <- cont (unsafeShiftNeedsPtr indirectionSize newNeeds1)+ -- Get the final position of the cursor+ let !(# finalCursor, writtenNeeds1 #) = getOffset writtenNeeds+ !(# og, writtenNeeds2 #) = getOrigin writtenNeeds1+ () <-+ toLinear3+ ( \finalCursor' fsPosition og' fsSize ->+ let+ -- Count the number of bytes that were written+ !writtenBytes = intToInt32# (finalCursor' -# (fsPosition +# unInt fsSize))+ in+ -- And write it++ L.fromSystemIO (poke (Ptr $ og' `plusAddr#` fsPosition) (I32# writtenBytes))+ )+ finalCursor+ fieldSizeOffset+ og+ indirectionSize+ L.return writtenNeeds2+ {-# INLINE applyNeedsWithFieldSize #-} applyNeedsWithFieldSize :: Needs '[] '[a] -> NeedsWriter' (FieldSize ': a ': '[]) r t-applyNeedsWithFieldSize n@(Needs builder) = write (FieldSize (fromIntegral (builderLength builder))) N.>> applyNeeds n+applyNeedsWithFieldSize n = withFieldSize (applyNeeds n) {-# INLINE readerWithFieldSize #-} @@ -85,8 +126,10 @@ {-# INLINE isolate #-} -- | Splits the 'Packed' value, and isolate the first encoded value.-isolate :: PackedReader '[FieldSize, a] r (Packed '[a])-isolate = mkPackedReader $ \packed l -> do- (FieldSize s, packed1, l1) <- runPackedReader reader packed l- let sizeInt = fromIntegral s- return (unsafeToPacked' packed1 sizeInt, packed1 `plusPtr` sizeInt, l1 - sizeInt)+isolate :: PackedReader '[FieldSize, a] r (PackedFragment '[a])+isolate = mkPackedReader $ \pf ->+ let+ Identity !(FieldSize s, PF packed1 l1) = runReaderStep reader pf+ !sizeInt = fromIntegral s+ in+ return (PF packed1 sizeInt, PF (packed1 `plusPtr` sizeInt) (l1 - sizeInt))
− src/Data/Packed/Instances.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-missing-export-lists #-}-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}---- | This module provides instances of 'Data.Packed.Packable' and 'Data.Packed.Unpackable' for basic types like 'Prelude.List' and 'Prelude.Maybe'-module Data.Packed.Instances where--import Data.Packed.TH-import Data.Packed.Unpackable-import Prelude hiding (readList)--$(mkPacked ''[] [])-$(mkPacked ''Maybe [])-$(mkPacked ''Either [])
+ src/Data/Packed/Internal.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}++module Data.Packed.Internal where++import GHC.Base+import GHC.Exts++{-# INLINE unPtr #-}+unPtr :: Ptr a %1 -> Addr#+unPtr (Ptr a) = a++{-# INLINE unInt #-}+unInt :: Int %1 -> Int#+unInt (I# i) = i++{-# INLINE unsafeDupablePerformIO #-}+unsafeDupablePerformIO :: IO a -> a+unsafeDupablePerformIO (IO m) = case runRW# m of (# _, !a #) -> a
src/Data/Packed/Needs.hs view
@@ -1,45 +1,90 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-} module Data.Packed.Needs ( -- * Type Needs (..),- withEmptyNeeds,- finish, -- * Builders- NeedsBuilder (..),+ NeedsBuilder,+ runBuilder,+ (>>=),+ (>=>), NeedsWriter, NeedsWriter',- (>>),- mkNeedsBuilder,- withNeeds, -- * Mixing Needs together concatNeeds, applyNeeds, -- * Internal+ getCursor,+ getOffset,+ getOrigin,+ writeStorable,++ -- * Dangerous+ unsafeWriteTag, unsafeCastNeeds,- (:++:),+ guardRealloc,+ unsafeShiftNeedsPtr, ) where -import ByteString.StrictBuilder+import qualified Control.Functor.Linear as L+import Data.ByteString.Internal+import Data.Int import Data.Kind+import qualified Data.Num.Linear as L+import qualified Data.Ord.Linear as L+import Data.Packed.Internal import Data.Packed.Packed-import Data.Packed.Utils-import Prelude hiding ((>>))+import Data.Packed.Utils ((:++:))+import Data.Unrestricted.Linear+import Foreign (Storable (..))+import GHC.Exts+import GHC.ForeignPtr+import GHC.IO (IO (..))+import qualified System.IO.Linear as L+import Unsafe.Linear+import Prelude hiding ((>>=)) -- | A buffer where packed values can be written -- The order to write these values is defined by the 'l' type list -- -- If 'p' is an empty list, then a value of type 't' can be extracted from that buffer.--- (See 'finish')-newtype Needs (p :: [Type]) (t :: [Type]) = Needs Builder+-- (See the signature of 'runReader')+data Needs (p :: [Type]) (t :: [Type])+ = Needs+ {-# UNPACK #-} !(MutableByteArray# RealWorld)+ {-# UNPACK #-} !Addr#+ {-# UNPACK #-} !Int -unsafeCastNeeds :: Needs a b -> Needs c d-unsafeCastNeeds (Needs b) = Needs b+{-# INLINE getCursor #-}+getCursor :: Needs a b %1 -> (# Addr#, Needs a b #)+getCursor = toLinear (\n@(Needs _ cursor _) -> (# cursor, n #)) +{-# INLINE getOffset #-}+getOffset :: Needs a b %1 -> (# Int#, Needs a b #)+getOffset = toLinear (\n@(Needs origin cursor _) -> (# cursor `minusAddr#` mutableByteArrayContents# origin, n #))++{-# INLINE getOrigin #-}+getOrigin :: Needs a b %1 -> (# Addr#, Needs a b #)+getOrigin = toLinear (\n@(Needs origin _ _) -> (# mutableByteArrayContents# origin, n #))++{-# INLINE getSpaceLeft #-}+getSpaceLeft :: Needs a b %1 -> (# Int, Needs a b #)+getSpaceLeft = toLinear (\n@(Needs _ _ spaceLeft) -> (# spaceLeft, n #))++-- | Casts a 'Data.Packed.Needs'+{-# INLINE unsafeCastNeeds #-}+unsafeCastNeeds :: Needs a b %1 -> Needs c d+unsafeCastNeeds (Needs a b c) = Needs a b c++--- Needs Builder+ -- | A wrapper around a function that builds a 'Needs' -- -- 'ps': The type of the expected input of the source 'Needs'@@ -51,34 +96,122 @@ -- 'td': The type of the final packed data of the resulting 'Needs' -- -- __Note:__ It is an indexed monad.-newtype NeedsBuilder ps ts pd td = NeedsBuilder- { runBuilder :: Needs ps ts -> Needs pd td- }+type NeedsBuilder p1 t1 p2 t2 = Needs p1 t1 %1 -> L.IO (Needs p2 t2) -(>>) :: NeedsBuilder p1 t1 p2 t2 -> NeedsBuilder p2 t2 p3 t3 -> NeedsBuilder p1 t1 p3 t3-(NeedsBuilder !b1) >> (NeedsBuilder !b2) = mkNeedsBuilder (\n -> b2 (b1 n))+-- | Similar to 'Prelude.>>='+{-# INLINE (>>=) #-}+(>>=) :: L.IO (Needs p1 t1) %1 -> (Needs p1 t1 %1 -> L.IO (Needs p2 t2)) -> L.IO (Needs p2 t2)+(>>=) a b = L.do+ !x <- a+ !x1 <- b x+ L.return x1 +-- | Similar to 'Control.Monad.>=>'+{-# INLINE (>=>) #-}+(>=>) :: (a %1 -> L.IO t) %1 -> (t %1 -> L.IO b) -> a %1 -> L.IO b+(>=>) a b !c = L.do+ !x <- a c+ !x1 <- b x+ L.return x1+ -- | Shortcut type for 'NeedsBuilder'\'s that simply write a value to a 'Needs' without changing the final packed type type NeedsWriter a r t = NeedsBuilder (a ': r) t r t -- | Shortcut type for 'NeedsBuilder'\'s that simply write multiple values to a 'Needs' without changing the final packed type type NeedsWriter' a r t = NeedsBuilder (a :++: r) t r t -mkNeedsBuilder :: (Needs ps ts -> Needs pd td) -> NeedsBuilder ps ts pd td-mkNeedsBuilder = NeedsBuilder+baseBufferSize :: Int+baseBufferSize = 1000 -withEmptyNeeds :: NeedsBuilder a b x y -> Needs x y-withEmptyNeeds (NeedsBuilder !b) = b (Needs mempty)+-- | Runs a 'Data.Packed.Needs.NeedsBuilder' computation. Produces a 'Data.Packed.Packed'+{-# INLINE runBuilder #-}+runBuilder :: NeedsBuilder p1 r '[] r -> Packed r+runBuilder builder = unsafeDupablePerformIO $ do+ srcNeeds <- IO $ \s -> case newAlignedPinnedByteArray# (unInt baseBufferSize) 0# s of+ (# s', byteArray #) -> (# s', Needs byteArray (mutableByteArrayContents# byteArray) baseBufferSize #)+ !finalNeeds <- L.withLinearIO $ L.fmap (toLinear Ur) (builder srcNeeds)+ finish finalNeeds -withNeeds :: Needs x y -> NeedsBuilder x y x1 y1 -> Needs x1 y1-withNeeds needs (NeedsBuilder !next) = next needs+{-# INLINE finish #-}+finish :: Needs '[] a -> IO (Packed a)+finish (Needs og cursor _) = do+ let !contentLen = cursor `minusAddr#` mutableByteArrayContents# og+ () <- IO $ \s -> case shrinkMutableByteArray# og contentLen s of+ s' -> (# s', () #)+ -- SRC: https://hackage.haskell.org/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.ForeignPtr.html#mallocPlainForeignPtrBytes+ let !fptr = ForeignPtr (mutableByteArrayContents# og) (PlainPtr og)+ -- BS calls this function when alloacting an ForeignPtr, let's do that too+ -- https://hackage-content.haskell.org/package/bytestring-0.12.2.0/docs/src/Data.ByteString.Internal.Type.html#mkDeferredByteString+ !bs <- mkDeferredByteString fptr (I# contentLen)+ return $! unsafeToPacked bs -concatNeeds :: Needs p t -> NeedsBuilder '[] t1 p (t1 :++: t)-concatNeeds (Needs !b) = NeedsBuilder (\(Needs s) -> Needs (s <> b))+-- | Appends a 'Data.Needs.Needs'+{-# INLINE concatNeeds #-}+concatNeeds :: Needs p t %1 -> NeedsBuilder '[] t1 p (t1 :++: t)+concatNeeds = toLinear2 appendNeeds -applyNeeds :: Needs '[] t1 -> NeedsBuilder (t1 :++: r) t r t-applyNeeds (Needs b) = NeedsBuilder (\(Needs s) -> Needs (s <> b))+-- | Uses a 'Data.Packed.Needs.Needs' to fill in the required values for the other 'Data.Packed.Needs.Needs'+{-# INLINE applyNeeds #-}+applyNeeds :: Needs '[] t1 %1 -> NeedsBuilder (t1 :++: r) t r t+applyNeeds = toLinear2 appendNeeds --- | Turns a 'Needs' value (that does not expect to be written to) to a 'Data.Packed.Packed'-finish :: Needs '[] t -> Packed t-finish (Needs !b) = Packed (builderBytes b)+-- | Writes a 'Storable'+{-# INLINE writeStorable #-}+writeStorable :: (Storable a) => a -> NeedsBuilder (a ': r) t r t+writeStorable !a !needs = L.do+ !newNeeds <- guardRealloc (sizeOf a) needs+ let !(# cursor, newNeeds1 #) = getCursor newNeeds+ () <- toLinear (\cursor' -> L.fromSystemIO (poke (Ptr cursor') a)) cursor+ L.return (unsafeShiftNeedsPtr (sizeOf a) newNeeds1)++-- Internal++{-# INLINE guardRealloc #-}+guardRealloc :: Int -> Needs p1 t1 %1 -> L.IO (Needs p1 t1)+guardRealloc neededSpace needs =+ if neededSpace L.> spaceLeft+ then reallocNeeds needs1 neededSpace+ else L.return needs1+ where+ !(# spaceLeft, needs1 #) = getSpaceLeft needs++{-# INLINE reallocNeeds #-}+reallocNeeds :: Needs p t %1 -> Int -> L.IO (Needs p t)+reallocNeeds = toLinear reallocNeeds'++reallocNeeds' :: Needs p t -> Int -> L.IO (Needs p t)+reallocNeeds' (Needs origin cursor spaceLeft) additionalNeededSpace =+ let !cursorOffset = I# $ cursor `minusAddr#` mutableByteArrayContents# origin+ !oldBufferSize = spaceLeft + cursorOffset+ !newBufferSize = 2 * (oldBufferSize `max` additionalNeededSpace)+ in L.fromSystemIO+ ( IO $ \s -> case resizeMutableByteArray# origin (unInt newBufferSize) s of+ (# s', reallocedBA #) ->+ (#+ s'+ , Needs+ reallocedBA+ (mutableByteArrayContents# reallocedBA `plusAddr#` unInt cursorOffset)+ (newBufferSize - cursorOffset)+ #)+ )++{-# NOINLINE appendNeeds #-}+appendNeeds :: Needs a b -> NeedsBuilder a' b' c d+appendNeeds (Needs srcMa cursor _) dest = L.do+ let !srcLen = cursor `minusAddr#` mutableByteArrayContents# srcMa+ !reallocedDest <- guardRealloc (I# srcLen) dest+ let %1 !(# destOg, reallocedDest1 #) = getOrigin reallocedDest+ %1 !() = toLinear (\destAddr -> case runRW# $ copyAddrToAddr# (mutableByteArrayContents# srcMa) destAddr srcLen of !_ -> ()) destOg+ L.return (unsafeCastNeeds reallocedDest1)++-- Utils++{-# INLINE unsafeWriteTag #-}+unsafeWriteTag :: Int8 -> NeedsBuilder a b a' b+unsafeWriteTag tag needs = writeStorable tag (unsafeCastNeeds needs)++{-# INLINE unsafeShiftNeedsPtr #-}+unsafeShiftNeedsPtr :: Int -> Needs a b %1 -> Needs a' b+unsafeShiftNeedsPtr n (Needs og cursor spaceLeft) =+ Needs og (toLinear2 plusAddr# cursor (unInt n)) (spaceLeft L.- n)
src/Data/Packed/Packable.hs view
@@ -3,23 +3,22 @@ module Data.Packed.Packable (Packable (..), pack) where -import ByteString.StrictBuilder import Data.Packed.Needs (- Needs (..), NeedsWriter,- finish,- mkNeedsBuilder,- withEmptyNeeds,+ runBuilder,+ writeStorable, ) import Data.Packed.Packed (Packed) import Foreign import Prelude hiding (length) +-- | Typeclass for values that can be packed, i.e. written inside a 'Data.Packed.Needs.Needs' class Packable a where write :: a -> NeedsWriter a r t instance (Storable a) => Packable a where- write v = mkNeedsBuilder (\(Needs b) -> Needs (b <> storable v))+ write = writeStorable +-- | Shortcut to produce a 'Data.Packed.Packed' buffer from a single 'Packable' value pack :: (Packable a) => a -> Packed '[a]-pack a = finish (withEmptyNeeds (write a))+pack = runBuilder . write
src/Data/Packed/Packed.hs view
@@ -1,20 +1,15 @@ module Data.Packed.Packed ( Packed (..), unsafeToPacked,- unsafeToPacked', fromPacked, unsafeCastPacked, duplicate,- getPtr, ) where import Control.DeepSeq import Data.ByteString (copy) import Data.ByteString.Internal import Data.Kind (Type)-import Foreign.Ptr-import GHC.Exts (Ptr (Ptr))-import GHC.ForeignPtr -- | A buffer that contains one or more packed (i.e. serialised) values. -- The order of the values in the buffer is defined by the 'l' type list@@ -44,9 +39,3 @@ -- | UNSAFE: Casts a typed 'Packed' value into another 'Packed' value of another type unsafeCastPacked :: Packed a -> Packed b unsafeCastPacked = unsafeToPacked . fromPacked--unsafeToPacked' :: Ptr a -> Int -> Packed b-unsafeToPacked' (Ptr addr) l = Packed (BS (ForeignPtr addr FinalPtr) l)--getPtr :: Packed a -> Ptr b-getPtr p = let BS fptr _ = fromPacked p in castPtr $ unsafeForeignPtrToPtr fptr
src/Data/Packed/Reader.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnboxedTuples #-} -- | -- It is recommended to import this module like so:@@ -13,28 +15,42 @@ PackedReader (..), mkPackedReader, runReader,++ -- * Applicative+ pure,+ liftA,+ liftA2,+ (<*>),+ (*>),+ (<*),++ -- * Monad (>>=), (>>),- lift, fail, return,- ReaderPtr,- finishReader,+ lift,++ -- * Application+ with,+ threadedWith,++ -- * Fragments+ PackedFragment (..),+ castPackedFragment, ) where +import Control.Monad.Identity+import Data.Bifunctor import Data.ByteString.Internal-import Data.Packed.Needs (Needs, finish)+import Data.Kind+import Data.Packed.Internal import Data.Packed.Packed import Data.Packed.Utils ((:++:))-import Data.Word (Word8)-import Foreign.ForeignPtr (newForeignPtr_)-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Foreign.Ptr-import Prelude hiding (fail, return, (>>), (>>=))+import Foreign hiding (with)+import Prelude hiding (fail, liftA2, pure, return, (*>), (<*), (<*>), (>>), (>>=)) import qualified Prelude -type ReaderPtr r = Ptr Word8- -- | Basically a function that reads/desrialises a value from a 'Data.Packed.Packed' -- -- 'p' the types of the packed values to read@@ -45,42 +61,86 @@ -- -- __Note:__ It is an indexed monad. newtype PackedReader p r v = PackedReader- { runPackedReader ::- ReaderPtr (p :++: r) ->- Int ->- IO (v, ReaderPtr r, Int)+ { runReaderStep :: PackedFragment (p :++: r) -> Identity (v, PackedFragment r) } +-- | Represents position of the cursor in the packed buffer to traverse+data PackedFragment (p :: [Type])+ = PF+ -- | Pointer in the packed buffer+ {-# UNPACK #-} !(Ptr Word8)+ -- | Number of bytes between the cursor's position and the end of the buffer+ {-# UNPACK #-} !Int++{-# INLINE castPackedFragment #-}+castPackedFragment :: PackedFragment p -> PackedFragment t+castPackedFragment (PF p t) = PF p t+ {-# INLINE mkPackedReader #-} --- | Builds a 'PackedReader'+-- | Builds a 'Data.Packed.Reader.PackedReader' mkPackedReader ::- ( ReaderPtr (p :++: r) ->- Int ->- IO (v, ReaderPtr r, Int)- ) ->+ (PackedFragment (p :++: r) -> Identity (v, PackedFragment r)) -> PackedReader p r v mkPackedReader = PackedReader instance Functor (PackedReader p r) where {-# INLINE fmap #-}- fmap f (PackedReader reader) = PackedReader $ \ptr l -> do- (!n, !rest, !l1) <- reader ptr l- Prelude.return (f n, rest, l1)+ fmap f (PackedReader reader) = PackedReader $ fmap (first f) . reader -{-# INLINE (>>=) #-}+-------- Applicative +-- | Similar to 'Control.Applicative.pure'+{-# INLINE pure #-}+pure :: v -> PackedReader '[] r v+pure = return++-- | Similar to 'Control.Applicative.liftA'+{-# INLINE liftA #-}+liftA :: (a -> b) -> PackedReader p t a -> PackedReader p t b+liftA = fmap++-- | Similar to 'Control.Applicative.liftA2'+{-# INLINE liftA2 #-}+liftA2 ::+ (v1 -> v2 -> v3) ->+ PackedReader p (r1 :++: r2) v1 ->+ PackedReader r1 r2 v2 ->+ PackedReader (p :++: r1) r2 v3+liftA2 f m1 m2 = PackedReader $ \pf -> do+ (!v1, !pf1) <- runReaderStep m1 (castPackedFragment pf)+ (!v2, !pf2) <- runReaderStep m2 pf1+ Prelude.return (f v1 v2, pf2)++-- | Similar to 'Control.Applicative.<*>'+{-# INLINE (<*>) #-}+(<*>) :: PackedReader p (r1 :++: r2) (v1 -> v2) -> PackedReader r1 r2 v1 -> PackedReader (p :++: r1) r2 v2+(<*>) = liftA2 id++-- | Similar to 'Control.Applicative.*>'+{-# INLINE (*>) #-}+(*>) :: PackedReader p (r1 :++: r2) v -> PackedReader r1 r2 v' -> PackedReader (p :++: r1) r2 v'+(*>) = (>>)++-- | Similar to 'Control.Applicative.<*'+{-# INLINE (<*) #-}+(<*) :: PackedReader p (r1 :++: r2) v2 -> PackedReader r1 r2 v1 -> PackedReader (p :++: r1) r2 v2+(<*) = liftA2 const++-------- Monad+ -- | Allows bindings 'Data.Packed.Reader.PackedReader' together, in a monad-like manner. -- -- Similar to 'Prelude.>>='+{-# INLINE (>>=) #-} (>>=) :: PackedReader p (r1 :++: r2) v -> (v -> PackedReader r1 r2 v') -> PackedReader (p :++: r1) r2 v'-(>>=) m1 m2 = PackedReader $ \packed l -> do- (!value, !packed1, !l1) <- runPackedReader m1 packed l- (!res, !rest, !l2) <- runPackedReader (m2 value) packed1 l1- Prelude.return (res, rest, l2)+(>>=) pr1 next = PackedReader $ \pf ->+ let Identity (!v1, !pf1) = runReaderStep pr1 (castPackedFragment pf)+ PackedReader !pr2 = next v1+ in pr2 pf1 {-# INLINE (>>) #-} @@ -89,68 +149,70 @@ PackedReader p (r1 :++: r2) v -> PackedReader r1 r2 v' -> PackedReader (p :++: r1) r2 v'-(>>) m1 m2 = PackedReader $ \packed l -> do- (!_, !packed1, !l1) <- runPackedReader m1 packed l- runPackedReader m2 packed1 l1+(>>) pr1 (PackedReader pr2) = PackedReader $ \pf ->+ let+ Identity (!_, !pf1) = runReaderStep pr1 (castPackedFragment pf)+ in+ pr2 pf1 {-# INLINE return #-} --- | Like 'Prelude.return', wraps a value in a 'PackedReader' that will not consume its input.+-- | Like 'Prelude.return', wraps a value in a 'Data.Packed.Reader.PackedReader' that will not consume its input. return :: v -> PackedReader '[] r v-return value = PackedReader $ \(!packed) !l ->- Prelude.return (value, packed, l)+return !value = PackedReader $ \(!pf) -> Identity (value, pf) +-- | Interrupts a 'Data.Packed.Reader.PackedReader' computation {-# INLINE fail #-} fail :: String -> PackedReader '[] r v-fail msg = mkPackedReader $ \_ _ -> Prelude.fail msg+fail msg = mkPackedReader $ \_ -> error msg --- | Allows reading another packed value in a do-notation.+-- | Run the reading function using a 'Data.Packed.Packed'.+{-# INLINE runReader #-}+runReader ::+ PackedReader p r v ->+ Packed (p :++: r) ->+ (v, Packed r)+runReader pr (Packed (BS fptr l)) =+ unsafeDupablePerformIO+ ( withForeignPtr fptr $ \ptr -> do+ let Identity (!v, !(PF ptr1 l1)) = runReaderStep pr (PF (castPtr ptr) l)+ !fptr1 <- newForeignPtr_ ptr1+ Prelude.return (v, Packed (BS fptr1 l1))+ )++-- | Consumes the input 'Data.Packed.Reader.PackedFragment'. ----- The reading of the second stream does not consume anything from the first.+-- To be used inside a 'Data.Packed.Reader.PackedReader' computation. ----- __Example__:+-- Example: -- -- @--- import qualified Data.Packed.Reader as R--- data Tree a = Leaf | Node (Tree a) a (Tree a)------ packedTreeToList :: 'PackedReader' '[Tree Int] '[] [Int]--- packedTreeToList = go []--- where--- go l =--- caseTree--- (R.return l)--- ( R.do--- packedLeft <- 'Data.Packed.isolate'--- n <- 'Data.Packed.readerWithFieldSize'--- packedRight <- 'Data.Packed.isolate'--- -- Using lift allows consuming the packedRight value--- rightList <- R.'lift' (go l) packedRight--- R.'lift' (go $ n : rightList) packedLeft--- )+-- sumPacked :: PackedReader '[Tree Int] r Int+-- sumPacked = PackedReader $ \case+-- PackedLeaf l -> reader `with` l+-- PackedNode n -> threadedWith n $ R.do+-- !left <- sumPacked2+-- !right <- sumPacked2+-- let !res = left + right+-- R.return res -- @+{-# INLINE with #-}+with :: PackedReader p r v -> PackedFragment (p :++: r) -> Identity (v, PackedFragment r)+with = runReaderStep++-- | Flipped version of 'with'+{-# INLINE threadedWith #-}+threadedWith :: PackedFragment (p :++: r) -> PackedReader p r v -> Identity (v, PackedFragment r)+threadedWith = flip with++-- | Allows running a 'Data.Packed.Reader.PackedReader' computation inside an other {-# INLINE lift #-} lift :: PackedReader a b v ->- Packed (a :++: b) ->+ PackedFragment (a :++: b) -> PackedReader '[] r v-lift r p = mkPackedReader $ \old l -> do- (!res, _) <- runReader r p- Prelude.return (res, old, l)---- | Run the reading function using a ByteString.-{-# INLINE runReader #-}-runReader ::- PackedReader p r v ->- Packed (p :++: r) ->- IO (v, Packed r)-runReader (PackedReader f) (Packed (BS fptr l)) = do- (!v, !ptr1, !l1) <- f (castPtr $ unsafeForeignPtrToPtr fptr) l- !fptr1 <- newForeignPtr_ ptr1- Prelude.return (v, Packed (BS fptr1 l1))--{-# INLINE finishReader #-}---- | Util function that calls 'Data.Packed.finish' on the value produced by the input 'PackedReader'-finishReader :: PackedReader p r (Needs '[] a) -> PackedReader p r (Packed a)-finishReader r = finish <$> r+lift r p = mkPackedReader $ \pf ->+ let+ Identity !(!res, !_) = runReaderStep r p+ in+ Identity (res, pf)
src/Data/Packed/Skippable.hs view
@@ -6,7 +6,7 @@ module Data.Packed.Skippable (Skippable (..), unsafeSkipN) where import Data.Kind-import Data.Packed.Reader+import Data.Packed.Reader hiding (return) import Foreign (plusPtr) import Foreign.Storable @@ -23,4 +23,4 @@ -- | UNSAFE: Shifts the cursor to n bytes to the right. unsafeSkipN :: forall (a :: [Type]) (r :: [Type]). Int -> PackedReader a r ()-unsafeSkipN n = mkPackedReader $ \ptr l -> Prelude.return ((), ptr `plusPtr` n, l - n)+unsafeSkipN n = mkPackedReader $ \(PF ptr l) -> return ((), PF (ptr `plusPtr` n) (l - n))
src/Data/Packed/TH.hs view
@@ -13,6 +13,9 @@ -- * Generate Case function genCase, + -- * Generate Patterns+ genPatterns,+ -- * Generate Packing function genPackableInstance, genConstructorPackers,@@ -40,6 +43,7 @@ import Data.Packed.TH.Flag import Data.Packed.TH.PackCon (genConstructorPackers) import Data.Packed.TH.Packable+import Data.Packed.TH.Pattern import Data.Packed.TH.Read import Data.Packed.TH.RepackCon import Data.Packed.TH.Skip@@ -75,6 +79,7 @@ [PackingFlag] -> Q [Dec] mkPacked tyName flags = do+ patterns <- genPatterns flags tyName caseFunction <- genCase flags tyName packableInstance <- genPackableInstance flags tyName unpackableInstance <- genUnpackableInstance flags tyName@@ -83,7 +88,8 @@ skipInstance <- genSkippableInstance flags tyName transformFunction <- genTransform flags tyName return $- caseFunction+ patterns+ ++ caseFunction ++ packableInstance ++ unpackableInstance ++ constructorPackers
src/Data/Packed/TH/Case.hs view
@@ -1,15 +1,22 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExtendedLiterals #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-} module Data.Packed.TH.Case (caseFName, genCase) where import Data.Packed.Reader hiding (return) import Data.Packed.TH.Flag-import Data.Packed.TH.Utils (Tag, getBranchesTyList, getNameAndBangTypesFromCon, resolveAppliedType, sanitizeConName)+import Data.Packed.TH.Pattern (patternFName)+import Data.Packed.TH.Utils (getBranchesTyList, getNameAndBangTypesFromCon, resolveAppliedType, sanitizeConName) import Language.Haskell.TH caseFName :: Name -> Name caseFName tyName = mkName $ "case" ++ sanitizeConName tyName +-- TODO Use generated patterns+ -- | Generates a function to allow pattern matching a packed data type using the data constructors -- -- __Example:__@@ -21,12 +28,9 @@ -- ('Data.Packed.PackedReader' '[a] r b) -> -- ('Data.Packed.PackedReader' '[Tree a, Tree a] r b) -> -- 'Data.Packed.PackedReader' '[Tree a] r b--- caseTree leafCase nodeCase = 'Data.Packed.Reader.mkPackedReader' $ \packed l -> do--- (tag :: 'Tag', packed1, l1) <- 'Data.Packed.Unpackable.runReader' 'Data.Packed.reader' packed l--- case tag of--- 0 -> 'Data.Packed.Reader.runReader' leafCase packed1 l1--- 1 -> 'Data.Packed.Reader.runReader' nodeCase packed1 l1--- _ -> fail "Bad Tag"+-- caseTree leafCase nodeCase = 'Data.Packed.Reader.mkPackedReader' $ \case+-- PackedLeaf l -> 'runReaderStep' leafCase l+-- PackedNode l -> 'runReaderStep' nodeCase l -- @ genCase :: [PackingFlag] ->@@ -35,49 +39,36 @@ Q [Dec] genCase flags tyName = do (TyConI (DataD _ _ _ _ cs _)) <- reify tyName- packedName <- newName "packed" -- For each data constructor, we build names for the pattern for the case functions -- Example: leafCase, nodeCase, etc.- let casePatterns = buildCaseFunctionName <$> cs- body <- buildBody casePatterns packedName+ let casePatterns = buildCaseCallbackNameAndPattern <$> cs+ body <- [|PackedReader $ $(buildCaseExpression casePatterns)|] signature <- genCaseSignature flags tyName return- [ signature+ [ PragmaD $ InlineP (caseFName tyName) Inline FunLike AllPhases+ , signature , FunD (caseFName tyName)- [Clause (VarP <$> casePatterns) (NormalB body) []]+ [Clause (VarP . snd <$> casePatterns) (NormalB body) []] ] where- -- Build the body (the do, binding and case expressions)- buildBody casePatterns packedName =- let bytes1VarName = mkName "b"- length1VarName = mkName "l"- flagVarName = mkName "flag"- in do- caseExpression <- buildCaseExpression flagVarName casePatterns bytes1VarName length1VarName- [|- mkPackedReader $ \($(varP packedName)) l' -> do- ($(varP flagVarName), $(varP bytes1VarName), $(varP length1VarName)) <- runPackedReader reader $(varE packedName) l'- $(return caseExpression)- |] -- for dataconstructor Leaf, will be 'leafCase'- buildCaseFunctionName = conNameToCaseFunctionName . fst . getNameAndBangTypesFromCon+ buildCaseCallbackNameAndPattern = (\name -> (patternFName name, conNameToCaseFunctionName name)) . fst . getNameAndBangTypesFromCon conNameToCaseFunctionName conName = mkName $ 'c' : (sanitizeConName conName) ++ "Case" -- Build the case .. of ... expression using the list of available xxxCase, the flag and bytestring- buildCaseExpression :: Name -> [Name] -> Name -> Name -> Q Exp- buildCaseExpression e casePatterns bytesVarName lengthVarName =+ buildCaseExpression :: [(Name, Name)] -> Q Exp+ buildCaseExpression casePatterns = -- For each xxxCase, we build a branch for the case expression let matches =- ( \(conIndex, caseFuncName) -> do- body <- [|runPackedReader $(varE caseFuncName) $(varE bytesVarName) $(varE lengthVarName)|]- return $ Match (LitP $ IntegerL conIndex) (NormalB body) []+ ( \(patternName, caseCallbackName) -> do+ let r = mkName "r"+ body <- [|runReaderStep $(varE caseCallbackName) $(varE r)|]+ let pat = ConP patternName [] [VarP r]+ return $ Match pat (NormalB body) [] )- <$> zip [0 ..] casePatterns- fallbackMatch = do- fallbackBody <- [|Prelude.fail "Bad Tag"|]- return $ Match WildP (NormalB fallbackBody) []- in caseE [|$(varE e) :: Tag|] $ matches ++ [fallbackMatch]+ <$> casePatterns+ in lamCaseE matches -- For a type 'Tree', generates the following signature -- caseTree ::
src/Data/Packed/TH/PackCon.hs view
@@ -17,11 +17,11 @@ -- For the 'Tree' data type, it generates the following functions -- -- @--- packLeaf :: ('Packable' a) => a -> 'Data.Packed' '[Tree a]--- packLeaf n = 'finish' ('withEmptyNeeds' (writeLeaf n))+-- packLeaf :: ('Packable' a) => a -> ('Data.Packed' '[Tree a])+-- packLeaf n = 'runBuilder' (writeLeaf n) ----- packNode :: ('Packable' a) => Tree a -> Tree a -> 'Data.Packed' '[Tree a]--- packNode t1 t2 = 'finish' ('withEmptyNeeds' (writeNode t1 t2))+-- packNode :: ('Packable' a) => Tree a -> Tree a -> ('Data.Packed' '[Tree a])+-- packNode t1 t2 = 'runBuilder' (writeNode t1 t2) -- @ genConstructorPackers :: [PackingFlag] -> Name -> Q [Dec] genConstructorPackers flags tyName = do@@ -42,7 +42,7 @@ genConstructorPacker flags conName argTypes = do varNames <- mapM (\_ -> newName "t") argTypes writeExp <- (foldl (\rest p -> appE rest (varE p)) (varE $ conWriteFName conName) varNames)- body <- [|finish (withEmptyNeeds $(return writeExp))|]+ body <- [|runBuilder $(return writeExp)|] signature <- genConstructorPackerSig flags conName argTypes return [ signature@@ -54,5 +54,5 @@ (DataConI _ _ tyName) <- reify conName (ty, typeParameterNames) <- resolveAppliedType tyName constraints <- mapM (\tyVarName -> [t|Packable $(varT tyVarName)|]) typeParameterNames- signature <- foldr (\p rest -> [t|$(return p) -> $rest|]) [t|Packed '[$(return ty)]|] argTypes+ signature <- foldr (\p rest -> [t|$(return p) -> $rest|]) [t|(Packed '[$(return ty)])|] argTypes return $ SigD (packConFName conName) $ ForallT [] constraints signature
+ src/Data/Packed/TH/Pattern.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Packed.TH.Pattern (genPatterns, patternFName, tagReaderFName) where++import Control.Monad (forM)+import Data.Packed.Reader (PackedFragment (..))+import Data.Packed.TH.Flag (PackingFlag (..))+import Data.Packed.TH.Utils+import GHC.Exts+import GHC.Ptr+import Language.Haskell.TH++-- | Generates patterns for packed values of the given type+--+-- __Example:__+--+-- For the 'Tree' data type, it generates the following patterns:+--+-- @+-- PackedLeaf :: (PackedFragment (a ': r)) -> PackedFragment (Tree a ': r)+--+-- PackedNode :: (PackedFragment (Tree A ': Tree a ': r)) -> PackedFragment (Tree a ': r)+-- @+--+-- More specifically, it generates the following code:+--+-- @+--+-- {-# INLINE readTreeTag #-}+-- readTreeTag :: PackedFragment (Tree a ': r) -> (# Word8#, PackedFragment n #)+-- readTreeTag (PF ptr@(Ptr addr) i) = case readWord8OffAddr# addr 0# realWorld# of+-- (# _, t #) -> case t of+-- 0 -> (# t, PF (ptr `plusPtr` 1) (i - 1) #)+-- 1 -> (# t, PF (ptr `plusPtr` 1) (i - 1) #)+-- _ -> error $ "Bag tag: Got " ++ show (W8# t)+--+-- {-# INLINE PackedLeaf #-}+-- pattern PackedLeaf :: PackedFragment (a ': r) -> 'PackedFragment' (Tree a ': r)+-- pattern PackedLeaf pf <- (readTreeTag -> (# 0, pf #))+--+-- {-# INLINE PackedNode #-}+-- pattern PackedNode :: 'PackedFragment' (Tree a ': Tree a ': r) -> 'PackedFragment' (Tree a ': r)+-- pattern PackedNode pf <- (readTreeTag -> (# 1, pf #))+--+-- {-# COMPLETE PackedLeaf, PackedNode #-}+-- @+genPatterns :: [PackingFlag] -> Name -> Q [Dec]+genPatterns flags tyName = do+ (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+ patterns <- concat <$> forM (zip cs [0 ..]) (uncurry (genPattern flags tyName))+ tagReader <- genTagReader flags tyName+ let completePragma =+ let+ patternNames = patternFName . fst . getNameAndBangTypesFromCon <$> cs+ in+ CompleteP patternNames Nothing+ return $ tagReader ++ patterns ++ [PragmaD completePragma]++genPattern :: [PackingFlag] -> Name -> Con -> Integer -> Q [Dec]+genPattern flags tyName con conIdx = do+ let patternName = patternFName $ fst $ getNameAndBangTypesFromCon con+ pfName <- newName "pf"+ (ty, _) <- resolveAppliedType tyName+ rVar <- newName "r"+ conArgTypes <- getBranchTyList con flags+ patternType <- do+ patternFieldType <- foldr (\curr rest -> [t|$(return curr) ': $rest|]) (varT rVar) conArgTypes+ fromType <- [t|$(return ty) ': $(varT rVar)|]+ [t|PackedFragment ($(return patternFieldType)) -> PackedFragment ($(return fromType))|]+ let patSynSig =+ PatSynSigD+ patternName+ patternType+ patSyn <- do+ let viewPat = [p|(# $(litP $ WordPrimL conIdx), $(varP pfName) #)|]+ patSynD+ patternName+ (prefixPatSyn [pfName])+ unidir+ (viewP (varE $ tagReaderFName tyName) viewPat)++ return+ [ PragmaD (InlineP patternName Inline FunLike AllPhases)+ , patSynSig+ , patSyn+ ]++patternFName :: Name -> Name+patternFName name = mkName $ "Packed" ++ sanitizeConName name++genTagReader :: [PackingFlag] -> Name -> Q [Dec]+genTagReader flags tyName = do+ rType <- newName "r"+ (ty, _) <- resolveAppliedType tyName+ conTypes <- getBranchesTyList tyName flags+ let fName = tagReaderFName tyName+ prototype <-+ let+ inType = [t|PackedFragment ($(return ty) ': $(varT rType))|]+ outType = [t|(# Word#, PackedFragment $(varT $ mkName "n") #)|]+ in+ [t|$inType -> $outType|]+ (pat, body) <- do+ let addrName = mkName "addr"+ ptrName = mkName "ptr"+ lengthName = mkName "l"+ tagVarName = mkName "t"+ readWordExp <- [|readWord8OffAddr# $(varE addrName) 0# realWorld#|]+ caseBranches <- forM (zip [0 ..] conTypes) $ \(conIdx, _) -> do+ tName <- newName "t"+ let pat = AsP tName (LitP $ WordPrimL conIdx)+ branchExp <- [|(# $(varE tName), PF ($(varE ptrName) `plusPtr` 1) ($(varE lengthName) - 1) #)|]+ return $ Match pat (NormalB branchExp) []+ errorBranch <- do+ tName <- newName "t"+ match (asP tName wildP) (normalB [|error $ "Bad tag, got " ++ show (W# $(varE tName))|]) []+ let caseExpr = caseE [|word8ToWord# $(varE tagVarName)|] (return <$> (caseBranches ++ [errorBranch]))+ body <- [|case $(return readWordExp) of (# _, $(varP tagVarName) #) -> $caseExpr|]+ pattern_ <- do+ ptrPattern <- asP ptrName [p|Ptr $(varP addrName)|]+ [p|(PF $(return ptrPattern) $(varP lengthName))|]+ return (pattern_, body)++ return+ [ PragmaD (InlineP fName Inline FunLike AllPhases)+ , SigD fName prototype+ , FunD fName [Clause [pat] (NormalB body) []]+ ]++tagReaderFName :: Name -> Name+tagReaderFName tyName = mkName $ "read" ++ sanitizeConName tyName ++ "Tag"
src/Data/Packed/TH/RepackCon.hs view
@@ -1,8 +1,9 @@ module Data.Packed.TH.RepackCon (genConstructorRepackers) where import Data.Packed.FieldSize-import Data.Packed.Needs (Needs, applyNeeds, withEmptyNeeds)+import Data.Packed.Needs (Needs, applyNeeds) import qualified Data.Packed.Needs as N+import Data.Packed.Packed (Packed) import Data.Packed.TH.Flag import Data.Packed.TH.Start (startFName) import Data.Packed.TH.Utils@@ -15,11 +16,11 @@ -- For the 'Tree' data type, it generates the following functions -- -- @--- repackLeaf :: 'Data.Packed.Needs' '[] a -> 'Data.Packed.Needs' '[] (Tree a)+-- repackLeaf :: 'Data.Packed.Needs' '[] a -> ('Data.Packed.Packed' '[Tree a]) -- repackLeaf pval = withEmptyNeeds (startLeaf N.>> 'Data.Packed.Needs.concatNeeds' pval) ----- repackNode :: 'Data.Packed.Needs' '[] (Tree a) -> 'Data.Packed.Needs' '[] (Tree a) -> 'Data.Packed.Needs' '[] (Tree a)--- repackNode lval rval = withEmptyNeeds (startNode N.>> 'concatNeeds' lval N.>> 'concatNeeds' rval)+-- repackNode :: 'Data.Packed.Needs' '[] (Tree a) -> 'Data.Packed.Needs' '[] (Tree a) -> ('Data.Packed.Packed '[Tree a])+-- repackNode lval rval needs = N.runBuilder (startNode needs N.>>= 'Data.Packed.Needs.concatNeeds' lval N.>>= 'concatNeeds' rval) -- @ genConstructorRepackers :: [PackingFlag] -> Name -> Q [Dec] genConstructorRepackers flags tyName = do@@ -34,18 +35,19 @@ genConstructorRepacker flags con = do let conName = fst $ getNameAndBangTypesFromCon con fieldTypes = getConFieldsIdxAndNeedsFS con flags+ needsName = mkName "needs" varNames <- mapM (\_ -> newName "t") fieldTypes writeExp <- let concated = foldl ( \rest ((_, _, needsFieldSize), varName) -> if needsFieldSize- then [|($rest) N.>> applyNeedsWithFieldSize $(varE varName)|]- else [|($rest) N.>> applyNeeds $(varE varName)|]+ then [|($rest) N.>>= applyNeedsWithFieldSize $(varE varName)|]+ else [|($rest) N.>>= applyNeeds $(varE varName)|] )- [|$(varE $ startFName conName)|]+ [|$(varE $ startFName conName) $(varE needsName)|] (zip fieldTypes varNames)- in [|withEmptyNeeds $concated|]+ in [|N.runBuilder $ \($(varP needsName)) -> $concated|] signature <- genConstructorPackerSig flags conName ((\(t, _, _) -> t) <$> fieldTypes) return [ signature@@ -56,5 +58,5 @@ genConstructorPackerSig _ conName argTypes = do (DataConI _ _ tyName) <- reify conName (ty, _) <- resolveAppliedType tyName- signature <- foldr (\p rest -> [t|Needs '[] '[$(return p)] -> $rest|]) [t|Needs '[] '[$(return ty)]|] argTypes+ signature <- foldr (\p rest -> [t|Needs '[] '[$(return p)] -> $rest|]) [t|Packed '[$(return ty)]|] argTypes return $ SigD (repackConFName conName) $ ForallT [] [] signature
src/Data/Packed/TH/Start.hs view
@@ -1,10 +1,8 @@ module Data.Packed.TH.Start (startFName, genStart) where import Data.Packed.Needs-import Data.Packed.Packable (write) import Data.Packed.TH.Flag (PackingFlag (..)) import Data.Packed.TH.Utils-import Data.Word (Word8) import Language.Haskell.TH -- | For a constructor 'Leaf', will generate the function name 'startLeaf'@@ -19,10 +17,10 @@ -- -- @ -- startLeaf :: NeedsBuilder (Tree a ': r) t (a ': r) t--- startLeaf = 'mkNeedsBuilder' (\n -> runBuilder (write (0 :: Word8) ('unsafeCastNeeds' n)))+-- startLeaf = 'unsafeWriteTag' 0 -- -- startNode :: NeedsBuilder (Tree a ': r) t (Tree a ': Tree a ': r) t--- startNode = 'mkNeedsBuilder' (\n -> runBuilder (write (1 :: Word8) ('unsafeCastNeeds' n)))+-- startNode = 'unsafeWriteTag' 1 -- @ genStart :: [PackingFlag] ->@@ -42,7 +40,7 @@ destNeedsTypeParams = foldr (\field rest -> [t|$(return field) ': $rest|]) r branchType parentType = getParentTypeFromConstructorType conType in [t|NeedsBuilder ($(return parentType) ': $r) $t $destNeedsTypeParams $t|]- expr <- [|mkNeedsBuilder (\n -> runBuilder (write (tag :: Word8)) (unsafeCastNeeds n))|]+ expr <- [|unsafeWriteTag $(litE $ IntegerL $ fromIntegral tag)|] return [ SigD fName sig , FunD fName [Clause [] (NormalB expr) []]
src/Data/Packed/TH/Transform.hs view
@@ -1,8 +1,8 @@ module Data.Packed.TH.Transform (transformFName, genTransform) where +import Control.Monad import Data.Maybe (catMaybes) import Data.Packed.FieldSize (FieldSize)-import Data.Packed.Needs (withEmptyNeeds) import qualified Data.Packed.Needs as N import Data.Packed.Reader (PackedReader) import qualified Data.Packed.Reader as R@@ -19,13 +19,14 @@ -- For a type 'Tree', generates the following function -- -- transformTree ::--- ('Data.Packed.Reader.PackedReader' '[a] r ('Data.Packed.Needs.NeedsBuilder' '[a] '[Tree a] '[] '[Tree a])) -> ----- ('Data.Packed.Reader.PackedReader' '[Tree a, Tree a] r ('Data.Packed.Needs.NeedsBuilder' '[Tree a, Tree a] '[Tree a] '[] '[Tree a])) ->--- 'Data.Packed.PackedReader' '[Tree a] r ('Data.Packed.Needs' '[] '[Tree a])+-- ('Data.Packed.Reader.PackedReader' '[a] r ('Data.Packed.Needs.NeedsBuilder' (a ': r1) '[Tree a] r1 '[Tree a])) ->+--+-- ('Data.Packed.Reader.PackedReader' '[Tree a, Tree a] r ('Data.Packed.Needs.NeedsBuilder' (Tree a ': Tree a ': r1) '[Tree a] r1 '[Tree a])) ->+-- 'Data.Packed.PackedReader' '[Tree a] r ('Data.Packed.NeedsBuilder' (Tree a ': r1) '[Tree a] r1 '[Tree a]) -- transformTree leafCase nodeCase = caseTree--- (leafCase R.>>= \l -> 'Data.Packed.Needs.finish' ('Data.Packed.Needs.withEmptyNeeds' (startLeaf 'Data.Packed.Needs.>>' l)))--- (nodeCase R.>>= \n -> 'Data.Packed.Needs.finish' ('Data.Packed.Needs.withEmptyNeeds' (startNode 'Data.Packed.Needs.>>' n)))+-- (leafCase R.>>= \l -> return (startLeaf 'Data.Packed.Needs.>=>' l))+-- (nodeCase R.>>= \n -> return (startNode 'Data.Packed.Needs.>=>' n))) genTransform :: [PackingFlag] -> Name -> Q [Dec] genTransform flags tyName = do signature <- genTransformSignature flags tyName@@ -35,10 +36,18 @@ ( \rest curr -> let caseName = buildCaseFunctionName curr in if not $ conHasArguments curr- then [|$rest (R.return (withEmptyNeeds $(varE (startFNameForCon curr))))|]- else [|$rest ($(varE caseName) R.>>= \resWriter -> R.return (withEmptyNeeds ($(varE (startFNameForCon curr)) N.>> resWriter)))|]+ then [|$rest (R.return $(varE (startFNameForCon curr)))|]+ else+ [|+ $rest+ ( $(varE caseName)+ R.>>= \resWriter ->+ R.return+ (($(varE (startFNameForCon curr)) N.>=> resWriter))+ )+ |] )- (varE $ caseFNameForType tyName)+ (varE $ caseFName tyName) cs return [ signature@@ -49,55 +58,56 @@ where -- for dataconstructor Leaf, will be 'leafCase' buildCaseFunctionName = conNameToCaseFunctionName . fst . getNameAndBangTypesFromCon- conNameToCaseFunctionName conName = mkName $ "case" ++ (sanitizeConName conName)+ conNameToCaseFunctionName conName = mkName $ "case_" ++ (sanitizeConName conName) startFNameForCon = startFName . fst . getNameAndBangTypesFromCon- caseFNameForType = caseFName conHasArguments = not . null . snd . getNameAndBangTypesFromCon -- For a type 'Tree', generates the following signature -- transformTree ::--- ('Data.Packed.Reader.PackedReader' '[a] r ('Data.Packed.Needs.NeedsBuilder' '[a] '[Tree a] '[] '[Tree a])) ->+-- ('Data.Packed.Reader.PackedReader' '[a] r ('Data.Packed.Needs.NeedsBuilder' (a ': r1) '[Tree a] r1 '[Tree a])) -> ----- ('Data.Packed.Reader.PackedReader' '[Tree a, Tree a] r ('Data.Packed.Needs.NeedsBuilder' '[Tree a, Tree a] '[Tree a] '[] '[Tree a])) ->--- 'Data.Packed.PackedReader' '[Tree a] r ('Data.Packed.Needs' '[] '[Tree a])+-- ('Data.Packed.Reader.PackedReader' '[Tree a, Tree a] r ('Data.Packed.Needs.NeedsBuilder' (Tree a ': Tree a ': r1) '[Tree a] r1 '[Tree a])) ->+-- 'Data.Packed.PackedReader' '[Tree a] r ('Data.Packed.NeedsBuilder' (Tree a ': r1) '[Tree a] r1 '[Tree a]) genTransformSignature :: [PackingFlag] -> Name -> Q Dec genTransformSignature flags tyName = do (sourceType, _) <- resolveAppliedType tyName (TyConI (DataD _ _ _ _ cs _)) <- reify tyName rVar <- newName "r"+ r1Var <- newName "r1" let rType = varT rVar- lambdaTypes = (\c -> buildLambdaType c sourceType rType) <$> cs+ r1Type = varT r1Var+ lambdaTypes = (\c -> buildLambdaType c sourceType rType r1Type) <$> cs outType = [t| PackedReader '[$(return sourceType)] $rType- (N.Needs '[] '[$(return sourceType)])+ (N.NeedsBuilder ($(return sourceType) ': $(r1Type)) '[$(return sourceType)] $(r1Type) '[$(return sourceType)]) |] signature <- foldr (\lambda out -> [t|$lambda -> $out|]) outType (catMaybes lambdaTypes) return $ SigD (transformFName tyName) signature where -- From a constructor (say Leaf a), build type PackedTransformer a r- buildLambdaType con ty restType =+ buildLambdaType con ty restType rest1Type = if null fieldType then Nothing else return $ do- packedContentType <-+ [readerType, builderType] <- forM [[t|'[]|], rest1Type] $ \r -> foldr ( \(fieldTy, _, needsFS) tys -> if needsFS then [t|FieldSize ': $(return fieldTy) ': $tys|] else [t|$(return fieldTy) ': $tys|] )- [t|'[]|]+ r fieldType [t| PackedReader- $(return packedContentType)+ $(return readerType) $restType- (N.NeedsBuilder $(return packedContentType) '[$(return ty)] '[] '[$(return ty)])+ (N.NeedsBuilder $(return builderType) '[$(return ty)] $(rest1Type) '[$(return ty)]) |] where fieldType = getConFieldsIdxAndNeedsFS con flags
src/Data/Packed/TH/Write.hs view
@@ -40,7 +40,7 @@ -- Generate names for each variable in the constructor paramNames <- mapM (const $ newName "t") types -- We apply each parameter of the constructor and the 'Needs' to the 'writeConXXX' function- body <- foldl (\f arg -> [|$f $(varE arg)|]) (varE $ conWriteFName conName) paramNames+ body <- foldl (\f arg -> appE f (varE arg)) (varE $ conWriteFName conName) paramNames return $ Clause [ConP conName [] (VarP <$> paramNames)] (NormalB body) [] ) cs
src/Data/Packed/TH/WriteCon.hs view
@@ -26,7 +26,7 @@ -- -- @ -- writeConLeaf :: ('Packable' a) => a -> 'NeedsWriter (Tree a) r t'--- writeConLeaf n = startLeaf 'Data.Packed.Needs.>>' 'write' n+-- writeConLeaf leafValue needs = startLeaf needs 'Data.Packed.Needs.>>=' 'write' n -- @ genConWrite :: [PackingFlag] ->@@ -44,6 +44,7 @@ t = VarT $ mkName "t" fName = conWriteFName conName paramTypes = getConFieldsIdxAndNeedsFS con flags+ srcNeedsName = mkName "needs" parentType <- do DataConI _ conTy _ <- reify conName return $ getParentTypeFromConstructorType conTy@@ -55,18 +56,18 @@ ( \rest ((_, _, needsFS), paramName) -> -- We insert the size before if needsFS- then [|$rest N.>> writeWithFieldSize $(varE paramName)|]- else [|$rest N.>> write $(varE paramName)|]+ then [|$rest N.>>= writeWithFieldSize $(varE paramName)|]+ else [|$rest N.>>= write $(varE paramName)|] )- [|$(varE $ startFName conName)|]+ [|$(varE $ startFName conName) $(varE srcNeedsName)|] fieldTypeAndName -- The pattern (lhs of '=' in a function implementation) will be something like '\a needs' for constructor 'Leaf a'- let patt = VarP . snd <$> fieldTypeAndName+ let patt = (VarP . snd <$> fieldTypeAndName) ++ [VarP srcNeedsName] start <- genStart flags con tag return $ start ++ [ signature- , FunD fName [Clause [] (NormalB $ LamE patt body) []]+ , FunD fName [Clause patt (NormalB body) []] ] -- Generates the function signature for functions like 'writeConLeaf'
src/Data/Packed/Unpackable.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} module Data.Packed.Unpackable (@@ -13,32 +15,38 @@ readerWithoutShift, ) where +import Control.Monad.Identity import Data.Packed.Packed-import Data.Packed.Reader+import Data.Packed.Reader hiding (return) import Foreign (Storable (peek, sizeOf), castPtr, plusPtr)-import GHC.IO (unsafePerformIO)+import GHC.Exts+import GHC.IO -- | An 'Unpackable' is a value that can be read (i.e. deserialised) from a 'Data.Packed' value class Unpackable a where- -- | The 'PackedReader' to unpack a value of that type+ -- | The 'Data.Packed.Reader.PackedReader' to unpack a value of that type reader :: PackedReader '[a] r a instance (Storable a) => Unpackable a where {-# INLINE reader #-}- reader = mkPackedReader $ \ptr l -> do- !n <- Foreign.peek (castPtr ptr)- let !shiftedCount = sizeOf n- !l1 = l - shiftedCount- !ptr1 = ptr `plusPtr` shiftedCount- Prelude.return (n, ptr1, l1)+ reader = PackedReader $ \(PF ptr int) -> case runRW# (unIO (peek $ castPtr ptr)) of+ (# _, !n #) ->+ let+ !sizeOfN = sizeOf n+ !shiftedPtr = ptr `plusPtr` sizeOfN+ !shiftedSize = int - sizeOfN+ in+ return (n, PF shiftedPtr shiftedSize) {-# INLINE readerWithoutShift #-} -- | In a `PackedReader`, reads a value without moving the cursor-readerWithoutShift :: (Unpackable a) => PackedReader (a ': r) (a ': r) a-readerWithoutShift = mkPackedReader $ \ptr len -> do- (!a, _, _) <- runPackedReader reader ptr len- Prelude.return (a, ptr, len)+readerWithoutShift :: (Unpackable a) => PackedReader '[] (a ': r) a+readerWithoutShift = mkPackedReader $ \pf ->+ let+ Identity !(!a, !_) = runReaderStep reader pf+ in+ return (a, pf) {-# INLINE unpack #-} @@ -46,7 +54,7 @@ -- -- Returns the unconsumed 'Data.Packed.Packed' portion unpack :: (Unpackable a) => Packed (a ': r) -> (a, Packed r)-unpack = unsafePerformIO . runReader reader+unpack = runReader reader {-# INLINE unpack' #-}
− src/Tree.hs
@@ -1,9 +0,0 @@-{-# OPTIONS_GHC -Wno-unused-top-binds #-}--module Tree (Tree (..), caseTree, readTree) where--import Data.Packed--data Tree a = Leaf a | Node (Tree a) (Tree a)--$(mkPacked ''Tree [InsertFieldSize, SkipLastFieldSize])
test/PackedTest/CaseTest.hs view
@@ -21,7 +21,7 @@ rightSum <- computeSum R.return $ leftSum + rightSum )- (res, _) <- runReader computeSum tree+ (res, _) = runReader computeSum tree res `shouldBe` 55 where buildTree 0 = Leaf1 0
test/PackedTest/IdentityTest.hs view
@@ -1,9 +1,13 @@+{-# LANGUAGE BangPatterns #-}+ module PackedTest.IdentityTest (specs) where import Data.Packed import PackedTest.Data import Test.Hspec+import Prelude hiding (readList) +$(mkPacked ''[] []) $(mkPacked ''Tree1 []) $(mkPacked ''Tree2 []) $(mkPacked ''Tree3 [])@@ -15,10 +19,20 @@ test "Tree 1" $ Node1 (Node1 (Leaf1 (1 :: Int)) (Leaf1 2)) (Leaf1 3) test "Tree 1 (with lists)" $ Node1 (Leaf1 [1 :: Int, 2]) (Node1 (Leaf1 []) (Leaf1 [3, 4])) test "Tree 1 (with custom ADT)" $ Node1 (Leaf1 (SmallData (1 :: Int))) (Node1 (Leaf1 $ BigData "Hello World") (Node1 (Leaf1 $ BigData "Goodbye") (Leaf1 $ SmallData 0)))+ test "Tree 1, size 20" $ buildNativeTree 20 test "Tree 2" $ Node2 (Node2 Leaf2 (1 :: Int) Leaf2) 2 (Node2 Leaf2 3 Leaf2) test "Tree 3" $ Node3 (Node3 Leaf3 Leaf3 (1 :: Int)) (Node3 Leaf3 Leaf3 3) 2 test "Tree 4" $ Node4 (Node4 (Leaf4 (1 :: Int)) (Leaf4 2)) (Leaf4 3) where- test name tree = it name $ do- let ptree = pack tree- unpack' ptree `shouldBe` tree+ test name tree =+ it name $+ let+ !ptree = pack tree+ in+ unpack' ptree `shouldBe` tree++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+ where+ !subTree = buildNativeTree (n - 1)
test/PackedTest/PackTest.hs view
@@ -77,6 +77,6 @@ ) where test name tree bldr =- it name $ do+ it name $ let ptree = Data.Packed.pack tree- fromPacked ptree `shouldBe` builderBytes bldr+ in fromPacked ptree `shouldBe` builderBytes bldr