packed-data (empty) → 0.1.0.0

raw patch · 53 files changed

+3782/−0 lines, 53 filesdep +Chartdep +Chart-diagramsdep +aesonsetup-changed

Dependencies added: Chart, Chart-diagrams, aeson, base, bytestring, bytestring-strict-builder, cassava, criterion, deepseq, directory, extra, filepath, hspec, listsafe, mtl, optparse-applicative, packed-data, split, template-haskell, time, vector

Files

• LICENSE +26/−0
• README.md +67/−0
• Setup.hs +3/−0
• app/Main.hs +47/−0
• benchmark/AST.hs +97/−0
• benchmark/Build.hs +46/−0
• benchmark/CIReport.hs +40/−0
• benchmark/Increment.hs +105/−0
• benchmark/List.hs +144/−0
• benchmark/Main.hs +70/−0
• benchmark/OutputData.hs +115/−0
• benchmark/Pack.hs +45/−0
• benchmark/Plot.hs +43/−0
• benchmark/Sum.hs +134/−0
• benchmark/Traversals.hs +225/−0
• benchmark/Utils.hs +41/−0
• benchmark/ast/Main.hs +60/−0
• benchmark/benchmark.c +199/−0
• benchmark/bigjson/Data.hs +76/−0
• benchmark/bigjson/Main.hs +89/−0
• packed-data.cabal +252/−0
• src/Data/Packed.hs +49/−0
• src/Data/Packed/FieldSize.hs +90/−0
• src/Data/Packed/Instances.hs +17/−0
• src/Data/Packed/Needs.hs +84/−0
• src/Data/Packed/Packable.hs +25/−0
• src/Data/Packed/Packed.hs +41/−0
• src/Data/Packed/Reader.hs +156/−0
• src/Data/Packed/Skippable.hs +26/−0
• src/Data/Packed/TH.hs +92/−0
• src/Data/Packed/TH/Case.hs +115/−0
• src/Data/Packed/TH/Flag.hs +38/−0
• src/Data/Packed/TH/PackCon.hs +58/−0
• src/Data/Packed/TH/Packable.hs +42/−0
• src/Data/Packed/TH/Read.hs +101/−0
• src/Data/Packed/TH/RepackCon.hs +70/−0
• src/Data/Packed/TH/Skip.hs +81/−0
• src/Data/Packed/TH/Skippable.hs +35/−0
• src/Data/Packed/TH/Start.hs +63/−0
• src/Data/Packed/TH/Transform.hs +100/−0
• src/Data/Packed/TH/Unpackable.hs +38/−0
• src/Data/Packed/TH/Utils.hs +51/−0
• src/Data/Packed/TH/Write.hs +70/−0
• src/Data/Packed/TH/WriteCon.hs +93/−0
• src/Data/Packed/Unpackable.hs +55/−0
• src/Data/Packed/Utils.hs +17/−0
• src/Tree.hs +9/−0
• test/PackedTest/CaseTest.hs +28/−0
• test/PackedTest/Data.hs +18/−0
• test/PackedTest/IdentityTest.hs +24/−0
• test/PackedTest/PackTest.hs +82/−0
• test/PackedTest/UnpackTest.hs +78/−0
• test/Spec.hs +12/−0

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

@@ -0,0 +1,67 @@+# `Packed` Haskell++Build, traverse and deserialise packed data in Haskell. ++## What is this for?++When components of a system exchange data, each component has to make sure that they send data in a way the recipient will be able to read. A simple example is an API, sending JSON data for the client to parse. This process of decoding the data takes time, especially for big objects like HTML pages.++*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` allows using packed data type-safely, without explicit pointer arithmetic.++## A portable library++Unlike other implementations of packed-data-support (e.g. [Gibbon](https://drops.dagstuhl.de/entities/document/10.4230/LIPIcs.ECOOP.2017.26)), `packed` is a library that does not modify the compiler in any way. It relies solely on already existing libraries (like `ByteString`), Template Haskell and common GHC extensions. This means that, virtually, `packed` can be used with any version of GHC (although, as of today, it has only been tested with GHC 9.10).++Its API is inspired by an example from the [Linear Haskell](https://dl.acm.org/doi/10.1145/3158093) paper (code available [here](https://github.com/tweag/linear-types/blob/12bed0d41d599e2697b29c5c4b37990642970e6c/Examples/src/Cursors/PureStorable.hs)).++## Example++```haskell++import qualified Data.Packed.Reader as R+import Data.Packed++data Tree a = Leaf a | Node (Tree a) (Tree a)++$(mkPacked ''Tree '[])++-- Compute sum of values in the tree+sumPacked :: PackedReader '[Tree Int] r Int+sumPacked =+    caseTree -- Generated by Template Haskell+        ( R.do -- If Tree is a Leaf+            !n <- reader+            R.return n+        )+        ( R.do -- If Tree is a Node+            !left <- sumPacked+            !right <- sumPacked+            let !res = left + right+            R.return res+        )++getSum :: Packed '[Tree Int] -> IO Int+getSum = runReader sumPacked++packTree :: Tree Int -> Packed '[Tree Int] +packTree = pack +```++Take a look at the `benchmark` directory for more examples.++## Benchmark++To run benchmarks, run the following command:++```+stack bench+# Saves the report as CSV+stack bench --ba --csv bench.csv+# Saves the report, and runs a specific test+stach bench --ba '--csv bench.csv sums'+```++Note: Graphs of the benchmark results will be generated in the `graph/` directory when saving the report as CSV.

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

@@ -0,0 +1,47 @@+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import Control.DeepSeq+import Data.Fixed+import Data.Int+import Data.Packed+import qualified Data.Packed.Reader as R+import Data.Time.Clock+import Text.Printf++data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)++$(mkPacked ''Tree1 [])++sumPacked :: PackedReader '[Tree1 Int64] r Int64+sumPacked =+    caseTree1+        ( R.do+            !n <- reader+            R.return n+        )+        ( R.do+            !left <- sumPacked+            !right <- sumPacked+            let !res = left + right+            R.return res+        )++buildNativeTree :: Int64 -> Tree1 Int64+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+  where+    subTree = buildNativeTree (n - 1)++main :: IO ()+main = do+    let packed = pack $! buildNativeTree 15+    _ <- fromPacked packed `deepseq` return ()+    startTime <- getCurrentTime+    (!s, !_) <- R.runReader sumPacked packed+    endTime <- s `seq` getCurrentTime+    printf+        "Sum: %d. Total execution time: %ss.\n"+        s+        (showFixed True $ nominalDiffTimeToSeconds $ diffUTCTime endTime startTime)

@@ -0,0 +1,97 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE TemplateHaskell #-}++module AST (benchmark) where++import Criterion.Main+import Data.ByteString.Internal+import Data.Packed+import qualified Data.Packed.Reader as R+import Data.Void+import Foreign+import Foreign.C+import Foreign.ForeignPtr.Unsafe+import Utils+import Prelude hiding (sum)++foreign import capi unsafe "benchmark.h eval" c_eval :: Ptr Void -> IO CLong++foreign import capi unsafe "benchmark.h build_ast" c_build_ast :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_ast" c_free_ast :: Ptr Void -> IO ()++data AST = Value Int32 | Add AST AST | Sub AST AST | Mul AST AST++$(mkPacked ''AST [])++benchmark :: [Int] -> Benchmark+benchmark depths =+    bgroup+        "ast"+        $ fmap buildAndEvaluateASTWithDepth depths++buildAndEvaluateASTWithDepth :: Int -> Benchmark+buildAndEvaluateASTWithDepth n =+    bgroup+        (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 packedWithUnpackTestName $ whnf (eval . fst . unpack) packedAST+        , bench nonMonadicPackedTestName $ nfAppIO evalPackedNonMonadic packedAST+        ]+  where+    !packedAST = pack nativeAST+    !nativeAST = buildNativeAST n++eval :: AST -> Int32+eval (Value n) = n+eval (Add a b) = eval a + eval b+eval (Sub a b) = eval a - eval b+eval (Mul a b) = eval a * eval b++evalPacked :: PackedReader '[AST] r Int32+evalPacked =+    caseAST+        reader+        (opLambda (+))+        (opLambda (-))+        (opLambda (*))+  where+    {-# INLINE opLambda #-}+    opLambda ::+        (Int32 -> Int32 -> Int32) ->+        PackedReader '[AST, AST] r Int32+    opLambda f = R.do+        left <- evalPacked+        right <- evalPacked+        R.return (f left right)++evalPackedNonMonadic :: Packed (AST ': r) -> IO Int+evalPackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+  where+    (BS fptr _) = fromPacked packed+    go :: Ptr Word8 -> IO (Int, Ptr Word8)+    go ptr = do+        tag <- peek ptr :: IO Word8+        let !nextPtr = ptr `plusPtr` 1+        case tag of+            0 -> do+                !n <- peek nextPtr :: IO Int32+                return (fromIntegral n, plusPtr nextPtr (sizeOf n))+            1 -> opLambda (+) nextPtr+            2 -> opLambda (-) nextPtr+            3 -> opLambda (*) nextPtr+            _ -> undefined+    {-# INLINE opLambda #-}+    opLambda :: (Int -> Int -> Int) -> Ptr Int32 -> IO (Int, Ptr Word8)+    opLambda f ptr = do+        (!left, !r) <- go $ castPtr ptr+        (!right, !r1) <- go r+        let !res = left `f` right+        return (res, r1)++buildNativeAST :: Int -> AST+buildNativeAST 0 = Value 1+buildNativeAST n = Add (buildNativeAST (n - 1)) (buildNativeAST (n - 1))

@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Build (benchmark) where++import Control.DeepSeq+import Criterion.Main+import Data.Packed+import Data.Packed.Needs+import qualified Data.Packed.Needs as N+import Utils+import Prelude hiding (sum)++data Tree1 a = Leaf1 a | Node1 !(Tree1 a) !(Tree1 a)++$(mkPacked ''Tree1 [])++instance NFData (Tree1 a) where+    rnf (Leaf1 a) = a `seq` ()+    rnf (Node1 l r) = l `seq` r `seq` ()++benchmark :: [Int] -> Benchmark+benchmark depths =+    bgroup+        "build"+        $ fmap buildTreeWithDepth depths++buildTreeWithDepth :: Int -> Benchmark+buildTreeWithDepth n =+    bgroup+        (depthGroupName n)+        [ bench nativeTestName $ nf buildNativeTree n+        , bench packedTestName $ nf (\p -> finish (buildPackedTree p)) n+        ]++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+  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)+  where+    !subTree = buildPackedTree (n - 1)

@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}++module CIReport (generateCIReport) where++import Data.Aeson+import GHC.Generics+import OutputData (BenchmarkResult (BenchmarkResult), BenchmarkValue (meanExecutionTime), mode, readBenchmarkResults)+import Text.Printf+import Utils (nativeTestName)++data ReportEntry = ReportEntry+    { name :: String+    , unit :: String+    , value :: Double+    }+    deriving (Generic, Show)++instance ToJSON ReportEntry++generateCIReport :: FilePath -> IO ()+generateCIReport csvPath = do+    let reportPath = "benchmark-report.json"+    benRes <- readBenchmarkResults csvPath+    let reportEntries = concatMap toReportEntries benRes+    encodeFile reportPath reportEntries++toReportEntries :: BenchmarkResult -> [ReportEntry]+toReportEntries (BenchmarkResult benName values) =+    concatMap+        ( \(depth, depthValues) ->+            ( \depthVal ->+                ReportEntry+                    { name = printf "%s/%d (%s)" benName depth (show $ mode depthVal)+                    , unit = "seconds"+                    , value = meanExecutionTime depthVal+                    }+            )+                <$> filter (\v -> show (mode v) /= nativeTestName) depthValues+        )+        values

@@ -0,0 +1,105 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}++module Increment (benchmark) where++import Control.DeepSeq+import Control.Monad+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+import Foreign+import Foreign.C+import Utils+import Prelude hiding (concat)++foreign import capi unsafe "benchmark.h increment" c_increment :: Ptr Void -> IO ()++foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()+data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)++instance NFData (Tree1 a) where+    rnf (Leaf1 a) = a `seq` ()+    rnf (Node1 l r) = l `seq` r `seq` ()++$(mkPacked ''Tree1 [])++benchmark :: [Int] -> Benchmark+benchmark depths =+    bgroup+        "increment"+        $ fmap computeTreeSumWithDepth depths++computeTreeSumWithDepth :: Int -> Benchmark+computeTreeSumWithDepth n =+    bgroup+        (depthGroupName n)+        [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $+            bench cTestName . nfAppIO c_increment+        , bench nativeTestName $+            nf increment nativeTree+        , bench (intercalate "-" [packedTestName, "needsbuilder"]) $+            nfAppIO incrementPackedRunner packedTree+        , bench (intercalate "-" ["unpack", "repack"]) $+            nf (pack . increment . fst . unpack) packedTree+        , bench (intercalate "-" [packedTestName, "rebuild-repack"]) $+            nfAppIO repackingIncrementPackedRunner packedTree+        ]+  where+    !packedTree = pack nativeTree+    !nativeTree = buildNativeTree n++increment :: Tree1 Int -> Tree1 Int+increment (Leaf1 n) = Leaf1 (n + 1)+increment (Node1 t1 t2) = Node1 (increment t1) (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++incrementPacked :: PackedReader '[Tree1 Int] r (Needs '[] '[Tree1 Int])+incrementPacked =+    transformTree1+        ( R.do+            n <- reader+            R.return (write (n + 1))+        )+        ( R.do+            left <- incrementPacked+            right <- incrementPacked+            R.return (applyNeeds left N.>> applyNeeds right)+        )++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+  where+    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++repackingIncrementPacked :: PackedReader '[Tree1 Int] r (Tree1 Int)+repackingIncrementPacked =+    caseTree1+        ( R.do+            n <- reader+            R.return (Leaf1 (n + 1))+        )+        ( R.do+            !left <- repackingIncrementPacked+            !right <- repackingIncrementPacked+            R.return (Node1 left right)+        )

@@ -0,0 +1,144 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}++module List (benchmark) where++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)++instance NFData (Tree1 a) where+    rnf Leaf1 = ()+    rnf (Node1 l n r) = n `seq` l `seq` r `seq` ()++$(mkPacked ''Tree1 [InsertFieldSize])++benchmark :: [Int] -> Benchmark+benchmark depths =+    bgroup+        "list"+        []++-- bgroup+--     "from-list"+--     $ fmap buildTreeFromListWithLength depths+-- , bgroup+--     "to-list"+--     $ fmap treeToListWithLength depths++-- buildTreeFromListWithLength :: Int -> Benchmark+-- buildTreeFromListWithLength n =+--     bgroup+--         (depthGroupName n)+--         [ bench nativeTestName $ nf buildTreeFromList list+--         , bench packedTestName $ nfAppIO buildPackedTreeFromList list+--         ]+--   where+--     list = buildUnorderedList n++-- treeToListWithLength :: Int -> Benchmark+-- treeToListWithLength n =+--     bgroup+--         (depthGroupName n)+--         [ bench nativeTestName $ nf treeToList (buildTreeFromList list)+--         , env (buildPackedTreeFromList list) $+--             bench packedTestName+--                 . nfAppIO+--                     (runReader packedTreeToList)+--         ]+-- where+--   list = buildUnorderedList n++buildTreeFromList :: [Int] -> Tree1 Int+buildTreeFromList = foldl (flip insertInTree) Leaf1+  where+    insertInTree n Leaf1 = Node1 Leaf1 n Leaf1+    insertInTree n (Node1 l n' r) =+        if n > n'+            then Node1 l n' (insertInTree n r)+            else Node1 (insertInTree n l) n' r++treeToList :: Tree1 Int -> [Int]+treeToList t = go t []+  where+    go Leaf1 r = r+    go (Node1 l n r) list = go l (n : go r list)++packedTreeToList :: PackedReader '[Tree1 Int] '[] [Int]+packedTreeToList = go []+  where+    go :: [Int] -> PackedReader '[Tree1 Int] r [Int]+    go l =+        caseTree1+            (R.return l)+            ( R.do+                packedLeft <- isolate+                n <- readerWithFieldSize+                packedRight <- isolate+                rightList <- R.lift (go l) packedRight+                R.lift (go $ n : rightList) packedLeft+            )++--+-- buildPackedTreeFromList :: [Int] -> IO (Packed '[Tree1 Int])+-- buildPackedTreeFromList l =+--     finish+--         =<< withEmptyNeeds+--         =<< foldl+--             ( \builder i -> R.do+--                 n <- insertInPackedTree i+--                 R.return (builder N.>> n)+--             )+--             (write Leaf1)+--             l+--   where+--     packedToNeeds :: Packed a -> Needs '[] a+--     packedToNeeds p = let (BS.BS fptr l) = fromPacked p in Needs fptr l l+--     insertInPackedTree ::+--         Int ->+--         PackedReader '[Tree1 Int] '[] (N.NeedsBuilder '[] '[Tree1 Int] '[] '[Tree1 Int])+--     insertInPackedTree n =+--         caseTree1+--             ( mkPackedReader+--                 ( \p l -> do+--                     let n =+--                             ( N.do+--                                 startNode1+--                                 writeWithFieldSize Leaf1+--                                 writeWithFieldSize 0+--                                 writeWithFieldSize Leaf1+--                             )+--                     return (n, p, l)+--                 )+--             )+--             ( R.do+--                 !left <- isolate+--                 !n' <- readerWithFieldSize+--                 !right <- isolate+--                 let !needLeft = packedToNeeds left+--                 let !needRight = packedToNeeds right+--                 needsN' <- mkPackedReader (\p l -> (,p,l) <$> withEmptyNeeds (write n'))+--                 if n > n'+--                     then R.do+--                         right' <- R.lift (insertInPackedTree n) right+--                         R.return (repackNode1 needLeft needsN' right')+--                     else R.do+--                         left' <- R.lift (insertInPackedTree n) left+--                         R.return (repackNode1 left' needsN' needRight)+--             )+--+buildUnorderedList :: Int -> [Int]+buildUnorderedList n = intercalate [(n `div` 2) .. n] [0 .. (n `div` 2) - 1]+  where+    intercalate a [] = a+    intercalate [] b = b+    intercalate (a : b) (c : d) = a : c : intercalate b d

@@ -0,0 +1,70 @@+module Main (main) where++import qualified AST+import qualified Build+import CIReport+import Control.Monad (when)+import Criterion.Main+import Criterion.Main.Options (Mode (..), describe)+import Criterion.Types (Config (..))+import Data.Maybe (isJust, isNothing)+import qualified Increment+import qualified List+import Options.Applicative (execParser)+import qualified Pack+import Plot+import qualified Sum+import System.Directory+import qualified Traversals++main :: IO ()+main = do+    mode <- execParser (describe defaultConfig)+    when (isNothing (csvPath mode) && modeExportOtherThanCsv mode) $ do+        putStrLn "Warning: Graphs will not be generated."+        putStrLn "Warning: Report for CI will not be generated."+        putStrLn "Warning: Use the CSV export function to generate graphs and CI report."+    -- Criterion seems to append the result to the file if it already exists+    -- Therefore, it adds a new header. Cassava does not like this.+    _ <- case csvPath mode of+        Just p -> do+            exists <- doesFileExist p+            when exists (removeFile p)+        _ -> return ()+    runMode mode benchmarks+    case csvPath mode of+        Nothing -> return ()+        Just exportPath -> do+            putStrLn "Generating graph..."+            generateGraphs exportPath+            putStrLn "Generation finished."+            putStrLn "Generating CI report..."+            generateCIReport exportPath+            putStrLn "Generation CI report."+  where+    depths = [1, 5, 10, 15, 20]+    benchmarks =+        [ Traversals.benchmark depths+        , Pack.benchmark depths+        , Increment.benchmark depths+        , Sum.benchmark depths+        , AST.benchmark depths+        , Build.benchmark depths+        , List.benchmark depths+        ]+    csvPath (RunIters cfg _ _ _) = csvPathFromCfg cfg+    csvPath (Run cfg _ _) = csvPathFromCfg cfg+    csvPath _ = Nothing+    csvPathFromCfg = csvFile+    modeExportOtherThanCsv (RunIters cfg _ _ _) = cfgExportOtherThanCsv cfg+    modeExportOtherThanCsv (Run cfg _ _) = cfgExportOtherThanCsv cfg+    modeExportOtherThanCsv _ = False+    cfgExportOtherThanCsv cfg =+        any+            isJust+            $ ($ cfg)+                <$> [ junitFile+                    , jsonFile+                    , reportFile+                    , rawDataFile+                    ]

@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}++module OutputData (+    RawCSVEntry (..),+    BenchmarkMode (..),+    BenchmarkResult (..),+    BenchmarkValue (..),+    readBenchmarkResults,+    genFail,+) where++import qualified Data.ByteString.Lazy as BS+import Data.Char (isDigit)+import Data.Csv+import qualified Data.List.Safe as Safe+import Data.List.Split (splitOn)+import Data.Vector (toList)+import System.Exit+import Text.Read++data RawCSVEntry = RawCSVEntry+    { _name :: String+    , _mean :: Double+    }+instance FromNamedRecord RawCSVEntry where+    parseNamedRecord m = RawCSVEntry <$> m .: "Name" <*> m .: "Mean"++newtype BenchmarkMode = BenchmarkMode String deriving (Eq)++instance Show BenchmarkMode where+    show (BenchmarkMode s) = s++instance Read BenchmarkMode where+    readsPrec _ s = [(BenchmarkMode s, "")]++-- | Processed data+data BenchmarkResult = BenchmarkResult+    { name :: String+    -- ^ Example: Build+    , values :: [(Int, [BenchmarkValue])]+    -- ^ Maps benchmark values with the depths of the related tree.+    }+    deriving (Show)++data BenchmarkValue = BenchmarkValue+    { mode :: BenchmarkMode+    , meanExecutionTime :: Double+    }+    deriving (Show)++readBenchmarkResults :: FilePath -> IO [BenchmarkResult]+readBenchmarkResults csvPath = do+    rawFile <- BS.readFile csvPath+    rawCSVEntries <-+        either+            genFail+            (return . toList . snd)+            (decodeByName rawFile)+    processedCSVEntries <-+        either+            genFail+            return+            (processCSVEntries rawCSVEntries)+    return processedCSVEntries++processCSVEntries :: [RawCSVEntry] -> Either String [BenchmarkResult]+processCSVEntries rawEntries = do+    entries <-+        mapM+            (maybe (Left "Error when processing entry") Right . processCSVEntry)+            rawEntries+    return $ foldr mergeBenchmarkEntries [] entries++processCSVEntry :: RawCSVEntry -> Maybe BenchmarkResult+processCSVEntry (RawCSVEntry rawname mean) = do+    let splitEntryName = splitOn "/" rawname+    benchName <- splitEntryName Safe.!! (length splitEntryName - 3 :: Int)+    benchMode <- readMaybe =<< Safe.last splitEntryName+    depth <- do+        rawDepth <- splitEntryName Safe.!! (length splitEntryName - 2)+        readMaybe $ takeWhile isDigit rawDepth+    let benchValue =+            BenchmarkValue+                { mode = benchMode+                , meanExecutionTime = mean+                }+    return $+        BenchmarkResult+            { name = benchName+            , values = [(depth, [benchValue])]+            }++mergeBenchmarkEntries :: BenchmarkResult -> [BenchmarkResult] -> [BenchmarkResult]+mergeBenchmarkEntries benRes [] = [benRes]+mergeBenchmarkEntries benRes (mergedRes : mergedRest) =+    let benValue = head $ snd $ head (values benRes)+        depth = fst $ head (values benRes)+     in if name benRes == name mergedRes+            then mergedRes{values = mergeBenchmarkValues depth benValue (values mergedRes)} : mergedRest+            else mergedRes : mergeBenchmarkEntries benRes mergedRest+  where+    mergeBenchmarkValues :: Int -> BenchmarkValue -> [(Int, [BenchmarkValue])] -> [(Int, [BenchmarkValue])]+    mergeBenchmarkValues depth val [] = [(depth, [val])]+    mergeBenchmarkValues valDepth val ((depth, vals) : b) =+        if valDepth == depth+            then (depth, val : vals) : b+            else (depth, vals) : mergeBenchmarkValues valDepth val b++-- | Prints error message, and exits+genFail :: (Show a) => a -> IO b+genFail msg = do+    putStrLn "An error occured while generating graphs:"+    print msg+    exitFailure

@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Pack (benchmark) where++import Control.DeepSeq+import Criterion.Main+import Data.Packed+import Utils+import Prelude hiding (sum)++data Tree1 a = Leaf1 a | Node1 !(Tree1 a) !(Tree1 a)+data Tree2 a = Leaf2 a | Node2 !(Tree2 a) !(Tree2 a)++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [])++instance NFData (Tree1 a) where+    rnf (Leaf1 a) = a `seq` ()+    rnf (Node1 l r) = l `seq` r `seq` ()++benchmark :: [Int] -> Benchmark+benchmark depths =+    bgroup+        "pack"+        $ fmap buildTreeWithDepth depths++buildTreeWithDepth :: Int -> Benchmark+buildTreeWithDepth n =+    bgroup+        (depthGroupName n)+        [ bench packedTestName $ nf Data.Packed.pack (buildNativeTree n)+        , bench packedWithFieldSizeTestName $ nf Data.Packed.pack (buildNativeTree2 n)+        ]++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+  where+    subTree = buildNativeTree (n - 1)++buildNativeTree2 :: Int -> Tree2 Int+buildNativeTree2 0 = Leaf2 1+buildNativeTree2 n = Node2 subTree subTree+  where+    subTree = buildNativeTree2 (n - 1)

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}++module Plot (generateGraphs) where++import Control.Monad+import Data.List (nub)+import Graphics.Rendering.Chart.Backend.Diagrams+import Graphics.Rendering.Chart.Easy+import OutputData+import System.Directory (createDirectory, doesDirectoryExist)+import Text.Printf++-- | Generates and saves graphs using CSV exported by Criterion+generateGraphs :: FilePath -> IO ()+generateGraphs csvPath = do+    let outDir = "graphs"+    processedCSVEntries <- readBenchmarkResults csvPath+    outdirExists <- doesDirectoryExist outDir+    unless outdirExists $ createDirectory outDir+    forM_ processedCSVEntries (generateGraph outDir)++generateGraph :: FilePath -> BenchmarkResult -> IO ()+generateGraph outDir benRes = do+    -- TODO: Make this work in windows+    let outFile = printf "%s/%s.svg" outDir (name benRes)+    toFile def outFile $ do+        layout_title .= name benRes+        layout_x_axis . laxis_title .= "Depth of tree"+        layout_y_axis . laxis_title .= "Execution Time"+        forM_ benchTypes $ \m ->+            plot+                ( line+                    (show m)+                    [ [ (depth, meanExecutionTime val)+                      | (depth, vals) <- values benRes+                      , val <- vals+                      , mode val == m+                      ]+                    ]+                )+  where+    benchTypes = nub $ mode <$> concatMap snd (values benRes)

@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}++module Sum (benchmark) where++import Criterion.Main+import Data.ByteString.Internal+import Data.Packed+import qualified Data.Packed.Reader as R+import Data.Void (Void)+import Foreign+import Foreign.C+import Foreign.ForeignPtr.Unsafe+import GHC.IO+import Utils+import Prelude hiding (sum)++foreign import capi unsafe "benchmark.h sum" c_sum :: Ptr Void -> IO CLong++foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()++data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)+data Tree2 a = Leaf2 a | Node2 (Tree2 a) (Tree2 a)++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [InsertFieldSize])++benchmark :: [Int] -> Benchmark+benchmark depths =+    bgroup+        "sum"+        $ fmap computeTreeSumWithDepth depths++computeTreeSumWithDepth :: Int -> Benchmark+computeTreeSumWithDepth n =+    bgroup+        (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 packedWithUnpackTestName $ whnf (sum . fst . unpack) packedTree+        , bench packedWithFieldSizeTestName $ whnfAppIO (R.runReader sumPacked2) packedTree2+        , bench nonMonadicPackedTestName $ nfAppIO sumPackedNonMonadic packedTree+        , bench nonMonadicPackedWithSizeTestName $ nfAppIO sumPackedNonMonadic2 packedTree2+        ]+  where+    !packedTree = pack nativeTree+    !packedTree2 = pack (buildNativeTree2 n)+    !nativeTree = buildNativeTree n++sum :: Tree1 Int -> Int+sum (Leaf1 n) = n+sum (Node1 t1 t2) = sum t1 + sum t2++sumPacked :: PackedReader '[Tree1 Int] r Int+sumPacked =+    caseTree1+        ( R.do+            !n <- reader+            R.return n+        )+        ( R.do+            !left <- sumPacked+            !right <- sumPacked+            let !res = left + right+            R.return res+        )++sumPacked2 :: PackedReader '[Tree2 Int] r Int+sumPacked2 =+    caseTree2+        ( R.do+            !n <- readerWithFieldSize+            R.return n+        )+        ( R.do+            !left <- skip R.>> sumPacked2+            !right <- skip R.>> sumPacked2+            let !res = left + right+            R.return res+        )+sumPackedNonMonadic :: Packed (Tree1 Int ': r) -> IO Int+sumPackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+  where+    (BS fptr _) = fromPacked packed+    go :: Ptr Word8 -> IO (Int, Ptr Word8)+    go ptr = do+        tag <- peek ptr :: IO Word8+        let !nextPtr = ptr `plusPtr` 1+        case tag of+            0 -> do+                !n <- peek nextPtr+                let !nextPtr1 = ptr `plusPtr` 9+                return (n, nextPtr1)+            1 -> do+                (!left, !r) <- go (castPtr nextPtr)+                (!right, !r1) <- go r+                let !res = left + right+                return (res, r1)+            _ -> undefined++sumPackedNonMonadic2 :: Packed (Tree2 Int ': r) -> IO Int+sumPackedNonMonadic2 packed = fst <$> go (unsafeForeignPtrToPtr fptr)+  where+    sizeOfFieldSize = sizeOf (1 :: Int32)+    (BS fptr _) = fromPacked packed+    go :: Ptr Word8 -> IO (Int, Ptr Word8)+    go ptr = do+        tag <- peek ptr :: IO Word8+        let !nextPtr = ptr `plusPtr` 1+        case tag of+            0 -> do+                !n <- peek (nextPtr `plusPtr` sizeOfFieldSize)+                let !nextPtr1 = ptr `plusPtr` 9 `plusPtr` sizeOfFieldSize+                return (n, nextPtr1)+            1 -> do+                (!left, !r) <- go (castPtr $ nextPtr `plusPtr` sizeOfFieldSize)+                (!right, !r1) <- go (r `plusPtr` sizeOfFieldSize)+                let !res = left + right+                return (res, r1)+            _ -> undefined+buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+  where+    subTree = buildNativeTree (n - 1)++buildNativeTree2 :: Int -> Tree2 Int+buildNativeTree2 0 = Leaf2 1+buildNativeTree2 n = Node2 subTree subTree+  where+    subTree = buildNativeTree2 (n - 1)

@@ -0,0 +1,225 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}++module Traversals (benchmark) where++import Criterion.Main+import Data.ByteString.Internal+import Data.Packed+import qualified Data.Packed.Reader as R+import Data.Void+import Foreign+import Foreign.C+import Foreign.ForeignPtr.Unsafe+import Utils++foreign import capi unsafe "benchmark.h get_right_most" c_get_right_most :: Ptr Void -> IO CLong++foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()++data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)+data Tree2 a = Leaf2 a | Node2 (Tree2 a) (Tree2 a)++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [InsertFieldSize])++benchmark :: [Int] -> Benchmark+benchmark depths =+    bgroup+        "traversals"+        [ bgroup+            "right-most-node"+            $ fmap compareGettingRightMostNode depths+        , bgroup+            "contains"+            $ fmap compareContainsValue depths+        ]++compareGettingRightMostNode :: Int -> Benchmark+compareGettingRightMostNode n =+    bgroup+        (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 packedWithUnpackTestName $ whnf (getRightMostNodeNative . fst . unpack) packedTree+        , bench nonMonadicPackedTestName $ nfAppIO getRightMostNodePackedNonMonadic packedTree+        , bench packedWithFieldSizeTestName $+            nfAppIO (runReader getRightMostNodePacked2) packedTreeWithSize+        , bench nonMonadicPackedWithSizeTestName $ nfAppIO getRightMostNodePacked2NonMonadic packedTreeWithSize+        ]+  where+    packedTree = pack nativeTree+    packedTreeWithSize = pack (tree1ToTree2 nativeTree)+    tree1ToTree2 (Leaf1 l) = Leaf2 l+    tree1ToTree2 (Node1 a b) = Node2 (tree1ToTree2 a) (tree1ToTree2 b)+    nativeTree = buildNativeTree n++getRightMostNodeNative :: Tree1 Int -> Int+getRightMostNodeNative (Leaf1 n) = n+getRightMostNodeNative (Node1 _ r) = getRightMostNodeNative r++getRightMostNodePacked :: PackedReader '[Tree1 Int] r Int+getRightMostNodePacked =+    caseTree1+        reader+        (skip R.>> getRightMostNodePacked)++getRightMostNodePackedNonMonadic :: Packed (Tree1 Int ': r) -> IO Int+getRightMostNodePackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+  where+    (BS fptr _) = fromPacked packed+    go :: Ptr Word8 -> IO (Int, Ptr Word8)+    go ptr = do+        tag <- peek ptr :: IO Word8+        case tag of+            0 -> do+                !n <- peek (plusPtr ptr 1)+                return (n, plusPtr ptr 9)+            1 -> do+                (!_, !r) <- go (plusPtr ptr 1)+                (!right, !r1) <- go r+                return (right, r1)+            _ -> undefined++getRightMostNodePacked2 :: PackedReader '[Tree2 Int] '[] Int+getRightMostNodePacked2 =+    caseTree2+        readerWithFieldSize+        ( R.do+            skipWithFieldSize+            skip R.>> getRightMostNodePacked2+        )++getRightMostNodePacked2NonMonadic :: Packed (Tree2 Int ': r) -> IO Int+getRightMostNodePacked2NonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+  where+    sizeOfFieldSize = sizeOf (1 :: Int32)+    sizeOfInt = sizeOf (1 :: Int)+    (BS fptr _) = fromPacked packed+    go :: Ptr Word8 -> IO (Int, Ptr Word8)+    go ptr = do+        tag <- peek ptr :: IO Word8+        let nextPtr = ptr `plusPtr` 1+        case tag of+            0 -> do+                !n <- peek (plusPtr nextPtr sizeOfFieldSize)+                let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + sizeOfInt)+                return (n, nextPtr1)+            1 -> do+                !fieldSize <- peek (castPtr nextPtr :: Ptr Int32)+                let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + fromIntegral fieldSize) `plusPtr` sizeOfFieldSize+                (!right, !r1) <- go nextPtr1+                return (right, r1)+            _ -> undefined++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 0+buildNativeTree n = Node1 subTree subTree+  where+    subTree = buildNativeTree (n - 1)++-- Contains++compareContainsValue :: Int -> Benchmark+compareContainsValue n =+    bgroup+        (depthGroupName n)+        [ bench nativeTestName $ nf (containsNative value) nativeTree+        , bench packedTestName $ nfAppIO (runReader (containsPacked value)) packedTree+        , bench nonMonadicPackedTestName $ nfAppIO (containsNonMonadic value) packedTree+        , bench packedWithFieldSizeTestName $+            nfAppIO (runReader (containsPacked2 value)) packedTreeWithSize+        , bench nonMonadicPackedWithSizeTestName $ nfAppIO (containsNonMonadic2 value) packedTreeWithSize+        ]+  where+    packedTree = pack nativeTree+    packedTreeWithSize = pack (tree1ToTree2 nativeTree)+    tree1ToTree2 (Leaf1 l) = Leaf2 l+    tree1ToTree2 (Node1 a b) = Node2 (tree1ToTree2 a) (tree1ToTree2 b)+    nativeTree = buildNativeTreeContains n value+    value = 500++containsNative :: Int -> Tree1 Int -> Bool+containsNative value (Leaf1 n) = n == value+containsNative value (Node1 s1 s2) = containsNative value s1 || containsNative value s2++containsPacked :: Int -> PackedReader '[Tree1 Int] r Bool+containsPacked n =+    caseTree1+        ( R.do+            i <- reader+            R.return (i == n)+        )+        ( R.do+            s1 <- containsPacked n+            if s1 then skip R.>> R.return s1 else containsPacked n+        )++containsPacked2 :: Int -> PackedReader '[Tree2 Int] r Bool+containsPacked2 n =+    caseTree2+        ( R.do+            i <- readerWithFieldSize+            R.return (i == n)+        )+        ( R.do+            s1 <- skip R.>> containsPacked2 n+            if s1 then skipWithFieldSize R.>> R.return s1 else skip R.>> containsPacked2 n+        )++containsNonMonadic :: Int -> Packed (Tree1 Int ': r) -> IO Bool+containsNonMonadic n packed = fst <$> go (unsafeForeignPtrToPtr fptr)+  where+    (BS fptr _) = fromPacked packed+    go :: Ptr Word8 -> IO (Bool, Ptr Word8)+    go ptr = do+        tag <- peek ptr :: IO Word8+        case tag of+            0 -> do+                !i <- peek (plusPtr ptr 1)+                return (i == n, plusPtr ptr 9)+            1 -> do+                (!b, !r) <- go (plusPtr ptr 1)+                if b+                    then do+                        (!_, !r1) <- go r+                        return (True, r1)+                    else do+                        (!right, !r1) <- go r+                        return (right, r1)+            _ -> undefined++containsNonMonadic2 :: Int -> Packed (Tree2 Int ': r) -> IO Bool+containsNonMonadic2 n packed = fst <$> go (unsafeForeignPtrToPtr fptr)+  where+    sizeOfFieldSize = sizeOf (1 :: Int32)+    sizeOfInt = sizeOf (1 :: Int)+    (BS fptr _) = fromPacked packed+    go :: Ptr Word8 -> IO (Bool, Ptr Word8)+    go ptr = do+        tag <- peek ptr :: IO Word8+        let nextPtr = ptr `plusPtr` 1+        case tag of+            0 -> do+                !i <- peek (plusPtr nextPtr sizeOfFieldSize)+                let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + sizeOfInt)+                return (i == n, nextPtr1)+            1 -> do+                let subTree1Ptr = nextPtr `plusPtr` sizeOfFieldSize+                (!b, !nextPtr1) <- go subTree1Ptr+                if b+                    then do+                        !fieldSize <- peek (castPtr nextPtr1 :: Ptr Int32)+                        return (True, castPtr $ nextPtr1 `plusPtr` (sizeOfFieldSize + fromIntegral fieldSize))+                    else go (nextPtr1 `plusPtr` sizeOfFieldSize)+            _ -> undefined++buildNativeTreeContains :: Int -> Int -> Tree1 Int+buildNativeTreeContains 0 _ = Leaf1 0+buildNativeTreeContains 1 n = Node1 (Leaf1 n) (buildNativeTreeContains 0 n)+buildNativeTreeContains depth n = Node1 subTree subTree+  where+    subTree = buildNativeTreeContains (depth - 1) n

@@ -0,0 +1,41 @@+module Utils (+    toRight,+    cTestName,+    nativeTestName,+    packedTestName,+    packedWithUnpackTestName,+    nonMonadicPackedTestName,+    packedWithFieldSizeTestName,+    nonMonadicPackedWithSizeTestName,+    depthGroupName,+) where++import Text.Printf++toRight :: Either b a -> a+toRight (Right a) = a+toRight _ = error "unexpected left"++cTestName :: String+cTestName = "c"++nativeTestName :: String+nativeTestName = "native"++packedTestName :: String+packedTestName = "packed"++packedWithUnpackTestName :: String+packedWithUnpackTestName = "packed-unpacked"++nonMonadicPackedTestName :: String+nonMonadicPackedTestName = "non-monadic-" ++ packedTestName++packedWithFieldSizeTestName :: String+packedWithFieldSizeTestName = "packed-with-size"++nonMonadicPackedWithSizeTestName :: String+nonMonadicPackedWithSizeTestName = "non-monadic-" ++ packedWithFieldSizeTestName++depthGroupName :: Int -> String+depthGroupName = printf "%02d-depth"

@@ -0,0 +1,60 @@+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import Criterion.Main (bench, defaultMain, nf, nfAppIO)+import Data.Packed+import qualified Data.Packed.Reader as R++data Arithmetic where+    Val :: Double -> Arithmetic+    Add :: Arithmetic -> Arithmetic -> Arithmetic+    Sub :: Arithmetic -> Arithmetic -> Arithmetic+    Mul :: Arithmetic -> Arithmetic -> Arithmetic+    Div :: Arithmetic -> Arithmetic -> Arithmetic++$(mkPacked ''Arithmetic [])++eval :: Arithmetic -> Double+eval (Val d) = d+eval (Add a b) = (eval a) + eval b+eval (Sub a b) = eval a - eval b+eval (Mul a b) = eval a * eval b+eval (Div a b) = eval a / eval b++evalPacked :: PackedReader '[Arithmetic] r Double+evalPacked =+    caseArithmetic+        reader+        (fn (+))+        (fn (-))+        (fn (*))+        (fn (/))+  where+    {-# INLINE fn #-}+    fn op = R.do+        !l <- evalPacked+        !r <- evalPacked+        R.return (l `op` r)++main :: IO ()+main = do+    let bigAst = genBigAst+        packedAst = pack bigAst+    defaultMain+        [ bench "packed" $ nfAppIO (runReader evalPacked) packedAst+        , bench "unpacked" $ nf eval bigAst+        ]++genBigAst :: Arithmetic+genBigAst = go 27+  where+    go :: Int -> Arithmetic+    go 0 = Val 3+    go n+        | n `mod` 5 == 0 = Div child child+        | n `mod` 4 == 0 = Mul child child+        | n `mod` 3 == 0 = Sub child child+        | otherwise = Add child child+      where+        child = go (n - 1)

@@ -0,0 +1,199 @@++#include "benchmark.h"+#include <assert.h>+#include <math.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+#include <time.h>++// static long get_nanos(void) {+//   struct timespec ts;+//   timespec_get(&ts, TIME_UTC);+//   return (long)ts.tv_sec * 1000000000L + ts.tv_nsec;+// }++//// AST++long eval(struct AST *t) {+  long left;+  long right;+  switch (t->tag) {+  case VAL:+    return t->value;+  case ADD:+    left = eval(t->left);+    right = eval(t->right);+    return left + right;+  case SUB:+    left = eval(t->left);+    right = eval(t->right);+    return left - right;+  case MUL:+    left = eval(t->left);+    right = eval(t->right);+    return left * right;+  case DIV:+    left = eval(t->left);+    right = eval(t->right);+    return left / right;+  }+}++struct AST *build_ast(int size) {+  struct AST *t = malloc(sizeof(struct AST));++  if (size <= 0) {+    t->tag = VAL;+    t->value = 1;+  } else {+    t->tag = ADD;+    t->left = build_ast(size - 1);+    t->right = build_ast(size - 1);+  }++  return t;+}++void free_ast(struct AST *t) {++  if (t->tag != VAL) {+    free_ast(t->left);+    free_ast(t->right);+  }+  free(t);+}++/// Tree+long sum(struct Tree *t) {+  if (t->tag == LEAF) {+    return t->value;+  } else {+    return sum(t->left) + sum(t->right);+  }+}++long get_right_most(struct Tree *t) {+  if (t->tag == LEAF) {+    return t->value;+  } else {+    return get_right_most(t->right);+  }+}++void increment(struct Tree *t) {+  if (t->tag == LEAF) {+    t->value++;+  } else {+    increment(t->left);+    increment(t->right);+  }+}++struct Tree *build_tree(int size) {+  struct Tree *t = malloc(sizeof(struct Tree));++  if (size <= 0) {+    t->tag = LEAF;+    t->value = 1;+  } else {+    t->tag = NODE;+    t->left = build_tree(size - 1);+    t->right = build_tree(size - 1);+  }++  return t;+}++void free_tree(struct Tree *t) {++  if (t->tag == NODE) {+    free_tree(t->left);+    free_tree(t->right);+  }+  free(t);+}++////////++// void time_sum(int size, struct Tree *tree) {+//   long begin = get_nanos();+//+//   long res = sum(tree);+//+//   long time_spent = (get_nanos() - begin);+//+//   assert(res == pow(2, size));+//   free_tree(tree);+//   // todo free tree+//   printf("Size: %d\n", size);+//   printf("Execution time %ldns\n", time_spent);+// }+//+// void time_traversal(int size, struct Tree *tree) {+//   long begin = get_nanos();+//+//   long res = get_right_most(tree);+//+//   long time_spent = (get_nanos() - begin);+//+//   free_tree(tree);+//   printf("Size: %d\n", size);+//   printf("Execution time %ldns\n", time_spent);+// }++// void time_eval(int size, struct AST *tree) {+//   long begin = get_nanos();+//+//   long res = eval(tree);+//+//   long time_spent = (get_nanos() - begin);+//+//   free_ast(tree);+//   printf("Size: %d\n", size);+//   printf("Execution time %ldns\n", time_spent);+// }+//+// int main(int argc, char **argv) {+//   // TODO Check "sum", "right-most"+//   if (argc < 2) {+//     printf("Expected at least one argument\n");+//     return 1;+//   }+//   if (strcmp(argv[1], "sum") == 0) {+//     printf("right-most\n");+//     if (argc == 3) {+//+//       int tree_size = atoi(argv[2]);+//       time_sum(tree_size, build_tree(tree_size));+//       return 0;+//     }+//     for (int tree_size = 0; tree_size <= 20; tree_size++) {+//+//       time_sum(tree_size, build_tree(tree_size));+//     }+//   } else if (strcmp(argv[1], "right-most") == 0) {+//     printf("right-most\n");+//     if (argc == 3) {+//       int tree_size = atoi(argv[2]);+//       time_traversal(tree_size, build_tree(tree_size));+//       return 0;+//     }+//     for (int tree_size = 0; tree_size <= 20; tree_size++) {+//+//       time_traversal(tree_size, build_tree(tree_size));+//     }+//+//   } else if (strcmp(argv[1], "ast") == 0) {+//     printf("ast\n");+//     if (argc == 3) {+//       int tree_size = atoi(argv[2]);+//       time_eval(tree_size, build_ast(tree_size));+//       return 0;+//     }+//     for (int tree_size = 0; tree_size <= 20; tree_size++) {+//+//       time_eval(tree_size, build_ast(tree_size));+//     }+//   }+// }

@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Data (MBRelations (..), MBLifeSpan (..), MBArea (..), caseMBArea) where++import Data.Aeson+import Data.Packed+import GHC.Generics (Generic)++data MBUnknownObject = MBUnknownObject deriving (Generic)++$(mkPacked ''MBUnknownObject [])+instance FromJSON MBUnknownObject++data MBLifeSpan = MBLifeSpan+    { ended :: Bool+    , end :: Maybe String+    , begin :: Maybe String+    }+    deriving (Generic, Show)++$(mkPacked ''MBLifeSpan [InsertFieldSize])+instance FromJSON MBLifeSpan++data MBRelations = MBRelations+    { targetCredit :: String+    , relationBegin :: Maybe String+    , direction :: String+    , relationTypeId :: String+    , sourceCredit :: String+    , relationType :: String+    , targetType :: String+    , relationEnd :: Maybe String+    , relationEnded :: Bool+    }+    deriving (Generic, Show)++$(mkPacked ''MBRelations [InsertFieldSize])++instance FromJSON MBRelations where+    parseJSON = withObject "relation" $ \v ->+        MBRelations+            <$> v .: "target-credit"+            <*> v .: "begin"+            <*> v .: "direction"+            <*> v .: "type-id"+            <*> v .: "source-credit"+            <*> v .: "type"+            <*> v .: "target-type"+            <*> v .: "end"+            <*> v .: "ended"++data MBArea = MBArea+    { name :: String+    , areaType :: Maybe String+    , lifeSpan :: MBLifeSpan+    , relations :: [MBRelations]+    , id :: String+    , disambiguation :: String+    , sortName :: String+    , typeId :: Maybe String+    }+    deriving (Generic, Show)++$(mkPacked ''MBArea [InsertFieldSize])+instance FromJSON MBArea where+    parseJSON = withObject "Area" $ \v ->+        MBArea+            <$> v .: "name"+            <*> v .: "type"+            <*> v .: "life-span"+            <*> v .: "relations"+            <*> v .: "id"+            <*> v .: "disambiguation"+            <*> v .: "sort-name"+            <*> v .: "type-id"

@@ -0,0 +1,89 @@+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import Control.Monad+import Criterion.Main+import Criterion.Main.Options (describe)+import Data+import Data.Aeson+import qualified Data.ByteString as B (readFile, writeFile)+import Data.Maybe (fromJust)+import Data.Packed+import Data.Packed.Instances (caseList)+import qualified Data.Packed.Reader as R+import GHC.IO.Exception (ExitCode (ExitFailure))+import Options.Applicative (execParser)+import System.Directory+import System.Exit (exitWith)++main :: IO ()+main = do+    let jsonFile = "./areaFull.json"+    let packedFile = "./areaFull.pckd"+    ogJsonExists <- doesPathExist jsonFile+    packedFileExists <- doesPathExist packedFile+    unless ogJsonExists $ do+        putStrLn "Could not find Original JSON"+        putStrLn "Download and unzip a dump of the 'area' table here (also, make it a list):"+        putStrLn "https://data.metabrainz.org/pub/musicbrainz/data/json-dumps/20241130-001001/"+        exitWith (ExitFailure 1)+    unless packedFileExists $ do+        -- l <- readFile jsonFile+        -- writeFile "./test.json" "["+        -- forM_ (lines l) $ \line -> appendFile "./test.json" (line ++ ",\n")+        -- appendFile "./test.json" "]"+        eareas <- eitherDecodeFileStrict jsonFile :: IO (Either String [MBArea])+        case eareas of+            Left err -> putStrLn err >> exitWith (ExitFailure 1)+            Right areas -> B.writeFile packedFile (fromPacked (pack areas))+    -- let bs = fromPacked (pack areas)+    -- _ <- print . name . Prelude.head . fst =<< runReader reader (unsafeToPacked bs)+    -- B.writeFile packedFile bs+    -- rbs <- B.readFile packedFile+    -- print (compare bs rbs)+    -- print (compare (B.length bs) (B.length rbs))+    -- _ <- print . name . Prelude.head . fst =<< runReader reader (unsafeToPacked bs)+    -- return ()+    putStrLn "Ready to start"+    mode <- execParser (describe defaultConfig)+    packed <- B.readFile packedFile+    json <- B.readFile jsonFile+    runMode+        mode+        [ bench "packed" $+            nfAppIO+                (\p -> runReader getTotalAreaNameLengthPacked (unsafeToPacked p))+                packed+        , bench "json" $+            nf+                (getTotalAreaNameLength . fromJust . decodeStrict)+                json+        ]++getTotalAreaNameLengthPacked :: PackedReader '[[MBArea]] '[] Int+getTotalAreaNameLengthPacked =+    caseList+        (R.return 0)+        ( R.do+            !n <-+                caseMBArea+                    ( R.do+                        !n <- readerWithFieldSize+                        skipWithFieldSize+                        skipWithFieldSize+                        skipWithFieldSize+                        skipWithFieldSize+                        skipWithFieldSize+                        skipWithFieldSize+                        skipWithFieldSize+                        R.return n+                    )+            r <- getTotalAreaNameLengthPacked+            R.return (length n + r)+        )++getTotalAreaNameLength :: [MBArea] -> Int+getTotalAreaNameLength [] = 0+getTotalAreaNameLength (area : areas) =+    length (name area) + getTotalAreaNameLength areas

@@ -0,0 +1,252 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           packed-data+version:        0.1.0.0+description:    Build, traverse and deserialise packed data in Haskell+category:       Data+homepage:       https://github.com/Arthi-chaud/packed-haskell#readme+bug-reports:    https://github.com/Arthi-chaud/packed-haskell/issues+author:         Arthi-chaud+maintainer:     aj530@kent.ac.uk+copyright:      2025 Arthi-chaud+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/Arthi-chaud/packed-haskell++library+  exposed-modules:+      Data.Packed+      Data.Packed.Reader+      Data.Packed.Needs+      Data.Packed.Instances+      Data.Packed.TH+      Data.Packed.Skippable+  other-modules:+      Data.Packed.FieldSize+      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.Read+      Data.Packed.TH.RepackCon+      Data.Packed.TH.Skip+      Data.Packed.TH.Skippable+      Data.Packed.TH.Start+      Data.Packed.TH.Transform+      Data.Packed.TH.Unpackable+      Data.Packed.TH.Utils+      Data.Packed.TH.Write+      Data.Packed.TH.WriteCon+      Data.Packed.Unpackable+      Data.Packed.Utils+      Tree+      Paths_packed_data+  autogen-modules:+      Paths_packed_data+  hs-source-dirs:+      src+  default-extensions:+      DataKinds+      TypeOperators+      KindSignatures+      GADTs+      LambdaCase+      TemplateHaskell+      TemplateHaskellQuotes+      TupleSections+      QualifiedDo+  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.12.1.0 && <0.13+    , bytestring-strict-builder >=0.4.5 && <0.5+    , deepseq >=1.5.0.0 && <1.6+    , extra >=1.0 && <2.0+    , mtl >=2.3.1 && <2.4+    , template-haskell >=2.22.0.0 && <2.23+  default-language: Haskell2010++executable packed-exe+  main-is: Main.hs+  other-modules:+      Paths_packed_data+  autogen-modules:+      Paths_packed_data+  hs-source-dirs:+      app+  default-extensions:+      DataKinds+      TypeOperators+      KindSignatures+      GADTs+      LambdaCase+      TemplateHaskell+      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+  build-depends:+      base >=4.7 && <5+    , deepseq+    , mtl+    , packed-data+    , time ==1.14.*+  default-language: Haskell2010++test-suite packed-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      PackedTest.CaseTest+      PackedTest.Data+      PackedTest.IdentityTest+      PackedTest.PackTest+      PackedTest.UnpackTest+      Paths_packed_data+  autogen-modules:+      Paths_packed_data+  hs-source-dirs:+      test+  default-extensions:+      DataKinds+      TypeOperators+      KindSignatures+      GADTs+      LambdaCase+      TemplateHaskell+      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 -Wno-orphans -Wno-redundant-constraints+  build-depends:+      base >=4.7 && <5+    , bytestring+    , bytestring-strict-builder >=0.4.5 && <0.5+    , hspec+    , packed-data+  default-language: Haskell2010++benchmark ast-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_packed_data+  autogen-modules:+      Paths_packed_data+  hs-source-dirs:+      benchmark/ast+  default-extensions:+      DataKinds+      TypeOperators+      KindSignatures+      GADTs+      LambdaCase+      TemplateHaskell+      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=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints+  build-depends:+      base >=4.7 && <5+    , criterion+    , optparse-applicative+    , packed-data+  default-language: Haskell2010++benchmark bigjson-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Data+      Paths_packed_data+  autogen-modules:+      Paths_packed_data+  hs-source-dirs:+      benchmark/bigjson+  default-extensions:+      DataKinds+      TypeOperators+      KindSignatures+      GADTs+      LambdaCase+      TemplateHaskell+      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=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , criterion+    , directory+    , optparse-applicative+    , packed-data+  default-language: Haskell2010++benchmark packed-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      AST+      Build+      CIReport+      Increment+      List+      OutputData+      Pack+      Plot+      Sum+      Traversals+      Utils+      Paths_packed_data+  autogen-modules:+      Paths_packed_data+  hs-source-dirs:+      benchmark+  default-extensions:+      DataKinds+      TypeOperators+      KindSignatures+      GADTs+      LambdaCase+      TemplateHaskell+      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=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints+  cc-options: -O2+  include-dirs:+      benchmark+  c-sources:+      benchmark/benchmark.c+  build-depends:+      Chart+    , Chart-diagrams+    , aeson+    , base >=4.7 && <5+    , bytestring+    , cassava+    , criterion+    , deepseq+    , directory+    , filepath+    , listsafe+    , mtl+    , optparse-applicative+    , packed-data+    , split+    , vector+  default-language: Haskell2010

@@ -0,0 +1,49 @@+module Data.Packed (+    -- * Classes+    Packable (..),+    pack,+    Unpackable (..),+    readerWithoutShift,+    unpack,+    unpack',++    -- * Needs+    Needs,+    withEmptyNeeds,+    writeWithFieldSize,+    finish,+    unsafeCastNeeds,++    -- * Packed+    Packed,+    skipWithFieldSize,+    isolate,+    fromPacked,+    unsafeToPacked,+    unsafeCastPacked,++    -- * PackedReader+    PackedReader,+    mkPackedReader,+    runReader,+    readerWithFieldSize,++    -- * Code generation+    mkPacked,+    PackingFlag (..),++    -- * Utils+    FieldSize,+    getFieldSizeFromPacked,+    Skippable (..),+) where++import Data.Packed.FieldSize+import Data.Packed.Instances ()+import Data.Packed.Needs+import Data.Packed.Packable+import Data.Packed.Packed+import Data.Packed.Reader+import Data.Packed.Skippable+import Data.Packed.TH+import Data.Packed.Unpackable

@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Packed.FieldSize (+    FieldSize (..),+    skipWithFieldSize,+    isolate,+    getFieldSizeFromPacked,+    writeWithFieldSize,+    readerWithFieldSize,+    applyNeedsWithFieldSize,+) where++import ByteString.StrictBuilder (builderLength)+import Control.Monad+import qualified Data.ByteString as BS+import Data.Int (Int32)+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)+import qualified Data.Packed.Reader as R+import Data.Packed.Skippable (Skippable (..), unsafeSkipN)+import Data.Packed.Unpackable+import Foreign.Ptr+import Foreign.Storable+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++instance {-# OVERLAPPING #-} Packable FieldSize where+    write (FieldSize value) = mkNeedsBuilder unsafeCastNeeds N.>> write value++instance {-# OVERLAPPING #-} Unpackable FieldSize where+    reader = mkPackedReader $ \packed l -> do+        (fieldSize, rest, l1) <- runPackedReader reader packed l+        return (FieldSize fieldSize, rest, l1)++instance {-# OVERLAPPING #-} Skippable FieldSize where+    skip = unsafeSkipN (sizeOf (1 :: Int32))++{-# INLINE getFieldSizeFromPacked #-}++-- | Returns the size of the packed value.+--+-- __Warning:__ For this to be accurate, there should only be one value packed in the binary strea.+getFieldSizeFromPacked :: Packed '[a] -> FieldSize+getFieldSizeFromPacked packed = FieldSize (fromIntegral $ BS.length (fromPacked packed))++{-# INLINE skipWithFieldSize #-}++-- | 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)++{-# INLINE writeWithFieldSize #-}++-- | Write a value into a 'Data.Packed.Needs.Needs', along with its 'FieldSize'+writeWithFieldSize :: (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)++{-# INLINE applyNeedsWithFieldSize #-}+applyNeedsWithFieldSize :: Needs '[] '[a] -> NeedsWriter' (FieldSize ': a ': '[]) r t+applyNeedsWithFieldSize n@(Needs builder) = write (FieldSize (fromIntegral (builderLength builder))) N.>> applyNeeds n++{-# INLINE readerWithFieldSize #-}++-- | Produces a reader for a value preceded by its 'FieldSize'+readerWithFieldSize :: (Unpackable a) => PackedReader '[FieldSize, a] r a+readerWithFieldSize = skip R.>> reader++{-# 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)

@@ -0,0 +1,17 @@+{-# 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.List (List)+import Data.Packed.TH+import Data.Packed.Unpackable+import Prelude hiding (readList)++$(mkPacked ''List [])+$(mkPacked ''Maybe [])+$(mkPacked ''Either [])

@@ -0,0 +1,84 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Packed.Needs (+    -- * Type+    Needs (..),+    withEmptyNeeds,+    finish,++    -- * Builders+    NeedsBuilder (..),+    NeedsWriter,+    NeedsWriter',+    (>>),+    mkNeedsBuilder,+    withNeeds,++    -- * Mixing Needs together+    concatNeeds,+    applyNeeds,++    -- * Internal+    unsafeCastNeeds,+    (:++:),+) where++import ByteString.StrictBuilder+import Data.Kind+import Data.Packed.Packed+import Data.Packed.Utils+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++unsafeCastNeeds :: Needs a b -> Needs c d+unsafeCastNeeds (Needs b) = Needs b++-- | A wrapper around a function that builds a 'Needs'+--+-- 'ps': The type of the expected input of the source 'Needs'+--+-- 'ts': The type of the final packed data of the source 'Needs'+--+-- 'pd': The type of the expected input of the resuling 'Needs'+--+-- '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+    }++(>>) :: NeedsBuilder p1 t1 p2 t2 -> NeedsBuilder p2 t2 p3 t3 -> NeedsBuilder p1 t1 p3 t3+(NeedsBuilder !b1) >> (NeedsBuilder !b2) = mkNeedsBuilder (\n -> b2 (b1 n))++-- | 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++withEmptyNeeds :: NeedsBuilder a b x y -> Needs x y+withEmptyNeeds (NeedsBuilder !b) = b (Needs mempty)++withNeeds :: Needs x y -> NeedsBuilder x y x1 y1 -> Needs x1 y1+withNeeds needs (NeedsBuilder !next) = next needs++concatNeeds :: Needs p t -> NeedsBuilder '[] t1 p (t1 :++: t)+concatNeeds (Needs !b) = NeedsBuilder (\(Needs s) -> Needs (s <> b))++applyNeeds :: Needs '[] t1 -> NeedsBuilder (t1 :++: r) t r t+applyNeeds (Needs b) = NeedsBuilder (\(Needs s) -> Needs (s <> b))++-- | 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)

@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Packed.Packable (Packable (..), pack) where++import ByteString.StrictBuilder+import Data.Packed.Needs (+    Needs (..),+    NeedsWriter,+    finish,+    mkNeedsBuilder,+    withEmptyNeeds,+ )+import Data.Packed.Packed (Packed)+import Foreign+import Prelude hiding (length)++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))++pack :: (Packable a) => a -> Packed '[a]+pack a = finish (withEmptyNeeds (write a))

@@ -0,0 +1,41 @@+module Data.Packed.Packed (Packed (..), unsafeToPacked, unsafeToPacked', fromPacked, unsafeCastPacked, duplicate) 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 (ForeignPtr (ForeignPtr), ForeignPtrContents (FinalPtr))++-- | 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+newtype Packed (l :: [Type]) = Packed ByteString++instance NFData (Packed a) where+    rnf packed = fromPacked packed `Prelude.seq` ()++-- | Duplicates a 'Packed' buffer. The returned 'Packed' is independent from the source one.+duplicate :: Packed a -> Packed a+duplicate (Packed bs) = Packed $ copy bs++{-# INLINE unsafeToPacked #-}++-- | UNSAFE: Casts a generic 'ByteString' into a 'Data.Packed.Needs'+unsafeToPacked :: ByteString -> Packed a+unsafeToPacked = Packed++{-# INLINE fromPacked #-}++-- | Extracts the raw buffer from a 'Data.Packed' value+fromPacked :: Packed a -> ByteString+fromPacked (Packed bs) = bs++{-# INLINE unsafeCastPacked #-}++-- | 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)

@@ -0,0 +1,156 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- It is recommended to import this module like so:+--+-- @+-- import qualified Data.Packed.Reader as R+-- @+module Data.Packed.Reader (+    PackedReader (..),+    mkPackedReader,+    runReader,+    (>>=),+    (>>),+    lift,+    fail,+    return,+    ReaderPtr,+    finishReader,+) where++import Data.ByteString.Internal+import Data.Packed.Needs (Needs, finish)+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 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+--+-- 'r' the packed type after the encoded values to read+--+-- 'v' the type of the value to unpack+--+-- __Note:__ It is an indexed monad.+newtype PackedReader p r v = PackedReader+    { runPackedReader ::+        ReaderPtr (p :++: r) ->+        Int ->+        IO (v, ReaderPtr r, Int)+    }++{-# INLINE mkPackedReader #-}++-- | Builds a 'PackedReader'+mkPackedReader ::+    ( ReaderPtr (p :++: r) ->+      Int ->+      IO (v, ReaderPtr r, Int)+    ) ->+    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)++{-# INLINE (>>=) #-}++-- | Allows bindings 'Data.Packed.Reader.PackedReader' together, in a monad-like manner.+--+-- Similar to 'Prelude.>>='+(>>=) ::+    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)++{-# INLINE (>>) #-}++-- | Similar to 'Prelude.>>'+(>>) ::+    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++{-# INLINE return #-}++-- | Like 'Prelude.return', wraps a value in a 'PackedReader' that will not consume its input.+return :: v -> PackedReader '[] r v+return value = PackedReader $ \(!packed) !l ->+    Prelude.return (value, packed, l)++{-# INLINE fail #-}+fail :: String -> PackedReader '[] r v+fail msg = mkPackedReader $ \_ _ -> Prelude.fail msg++-- | Allows reading another packed value in a do-notation.+--+-- The reading of the second stream does not consume anything from the first.+--+-- __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+--                 )+-- @+{-# INLINE lift #-}+lift ::+    PackedReader a b v ->+    Packed (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

@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Packed.Skippable (Skippable (..), unsafeSkipN) where++import Data.Kind+import Data.Packed.Reader+import Foreign (plusPtr)+import Foreign.Storable++class Skippable a where+    -- A function that moves the cursor at the end of the first packed value in the buffer.+    --+    -- Beware, this does not rely on `Data.Packed.FieldSize`, therefore it usually entails a traversals+    skip :: PackedReader '[a] r ()++instance (Storable a) => Skippable a where+    skip = unsafeSkipN (sizeOf (undefined :: a))++{-# INLINE unsafeSkipN #-}++-- | 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)

@@ -0,0 +1,92 @@+-- | Module responsible for generating various functions to manipulate packed data.+--+-- __Note__: For each example, consider that the code is generated for the following type:+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- @+module Data.Packed.TH (+    -- * Entrypoint+    mkPacked,+    PackingFlag (..),++    -- * Generate Case function+    genCase,++    -- * Generate Packing function+    genPackableInstance,+    genConstructorPackers,+    genConstructorRepackers,+    genWrite,+    genConWrite,+    genStart,++    -- * Generate Unpacking function+    genUnpackableInstance,+    genRead,++    -- * Generate Skip function+    genSkippableInstance,+    genSkip,++    -- * Generate Transform function+    genTransform,++    -- * Misc+    Tag,+) where++import Data.Packed.TH.Case+import Data.Packed.TH.Flag+import Data.Packed.TH.PackCon (genConstructorPackers)+import Data.Packed.TH.Packable+import Data.Packed.TH.Read+import Data.Packed.TH.RepackCon+import Data.Packed.TH.Skip+import Data.Packed.TH.Skippable (genSkippableInstance)+import Data.Packed.TH.Start+import Data.Packed.TH.Transform (genTransform)+import Data.Packed.TH.Unpackable+import Data.Packed.TH.Utils+import Data.Packed.TH.Write+import Data.Packed.TH.WriteCon+import Language.Haskell.TH++-- | Generate the following for the given type+--+--   - A 'case' function (see 'genCase')+--+--   - An instance of 'Data.Packed.Packable' (see 'genPackableInstance')+--+--   - An instance of 'Data.Packed.Unpackable' (see 'genUnpackableInstance')+--+--   - An instance of 'Data.Packed.Skippable' (see 'genSkippableInstance')+--+--  __Example:__+--+--+-- @+--  $('mkPacked' ''Tree ['Data.Packed.TH.InsertFieldSize'])+-- @+mkPacked ::+    -- | The name of the type to generate the functions for+    Name ->+    -- | Generation customisation flags+    [PackingFlag] ->+    Q [Dec]+mkPacked tyName flags = do+    caseFunction <- genCase flags tyName+    packableInstance <- genPackableInstance flags tyName+    unpackableInstance <- genUnpackableInstance flags tyName+    constructorPackers <- genConstructorPackers flags tyName+    constructorRepackers <- genConstructorRepackers flags tyName+    skipInstance <- genSkippableInstance flags tyName+    transformFunction <- genTransform flags tyName+    return $+        caseFunction+            ++ packableInstance+            ++ unpackableInstance+            ++ constructorPackers+            ++ constructorRepackers+            ++ skipInstance+            ++ transformFunction

@@ -0,0 +1,115 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Packed.TH.Case (caseFName, genCase) where++import Data.Packed.FieldSize+import Data.Packed.Reader hiding (return)+import Data.Packed.TH.Flag+import Data.Packed.TH.Utils (Tag, getNameAndBangTypesFromCon, resolveAppliedType, sanitizeConName)+import Data.Packed.Utils ((:++:))+import Language.Haskell.TH++caseFName :: Name -> Name+caseFName tyName = mkName $ "case" ++ nameBase tyName++-- | Generates a function to allow pattern matching a packed data type using the data constructors+--+--  __Example:__+--+-- For the 'Tree' data type, it generates the following function:+--+-- @+-- caseTree ::+--     ('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"+-- @+genCase ::+    [PackingFlag] ->+    -- | The name of the type to generate the function for+    Name ->+    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+    signature <- genCaseSignature flags tyName+    return+        [ signature+        , FunD+            (caseFName tyName)+            [Clause (VarP <$> 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+    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 =+        -- 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) []+                )+                    <$> zip [0 ..] casePatterns+            fallbackMatch = do+                fallbackBody <- [|Prelude.fail "Bad Tag"|]+                return $ Match WildP (NormalB fallbackBody) []+         in caseE [|$(varE e) :: Tag|] $ matches ++ [fallbackMatch]++-- For a type 'Tree', generates the following signature+-- caseTree ::+--     ('Data.Packed.PackedReader' '[a] r b) ->+--     ('Data.Packed.PackedReader' '[Tree a, Tree a] r b) ->+--     'Data.Packed.PackedReader' '[Tree a] r b+genCaseSignature :: [PackingFlag] -> Name -> Q Dec+genCaseSignature flags tyName = do+    (sourceType, _) <- resolveAppliedType tyName+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    bVar <- newName "b"+    rVar <- newName "r"+    let+        bType = varT bVar+        rType = varT rVar+        lambdaTypes = (\c -> buildLambdaType c bType rType) <$> cs+        outType = [t|PackedReader '[$(return sourceType)] $rType $bType|]+    signature <- foldr (\lambda out -> [t|$lambda -> $out|]) outType lambdaTypes+    return $ SigD (caseFName tyName) signature+  where+    -- From a constructor (say Leaf a), build type PackedReader '[a] r b+    buildLambdaType con returnType restType = do+        let constructorTypeNames = snd <$> snd (getNameAndBangTypesFromCon con)+            packedContentType =+                foldr+                    ( \(i, x) xs ->+                        if (InsertFieldSize `elem` flags) && (SkipLastFieldSize `notElem` flags || (SkipLastFieldSize `elem` flags && i /= 1))+                            then [t|'[FieldSize, $(return x)] :++: $xs|]+                            else [t|$(return x) ': $xs|]+                    )+                    [t|'[]|]+                    $ zip (reverse [0 .. length constructorTypeNames]) constructorTypeNames+        [t|PackedReader ($packedContentType) $restType $returnType|]

@@ -0,0 +1,38 @@+module Data.Packed.TH.Flag (PackingFlag (..)) where++-- | Options for the generation process.+--+-- __Beware__: these options alter the signature and behaviour of the generated functions.+data PackingFlag+    = -- | When specified, each field in a packed data constructor will be preceded by a 'Data.Packed.TH.FieldSize',+      -- which indicates the size of the following packed value.+      --+      -- __Example__+      --+      -- As a consequence, for the following type, the `caseTree` function will have the following signature+      --+      -- @+      --+      -- caseTree ::+      --     ('Data.Packed.PackedReader' ('Data.Packed.FieldSize' ': a ': r) r b) ->+      --     ('Data.Packed.PackedReader' ('Data.Packed.FieldSize' ': Tree a ': 'Data.Packed.FieldSize' ': Tree a ': r) r b) ->+      --     'Data.Packed.PackedReader' (Tree a ': r) r b+      -- @+      InsertFieldSize+    | -- | This flag should be used in complement to 'InsertFieldSize'+      --+      -- If set, no 'Data.Packed.FieldSize' will be inserted before the last parameter of the data constructor.+      --+      -- __Example__+      --+      -- If this flag is set (along with 'InsertFieldSize'), for the following type,+      -- the `caseTree` function will have the following signature+      --+      -- @+      -- caseTree ::+      --     ('Data.Packed.PackedReader' (a ': r) r b) ->+      --     ('Data.Packed.PackedReader' ('Data.Packed.FieldSize' ': Tree a ': Tree a ': r) r b) ->+      --     'Data.Packed.PackedReader' (Tree a ': r) r b+      -- @+      SkipLastFieldSize+    deriving (Eq)

@@ -0,0 +1,58 @@+module Data.Packed.TH.PackCon (genConstructorPackers) where++import Data.Packed.Needs+import Data.Packed.Packable+import Data.Packed.Packed+import Data.Packed.TH.Flag (PackingFlag)+import Data.Packed.TH.Utils+import Data.Packed.TH.WriteCon+import Language.Haskell.TH++-- | Generates a function that serialises an applied data constructor+--+-- The function calls the functions generated by 'Data.Packed.TH.genConWrite'+--+-- __Example:__+--+-- For the 'Tree' data type, it generates the following functions+--+-- @+-- packLeaf :: ('Packable' a) => a -> 'Data.Packed' '[Tree a]+-- packLeaf n = 'finish' ('withEmptyNeeds' (writeLeaf n))+--+-- packNode :: ('Packable' a) => Tree a -> Tree a -> 'Data.Packed' '[Tree a]+-- packNode t1 t2 = 'finish' ('withEmptyNeeds' (writeNode t1 t2))+-- @+genConstructorPackers :: [PackingFlag] -> Name -> Q [Dec]+genConstructorPackers flags tyName = do+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    packers <-+        mapM+            ( \con ->+                let (conName, bt) = getNameAndBangTypesFromCon con+                 in genConstructorPacker flags conName (snd <$> bt)+            )+            cs+    return $ concat packers++packConFName :: Name -> Name+packConFName conName = mkName $ "pack" ++ sanitizeConName conName++genConstructorPacker :: [PackingFlag] -> Name -> [Type] -> Q [Dec]+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))|]+    signature <- genConstructorPackerSig flags conName argTypes+    return+        [ signature+        , FunD (packConFName conName) [Clause (VarP <$> varNames) (NormalB body) []]+        ]++genConstructorPackerSig :: [PackingFlag] -> Name -> [Type] -> Q Dec+genConstructorPackerSig _ conName argTypes = do+    (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+    return $ SigD (packConFName conName) $ ForallT [] constraints signature

@@ -0,0 +1,42 @@+module Data.Packed.TH.Packable (genPackableInstance) where++import Data.Packed.Packable+import Data.Packed.TH.Flag (PackingFlag)+import Data.Packed.TH.Utils (resolveAppliedType)+import Data.Packed.TH.Write+import Language.Haskell.TH++-- | Generates an instance of 'Packable' for the given type+--+-- All the parameters of each constructor should be instances of 'Packable'+--+-- Note: The pack function simply calls the function generated by 'genWrite'+--+-- __Example__+--+-- For the 'Tree' data type, it generates the following instance:+--+-- @+-- instance ('Packable' a) => 'Packable' (Tree a) where+--     write = writeTree+-- @+genPackableInstance ::+    [PackingFlag] ->+    -- | The name of the type to generate the instance for+    Name ->+    Q [Dec]+genPackableInstance flags tyName = do+    (resolvedType, typeParameterNames) <- resolveAppliedType tyName+    constraints <- mapM (\t -> [t|Packable $(varT t)|]) typeParameterNames+    instanceType <- [t|Packable $(return resolvedType)|]+    writeFunc <- genWrite flags tyName+    toNeedsExpr <- varE $ writeFName tyName+    toNeedsMethod <- funD 'write [clause [] (normalB (return toNeedsExpr)) []]+    return $+        writeFunc+            ++ [ InstanceD+                    (Just Overlapping)+                    constraints+                    instanceType+                    [toNeedsMethod]+               ]

@@ -0,0 +1,101 @@+{-# LANGUAGE QualifiedDo #-}++module Data.Packed.TH.Read (readFName, genRead) where++import Data.Packed.Reader hiding (return)+import qualified Data.Packed.Reader as R+import Data.Packed.TH.Case (caseFName)+import Data.Packed.TH.Flag (PackingFlag (..))+import Data.Packed.TH.Utils+import Data.Packed.Unpackable+import Language.Haskell.TH++readFName :: Name -> Name+readFName tyName = mkName $ "read" ++ nameBase tyName++-- | Generates an function to read (i.e. deserialise) the given data type.+--+--  __Example:__+--+-- For the 'Tree' data type, it generates the following function:+--+-- @+-- readTree :: ('Unpackable' a) => 'Data.Packed.PackedReader' '[Tree a] r (Tree a)+-- readTree = caseTree+--     ('Data.Packed.reader' >>= \\leafContent ->+--          'Data.Packed.Reader.return' $ Leaf leafContent+--     )+--+--     ('Data.Packed.reader' >>= \\leftContent ->+--      'Data.Packed.reader' >>= \\rightContent ->+--          'Data.Packed.Reader.return' $ Node leftContent rightContent+--     )+-- @+--+-- __Note__ We use bindings ('Data.Packed.Reader.>>=') intead of a do-notation, since 'Data.Packed.Reader' is not a monad. It's an indexed monad, meaning that the user would have to enable the 'QualifiedDo' extenstion for it to compile.+genRead ::+    [PackingFlag] ->+    Name ->+    -- | The name of the type to generate the function for+    Q [Dec]+genRead flags tyName = do+    let fName = readFName tyName+    (resolvedType, typeVariables) <- resolveAppliedType tyName+    lambdas <- genReadLambdas flags tyName+    -- we fold the list of lambda by applring them to `caseTree packed`+    funExpr <-+        foldl+            (\rest arg -> [|$rest $(return arg)|])+            (varE $ caseFName tyName)+            lambdas+    let fun = FunD fName [Clause [] (NormalB funExpr) []]+    signature <- genReadSignature tyName resolvedType typeVariables+    return [signature, fun]++-- Generates all the lambda functions we will need, to unpack using caseTree+genReadLambdas :: [PackingFlag] -> Name -> Q [Exp]+genReadLambdas flags tyName = do+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    mapM+        ( \con ->+            let (conName, bt) = getNameAndBangTypesFromCon con+             in genReadLambda flags conName (snd <$> bt)+        )+        cs++-- generates a single lambda to use with caseTree for our unpack method+genReadLambda :: [PackingFlag] -> Name -> [Type] -> Q Exp+genReadLambda flags conName conParameterTypes = do+    let appliedConstructor =+            foldl+                (\rest arg -> AppE rest $ VarE arg)+                (ConE conName)+                $ (\i -> mkName $ "arg" ++ show i)+                    <$> [0 .. (length conParameterTypes - 1)]+    buildBindingExpression appliedConstructor+  where+    hasSizeFlag = InsertFieldSize `elem` flags+    skipLastFieldSizeFlag = SkipLastFieldSize `elem` flags+    buildBindingExpression :: Exp -> Q Exp+    buildBindingExpression appliedConstructor =+        foldr+            ( \(argIndex, hasSize) ret ->+                let+                    skipAndUnpack = [|skip R.>> $unpackExpr|]+                    unpackExpr = [|reader R.>>= \($(varP $ mkName $ "arg" ++ show argIndex)) -> $ret|]+                 in+                    if hasSize then skipAndUnpack else unpackExpr+            )+            [|R.return ($(parensE (return appliedConstructor)))|]+            $ (\i -> (i, hasSizeFlag && (not skipLastFieldSizeFlag || (skipLastFieldSizeFlag && i /= length conParameterTypes - 1))))+                <$> [0 .. (length conParameterTypes - 1)]++-- For a type 'Tree', generates the following function signature+-- readTree :: ('Unpackable' a) => 'Data.Packed.PackedReader' '[Tree a] r (Tree a)+genReadSignature :: Name -> Type -> [Name] -> Q Dec+genReadSignature tyName resolvedType typeVariables = do+    restTypeName <- newName "r"+    let readerType = [t|PackedReader '[$(return resolvedType)] $(varT restTypeName) ($(return resolvedType))|]+        constraints = mapM (\tyVarName -> [t|Unpackable $(varT tyVarName)|]) typeVariables+        signature = readerType+    sigD (readFName tyName) $ forallT [] constraints signature

@@ -0,0 +1,70 @@+module Data.Packed.TH.RepackCon (genConstructorRepackers) where++import Data.Packed.FieldSize+import Data.Packed.Needs (Needs, applyNeeds, withEmptyNeeds)+import qualified Data.Packed.Needs as N+import Data.Packed.TH.Flag+import Data.Packed.TH.Start (startFName)+import Data.Packed.TH.Utils+import Language.Haskell.TH++-- | Generates a function that builds back data using already serialised fields+--+-- __Example:__+--+-- For the 'Tree' data type, it generates the following functions+--+-- @+-- repackLeaf :: 'Data.Packed.Needs' '[] a -> 'Data.Packed.Needs' '[] (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)+-- @+genConstructorRepackers :: [PackingFlag] -> Name -> Q [Dec]+genConstructorRepackers flags tyName = do+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    packers <-+        mapM+            ( \con ->+                let (conName, bt) = getNameAndBangTypesFromCon con+                 in genConstructorRepacker flags conName (snd <$> bt)+            )+            cs+    return $ concat packers++repackConFName :: Name -> Name+repackConFName conName = mkName $ "repack" ++ sanitizeConName conName++genConstructorRepacker :: [PackingFlag] -> Name -> [Type] -> Q [Dec]+genConstructorRepacker flags conName argTypes = do+    let argCount = length argTypes+        needsFieldSize i =+            (InsertFieldSize `elem` flags)+                && ( (SkipLastFieldSize `notElem` flags)+                        || i < argCount - 1+                   )+    varNames <- mapM (\_ -> newName "t") argTypes+    writeExp <-+        let concated =+                foldl+                    ( \rest (i, p) ->+                        if needsFieldSize i+                            then [|($rest) N.>> applyNeedsWithFieldSize $(varE p)|]+                            else [|($rest) N.>> applyNeeds $(varE p)|]+                    )+                    [|$(varE $ startFName conName)|]+                    (zip [0 ..] varNames)+         in [|withEmptyNeeds $concated|]+    signature <- genConstructorPackerSig flags conName argTypes+    return+        [ signature+        , FunD (repackConFName conName) [Clause (VarP <$> varNames) (NormalB writeExp) []]+        ]++genConstructorPackerSig :: [PackingFlag] -> Name -> [Type] -> Q Dec+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+    return $ SigD (repackConFName conName) $ ForallT [] [] signature

@@ -0,0 +1,81 @@+module Data.Packed.TH.Skip (genSkip, skipFName) where++import Data.Packed.FieldSize (skipWithFieldSize)+import Data.Packed.Reader (PackedReader)+import qualified Data.Packed.Reader as R+import Data.Packed.Skippable (Skippable (skip))+import Data.Packed.TH.Case (caseFName)+import Data.Packed.TH.Flag (PackingFlag (..))+import Data.Packed.TH.Utils+import Language.Haskell.TH++-- For a data type 'Tree', will generate the function name 'skipTree'+skipFName :: Name -> Name+skipFName tyName = mkName $ "skip" ++ nameBase tyName++-- | Generates an function to skip a value of the given type in a 'Data.Packed.Packed'+--+--  __Example:__+--+-- For the 'Tree' data type, it generates the following function:+--+-- @+-- skipTree :: ('Data.Packed.Skippable' a) => 'Data.Packed.PackedReader' '[Tree a] r ()+-- skipTree = caseTree+--      'Data.Packed.Skip.skip'+--      ('skipTree' >> 'skipTree')+-- @+genSkip :: [PackingFlag] -> Name -> Q [Dec]+genSkip flags tyName = do+    let fName = skipFName tyName+    lambdas <- genSkipLambdas flags tyName+    funExpr <-+        foldl+            (\rest arg -> [|$rest $(return arg)|])+            (varE $ caseFName tyName)+            lambdas+    let fun = FunD fName [Clause [] (NormalB funExpr) []]+    signature <- genSkipSignature tyName+    return [signature, fun]++-- Generates all the lambda functions we will need, to skip using caseTree+genSkipLambdas :: [PackingFlag] -> Name -> Q [Exp]+genSkipLambdas flags tyName = do+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    mapM+        ( \con ->+            let (_, bt) = getNameAndBangTypesFromCon con+             in genSkipLambda flags (snd <$> bt)+        )+        cs++-- generates a single lambda to use with caseTree for our skip method+genSkipLambda :: [PackingFlag] -> [Type] -> Q Exp+genSkipLambda flags conParameterTypes =+    foldr+        ( \hasSize ret ->+            let+                skipFSAndSkipField = [|skipWithFieldSize R.>> $ret|]+                skipField = [|skip R.>> $ret|]+             in+                if hasSize then skipFSAndSkipField else skipField+        )+        [|R.return ()|]+        $ (\i -> hasSizeFlag && (not skipLastFieldSizeFlag || (skipLastFieldSizeFlag && i /= length conParameterTypes - 1)))+            <$> [0 .. (length conParameterTypes - 1)]+  where+    hasSizeFlag = InsertFieldSize `elem` flags+    skipLastFieldSizeFlag = SkipLastFieldSize `elem` flags++-- Generates the following function signature for a data type 'Tree'+-- skipTree :: ('Data.Packed.Skippable' a) => 'Data.Packed.PackedReader' '[Tree a] r ()+genSkipSignature :: Name -> Q Dec+genSkipSignature tyName = do+    (sourceType, typeParameterNames) <- resolveAppliedType tyName+    let fName = skipFName tyName+        -- Type variables for Needs+        r = varT $ mkName "r"+        -- Define Skippable constraints on each of the type parameters+        constraints = mapM (\tyVarName -> [t|Skippable $(varT tyVarName)|]) typeParameterNames+        signature = [t|PackedReader '[$(return sourceType)] $r ()|]+    sigD fName (forallT [] constraints signature)

@@ -0,0 +1,35 @@+module Data.Packed.TH.Skippable (genSkippableInstance) where++import Data.Packed.Skippable (Skippable (..))+import Data.Packed.TH.Flag+import Data.Packed.TH.Skip (genSkip, skipFName)+import Data.Packed.TH.Utils+import Language.Haskell.TH++-- | Generates an instance of 'Skippable' for the given type+--+-- All the parameters of each constructor should be instances of 'Skippable'+--+-- __Example__+--+-- For the 'Tree' data type, it generates the following instance:+--+-- @+-- instance ('Skippable' a) => 'Skippable' (Tree a) where+--     skip = skipTree+-- @+genSkippableInstance :: [PackingFlag] -> Name -> Q [Dec]+genSkippableInstance flags tyName = do+    (resolvedType, typeParameterNames) <- resolveAppliedType tyName+    constraints <- mapM (\t -> [t|Skippable $(varT t)|]) typeParameterNames+    instanceType <- [t|Skippable $(return resolvedType)|]+    skipD <- genSkip flags tyName+    skipMethod <- funD 'skip [clause [] (normalB [|$(varE $ skipFName tyName)|]) []]+    return $+        skipD+            ++ [ InstanceD+                    (Just Overlapping)+                    constraints+                    instanceType+                    [skipMethod]+               ]

@@ -0,0 +1,63 @@+module Data.Packed.TH.Start (startFName, genStart) where++import Data.Packed.FieldSize+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'+startFName :: Name -> Name+startFName conName = mkName $ "start" ++ sanitizeConName conName++-- | Generates a function that prepares a 'Data.Packed.Needs' to receive values from a data constructor.+--+-- __Example:__+--+-- For the 'Tree' data type, it generates the following functions+--+-- @+-- startLeaf :: NeedsBuilder (Tree a ': r) t (a ': r) t+-- startLeaf = 'mkNeedsBuilder' (\n -> runBuilder (write (0 :: Word8) ('unsafeCastNeeds' n)))+--+-- startNode :: NeedsBuilder (Tree a ': r) t (Tree a ': Tree a ': r) t+-- startNode = 'mkNeedsBuilder' (\n -> runBuilder (write (1 :: Word8) ('unsafeCastNeeds' n)))+-- @+genStart ::+    [PackingFlag] ->+    -- | The name of the data constructor to generate the function for+    Name ->+    -- | The 'Tag' (byte) to write for this constructor+    Tag ->+    -- | The list of 'Type's of the data constructor's arguments+    [Type] ->+    Q [Dec]+genStart flags conName tag paramTypeList = do+    let fName = startFName conName+        constructorParamTypes = return <$> paramTypeList+    (DataConI _ conType _) <- reify conName+    sig <-+        let r = varT $ mkName "r"+            t = varT $ mkName "t"+            insertFieldSizes = InsertFieldSize `elem` flags+            skipLastFieldSize = SkipLastFieldSize `elem` flags+            -- From the list of the constructor's parameters, generate the correct type for 'Data.Packed.Needs'+            -- For Leaf a, we will obtain Needs (a ': r)+            -- For node, if size flag is enabled, we will get Needs (FieldSize ': Tree a ': FieldSize ': Tree a ': r)+            destNeedsTypeParams =+                foldr+                    ( \(i, x) xs ->+                        if insertFieldSizes && (not skipLastFieldSize || (skipLastFieldSize && i /= 1))+                            then [t|FieldSize ': $x ': $xs|]+                            else [t|$x ': $xs|]+                    )+                    r+                    $ zip (reverse [0 .. length constructorParamTypes]) constructorParamTypes+         in [t|NeedsBuilder ($(return $ getParentTypeFromConstructorType conType) ': $r) $t $destNeedsTypeParams $t|]+    expr <- [|mkNeedsBuilder (\n -> runBuilder (write (tag :: Word8)) (unsafeCastNeeds n))|]+    return+        [ SigD fName sig+        , FunD fName [Clause [] (NormalB expr) []]+        ]

@@ -0,0 +1,100 @@+module Data.Packed.TH.Transform (transformFName, genTransform) where++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+import Data.Packed.TH.Case (caseFName)+import Data.Packed.TH.Flag+import Data.Packed.TH.Start (startFName)+import Data.Packed.TH.Utils+import Language.Haskell.TH++-- | For a constructor 'Leaf', will generate the function name 'transformLeaf'+transformFName :: Name -> Name+transformFName conName = mkName $ "transform" ++ sanitizeConName conName++-- 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])+-- 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)))+genTransform :: [PackingFlag] -> Name -> Q [Dec]+genTransform flags tyName = do+    signature <- genTransformSignature flags tyName+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    body <-+        foldl+            ( \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)))|]+            )+            (varE $ caseFNameForType tyName)+            cs+    return+        [ signature+        , FunD+            (transformFName tyName)+            [Clause (VarP . buildCaseFunctionName <$> filter conHasArguments cs) (NormalB body) []]+        ]+  where+    -- for dataconstructor Leaf, will be 'leafCase'+    buildCaseFunctionName = conNameToCaseFunctionName . fst . getNameAndBangTypesFromCon+    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' '[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])+genTransformSignature :: [PackingFlag] -> Name -> Q Dec+genTransformSignature flags tyName = do+    (sourceType, _) <- resolveAppliedType tyName+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    rVar <- newName "r"+    let+        rType = varT rVar+        lambdaTypes = (\c -> buildLambdaType c sourceType rType) <$> cs+        outType =+            [t|+                PackedReader+                    '[$(return sourceType)]+                    $rType+                    (N.Needs '[] '[$(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 = case snd <$> snd (getNameAndBangTypesFromCon con) of+        [] -> Nothing+        constructorTypeNames -> return $ do+            packedContentType <-+                foldr+                    ( \(i, x) xs ->+                        if (InsertFieldSize `elem` flags) && (SkipLastFieldSize `notElem` flags || (SkipLastFieldSize `elem` flags && i /= 1))+                            then [t|'[FieldSize, $(return x)] :++: $xs|]+                            else [t|$(return x) ': $xs|]+                    )+                    [t|'[]|]+                    $ zip (reverse [0 .. length constructorTypeNames]) constructorTypeNames+            [t|+                PackedReader+                    $(return packedContentType)+                    $restType+                    (N.NeedsBuilder $(return packedContentType) '[$(return ty)] '[] '[$(return ty)])+                |]

@@ -0,0 +1,38 @@+module Data.Packed.TH.Unpackable (genUnpackableInstance) where++import Data.Packed.TH.Flag (PackingFlag)+import Data.Packed.TH.Read+import Data.Packed.TH.Utils (resolveAppliedType)+import Data.Packed.Unpackable+import Language.Haskell.TH++-- | Generates an instance of 'Unpackable' for the given type+--+-- All the parameters of each constructor should be instances of 'Unpackable'+--+-- Note: The unpack function simply calls the function generated by 'genRead'+--+--+-- __Example__+--+-- For the 'Tree' data type, it generates the following instance:+--+-- @+-- instance ('Unpackable' a) => 'Unpackable' (Tree a) where+--    reader = readTree+-- @+genUnpackableInstance :: [PackingFlag] -> Name -> Q [Dec]+genUnpackableInstance flags tyName = do+    (resolvedType, typeParameterNames) <- resolveAppliedType tyName+    constraints <- mapM (\t -> [t|Unpackable $(varT t)|]) typeParameterNames+    instanceType <- [t|Unpackable $(return resolvedType)|]+    readerD <- genRead flags tyName+    readerMethod <- funD 'reader [clause [] (normalB [|$(varE $ readFName tyName)|]) []]+    return $+        readerD+            ++ [ InstanceD+                    (Just Overlapping)+                    constraints+                    instanceType+                    [readerMethod]+               ]

@@ -0,0 +1,51 @@+module Data.Packed.TH.Utils (+    Tag,+    getParentTypeFromConstructorType,+    resolveAppliedType,+    getNameAndBangTypesFromCon,+    sanitizeConName,+) where++import Data.Char+import Data.Word (Word8)+import Language.Haskell.TH++-- | Byte in a 'Data.Packed' value to identify which data constructor is serialised+type Tag = Word8++getParentTypeFromConstructorType :: Type -> Type+getParentTypeFromConstructorType (ForallT _ _ t) = getParentTypeFromConstructorType t+getParentTypeFromConstructorType t@(AppT _ (VarT _)) = t+getParentTypeFromConstructorType (AppT _ t) = getParentTypeFromConstructorType t+getParentTypeFromConstructorType x = x++-- From a type, returns the fully applied type with type variables' names+-- For a type 'Tree', will return (Tree a, [a])+resolveAppliedType :: Name -> Q (Type, [Name])+resolveAppliedType tyName = do+    (TyConI (DataD _ _ boundTypeVar _ _ _)) <- reify tyName+    -- Extract already existing type names from types variables bound to source type+    let typeParameterNames =+            ( \case+                (KindedTV n _ _) -> n+                x -> error $ "unhandled type parameter" ++ show x+            )+                <$> boundTypeVar+    -- Builds back 'Tree a' using type variable names (fold by applying each of them to the source type name)+    sourceType <- foldl (\ty par -> [t|$ty $(varT par)|]) (conT tyName) typeParameterNames+    return (sourceType, typeParameterNames)++getNameAndBangTypesFromCon :: Con -> (Name, [BangType])+getNameAndBangTypesFromCon (NormalC name bt) = (name, bt)+getNameAndBangTypesFromCon (RecC name nbt) = (name, (\(_, b, t) -> (b, t)) <$> nbt)+getNameAndBangTypesFromCon (InfixC bt1 name bt2) = (name, [bt1, bt2])+getNameAndBangTypesFromCon (ForallC _ _ con) = getNameAndBangTypesFromCon con+getNameAndBangTypesFromCon (GadtC (name : _) bt _) = (name, bt)+getNameAndBangTypesFromCon (RecGadtC (name : _) nbt _) = (name, (\(_, b, t) -> (b, t)) <$> nbt)+getNameAndBangTypesFromCon x = error $ "unhandled data constructor: " ++ show x++-- | Sanitize constructor name so that it can be used as a symbol name+sanitizeConName :: Name -> String+sanitizeConName conName = strName $ nameBase conName+  where+    strName s = (\c -> if isAlphaNum c then [c] else show $ ord c) =<< s

@@ -0,0 +1,70 @@+module Data.Packed.TH.Write (genWrite, writeFName) where++import Data.Packed.Needs+import Data.Packed.Packable+import Data.Packed.TH.Flag (PackingFlag)+import Data.Packed.TH.Utils+import Data.Packed.TH.WriteCon+import Language.Haskell.TH++-- For a data type 'Tree', will generate the function name 'writeTree'+writeFName :: Name -> Name+writeFName tyName = mkName $ "write" ++ nameBase tyName++-- | Generates a function that serialises and writes a value into a 'Needs'+--+-- The function simply calls the functions generated by 'Data.Packed.TH.genConWrite'+--+-- __Example:__+--+-- For the 'Tree' data type, it generates the following function+--+-- @+-- writeTree :: ('Packable' a) => Tree a -> 'NeedsWriter' (Tree a) r t+-- writeTree (Leaf n) = writeConLeaf n+-- writeTree (Node l r) = writeConNode l r+-- @+genWrite ::+    [PackingFlag] ->+    -- | The name of the type to generate the function for+    Name ->+    Q [Dec]+genWrite flags tyName = do+    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+    -- For each data constructor, we generate the corresponding clause+    clauses <-+        mapM+            ( \con -> do+                let (conName, types) = getNameAndBangTypesFromCon con+                -- 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+                return $ Clause [ConP conName [] (VarP <$> paramNames)] (NormalB body) []+            )+            cs+    -- For each of the data constructor of the type, we generate the corresponding `writeConXXX`+    -- We define the Tag using the index of the data constructor+    conWriter <-+        mapM+            ( \(index, constructor) ->+                let (conName, types) = getNameAndBangTypesFromCon constructor+                 in genConWrite flags conName index types+            )+            $ zip [0 ..] cs+    signature <- genWriteSignature tyName+    return $ concat conWriter ++ [signature, FunD (writeFName tyName) clauses]++-- Generates the following function signature for a data type 'Tree'+-- writeTree :: ('Packable' a) => Tree a -> 'NeedsWriter' (Tree a) r t+genWriteSignature :: Name -> Q Dec+genWriteSignature tyName = do+    (sourceType, typeParameterNames) <- resolveAppliedType tyName+    let fName = writeFName tyName+        -- Type variables for Needs+        r = varT $ mkName "r"+        t = varT $ mkName "t"+        -- Define Packable constraints on each of the type parameters+        constraints = mapM (\tyVarName -> [t|Packable $(varT tyVarName)|]) typeParameterNames+        signature = [t|$(return sourceType) -> NeedsWriter $(return sourceType) $r $t|]+    sigD fName (forallT [] constraints signature)

@@ -0,0 +1,93 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}++module Data.Packed.TH.WriteCon (genConWrite, conWriteFName) where++import Data.List (group, sort)+import Data.Packed.FieldSize+import Data.Packed.Needs (NeedsWriter)+import qualified Data.Packed.Needs as N+import Data.Packed.Packable+import Data.Packed.TH.Flag (PackingFlag (..))+import Data.Packed.TH.Start (genStart, startFName)+import Data.Packed.TH.Utils+import Language.Haskell.TH++-- For a constructor 'Leaf', will generate the function name 'writeConLeaf'+conWriteFName :: Name -> Name+conWriteFName conName = mkName $ "writeCon" ++ sanitizeConName conName++-- | Generates a function that serialises and write a value to a 'Needs'.+-- The generated function is specific to a single data constructor.+--+-- __Example:__+--+-- For the 'Tree' data type, it generates the following function for the 'Leaf' constructor+--+-- @+-- writeConLeaf :: ('Packable' a) => a -> 'NeedsWriter (Tree a) r t'+-- writeConLeaf n  = startLeaf 'Data.Packed.Needs.>>' 'write' n+-- @+genConWrite ::+    [PackingFlag] ->+    -- | The name of the data constructor to generate the function for+    Name ->+    -- | A unique (to the data type) 'Tag' to identify the packed data constructor.+    --+    -- For example, for a 'Tree' data type,+    -- we would typically use '0' for the 'Leaf' constructor and '1' for the 'Node' constructor+    Tag ->+    [BangType] ->+    Q [Dec]+genConWrite flags conName conIndex bangTypes = do+    (DataConI _ conType _) <- reify conName+    let r = VarT $ mkName "r"+        t = VarT $ mkName "t"+        fName = conWriteFName conName+        paramTypeList = snd <$> bangTypes+        parentType = getParentTypeFromConstructorType conType+    signature <- genConWriteSignature conName paramTypeList parentType r t+    -- for each parameter type, we create a name+    varNameAndType <- mapM (\ty -> (,ty) <$> newName "t") paramTypeList+    -- we either call `encode` for every type parameter, and fold+    body <-+        foldl+            ( \rest (paramName, needsSizeTag) ->+                -- We insert the size before+                if needsSizeTag+                    then [|$rest N.>> writeWithFieldSize $(varE paramName)|]+                    else [|$rest N.>> write $(varE paramName)|]+            )+            [|$(varE $ startFName conName)|]+            ( if InsertFieldSize `elem` flags+                then case reverse varNameAndType of+                    -- Here, 'a' is the last field. We insert a FieldSize iff SkipLastFieldSize is not set+                    (a : b) -> reverse $ (fst a, SkipLastFieldSize `notElem` flags) : ((,True) . fst <$> b)+                    x -> reverse $ (,True) . fst <$> x+                else (,False) . fst <$> varNameAndType+            )+    -- The pattern (lhs of '=' in a function implementation) will be something like '\a needs' for constructor 'Leaf a'+    let patt = VarP . fst <$> varNameAndType+    start <- genStart flags conName conIndex (snd <$> bangTypes)+    return $+        start+            ++ [ signature+               , FunD fName [Clause [] (NormalB $ LamE patt body) []]+               ]++-- Generates the function signature for functions like 'writeConLeaf'+-- writeConLeaf :: ('Packable' a) => a -> 'NeedsWriter (Tree a) r t'+genConWriteSignature :: Name -> [Type] -> Type -> Type -> Type -> Q Dec+genConWriteSignature constructorName constructorArgumentsTypes parentType restType resultType = do+    let funName = conWriteFName constructorName+        typeVariables = filterDuplicates $ concatMap getAllVarInType constructorArgumentsTypes+        -- The signature without the constructor's parameters+        needsWriterType = [t|NeedsWriter $(return parentType) $(return restType) $(return resultType)|]+        constraints = mapM (\tyVar -> [t|(Packable $(return tyVar))|]) typeVariables+        funSignature = foldr (\p rest -> [t|$(return p) -> $rest|]) needsWriterType constructorArgumentsTypes+    sigD funName $ forallT [] constraints funSignature+  where+    getAllVarInType (AppT a b) = getAllVarInType a ++ getAllVarInType b+    getAllVarInType v@(VarT _) = [v]+    getAllVarInType _ = []+    filterDuplicates = map head . sort . group

@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Packed.Unpackable (+    Unpackable (..),+    PackedReader,+    unpack,+    unpack',+    runReader,+    readerWithoutShift,+) where++import Data.Packed.Packed+import Data.Packed.Reader+import Foreign (Storable (peek, sizeOf), castPtr, plusPtr)+import GHC.IO (unsafePerformIO)++-- | 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+    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)++{-# 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)++{-# INLINE unpack #-}++-- | Deserialise a value from a 'Data.Packed.Packed'.+--+-- Returns the unconsumed 'Data.Packed.Packed' portion+unpack :: (Unpackable a) => Packed (a ': r) -> (a, Packed r)+unpack = unsafePerformIO . runReader reader++{-# INLINE unpack' #-}++-- | Same as 'unpack', but throws away the unconsumed bytes+unpack' :: (Unpackable a) => Packed (a : r) -> a+unpack' p = fst $ unpack p

@@ -0,0 +1,17 @@+{-# LANGUAGE TypeFamilies #-}++module Data.Packed.Utils ((:++:)) where++-- | Type operator to concat lists of types+type family a :++: b where+    '[] :++: xs = xs+    (x ': xs) :++: r = x ': (xs :++: r)++-- class+--     (:++:) (xs :: [Type]) (ys :: [Type]) (zs :: [Type])+--         | zs ys -> xs+--         , zs xs -> ys+--+-- instance (ys ~ zs) => (:++:) '[] ys zs+--+-- instance ((:++:) xs ys zs) => (:++:) (x : xs) ys (x : zs)

@@ -0,0 +1,9 @@+{-# 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])

@@ -0,0 +1,28 @@+module PackedTest.CaseTest (specs) where++import Data.Int+import Data.Packed+import qualified Data.Packed.Reader as R+import PackedTest.Data+import Test.Hspec++$(mkPacked ''Tree1 [])++specs :: Spec+specs = describe "Case on Trees" $ do+    it "should get the sum of the values in the tree" $ do+        let tree = pack $ buildTree (10 :: Int64)+            computeSum :: PackedReader '[Tree1 Int64] r Int64+            computeSum =+                caseTree1+                    reader+                    ( R.do+                        leftSum <- computeSum+                        rightSum <- computeSum+                        R.return $ leftSum + rightSum+                    )+        (res, _) <- runReader computeSum tree+        res `shouldBe` 55+  where+    buildTree 0 = Leaf1 0+    buildTree n = if odd n then Node1 (buildTree (n - 1)) (Leaf1 n) else Node1 (Leaf1 n) (buildTree (n - 1))

@@ -0,0 +1,18 @@+module PackedTest.Data (+    Tree1 (..),+    Tree2 (..),+    Tree3 (..),+    Tree4 (..),+    MyData (..),+) where++data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a) deriving (Show, Eq)++data Tree2 a = Leaf2 | Node2 (Tree2 a) a (Tree2 a) deriving (Show, Eq)++data Tree3 a = Leaf3 | Node3 (Tree3 a) (Tree3 a) a deriving (Show, Eq)++-- | Basically the same as Tree1, but could be used to test flags+data Tree4 a = Leaf4 a | Node4 (Tree4 a) (Tree4 a) deriving (Show, Eq)++data MyData = SmallData Int | BigData String deriving (Eq, Show)

@@ -0,0 +1,24 @@+module PackedTest.IdentityTest (specs) where++import Data.Packed+import PackedTest.Data+import Test.Hspec++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [])+$(mkPacked ''Tree3 [])+$(mkPacked ''Tree4 [InsertFieldSize])+$(mkPacked ''MyData [])++specs :: Spec+specs = describe "Pack / Unpack Identity" $ do+    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 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

@@ -0,0 +1,82 @@+module PackedTest.PackTest (specs) where++import ByteString.StrictBuilder+import Data.Int (Int32)+import Data.Packed+import Data.Packed.TH+import PackedTest.Data+import Test.Hspec++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [])+$(mkPacked ''Tree3 [])+$(mkPacked ''Tree4 [InsertFieldSize])++specs :: Spec+specs = describe "Pack Trees" $ do+    describe "Tree1" $ do+        test+            "Leaf"+            (Leaf1 10 :: Tree1 Int)+            (storable (0 :: Tag) <> storable (10 :: Int))++        test+            "Node"+            (Node1 (Node1 (Leaf1 1) (Leaf1 2)) (Leaf1 3) :: Tree1 Int)+            ( let node = storable (1 :: Tag) <> subNode <> leaf+                  subNode = storable (1 :: Tag) <> subLeafL <> subLeafR+                  subLeafL = storable (0 :: Tag) <> storable (1 :: Int)+                  subLeafR = storable (0 :: Tag) <> storable (2 :: Int)+                  leaf = storable (0 :: Tag) <> storable (3 :: Int)+               in node+            )+    describe "Test2" $ do+        test+            "Leaf"+            (Leaf2 :: Tree2 Int)+            (storable (0 :: Tag))+        test+            "Node"+            (Node2 Leaf2 (1 :: Int) Leaf2)+            ( let node = storable (1 :: Tag) <> leaf <> storable (1 :: Int) <> leaf+                  leaf = storable (0 :: Tag)+               in node+            )+    describe "Test3" $ do+        test+            "Leaf"+            (Leaf3 :: Tree3 Int)+            (storable (0 :: Tag))+        test+            "Node"+            (Node3 Leaf3 Leaf3 (42 :: Int))+            ( let node = storable (1 :: Tag) <> leaf <> leaf <> storable (42 :: Int)+                  leaf = storable (0 :: Tag)+               in node+            )+    describe "Tree1 (with `InsertFieldSize`)" $ do+        test+            "Leaf"+            (Leaf4 10 :: Tree4 Int)+            (storable (0 :: Tag) <> storable (8 :: Int32) <> storable (10 :: Int))+        test+            "Node"+            (Node4 (Leaf4 4) (Leaf4 5) :: Tree4 Int)+            ( let node =+                    storable (1 :: Tag)+                        <> packedNodeFieldSize+                        <> leafL+                        <> packedNodeFieldSize+                        <> leafR+                  packedNodeFieldSize = storable (1 + 4 + 8 :: Int32)+                  -- 1 for tag, 4 for field size and 8 for Int+                  packedLeafFieldSize = storable (8 :: Int32)+                  leafL = storable (0 :: Tag) <> packedLeafFieldSize <> storable (4 :: Int)+                  leafR = storable (0 :: Tag) <> packedLeafFieldSize <> storable (5 :: Int)+               in node+            )+  where+    test name tree bldr =+        it name $ do+            let ptree = Data.Packed.pack tree+            fromPacked ptree `shouldBe` builderBytes bldr

@@ -0,0 +1,78 @@+module PackedTest.UnpackTest (specs) where++import ByteString.StrictBuilder+import Data.Int (Int32)+import Data.Packed+import Data.Packed.TH+import PackedTest.Data+import Test.Hspec++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [])+$(mkPacked ''Tree3 [])+$(mkPacked ''Tree4 [InsertFieldSize])++specs :: Spec+specs = describe "Unpack Trees" $ do+    describe "Tree1" $ do+        test+            "Leaf"+            (storable (0 :: Tag) <> storable (10 :: Int))+            (Leaf1 10 :: Tree1 Int)+        test+            "Node"+            ( let node = storable (1 :: Tag) <> subNode <> leaf+                  subNode = storable (1 :: Tag) <> subLeafL <> subLeafR+                  subLeafL = storable (0 :: Tag) <> storable (1 :: Int)+                  subLeafR = storable (0 :: Tag) <> storable (2 :: Int)+                  leaf = storable (0 :: Tag) <> storable (3 :: Int)+               in node+            )+            (Node1 (Node1 (Leaf1 1) (Leaf1 2)) (Leaf1 3) :: Tree1 Int)+    describe "Test2" $ do+        test+            "Leaf"+            (storable (0 :: Tag))+            (Leaf2 :: Tree2 Int)+        test+            "Node"+            ( let node = storable (1 :: Tag) <> leaf <> storable (1 :: Int) <> leaf+                  leaf = storable (0 :: Tag)+               in node+            )+            (Node2 Leaf2 (1 :: Int) Leaf2)+    describe "Test3" $ do+        test+            "Leaf"+            (storable (0 :: Tag))+            (Leaf3 :: Tree3 Int)+        test+            "Node"+            ( let node = storable (1 :: Tag) <> leaf <> leaf <> storable (42 :: Int)+                  leaf = storable (0 :: Tag)+               in node+            )+            (Node3 Leaf3 Leaf3 (42 :: Int))+    describe "Tree1 (with `InsertFieldSize`)" $ do+        test+            "Leaf"+            (storable (0 :: Tag) <> storable (8 :: Int32) <> storable (10 :: Int))+            (Leaf4 10 :: Tree4 Int)+        test+            "Node"+            ( let node =+                    storable (1 :: Tag)+                        <> packedNodeFieldSize+                        <> leafL+                        <> packedNodeFieldSize+                        <> leafR+                  packedNodeFieldSize = storable (1 + 8 + 8 :: Int32)+                  packedLeafFieldSize = storable (8 :: Int32)+                  leafL = storable (0 :: Tag) <> packedLeafFieldSize <> storable (4 :: Int)+                  leafR = storable (0 :: Tag) <> packedLeafFieldSize <> storable (5 :: Int)+               in node+            )+            (Node4 (Leaf4 4) (Leaf4 5) :: Tree4 Int)+  where+    test name bldr t = it name $ case Data.Packed.unpack (unsafeToPacked (builderBytes bldr)) of+        (tree, _) -> tree `shouldBe` t

@@ -0,0 +1,12 @@+import qualified PackedTest.CaseTest as CaseTest+import qualified PackedTest.IdentityTest as IdentityTest+import qualified PackedTest.PackTest as PackTest+import qualified PackedTest.UnpackTest as UnpackTest+import Test.Hspec (hspec)++main :: IO ()+main = hspec $ do+    PackTest.specs+    UnpackTest.specs+    CaseTest.specs+    IdentityTest.specs