diff --git a/.gitignore b/.gitignore
new file mode 100644
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,20 @@
+*.hi
+*.o
+*.swp
+*.tag
+*~
+*_flymake.hs
+.hsenv
+.stack-work/
+/*.html
+TAGS
+/.idea/
+/.dir-locals.el
+*.refactored.hs
+/*.html
+*-build-timed.log
+cabal.project.local
+.ghc.environment.*
+dist/
+dist-newstyle/
+result
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,3 @@
+language: haskell
+ghc:
+ - 8.6.3
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,9 @@
+# 0.11.4.0
+
+* Rename `AacMp4StreamConfig` to `AacInitSegment`
+* Rename `InitSegment` to `BinaryAacInitSegment`
+* Extract `AacInitSegment` and `BinaryAacInitSegment` from module `AudioStreaming` into a new
+ module: `Data.ByteString.Mp4.AacInitSegment`
+* Fix unit test `Mp4AudioSampleEntrySpec`
+* Add CHANGELOG.md
+* Switch to stackage lts-8.6
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Sven Heyll and Lindenbaum GmbH (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * 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.
+
+ * Neither the name of Author name here nor the names of other
+ 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
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, addParameter, 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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,10 @@
+[](https://travis-ci.org/sheyll/isobmff)
+[](http://hackage.haskell.org/package/isobmff)
+
+# ISO-14496-12 Base Media File Format Library
+
+This project contains a parser and builder for the media data container file
+format defined as part of the MPEG-4 (ISO-14496) family of standards, called the
+Iso Base Media File Format, or ISOBMFF.
+
+It is a container format for both stored and transfered media data.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/benchmarks/bit-records/Main.hs b/benchmarks/bit-records/Main.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/bit-records/Main.hs
@@ -0,0 +1,193 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# LANGUAGE CPP #-}
+module Main where
+
+import Prelude hiding ( (.), id )
+import Control.Category
+import Criterion.Main
+import qualified Data.ByteString.Builder as L
+import qualified Data.ByteString.Lazy as L
+import Data.Proxy
+import Data.Type.BitRecords
+import Data.Word
+import Data.Tagged
+import GHC.TypeLits ()
+#ifdef FULLBENCHMARKS
+import Data.Type.Equality
+#endif
+import Test.TypeSpecCrazy
+
+#ifdef FULLBENCHMARKS
+
+type Static64 =
+ Field 3 := 2
+ .+. Field 5 := 4
+ .+. Field 9 := 333
+ .+. Field 7 := 35
+ .+. Field 30 := 458329
+ .+. Field 2 := 1
+ .+. Field 2 := 0
+ .+. Field 2 := 1
+ .+. Field 4 := 9
+
+
+type Static64WithParams =
+ Field 3 := 0
+ .+. Field 5 := 0
+ .+. Field 9 := 0
+ .+. "x" @: Field 7
+ .+. Field 30 := 0
+ .+. "y" @: Field 2
+ .+. Field 2 := 0
+ .+. Field 2 := 0
+ .+. Field 4 := 0
+
+type Static128 = Field 64 := 3735928559 .+. Field 64 := 3405688830
+
+type Static256 = Static64 :+: Static128 :+: Static64
+
+type Static517 = Static256 :+: Static256 :+. Field 5 := 0
+
+#else
+
+type Static64 = 'BitRecordMember (Field 64 := 0)
+
+
+type Static64WithParams =
+ "x" @: Field 32
+ .+. "y" @: Field 32
+
+#endif
+
+aboutStatic64 ::
+
+ "Test Types Sizes"
+ ########################
+
+ It's "64 bit long: Static64" (ShouldBe 64 (BitRecordSize Static64))
+ -* It's "64 bit long: Static64WithParams" (ShouldBe 64 (BitRecordSize Static64WithParams))
+#ifdef FULLBENCHMARKS
+ -* It's "128 bit long" (ShouldBeTrue ((BitRecordSize Static128) == 128))
+ -* It's "256 bit long" (ShouldBeTrue ((BitRecordSize Static256) == 256))
+ -* It's "517 bit long" (ShouldBeTrue ((BitRecordSize Static517) == 517))
+#endif
+
+aboutStatic64 =
+ Valid
+
+lumpUp :: Word64 -> L.Builder -> [Word8]
+lumpUp m = L.unpack . L.toLazyByteString . mconcat . replicate (fromIntegral m)
+
+static64 m = lumpUp m $
+ runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static64)
+
+static64WithParam m = lumpUp m $
+ runBitStringBuilderHoley (bitStringBuilderHoley (Proxy :: Proxy Static64WithParams))
+ (B m)
+ (B m)
+
+#ifdef FULLBENCHMARKS
+
+static128 m =
+ lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static128)
+
+static256 m =
+ lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static256)
+
+static517 m =
+ lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static517)
+
+staticPlain512bitBaseline m =
+ lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley
+ (Proxy :: Proxy (
+ Field 64 .+. Field 64 .+. Field 64 .+. Field 64 .+.
+ Field 64 .+. Field 64 .+. Field 64 .+. Field 64
+ ))
+
+
+#endif
+
+main = do
+ print aboutStatic64
+ defaultMain [ bgroup "ByteStringBuilder"
+ [ bgroup "64-bit"
+ [ bench "1" $ nf static64 1
+ , bench "100" $ nf static64 5
+ , bench "1000" $ nf static64 1000
+ ]
+ , bgroup "64-bit parameterized"
+ [ bench "1" $
+ nf static64WithParam 1
+ , bench "100" $
+ nf static64WithParam 5
+ , bench "1000" $
+ nf static64WithParam 1000
+ ]
+#ifdef FULLBENCHMARKS
+ , bgroup "128-bit"
+ [ bench "1" $
+ nf static128 1
+ , bench "100" $
+ nf static128 5
+ , bench "1000" $
+ nf static128 1000
+ ]
+ , bgroup "256-bit"
+ [ bench "1" $
+ nf static256 1
+ , bench "100" $
+ nf static256 5
+ , bench "1000" $
+ nf static256 1000
+ ]
+ , bgroup "517-bit"
+ [ bench "1" $
+ nf static517 1
+ , bench "100" $
+ nf static517 5
+ , bench "1000" $
+ nf static517 1000
+ ]
+ , bgroup "512-bit baseline"
+ [ bench "1" $
+ nf staticPlain512bitBaseline 1
+ , bench "100" $
+ nf staticPlain512bitBaseline 100
+ , bench "1000" $
+ nf staticPlain512bitBaseline 1000
+ ]
+#endif
+ , bgroup "BitString Word64 direct"
+ [ bench "1" $
+ nf bitStringWord64Direct 1
+ , bench "100" $
+ nf bitStringWord64Direct 5
+ , bench "1000" $
+ nf bitStringWord64Direct 1000
+ ]
+ , bgroup "BitString Word64 holey"
+ [ bench "1" $
+ nf bitStringWord64Holey 1
+ , bench "100" $
+ nf bitStringWord64Holey 5
+ , bench "1000" $
+ nf bitStringWord64Holey 1000
+ ]
+ ]
+ ]
+
+bitStringWord64Direct m =
+ lumpUp 1
+ $ runBitStringBuilder
+ $ mconcat
+ $ replicate m
+ $ appendBitString
+ $ bitString 64 0x01020304050607
+
+bitStringWord64Holey m =
+ lumpUp 1
+ $ runBitStringBuilderHoley
+ $ mconcat
+ $ replicate m
+ $ bitStringBuilderHoley
+ $ bitString 64 0x01020304050607
diff --git a/doc/ES_Descriptor.markDown b/doc/ES_Descriptor.markDown
new file mode 100644
--- /dev/null
+++ b/doc/ES_Descriptor.markDown
@@ -0,0 +1,36 @@
+# `esds` Box Contents
+
+ 00000027 65736473 00000000
+
+ ES_Descriptor
+ | length
+ x 03 | ES_ID
+ x 19 |sdf
+ x 0001|url
+ b 0|ocr
+ b 0| stream priority
+ b 0 | DecoderConfigDescriptor
+ b 00000 | length
+ x 04 | objectype indication: Audio ISO/IEC 14496-3
+ x 11 | stream-type: 0x5 AudioStream
+ x 40 |Upstream
+ b 000101|reserved
+ b 0| BufferSize DB
+ b 1 | maxBitrate
+ x 000000 | avgBitrate
+ x 00000000 | DecoderSpecificInfo
+ x 00000000 | length
+ x 05 |
+ x 02
+ x 1 1 9 0
+ =b 00010 - audioObjectType: 2 AAC LC
+ =b 0011 - (=3) samplingFrequencyIndex: 48k
+ =b 0010 - channelConfiguration: channel pair
+ =b 0 - frameLenflag \
+ =b 0 - dependsOnCoreCoder | GASpecificconfig
+ =b 0 - coreCoderDelay /
+ SLConfigDescrTag
+ | length: 1
+ x 06 | Predefined according to iso 14496-14 section 3.1.2
+ x 01 |
+ x 02
diff --git a/doc/basic-structure.svg b/doc/basic-structure.svg
new file mode 100644
--- /dev/null
+++ b/doc/basic-structure.svg
@@ -0,0 +1,2259 @@
+
+
+
+
diff --git a/doc/data_reference_box.svg b/doc/data_reference_box.svg
new file mode 100644
--- /dev/null
+++ b/doc/data_reference_box.svg
@@ -0,0 +1,2427 @@
+
+
+
+
diff --git a/doc/trun.markDown b/doc/trun.markDown
new file mode 100644
--- /dev/null
+++ b/doc/trun.markDown
@@ -0,0 +1,43 @@
+
+# Contents of a `trun` box
+
+
+ 0000 047c
+ 00000060: 7472 756e 0000 0701 0000 005e 0000 04c8
+ 00000070: 0000 0400 0000 0095 0200 0000 0000 0400
+ 00000080: 0000 0076 0200 0000 0000 0400 0000 008c
+ 00000090: 0200 0000 0000 0400 0000 008b 0200 0000
+ 000000a0: 0000 0400 0000 0094 0200 0000 0000 0400
+ 000000b0: 0000 007a 0200 0000 0000 0400 0000 0087
+ 000000c0: 0200 0000 0000 0400 0000 0099 0200 0000
+ 000000d0: 0000 0400 0000 0095 0200 0000 0000 0400
+
+## Box header
+
+ 0x0000047c size
+ 0x7472 756e 'trun'
+ 0x00 version
+ 0x000701 flags
+ 0x0000005e sample_count = 94
+ 0x000004c8 data_offset
+
+## A closer look at a single entry
+
+ 0x00000400 sample duration
+ 0x00000095 sample size
+ 0x02000000 sample flags
+
+
+### Sample flags
+
+ 0 2 0 0 0 0 0 0 (hex)
+ 0000 0010 0000 0000 0000 0000 0000 0000 (binary)
+
+ 0000 -> 4 bits reserved = 0
+ 00 -> is_leading
+ 10 -> sample_depends
+ 00 -> sample_is_depended_on
+ 00 -> sample has redundancy
+ 000 -> padding
+ 0 -> non sync
+ 0000 0000 0000 0000 degradation priority
diff --git a/isobmff.cabal b/isobmff.cabal
new file mode 100644
--- /dev/null
+++ b/isobmff.cabal
@@ -0,0 +1,281 @@
+name: isobmff
+version: 0.13.0.0
+synopsis: A parser and generator for the ISO-14496-12/14 base media file format
+description: Please see README.md
+homepage: https://github.com/sheyll/isobmff#readme
+license: BSD3
+license-file: LICENSE
+author: Sven Heyll
+maintainer: sven.heyll@lindenbaum.eu
+copyright: 2016-2019 Sven Heyll, Lindenbaum GmbH
+category: Codec
+build-type: Simple
+extra-source-files: README.md
+ , CHANGELOG.md
+ , stack.yaml
+ , .travis.yml
+ , doc/basic-structure.svg
+ , doc/data_reference_box.svg
+ , doc/ES_Descriptor.markDown
+ , doc/trun.markDown
+ , .gitignore
+cabal-version: >=1.10
+
+flag tracing
+ description: Build with trace output enabled
+ default: True
+
+flag fullbenchmarks
+ description: Enable the compilation of all benchmarks, takes a long time to compile
+ default: True
+
+flag complextests
+ description: Enable the compilation of all unit tests, even those, that take a long time to compile
+ default: True
+
+library
+ hs-source-dirs: src
+ exposed-modules: Data.ByteString.IsoBaseFileFormat.Box
+ , Data.ByteString.IsoBaseFileFormat.Boxes
+ , Data.ByteString.IsoBaseFileFormat.Boxes.AudioSampleEntry
+ , Data.ByteString.IsoBaseFileFormat.Boxes.ChunkOffset
+ , Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrl
+ , Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrn
+ , Data.ByteString.IsoBaseFileFormat.Boxes.DataInformation
+ , Data.ByteString.IsoBaseFileFormat.Boxes.DataReference
+ , Data.ByteString.IsoBaseFileFormat.Boxes.FileType
+ , Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+ , Data.ByteString.IsoBaseFileFormat.Boxes.HintMediaHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.HintSampleEntry
+ , Data.ByteString.IsoBaseFileFormat.Boxes.Media
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MediaData
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MediaHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MediaInformation
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MetaDataSampleEntry
+ , Data.ByteString.IsoBaseFileFormat.Boxes.Movie
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MovieExtends
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MovieExtendsHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MovieFragment
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MovieFragmentHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.NullMediaHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation
+ , Data.ByteString.IsoBaseFileFormat.Boxes.Language
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SampleDescription
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SampleSize
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SampleTable
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SampleToChunk
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SegmentType
+ , Data.ByteString.IsoBaseFileFormat.Boxes.Skip
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SoundMediaHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TimeToSample
+ , Data.ByteString.IsoBaseFileFormat.Boxes.Track
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TrackExtends
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragBaseMediaDecodeTime
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragment
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragmentHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TrackRun
+ , Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.VisualSampleEntry
+ , Data.ByteString.IsoBaseFileFormat.Brands.Dash
+ , Data.ByteString.IsoBaseFileFormat.MediaFile
+ , Data.ByteString.IsoBaseFileFormat.ReExports
+ , Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+ , Data.ByteString.IsoBaseFileFormat.Util.FullBox
+ , Data.ByteString.IsoBaseFileFormat.Util.Time
+ , Data.ByteString.IsoBaseFileFormat.Util.TypeLayout
+ , Data.ByteString.IsoBaseFileFormat.Util.Versioned
+ , Data.ByteString.Mp4.Boxes.AudioSpecificConfig
+ , Data.ByteString.Mp4.Boxes.BaseDescriptor
+ , Data.ByteString.Mp4.Boxes.DecoderConfigDescriptor
+ , Data.ByteString.Mp4.Boxes.DecoderSpecificInfo
+ , Data.ByteString.Mp4.Boxes.ElementaryStreamDescriptor
+ , Data.ByteString.Mp4.Boxes.Expandable
+ , Data.ByteString.Mp4.Boxes.Mp4AudioSampleEntry
+ , Data.ByteString.Mp4.Boxes.SyncLayerConfigDescriptor
+ , Data.ByteString.Mp4.AudioStreaming
+ , Data.ByteString.Mp4.AacInitSegment
+ , Data.Kind.Extra
+ , Data.Type.BitRecords
+ , Data.Type.BitRecords.Arithmetic
+ , Data.Type.BitRecords.Assert
+ , Data.Type.BitRecords.Builder.BitBuffer
+ , Data.Type.BitRecords.Builder.LazyByteStringBuilder
+ , Data.Type.BitRecords.Core
+ , Data.Type.BitRecords.Enum
+ , Data.Type.BitRecords.SizedString
+ , Data.Type.BitRecords.Sized
+ build-depends: base >= 4.12 && < 5
+ , bytestring
+ -- , type-list
+ , data-default
+ , vector
+ , singletons >= 2.5 && < 2.6
+ , tagged
+ , time
+ , function-builder >= 0.1 && < 0.2
+ , text
+ , type-spec >= 0.3
+ , mtl
+ , pretty-types >= 0.2.3 && < 0.4
+ , template-haskell
+ default-language: Haskell2010
+ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fprint-explicit-kinds
+ if flag(tracing)
+ cpp-options: -DTRACING
+ else
+ cpp-options: -DNTRACING
+
+ default-extensions: BangPatterns
+ , ConstraintKinds
+ , CPP
+ , DataKinds
+ , DefaultSignatures
+ , DeriveDataTypeable
+ , DeriveFunctor
+ , DeriveGeneric
+ , DuplicateRecordFields
+ , FlexibleInstances
+ , FlexibleContexts
+ , FunctionalDependencies
+ , GADTs
+ , GeneralizedNewtypeDeriving
+ , KindSignatures
+ , MultiParamTypeClasses
+ , NoStarIsType
+ , OverloadedStrings
+ , QuasiQuotes
+ , RecordWildCards
+ , RankNTypes
+ , ScopedTypeVariables
+ , StandaloneDeriving
+ , TemplateHaskell
+ , TupleSections
+ , TypeApplications
+ , TypeFamilies
+ , TypeInType
+ , TypeOperators
+ , TypeSynonymInstances
+ , UnicodeSyntax
+test-suite spec
+ type: exitcode-stdio-1.0
+ ghc-options: -Wall
+ hs-source-dirs: spec
+ default-language: Haskell2010
+ main-is: Spec.hs
+ other-modules: BitRecordsSpec
+ , BoxFieldsSpec
+ , BoxSpec
+ , DataReferenceSpec
+ , ElementaryStreamDescriptorSpec
+ , EnumSpec
+ , ExpandableSpec
+ , Mp4AudioSampleEntrySpec
+ , MediaFileSpec
+ , Mp4AudioFileSpec
+ , Mp4AudioSegmentSpec
+ , TypeLayoutSpec
+ build-depends: base >= 4.12 && < 5
+ , bytestring
+ , hspec
+ , isobmff
+ , binary
+ , text
+ , type-spec
+ , mtl
+ , QuickCheck
+ , tagged
+ , pretty-types >= 0.2.1 && < 0.4
+ default-extensions: BangPatterns
+ , ConstraintKinds
+ , CPP
+ , DataKinds
+ , DefaultSignatures
+ , DeriveDataTypeable
+ , DeriveFunctor
+ , DeriveGeneric
+ , FlexibleInstances
+ , FlexibleContexts
+ , FunctionalDependencies
+ , GADTs
+ , GeneralizedNewtypeDeriving
+ , KindSignatures
+ , MultiParamTypeClasses
+ , OverloadedStrings
+ , QuasiQuotes
+ , RecordWildCards
+ , RankNTypes
+ , NoStarIsType
+ , ScopedTypeVariables
+ , StandaloneDeriving
+ , TemplateHaskell
+ , TupleSections
+ , TypeApplications
+ , TypeFamilies
+ , TypeInType
+ , TypeOperators
+ , TypeSynonymInstances
+ , UnicodeSyntax
+ ghc-options: -Wall +RTS -A256m -n2m -RTS
+ -fwarn-unused-binds -fno-warn-unused-do-bind -fno-warn-missing-signatures -fprint-explicit-kinds
+ if flag(complextests)
+ cpp-options: -DCOMPLEXTESTS
+ else
+ cpp-options: -DNCOMPLEXTESTS
+
+benchmark bit-records
+ type: exitcode-stdio-1.0
+ hs-source-dirs: benchmarks/bit-records
+ main-is: Main.hs
+ build-depends: base >= 4.12 && < 5
+ , isobmff
+ , binary
+ , bytestring
+ , criterion
+ , tagged
+ , type-spec >= 0.3
+ default-language: Haskell2010
+ default-extensions: BangPatterns
+ , ConstraintKinds
+ , CPP
+ , DataKinds
+ , DefaultSignatures
+ , DeriveDataTypeable
+ , DeriveFunctor
+ , DeriveGeneric
+ , FlexibleInstances
+ , FlexibleContexts
+ , FunctionalDependencies
+ , GADTs
+ , GeneralizedNewtypeDeriving
+ , KindSignatures
+ , MultiParamTypeClasses
+ , NoStarIsType
+ , OverloadedStrings
+ , QuasiQuotes
+ , RecordWildCards
+ , RankNTypes
+ , ScopedTypeVariables
+ , StandaloneDeriving
+ , TemplateHaskell
+ , TupleSections
+ , TypeApplications
+ , TypeFamilies
+ , TypeInType
+ , TypeOperators
+ , TypeSynonymInstances
+ , UnicodeSyntax
+ ghc-options: +RTS -A256m -n2m -RTS
+ -Wall -fwarn-unused-binds
+ -fno-warn-unused-do-bind -fprint-explicit-kinds
+ if flag(fullbenchmarks)
+ cpp-options: -DFULLBENCHMARKS
+ else
+ cpp-options: -DNFULLBENCHMARKS
+
+source-repository head
+ type: git
+ location: https://github.com/sheyll/isobmff
diff --git a/spec/BitRecordsSpec.hs b/spec/BitRecordsSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/BitRecordsSpec.hs
@@ -0,0 +1,471 @@
+{-# LANGUAGE UndecidableInstances #-}
+module BitRecordsSpec (spec) where
+
+import Data.Bits
+import Data.ByteString.Builder
+import Data.Proxy
+import Data.Type.BitRecords
+import Data.Type.Equality ()
+import Data.Kind.Extra
+import GHC.TypeLits
+import Prelude hiding ((.), id)
+import Test.Hspec
+import Test.QuickCheck (property, Arbitrary(..), choose)
+import Test.TypeSpecCrazy
+import Text.Printf
+
+basicsSpec :: Spec
+basicsSpec = do
+ describe "Maybe, Lists, Either, Bool, 'True, 'False, FlagJust, FlagNothing" $ do
+ let checkFlagJust ::
+ "Type Level Bool, 'True, 'False, FlagJust, FlagNothing Accessors"
+ ##################################################################
+
+ "The record size works"
+ ~~~~~~~~~~~~~~~~~~~~~~~~
+ 1 `ShouldBe` BitRecordFieldSize (FlagJust 'Nothing)
+ -* 1 `ShouldBe` BitRecordFieldSize (FlagJust ('Just "Blah"))
+ -* 1 `ShouldBe` BitRecordFieldSize (FlagNothing ('Just "Blah"))
+ -- TODO reenable tests
+ -- -* 32 `ShouldBe` BitRecordSize (ToBitRecord ('Just FieldU32))
+ -- -* 0 `ShouldBe` BitRecordSize (ToBitRecord '[])
+ -- -* 10 `ShouldBe` BitRecordSize (ToBitRecord '[Field 10])
+ -- -* 25 `ShouldBe` BitRecordSize (ToBitRecord '[Field 10, Field 15])
+ -- -* 1 `ShouldBe` BitRecordSize (ToBitRecord Bool)
+ -- -* 1 `ShouldBe` BitRecordSize (ToBitRecord 'True)
+ -- -* 1 `ShouldBe` BitRecordSize (ToBitRecord 'False)
+ checkFlagJust = Valid
+ runIO $ print checkFlagJust
+ describe "bitStringBuilder" $ do
+ describe "Just x" $ it "writes x" $
+ bitStringPrinter (Proxy :: Proxy (OptionalRecord ('Just ('BitRecordMember (Flag := 'True))))) `shouldBe` "<< 80 >>"
+ describe "Nothing" $ it "writes nothing" $
+ bitStringPrinter (Proxy :: Proxy (OptionalRecord ('Nothing))) `shouldBe` "<< >>"
+ -- describe "'[]" $ it "writes nothing" $
+ -- bitStringPrinter (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField) ('[]))) `shouldBe` "<< >>"
+ -- describe "'[x1, x2]" $ it "writes x1 then x2" $
+ -- bitStringPrinter (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField) ('[FieldU8 := 1, FieldU8 := 2]))) `shouldBe` "<< 01 02 >>"
+ describe "'True" $ it "writes a single bit with a 1" $
+ bitStringPrinter (Proxy :: Proxy (RecordField (Flag := 'True))) `shouldBe` "<< 80 >>"
+ describe "'False" $ it "writes a single bit with a 0" $
+ bitStringPrinter (Proxy :: Proxy (RecordField (Flag := 'False))) `shouldBe` "<< 00 >>"
+ describe "@: labelled fields" $ do
+ it "writes them ..." $
+ let fld = Proxy @(Eval (RecordField ( "foo" @: FlagJust 'Nothing )))
+ in bitStringPrinter fld `shouldBe` "<< 00 >>"
+ describe "FlagJust" $ do
+ it "writes a single bit '1' for a 'Just ...' parameter" $
+ bitStringPrinter (Proxy :: Proxy (RecordField (FlagJust ('Just "test")))) `shouldBe` "<< 80 >>"
+ it "writes a single bit '0' for a 'Nothing' parameter" $
+ bitStringPrinter (Proxy :: Proxy (RecordField (FlagJust 'Nothing))) `shouldBe` "<< 00 >>"
+ describe "FlagNothing" $ do
+ it "writes a single bit '0' for a 'Just ...' parameter" $
+ bitStringPrinter (Proxy :: Proxy (RecordField (FlagNothing ('Just "test")))) `shouldBe` "<< 00 >>"
+ it "writes a single bit '1' for a 'Nothing' parameter" $
+ bitStringPrinter (Proxy :: Proxy (RecordField (FlagNothing 'Nothing))) `shouldBe` "<< 80 >>"
+ -- TODO reenable showRecord tests
+ -- describe "showRecord" $ do
+ -- describe "Maybe" $ do
+ -- it "prints 'Just x'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord ('Just 'True))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
+ -- it "prints nothing for 'Nothing'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord ('Nothing))) `shouldBe` ""
+ -- describe "List" $ do
+ -- it "prints '[x]'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord ('[ 'True ]))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
+ -- it "prints '[x1, x2, x3]'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord ('[ Bool, Bool, Bool ]))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\nField:\n Demote Rep: Bool\n Bits: 1\nField:\n Demote Rep: Bool\n Bits: 1"
+ -- it "prints nothing for '[]'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord ('[]))) `shouldBe` ""
+ -- describe "Bool" $ do
+ -- it "prints 'True" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord ('True))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
+ -- it "prints 'False" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord ('False))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'False"
+ -- it "prints a Bool" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord Bool)) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1"
+ -- describe "FlagJust" $ do
+ -- it "prints a 'FlagJust 'Just ..'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord (FlagJust ('Just "123")))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
+ -- it "prints a 'FlagJust 'Nothing'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord (FlagJust 'Nothing))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'False"
+ -- describe "FlagNothing" $ do
+ -- it "prints 'FlagNothing 'Just ..'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord (FlagNothing ('Just "123")))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'False"
+ -- it "prints a 'FlagNothing 'Nothing'" $
+ -- showRecord (Proxy :: Proxy (ToBitRecord (FlagNothing 'Nothing))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
+
+#ifdef COMPLEXTESTS
+arraySpec :: SpecWith ()
+arraySpec =
+ describe "RecArray" $ do
+ describe "level record accessors" $ do
+ let checkArrayRec ::
+ "BitRecord accessors involving RecArray"
+ #######################################
+
+ "The record size works"
+ ~~~~~~~~~~~~~~~~~~~~~~~~
+ 1 `ShouldBe` BitRecordSize (Eval (RecArray ('BitRecordMember Flag) 1))
+ -* 91 `ShouldBe` BitRecordSize (Eval (("foo" @: Flag .+. FieldU8) ^^ 10) :+. Flag)
+ -* 91 `ShouldBe` BitRecordSize (Eval (RecArray ("foo" @: Flag .+. FieldU8) 10) :+. Flag)
+ checkArrayRec = Valid
+ runIO $ print checkArrayRec
+ describe "showRecord" $
+ it "appends its body n times" $
+ let expected = "utf-8(40) := <> [5 Bytes]\nutf-8(40) := <> [5 Bytes]\nutf-8(40) := <> [5 Bytes]\nutf-8(40) := <> [5 Bytes]\nutf-8(40) := <> [5 Bytes]"
+ actual = showARecord (Proxy @ (('BitRecordMember [utf8|hello|] ^^ 5)))
+ in actual `shouldBe` expected
+ describe "bitStringBuilder" $
+ it "writes its contents n times to the builder" $
+ let actual = bitStringPrinter (Proxy :: Proxy (('BitRecordMember (Field 24 := 0x010203) ^^ 4)))
+ expected = "<< 01 02 03 01 02 03 01 02 03 01 02 03 >>"
+ in actual `shouldBe` expected
+
+sizedSpec =
+ describe "Sized" $ do
+ describe "TypeChecks" $
+ let
+ checkSized ::
+ "Sized"
+ #########
+
+ "SizedString"
+ ~~~~~~~~~~~~~~~
+ 88 `ShouldBe` BitRecordFieldSize [utf8|Hello World|]
+ -* 104 `ShouldBe` BitRecordSize (Eval (RecordField [utf8|Heλλo World|]))
+
+ -/-
+
+ "Sized BitRecord Members"
+ ~~~~~~~~~~~~~~~~~~~~~~~~
+ 8 `ShouldBe` BitRecordSize (Eval (Sized8 'EmptyBitRecord))
+ -* 9 `ShouldBe` BitRecordSize (Eval (Sized8 ('BitRecordMember Flag)))
+ -* 0 `ShouldBe` SizeFieldValue 'EmptyBitRecord
+ -* 1 `ShouldBe` SizeFieldValue ('BitRecordMember Flag)
+
+ -/-
+
+ "SizedField"
+ ~~~~~~~~~~~~
+ 9 `ShouldBe` BitRecordSize (Eval (SizedField8 Flag))
+ -* 1 `ShouldBe` SizeFieldValue Flag
+
+ -- TODO add more Sized tests, especially for SizedField
+ checkSized = Valid
+ in runIO $ print checkSized
+ describe "showRecord" $ do
+ describe "SizedString" $
+ it "renders a string containing wide utf-8 characters to a header containing the number of chars and the actual string" $
+ showARecord (Proxy :: Proxy (RecordField [utf8|Heλλo World!|])) `shouldBe` "utf-8(112) := <> [14 Bytes]"
+ describe "Sized SizeField16 SizedString" $
+ it "renders the number bytes not chars as the size field value" $
+ showARecord (Proxy :: Proxy (SizedField16 [utf8|Heλλo World!|])) `shouldBe` "size: U16 := hex: 000e (dec: 14)\nutf-8(112) := <> [14 Bytes]"
+ describe "bitStringBuilder" $ do
+ describe "no length prefix" $
+ it "renders no size prefix and the string as UTF-8 bytes" $
+ bitStringPrinter (Proxy :: Proxy (RecordField [utf8|ABC|]))
+ `shouldBe`
+ "<< 41 42 43 >>"
+ describe "8-bit length prefix" $
+ it "renders a single byte size prefix and the string as UTF-8 bytes" $
+ bitStringPrinter (Proxy :: Proxy (SizedField8 [utf8|ABC|]))
+ `shouldBe`
+ "<< 03 41 42 43 >>"
+ describe "16-bit length prefix" $
+ it "renders a big endian 16 bit size prefix and the string as UTF-8 bytes" $
+ bitStringPrinter (Proxy :: Proxy (SizedField16 [utf8|ABC|]))
+ `shouldBe`
+ "<< 00 03 41 42 43 >>"
+ describe "32-bit length prefix" $
+ it "renders a big endian 32 bit size prefix and the string as UTF-8 bytes" $
+ bitStringPrinter (Proxy :: Proxy (SizedField32 [utf8|ABC|]))
+ `shouldBe`
+ "<< 00 00 00 03 41 42 43 >>"
+ describe "64-bit length prefix" $
+ it "renders a big endian 64 bit size prefix and the string as UTF-8 bytes" $
+ bitStringPrinter (Proxy :: Proxy (SizedField64 [utf8|ABC|]))
+ `shouldBe`
+ "<< 00 00 00 00 00 00 00 03 41 42 43 >>"
+
+type TestRecAligned =
+ "bar" @: Field 8 .+:
+ Field 8 := 0 .+:
+ "baz" @: Field 8 .+:
+ Field 32 := 0 .+:
+ "foo" @: Field 8 .+:
+ Field 8 := 0 .+:
+ "oof" @: Field 8 .+:
+ Field 8 := 0 .+.
+ "rab" @: Field 8
+
+checkTestRecAligned
+ :: Expect '[ ShouldBe 96 (BitRecordSize TestRecAligned) ]
+checkTestRecAligned = Valid
+
+type TestRecUnAligned =
+ "bar" @: Field 8 .+:
+ Field 8 := 0 .+:
+ "baz" @: Field 7 .+:
+ Field 32 := 0 .+:
+ "foo" @: Field 8 .+.
+ Field 8 := 0xfe
+
+checkTestRecUnAligned
+ :: Expect '[ ShouldBe 71 (BitRecordSize TestRecUnAligned) ]
+checkTestRecUnAligned = Valid
+
+testTakeLastN ::
+ "Taking the last n elements of a list" #######################################
+
+ TakeLastN 0 '[1,2,3] `ShouldBe` ('[] :: [Nat])
+ -* TakeLastN 1 '[1,2,3] `ShouldBe` '[3]
+ -* TakeLastN 2 '[1,2,3] `ShouldBe` '[2,3]
+ -* TakeLastN 5 '[1,2,3] `ShouldBe` '[1,2,3]
+
+testTakeLastN = Valid
+
+testRem
+ :: Expect '[ Mod 0 3 `ShouldBe` 0
+ , Mod 1 3 `ShouldBe` 1
+ , Mod 2 3 `ShouldBe` 2
+ , Mod 3 3 `ShouldBe` 0
+ , Mod 4 3 `ShouldBe` 1
+ , Mod 5 3 `ShouldBe` 2
+ , Mod 6 3 `ShouldBe` 0
+ ]
+testRem = Valid
+
+testRemPow2
+ ::
+ "ModPow2"
+ #########
+
+ "Remainder of '1'"
+ ~~~~~~~~~~~~~~~~~~
+
+ It "1 `ModPow2` 1 is 1" (Is 1 (ModPow2 1 1))
+ -* It "1 `ModPow2` 8 is 1" (Is 1 (ModPow2 1 8))
+
+ -/-
+
+ "Remainder of '3916441'"
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ It " `ModPow2` 1 is 1" (Is 1 (ModPow2 3916441 1))
+ -* It " `ModPow2` 4 is 9" (Is 9 (ModPow2 3916441 4))
+ -* It " `ModPow2` 8 is 153" (Is 153 (ModPow2 3916441 8))
+
+testRemPow2 = Valid
+
+testDiv
+ :: Expect '[ Div 0 3 `ShouldBe` 0
+ , Div 1 3 `ShouldBe` 0
+ , Div 2 3 `ShouldBe` 0
+ , Div 3 3 `ShouldBe` 1
+ , Div 4 3 `ShouldBe` 1
+ , Div 5 3 `ShouldBe` 1
+ , Div 6 3 `ShouldBe` 2
+ , Div 144 13 `ShouldBe` 11
+ -- , Div 512 128 `ShouldBe` 11
+ ]
+testDiv = Valid
+
+testNatBits
+ :: "Type Level bit operations"
+ ###########################
+
+ "TestHighBit"
+ ~~~~~~~~~~~~
+
+ ShouldBeFalse (TestHighBit 127 8)
+ -* ShouldBeFalse (TestHighBit 127 7)
+ -* ShouldBeTrue (TestHighBit 127 6)
+ -* ShouldBeFalse (TestHighBit 32 6)
+ -* ShouldBeTrue (TestHighBit 32 5)
+ -* ShouldBeFalse (TestHighBit 16 5)
+ -* ShouldBeTrue (TestHighBit 16 4)
+ -* ShouldBeFalse (TestHighBit 8 4)
+ -* ShouldBeTrue (TestHighBit 8 3)
+ -* ShouldBeFalse (TestHighBit 4 3)
+ -* ShouldBeTrue (TestHighBit 4 2)
+ -* ShouldBeFalse (TestHighBit 2 2)
+ -* ShouldBeTrue (TestHighBit 2 1)
+ -* ShouldBeFalse (TestHighBit 0 1)
+ -* ShouldBeTrue (TestHighBit 1 0)
+
+ -/-
+
+ "ToBits"
+ ~~~~~~~~~
+
+ It "returns the empty list for a zero bit length"
+ (ToBits 1023 0 `ShouldBe` ('[] :: [Bool]) )
+
+ -* It "returns [] for a single unset bit"
+ (ShouldBe ('[] :: [Bool]) (ToBits 0 1))
+
+ -* It "returns [True] for a single set bit"
+ (ShouldBe '[ 'True] (ToBits 1 1))
+
+ -* It "returns [True, False] when getting two bits from 0x2"
+ (ShouldBe '[ 'True, 'False] (ToBits 0x2 2))
+
+ -* It "returns the list of bits in correct order"
+ (ShouldBe '[ 'True, 'True, 'True, 'True
+ , 'False, 'False, 'False, 'False]
+ (ToBits 0xf0 8))
+
+ -* It "returns no leading 'False (i.e. it omits leading zero bits)"
+ (ShouldBe '[ 'True, 'True, 'True, 'True]
+ (ToBits 0x0000000f 32))
+ -/-
+
+ "FromBits"
+ ~~~~~~~~~
+
+ It "returns 0 for '[]"
+ (ShouldBe 0 (FromBits ('[] :: [Bool])))
+
+ -* It "returns 0 for [False]"
+ (ShouldBe 0 (FromBits '[ 'False]))
+
+ -* It "returns 1 for [True]"
+ (ShouldBe 1 (FromBits '[ 'True]))
+
+ -* It "returns 2 for [True, False]"
+ (ShouldBe 2 (FromBits '[ 'True, 'False]))
+
+ -* It "returns 4 for [True, False, False]"
+ (ShouldBe 4 (FromBits '[ 'True, 'False, 'False]))
+
+ -* It "returns 5 for [True, False, True]"
+ (ShouldBe 5 (FromBits '[ 'True, 'False, 'True]))
+ -/-
+
+ "ShiftBitsR"
+ ~~~~~~~~~~~~
+
+ It "returns the input bits for n == 0"
+ (ShouldBe '[ 'True, 'False] (ShiftBitsR ['True, 'False] 0))
+
+ -* It "returns '[] when shifting [True] 1 bits"
+ (ShouldBe ('[] :: [Bool]) (ShiftBitsR '[ 'True ] 1))
+
+ -* It "returns '[True] when shifting [True, True] 1 bits"
+ (ShouldBe '[ 'True] (ShiftBitsR '[ 'True, 'True ] 1))
+
+ -* It "returns (ToBits 12 8) when shifting (ToBits 97 8) 3 bits to the right"
+ (ShouldBe (ToBits 12 8) (ShiftBitsR (ToBits 97 8) 3))
+ -/-
+
+ "GetMostSignificantBitIndex"
+ ~~~~~~~~~~~~~~~
+
+ It "returns 1 for 0"
+ (ShouldBe 1 (GetMostSignificantBitIndex 64 0))
+
+ -* It "returns 1 for 1"
+ (ShouldBe 1 (GetMostSignificantBitIndex 64 1))
+
+ -* It "returns 1 for 2"
+ (ShouldBe 1 (GetMostSignificantBitIndex 64 2))
+
+ -* It "returns 1 for 3"
+ (ShouldBe 1 (GetMostSignificantBitIndex 64 3))
+
+ -* It "returns 2 for 4"
+ (ShouldBe 2 (GetMostSignificantBitIndex 64 4))
+
+ -* It "returns 2 for 5"
+ (ShouldBe 2 (GetMostSignificantBitIndex 64 4))
+
+ -* It "returns 8 for 511"
+ (ShouldBe 8 (GetMostSignificantBitIndex 64 511))
+
+ -* It "returns 63 for (2^64 - 1)"
+ (ShouldBe 63 (GetMostSignificantBitIndex 64 (2^64 - 1)))
+
+ -/-
+
+
+ "ShiftR"
+ ~~~~~~~~~
+
+ It "returns '0' when shifting '42' 6 bits to the right"
+ (ShouldBe 0 (ShiftR 64 42 6))
+ -* It "returns 2 when shifting 512 8 bits to the right"
+ (ShouldBe 2 (ShiftR 64 512 8))
+
+testNatBits = Valid
+#endif
+
+
+spec :: Spec
+spec = do
+ basicsSpec
+#ifdef COMPLEXTESTS
+ sizedSpec
+ arraySpec
+ describe "The Set of Type Functions" $
+ it "is sound" $ do
+ print (Valid :: Expect (BitRecordSize (Flag .+. Field 7) `Is` 8))
+ print testTakeLastN
+ print testRem
+ print testRemPow2
+ print testDiv
+ print testNatBits
+ print checkTestRecAligned
+ print checkTestRecUnAligned
+ describe "showARecord" $ do
+ it "prints (Field 4 .+. (Field 4 := 0x96)) to \"<..>0110\"" $
+ let actual = showRecord (Proxy :: Proxy (Field 4 .+. Field 4 := 0x96))
+ in actual `shouldBe` "bits(4)\nbits(4) := 10010110 (hex: 96 dec: 150)"
+ describe "StaticLazybytestringbuilder" $ do
+ it "writes (and flushes) bits" $
+ let rec = Proxy
+ rec :: Proxy TestRecUnAligned
+ actualB :: Builder
+ actualB =
+ runBitStringBuilderHoley
+ (bitStringBuilderHoley rec)
+ 1
+ 3
+ 7
+ actual = printBuilder actualB
+ in actual `shouldBe`
+ "<< 01 00 06 00 00 00 00 0f fc >>"
+ describe "Formatting sub-byte fields" $ do
+ it "only the addressed bits are copied to the output" $
+ property $ \value ->
+ let rec = Proxy
+ rec :: Proxy (Field 4 := 0 .+. "here" @: Field 4)
+ actualB :: Builder
+ actualB = runBitStringBuilderHoley (bitStringBuilderHoley rec) value
+ actual = printBuilder actualB
+ expected = printf "<< %.2x >>" (value .&. 0xf)
+ in actual `shouldBe` expected
+ it "renders (Flag := 0 .+. Field 7 := 130) to << 02 >>" $
+ let rec = Proxy
+ rec :: Proxy (Flag := 'False .+. Field 7 := 130)
+ actual = printBuilder b
+ where b = runBitStringBuilderHoley (bitStringBuilderHoley rec)
+ in actual `shouldBe` "<< 02 >>"
+ describe "ByteStringBuilder" $
+ describe "runBitStringBuilderHoley" $
+ it "0x01020304050607 to << 00 01 02 03 04 05 06 07 >>" $
+ let expected = "<< 00 01 02 03 04 05 06 07 >>"
+ actual =
+ printBuilder
+ (runBitStringBuilderHoley
+ (bitStringBuilderHoley
+ (bitString 64 0x01020304050607)))
+ in actual `shouldBe` expected
+#endif
+
+instance (KnownNat n, n <= 64) => Arbitrary (B n) where
+ arbitrary = do
+ let h = 2^(n'-1) - 1
+ n' = fromIntegral (natVal (Proxy @n)) :: Int
+ x <- choose (0, h + h + 1)
+ return (B x)
diff --git a/spec/BoxFieldsSpec.hs b/spec/BoxFieldsSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/BoxFieldsSpec.hs
@@ -0,0 +1,96 @@
+module BoxFieldsSpec (spec) where
+
+import Test.Hspec
+import Data.ByteString.IsoBaseFileFormat.Boxes
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import qualified Data.ByteString.Lazy as BL
+import Control.Exception (evaluate)
+
+-- import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BL import
+-- qualified Data.Binary.Get as Binary
+spec :: Spec
+spec =
+ do describe "mkLanguage" $
+ do it "throws runtime exceptions when the code is too short or too long" $
+ do evaluate (mkLanguage "") `shouldThrow` anyException
+ evaluate (mkLanguage "a") `shouldThrow` anyException
+ evaluate (mkLanguage "aa") `shouldThrow` anyException
+ evaluate (mkLanguage "bbbb") `shouldThrow` anyException
+ evaluate (mkLanguage "bbbbb") `shouldThrow` anyException
+ it "throws runtime exceptions when the code is not in aaa .. zzz" $
+ do evaluate (mkLanguage "! 3") `shouldThrow` anyException
+ evaluate (mkLanguage "AAA") `shouldThrow` anyException
+ it "renders lower case three-letter strings correctly" $
+ let actual =
+ BL.unpack (toLazyByteString (boxBuilder (mkLanguage "deu")))
+ expected =
+ BL.unpack (toLazyByteString (word16BE (4 * 1024 + 5 * 32 + 21)))
+ in actual `shouldBe` expected
+ describe "Scalar, Constant, Template and ScalarArry composition" $
+ describe "IsBoxContent instances" $
+ do describe "example1" $
+ do it "boxSize reports the correct size" $ boxSize example1 `shouldBe`
+ (1 + 1 + (3 * 8) + (7 * 8))
+ it "crashes during rendering because of the invalid number of array elements for \"baz\"" $
+ evaluate (renderBox example1') `shouldThrow`
+ anyException
+ describe "example2" $
+ do it "boxSize reports the correct size" $ boxSize example2 `shouldBe`
+ (2 * 4 + 2 + 2 + 2 + 2 + 9 * 4 + 4 + 4)
+ it "it renders the expected content" $ renderBox example2 `shouldBe`
+ BL.pack [0 ,0 ,0 ,0
+ ,0 ,0 ,0 ,0
+ ,0 ,65 ,0 ,66
+ ,1 ,0 ,0 ,0
+ ,0 ,0 ,0 ,67
+ ,0 ,0 ,0 ,68
+ ,0 ,0 ,0 ,69
+ ,0 ,0 ,0 ,70
+ ,0 ,0 ,0 ,71
+ ,0 ,0 ,0 ,72
+ ,0 ,0 ,0 ,73
+ ,0 ,0 ,0 ,74
+ ,0 ,0 ,0 ,75
+ ,0 ,0 ,0 ,76
+ ,0 ,0 ,0 ,77]
+
+renderBox :: IsBoxContent c
+ => c -> BL.ByteString
+renderBox = toLazyByteString . boxBuilder
+
+type ExampleContent =
+ Scalar Word8 "bla"
+ :+ Constant (Scalar Word8 "blub") 123
+ :+ Template (ScalarArray "foos" 3 Int64) '[1, 2, 3]
+ :+ ScalarArray "baz" 7 Word64
+
+type ExampleContentShort =
+ U8 "bla"
+ :+ Constant (U8 "blub") 123
+ :+ Template (I64Arr "foos" 3) '[1, 2, 3]
+ :+ U64Arr "baz" 7
+
+example1 :: ExampleContent
+example1 = Scalar 100 :+ Constant :+ Template :+ u64Arr [1,2,3,4,5,6,7]
+
+example1' :: ExampleContentShort
+example1' = Scalar 100 :+ Constant :+ Template :+ u64Arr [6,6,6]
+
+type Example2 isAudio =
+ Constant (I32Arr "reserved" 2) '[0, 0]
+ :+ Template (I16 "layer") 0
+ :+ Template (I16 "alternate_group") 0
+ :+ Template (I16 "volume") (If isAudio 256 0)
+ :+ Constant (I16 "reserved") 0
+ :+ Template (I32Arr "matrix" 9) '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824]
+ :+ I32 "width"
+ :+ I32 "height"
+
+example2 :: Example2 'True
+example2 =
+ Constant :+ Custom 65 :+ Custom 66 :+ Template :+ Constant :+
+ Custom (i32Arr [67 .. 75]) :+
+ i32 76 :+
+ i32 77
diff --git a/spec/BoxSpec.hs b/spec/BoxSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/BoxSpec.hs
@@ -0,0 +1,92 @@
+module BoxSpec
+ ( spec
+ )
+where
+
+import Test.Hspec
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import qualified Data.ByteString.Builder as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Binary.Get as Binary
+import qualified Data.Text as T
+
+spec :: Spec
+spec =
+ describe "IsBoxContent instances" $ do
+ describe "IsBoxContent Data.Text.Text" $ do
+ describe "boxSize"
+ $ it "returns string length + 1 (for the null termination byte)"
+ $ do
+ boxSize (T.pack "") `shouldBe` 1
+ boxSize (T.pack "Hello!") `shouldBe` 7
+ describe "boxBuilder of Data.Text.Text" $ do
+ it "appends the null termination byte"
+ $ let
+ expected =
+ [72, 101, 108, 108, 111, 32, 119, 111, 114, 108, 100, 33, 0]
+ actual = BL.unpack $ toLazyByteString $ boxBuilder
+ (T.pack "Hello world!")
+ in
+ actual `shouldBe` expected
+ it "appends the null termination byte"
+ $ let
+ expected =
+ [72, 101, 108, 108, 111, 32, 119, 111, 114, 108, 100, 33, 0]
+ actual = BL.unpack $ toLazyByteString $ boxBuilder
+ (T.pack "Hello world!")
+ in
+ actual `shouldBe` expected
+ it "replaces embeded NULL characters with a space (0x20)"
+ $ let
+ expected =
+ [72, 101, 108, 108, 111, 32, 119, 111, 114, 108, 100, 33, 0]
+ actual = BL.unpack $ toLazyByteString $ boxBuilder
+ (T.pack "Hello\0world!")
+ in
+ actual `shouldBe` expected
+ describe "()" $ do
+ describe "boxSize" $ it "returns 0" $ boxSize () `shouldBe` 0
+ describe "boxBuilder"
+ $ it "emits no data"
+ $ BL.length (B.toLazyByteString (boxBuilder ()))
+ `shouldBe` 0
+ describe "Box" $ do
+ describe "boxSize"
+ $ it "returns the header size if the content is empty"
+ $ boxSize testBox1
+ `shouldBe` (4 + 4)
+ describe "Boxes" $ do
+ describe "boxSize" $ do
+ describe "a box with one nested box" $ do
+ it "returns the sum of both boxSizes"
+ $ boxSize (testParentBox1 $ singletonBox testBox1)
+ `shouldBe` (2 * boxSize testBox1)
+ it "returns the same value as written by boxBuilder"
+ $ let b = testParentBox1 $ singletonBox testBox1
+ writtenSize =
+ let out = toLazyByteString (boxBuilder b)
+ getSize = Binary.runGet Binary.getWord32be
+ in BoxSize $ fromIntegral $ getSize out
+ reportedSize = boxSize b
+ in writtenSize `shouldBe` reportedSize
+
+data TestBox1
+
+instance IsBox TestBox1 where
+ type BoxContent TestBox1 = ()
+
+type instance BoxTypeSymbol TestBox1 = "tst1"
+
+testBox1 :: Box TestBox1
+testBox1 = Box ()
+
+data TestParentBox1
+
+instance IsBox TestParentBox1 where
+ type BoxContent TestParentBox1 = ()
+
+type instance BoxTypeSymbol TestParentBox1 = "par1"
+
+testParentBox1 :: Boxes ts -> Box (ContainerBox TestParentBox1 ts)
+testParentBox1 = containerBox ()
diff --git a/spec/DataReferenceSpec.hs b/spec/DataReferenceSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/DataReferenceSpec.hs
@@ -0,0 +1,20 @@
+module DataReferenceSpec (spec) where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes
+import Test.Hspec
+
+spec :: Spec
+spec =
+ describe "IsBoxContent" $
+ describe "LocalMediaEntry" $
+ describe "boxSize" $
+ it "returns 0" $
+ let actual = boxSize localMediaDataReference
+ expected = drefHeader + entryField + durlHeader
+ drefHeader = boxHeader + fullHeader
+ entryField = 4
+ durlHeader = boxHeader + fullHeader
+ boxHeader = 4 + 4
+ fullHeader = 4
+ in actual `shouldBe` expected
diff --git a/spec/ElementaryStreamDescriptorSpec.hs b/spec/ElementaryStreamDescriptorSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/ElementaryStreamDescriptorSpec.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+module ElementaryStreamDescriptorSpec (spec) where
+
+import Test.Hspec
+import Data.ByteString.Mp4.Boxes.ElementaryStreamDescriptor
+import Data.ByteString.Mp4.Boxes.AudioSpecificConfig
+import Data.ByteString.Mp4.Boxes.DecoderConfigDescriptor
+import Data.ByteString.Mp4.Boxes.DecoderSpecificInfo
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.IsoBaseFileFormat.Box
+
+spec :: Spec
+spec = do
+#ifndef COMPLEXTESTS
+ return ()
+#else
+ describe "EsdBox" $ do
+ let eb = esdBox (Proxy @TestEsDescriptor) False 0 0 0
+ it "has the correct size" $
+ boxSize eb `shouldBe` 39
+ it "generates the expected bits" $
+ printBuilder (boxBuilder eb)
+ `shouldBe` "<< 00 00 00 27 65 73 64 73 00 00 00 00 03 19 00 01 00 04 11 40 15 00 00 00 00 00 00 00 00 00 00 00 05 02 11 98 06 01 02 >>"
+
+type TestEsDescriptor =
+ ESDescriptorMp4File
+ (StaticFieldValue "esId" 1)
+ TestConfigDescriptor
+
+type TestConfigDescriptor =
+ DecoderConfigDescriptor
+ 'AudioIso14496_3
+ 'AudioStream
+ '[AudioConfigAacMinimal
+ 'AacLc
+ DefaultGASpecificConfig
+ (SetEnum "samplingFreq" SamplingFreq 'SF48000)
+ (SetEnum "channelConfig" ChannelConfig 'SinglePair)]
+ '[]
+#endif
diff --git a/spec/EnumSpec.hs b/spec/EnumSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/EnumSpec.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE UndecidableInstances #-}
+module EnumSpec (spec) where
+
+import Data.Proxy
+import Data.Type.BitRecords
+import Data.Type.Equality ()
+import Prelude hiding ((.), id)
+import Test.Hspec
+
+spec = do
+ describe "ToPretty" $ do
+ it "renders as a record using showRecord" $
+ showRecord (Proxy @(BitRecordOfEnum (EnumParam "test" TestEnumExt)))
+ `shouldBe` "test: <>(2)"
+ describe "BitStringBuilder" $ do
+ it "produces binary output" $
+ bitStringPrinter (Proxy @(BitRecordOfEnum (EnumParam "test" TestEnumExt)))
+ (MkEnumValue (Proxy @'A))
+ `shouldBe` "<< 40 >>"
+
+type TestEnumExt = ExtEnum TestEnum 2 'Be FieldU16
+
+
+data TestEnum =
+ A | Be | C
+
+type instance FromEnum TestEnum 'A = 1
+type instance FromEnum TestEnum 'Be = 2
+type instance FromEnum TestEnum 'C = 4
diff --git a/spec/ExpandableSpec.hs b/spec/ExpandableSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/ExpandableSpec.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE UndecidableInstances #-}
+module ExpandableSpec (spec) where
+
+
+import Data.ByteString.Builder
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import qualified Data.ByteString.Lazy as B
+import Data.ByteString.Mp4.Boxes.Expandable
+import Test.Hspec
+import Test.QuickCheck
+
+
+spec :: Spec
+spec = do
+ describe "StaticExpandable" $ do
+ describe "ExpandableSizeLastChunk" $
+ it "renders both 2 and 130 as 00000010 " $ do
+ let actual130 = bitStringPrinter (Proxy :: Proxy ((ExpandableSizeLastChunk 130)))
+ actual2 = bitStringPrinter (Proxy :: Proxy (ExpandableSizeLastChunk 2))
+ actual130 `shouldBe` actual2
+ actual2 `shouldBe` "<< 02 >>"
+ describe "ExpandableSize" $
+ it "creates a stdandard conform size representation for the size 130" $
+ let actualStr = bitStringPrinter (Proxy :: Proxy (ExpandableSize 130))
+ in actualStr `shouldBe` "<< 81 02 >>"
+
+ -- TODO add new test
+ -- it "has a boxSize of 3 when using a 16-bit body value" $
+ -- boxSize (staticExpandable (Proxy :: Proxy (RecordField (Field 16 := 1234 )))) `shouldBe` BoxSize 3
+ -- it "has a boxBuilder that writes the body in big endian byte order for a 32-bit body value" $
+ -- B.unpack (toLazyByteString (boxBuilder (staticExpandable (Proxy :: Proxy (RecordField (Field 32 := 0x12345678 ))))))
+ -- `shouldBe` [4, 0x12, 0x34, 0x56, 0x78]
+ it "writes the size 128 as [ 0b10000001, 0b00000000 ] " $
+ let actual = B.unpack $ toLazyByteString (boxBuilder (Expandable (ETC 128)))
+ expected = [ 129, 0 ]
+ in actual `shouldBe` expected
+ it "writes the size (2 ^ 21) as [ 0b10000001, 0b10000000, 0b10000000, 0b00000000 ] " $
+ let actual = B.unpack $ toLazyByteString (boxBuilder (Expandable (ETC (2^(21 :: Int)))))
+ expected = [ 129, 128, 128, 0 ]
+ in actual `shouldBe` expected
+ it "writes the size (2 ^ 21 - 1) as [ 0b11111111, 0b11111111, 0b01111111 ] " $
+ let actual = B.unpack $ toLazyByteString (boxBuilder (Expandable (ETC (2^(21 :: Int) - 1))))
+ expected = [ 255, 255, 127 ]
+ in actual `shouldBe` expected
+ it "writes size according to the spec" $
+ property $ \etc@(ETC s) ->
+ let expectedBoxSize =
+ BoxSize $
+ s +
+ if s < 2 ^ ( 7 :: Int) then 1
+ else if s < 2 ^ (14 :: Int) then 2
+ else if s < 2 ^ (21 :: Int) then 3 else 4
+ actualBoxSize = boxSize (Expandable etc)
+ in
+ actualBoxSize `shouldBe` expectedBoxSize
+
+
+instance Arbitrary ExpandableTestContent where
+ arbitrary = ETC <$> choose (0, 2^(28::Integer) - 1)
+
+newtype ExpandableTestContent =
+ ETC Word64
+ deriving (Show, Eq)
+
+instance IsBoxContent ExpandableTestContent where
+ boxSize (ETC s) = BoxSize s
+ boxBuilder _ = mempty
diff --git a/spec/MediaFileSpec.hs b/spec/MediaFileSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/MediaFileSpec.hs
@@ -0,0 +1,71 @@
+module MediaFileSpec
+ (spec)
+ where
+
+import Test.Hspec
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.MediaFile
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.Lazy (unpack)
+
+spec :: Spec
+spec =
+ describe "mediaBuilder" $
+ do describe "Empty BoxLayout" $
+ it "accepts valid box content types" $
+ let test =
+ mediaBuilder (Proxy :: Proxy TestBrandEmpty)
+ NoBoxes
+ in printBuilderStdOut test
+ describe "Single Box BoxLayout" $
+ it "accepts valid box content types" $
+ let test =
+ mediaBuilder (Proxy :: Proxy TestBrandSingle)
+ (singletonBox testBox1)
+ in printBuilderStdOut test
+ describe "Multiple nested Boxes BoxLayout" $
+ it "accepts valid box content types" $
+ let test =
+ mediaBuilder (Proxy :: Proxy TestBrandNested)
+ (singletonBox (testParentBox1 $: testBox1))
+ in printBuilderStdOut test
+
+printBuilderStdOut :: Builder -> IO ()
+printBuilderStdOut b =
+ putStrLn $ unlines $ (" "++) <$> lines (show (unpack (toLazyByteString b)))
+
+data TestBox1
+
+instance IsBox TestBox1 where
+ type BoxContent TestBox1 = ()
+
+type instance BoxTypeSymbol TestBox1 = "tst1"
+
+testBox1 :: Box TestBox1
+testBox1 = Box ()
+
+data TestParentBox1
+
+instance IsBox TestParentBox1 where
+ type BoxContent TestParentBox1 = ()
+
+type instance BoxTypeSymbol TestParentBox1 = "par1"
+
+testParentBox1
+ :: Boxes ts -> Box (ContainerBox TestParentBox1 ts)
+testParentBox1 = containerBox ()
+
+data TestBrandEmpty
+
+instance IsMediaFileFormat TestBrandEmpty where
+ type BoxLayout TestBrandEmpty = Boxes '[]
+
+data TestBrandSingle
+
+instance IsMediaFileFormat TestBrandSingle where
+ type BoxLayout TestBrandSingle = Boxes '[OM_ TestBox1]
+
+data TestBrandNested
+
+instance IsMediaFileFormat TestBrandNested where
+ type BoxLayout TestBrandNested = Boxes '[OM TestParentBox1 '[OM_ TestBox1]]
diff --git a/spec/Mp4AudioFileSpec.hs b/spec/Mp4AudioFileSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/Mp4AudioFileSpec.hs
@@ -0,0 +1,193 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Mp4AudioFileSpec (spec) where -- TODO rename to mp4 audio init spec
+
+import Test.Hspec
+import Data.ByteString.Mp4.Boxes.BaseDescriptor
+import Data.ByteString.Mp4.Boxes.AudioSpecificConfig
+import Data.ByteString.Mp4.Boxes.Mp4AudioSampleEntry
+import Data.ByteString.Mp4.AudioStreaming
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString as BS
+import Data.Text ()
+
+spec :: Spec
+spec =
+ do
+ describe "Mp4AacAudioDecoderConfigDescriptor" $ do
+ it "can be pretty printed" $
+ showRecord (Proxy @(BitRecordOfDescriptor
+ $~ (Eval (Mp4AacAudioDecoderConfigDescriptor
+ (AudioConfigAacLc
+ (EnumParam "samplingFreq" SamplingFreq)
+ (EnumParam "channelConfig" ChannelConfig))))))
+ `shouldEndWith`
+ "has-gas-extension: boolean := no"
+
+#ifdef COMPLEXTESTS
+ it "can be transformed to binary output" $
+ let actual =
+ bitStringPrinter
+ (Proxy @(BitRecordOfDescriptor
+ $~ Eval (Mp4AacAudioDecoderConfigDescriptor
+ (AudioConfigAacLc
+ (EnumParam "samplingFreq" SamplingFreq)
+ (EnumParam "channelConfig" ChannelConfig)))))
+ True
+ 1
+ 2
+ 3
+ (MkEnumValue (Proxy @'SF16000))
+ (MkEnumValue (Proxy @'SingleChannel))
+ expexted = "<< 04 11 40 17 00 00 01 00 00 00 02 00 00 00 03 05 02 14 08 >>"
+ in actual `shouldBe` expexted
+ describe "Mp4AacLcEsDescriptor" $
+ do it "can be transformed to binary output" $
+ bitStringPrinter (Proxy @(BitRecordOfDescriptor $~ Eval Mp4AacLcEsDescriptor))
+ False 0 0 0
+ (MkEnumValue (Proxy @'SF48000))
+ (MkEnumValue (Proxy @'SingleChannel))
+ `shouldBe`
+ "<< 03 19 00 01 00 04 11 40 15 00 00 00 00 00 00 00 00 00 00 00 05 02 11 88 06 01 02 >>"
+ it "can be pretty printed" $
+ showRecord (Proxy @(BitRecordOfDescriptor $~ Eval Mp4AacLcEsDescriptor))
+ `shouldStartWith` "U8 := hex: 03 (dec: 3)\n"
+ describe "Mp4HeAacEsDescriptor" $
+ do it "can be transformed to binary output" $
+ bitStringPrinter (Proxy @(BitRecordOfDescriptor $~ Eval Mp4HeAacEsDescriptor))
+ False 0 0 0
+ (MkEnumValue (Proxy @'SF48000))
+ (MkEnumValue (Proxy @'SingleChannel))
+ (MkEnumValue (Proxy @'SF24000))
+ `shouldBe`
+ "<< 03 1a 00 01 00 04 12 40 15 00 00 00 00 00 00 00 00 00 00 00 05 03 29 8b 08 03 00 81 00 >>"
+ describe "SingleAudioTrackInit version 0" $
+ do it "renders some output at all" $
+ do creationTime <- mp4CurrentTime
+ let ct :: Word32
+ ct = fromScalar creationTime
+ ct3 = (ct `shiftR` 24) .&. 255
+ ct2 = (ct `shiftR` 16) .&. 255
+ ct1 = (ct `shiftR` 8) .&. 255
+ ct0 = (ct `shiftR` 0) .&. 255
+ cts :: [Word8]
+ cts = fromIntegral <$> [ct3,ct2,ct1,ct0]
+ let args = exampleSingleTrackInit creationTime
+ doc = buildAacInitSegment args
+ rendered = BS.unpack $ fromBinaryAacInitSegment doc
+ expected =
+ [
+ -- ftyp box
+ 0,0,0,32
+ ,102,116,121,112
+ ,105,115,111,53,0,0,0,0
+ ,105,115,111,109
+ ,105,115,111,53
+ ,100,97,115,104
+ ,109,112,52,50
+ -- skip box
+ ,0,0,0,49
+ ,115,107,105,112
+ ,76,105,110,100,101,110,98,97,117,109,32,71,109,98,72,44,32,105
+ ,115,111,98,109,102,102,44,32
+ ,83,118,101,110,32,72,101,121,108,108,32,50,48,49,57
+ -- moov box
+ ,0,0,2,57,109 ,111 ,111 ,118
+ -- mvhd box
+ ,0 ,0 ,0 ,108 ,109 ,118 ,104 ,100 ,0 ,0 ,0 ,0]
+ ++ cts ++ cts ++
+ [0 ,1 ,95 ,144
+ ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0 ,1 ,0 ,0 ,0
+ ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0
+ ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
+ ,0 ,0 ,0 ,0 ,0 ,0 ,64 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
+ ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
+ ,0 ,0 ,0 ,2
+ -- trak box
+ ,0 ,0 ,1,157
+ ,116 ,114 ,97 ,107
+ -- tkhd box
+ ,0 ,0 ,0 ,92
+ ,116 ,107 ,104 ,100
+ ,0 ,0 ,0 ,7]
+ ++ cts ++ cts ++
+ [0 ,0 ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
+ ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0 ,0
+ ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
+ ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
+ ,0 ,64 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
+ -- mdia box
+ ,0,0,1,57
+ ,109,100,105,97
+ -- mdhd box
+ ,0,0,0,32
+ ,109,100,104,100
+ ,0,0,0,0]
+ ++ cts ++ cts ++
+ [0,0,187,128
+ ,0,0,0,0
+ ,85,196
+ ,0,0
+ -- hdlr box
+ ,0,0,0,44
+ ,104,100,108,114
+ ,0,0,0,0,0,0,0,0,115,111,117,110,0,0,0,0,0,0,0,0,0,0,0,0
+ ,72,101,108,108,111,32,119,111,114,108,100,0
+ -- minf box
+ ,0,0,0,229
+ ,109,105,110,102
+ -- smhd box
+ ,0,0,0,16
+ ,115,109,104,100,0,0,0,0,0,0,0,0
+ -- dinf boimport Data.ByteString.IsoBaseFileFormat.Boxes
+ ,0,0,0,36
+ ,100,105,110,102
+ -- dref box
+ ,0,0,0,28
+ ,100,114,101,102
+ ,0,0,0,0,0,0,0,1
+ -- url box
+ ,0,0,0,12
+ ,117,114,108,32
+ ,0,0,0,1
+ -- stbl box
+ ,0,0,0,169
+ ,115,116,98,108
+ -- stsd box
+ ,0,0,0,93
+ ,115,116,115,100
+ ,0,0,0,0,0,0,0,1
+ -- mp4a box
+ ,0,0,0,77
+ ,109,112,52,97
+ ,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,1,0,16,0,0,0,0,187,128,0,0
+ -- esds box
+ ,0,0,0,41
+ ,101,115,100,115
+ ,0,0,0,0,3,26,0,1,0,4,18,64,21
+ ,0,0,0,0,0,0,0,0,0,0,0,5,3,41,137,136,3,0,129,0
+ -- stts box
+ ,0,0,0,16
+ ,115,116,116,115,0,0,0,0,0,0,0,0
+ -- stsc box
+ ,0,0,0,16
+ ,115,116,115,99,0,0,0,0,0,0,0,0
+ -- stsz box
+ ,0,0,0,20
+ ,115,116,115,122,0,0,0,0,0,0,0,0,0,0,0,0
+ -- stc0 box
+ ,0,0,0,16
+ ,115,116,99,111,0,0,0,0,0,0,0,0
+ -- mvex box
+ ,0,0,0,40
+ ,109,118,101,120
+ -- trex box
+ ,0,0,0,32
+ ,116,114,101,120,0,0,0,0,0,0,0,1,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0]
+ BL.writeFile "/tmp/isobmff-test-case-dash-spec.mp4" (BL.pack rendered)
+ rendered `shouldBe`
+ expected
+
+exampleSingleTrackInit :: U32 "creation_time" -> AacInitSegment
+exampleSingleTrackInit creationTime =
+ AacInitSegment creationTime "Hello world" True SF48000 SingleChannel
+#endif
diff --git a/spec/Mp4AudioSampleEntrySpec.hs b/spec/Mp4AudioSampleEntrySpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/Mp4AudioSampleEntrySpec.hs
@@ -0,0 +1,24 @@
+module Mp4AudioSampleEntrySpec ( spec ) where
+
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.Mp4.Boxes.AudioSpecificConfig
+import Test.Hspec
+
+spec :: Spec
+spec = describe "AudioObjectType" $
+ it "type-checks" $ do
+ print testAudioObjectType
+
+testAudioObjectType = Valid
+testAudioObjectType ::
+
+ "Audio Object Types"
+ #####################
+
+ "Small Audio Object Types"
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ 5 `ShouldBe` BitRecordSize (AudioObjectTypeRec 'AoReserved5) -/-
+
+ "Big Audio Object Types"
+ ~~~~~~~~~~~~~~~~~~~~~~~~
+ 11 `ShouldBe` BitRecordSize (AudioObjectTypeRec 'AoCustom)
diff --git a/spec/Mp4AudioSegmentSpec.hs b/spec/Mp4AudioSegmentSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/Mp4AudioSegmentSpec.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Mp4AudioSegmentSpec (spec) where
+
+import qualified Data.ByteString as BS
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import qualified Data.ByteString.Lazy as BL
+import Data.ByteString.Mp4.AudioStreaming
+import Data.Text ()
+import Test.Hspec
+
+spec :: Spec
+spec =
+ describe "AacMp4TrackFragment" $
+ do let args = moof
+ doc = buildAacMp4TrackFragment args
+ rendered = BL.unpack $ toLazyByteString $ doc
+ dataOffset = 120
+ expected =
+ [
+ -- styp box
+ 0,0,0,24
+ ,115,116,121,112
+ ,109,115,100,104,0,0,0,0
+ ,109,115,100,104
+ ,100,97,115,104
+ -- moov box [offset here: 32]
+ ,0,0,0,112
+ ,109,111,111,102
+ -- mfhd box
+ ,0,0,0,16
+ ,109,102,104,100
+ ,0,0,0,0,0,0,0,13
+ -- traf
+ ,0,0,0,88
+ ,116,114,97,102
+ -- tfhd
+ ,0,0,0,16
+ ,116,102,104,100
+ ,0,2,0,0,0,0,0,1
+ -- tfdt
+ ,0,0,0,20
+ ,116,102,100,116
+ ,1,0,0,0,0,0,0,0,0,0,0,37
+ -- trun
+ ,0,0,0,44
+ ,116,114,117,110
+ ,0,0,7,1
+ ,0,0,0,2
+ ,0,0,0,dataOffset
+ -- sample 1
+ ,0,0,0,23 -- duration
+ ,0,0,0,192 -- length
+ ,2,0,0,0 -- flags
+ -- sample 2
+ ,0,0,0,23
+ ,0,0,0,192
+ ,2,0,0,0
+ -- mdat
+ ,0,0,1,136
+ ,109,100,97,116]
+ -- sample 1
+ ++ [0..191]
+ -- sample 2
+ ++ [0..191]
+ it "renders the exact expectected output" $ do
+#ifdef COMPLEXTESTS
+ BL.writeFile "/tmp/isobmff-test-case-dash-spec.m4s" (BL.pack rendered)
+#endif
+ rendered `shouldBe` expected
+ it "calculates the data-offset correctly" $
+ drop ((fromIntegral dataOffset) + 12 * 2) rendered
+ `shouldBe` ([0..191] ++ [0..191])
+
+moof :: AacMp4TrackFragment
+moof = AacMp4TrackFragment 13 37 (replicate 2 (23, BS.pack [0..191]))
diff --git a/spec/Spec.hs b/spec/Spec.hs
new file mode 100644
--- /dev/null
+++ b/spec/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/spec/TypeLayoutSpec.hs b/spec/TypeLayoutSpec.hs
new file mode 100644
--- /dev/null
+++ b/spec/TypeLayoutSpec.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE UndecidableInstances #-}
+module TypeLayoutSpec (spec) where
+
+import Test.Hspec
+import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout
+import Data.ByteString.IsoBaseFileFormat.Box
+
+spec :: Spec
+spec =
+ describe "IsRuleConform" $ do
+ describe "TopLevel" $ do
+ it "validates TopLevel Boxes" $ test1 `shouldBe` ()
+ describe "ContainerBoxes" $ do
+ describe "OnceOptional" $ do
+ it "validates empty containters" $ test2a `shouldBe` ()
+ it "validates a singleton container" $ test2b `shouldBe` ()
+ describe "SomeOptional" $ do
+ it "validates empty containters" $ test3a `shouldBe` ()
+ it "validates a singleton container" $ test3b `shouldBe` ()
+ it "validates a multi-element container" $ test3c `shouldBe` ()
+ describe "(implied) mandatory" $ do
+ it "validates a singleton container" $ test4 `shouldBe` ()
+ describe "SomeMandatory" $ do
+ it "validates a singleton container" $ test5a `shouldBe` ()
+ it "validates a multi-element container" $ test5b `shouldBe` ()
+#ifdef COMPLEXTESTS
+ it "validates a Mix of SomeMandatory, OnceOptional, SomeOptional" $ do
+ test6a `shouldBe` ()
+ test6b `shouldBe` ()
+ test6c `shouldBe` ()
+ test6d `shouldBe` ()
+ it "validates deeply nested container" $ do
+ test7a `shouldBe` ()
+ test7b `shouldBe` ()
+ test7c `shouldBe` ()
+#endif
+
+----
+data Foo
+type instance BoxTypeSymbol Foo = ToSymbol Foo
+type instance ToSymbol Foo = "foo "
+data Fov
+type instance BoxTypeSymbol Fov = ToSymbol Fov
+type instance ToSymbol Fov = "fov "
+data Bar
+type instance BoxTypeSymbol Bar = ToSymbol Bar
+type instance ToSymbol Bar = "bar "
+data Baz
+type instance BoxTypeSymbol Baz = ToSymbol Baz
+type instance ToSymbol Baz = "baz "
+----
+type TestRule1 = TopLevel (MatchSymbol "foo ")
+type TestType1 = Foo
+test1 :: (IsRuleConform TestType1 TestRule1 ~ 'True) => ()
+test1 = ()
+----
+
+type TestRule2 = TopLevel (ContainerBox Foo '[OnceOptionalX (MatchSymbol "bar ")])
+type TestType2a = Box (ContainerBox Foo '[])
+test2a :: (IsRuleConform TestType2a TestRule2 ~ 'True
+ ) => ()
+test2a = ()
+--
+type TestType2b = Box (ContainerBox Foo '[Bar])
+test2b :: (IsRuleConform TestType2b TestRule2 ~ 'True) => ()
+test2b = ()
+----
+type TestRule3 = TopLevel (ContainerBox Foo '[SomeOptionalX (MatchSymbol "bar ")])
+type TestType3a = Box (ContainerBox Foo '[])
+test3a :: (IsRuleConform TestType3a TestRule3 ~ 'True) => ()
+test3a = ()
+--
+type TestType3b = Box (ContainerBox Foo '[Bar])
+test3b :: (IsRuleConform TestType3b TestRule3 ~ 'True) => ()
+test3b = ()
+--
+type TestType3c = Box (ContainerBox Foo '[Bar,Bar])
+test3c :: (IsRuleConform TestType3c TestRule3 ~ 'True) => ()
+test3c = ()
+----
+type TestRule4 = TopLevel (ContainerBox Foo '[MatchSymbol "bar "])
+type TestType4 = Box (ContainerBox Foo '[Bar])
+test4 :: (IsRuleConform TestType4 TestRule4 ~ 'True) => ()
+test4 = ()
+----
+type TestRule5 = TopLevel (ContainerBox Foo '[SomeMandatoryX (MatchSymbol "bar ")])
+type TestType5a = Box (ContainerBox Foo '[Bar])
+test5a :: (IsRuleConform TestType5a TestRule5 ~ 'True) => ()
+test5a = ()
+type TestType5b = Box (ContainerBox Foo '[Bar, Bar])
+test5b :: (IsRuleConform TestType5b TestRule5 ~ 'True) => ()
+test5b = ()
+
+
+----
+#ifdef COMPLEXTESTS
+type TestRule6 =
+ (ContainerBox Foo
+ '[ OnceOptionalX (MatchSymbol "baz ")
+ , SomeMandatoryX (MatchSymbol "bar ")
+ , SomeOptionalX (MatchSymbol "fov ")
+ , MatchSymbol "foo "])
+type TestType6a =
+ Box (ContainerBox Foo '[Baz,Bar,Bar,Bar,Fov,Fov,Foo])
+test6a :: (IsRuleConform TestType6a TestRule6 ~ 'True) => ()
+test6a = ()
+type TestType6b =
+ Box (ContainerBox Foo '[Bar,Bar,Bar,Fov,Fov,Foo])
+test6b :: (IsRuleConform TestType6b TestRule6 ~ 'True) => ()
+test6b = ()
+type TestType6c =
+ Box (ContainerBox Foo '[Bar,Fov,Fov,Foo])
+test6c :: (IsRuleConform TestType6c TestRule6 ~ 'True) => ()
+test6c = ()
+type TestType6d = Box (ContainerBox Foo '[Bar,Foo])
+test6d :: (IsRuleConform TestType6d TestRule6 ~ 'True) => ()
+test6d = ()
+
+
+----
+type TestRule7 =
+ TopLevel (ContainerBox Foo
+ '[ SomeOptionalX (ContainerBox Fov
+ '[ OnceOptionalX (ContainerBox Baz
+ '[MatchSymbol "foo "])
+ , SomeMandatoryX (MatchSymbol "bar ")
+ ])])
+type TestType7a = Box (ContainerBox Foo '[ ])
+test7a :: (IsRuleConform TestType7a TestRule7 ~ 'True) => ()
+test7a = ()
+type TestType7b = Box (ContainerBox Foo
+ '[ Box (ContainerBox Fov
+ '[Box (ContainerBox Baz
+ '[Foo])
+ , Bar])])
+test7b :: (IsRuleConform TestType7b TestRule7 ~ 'True) => ()
+test7b = ()
+type TestType7c = Box (ContainerBox Foo
+ '[ Box (ContainerBox Fov
+ '[ Box (ContainerBox Baz
+ '[Foo])
+ , Bar
+ , Bar
+ , Bar
+ ])
+ , Box (ContainerBox Fov
+ '[ Box (ContainerBox Baz
+ '[Foo])
+ , Bar
+ , Bar
+ , Bar
+ ])
+ ])
+test7c :: (IsRuleConform TestType7c TestRule7 ~ 'True) => ()
+test7c = ()
+#endif
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Box.hs b/src/Data/ByteString/IsoBaseFileFormat/Box.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Box.hs
@@ -0,0 +1,379 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Definition of the most basic element in an ISOBMFF file: a /box/. See
+-- Chapter 4 in the standard document. A box is a container with a type, a
+-- size, some data and some nested boxes. The standard defines - among other
+-- characteristics - available box types and their semantics, the fields they
+-- contain and how they are nested into each other. This library tries to
+-- capture some of these characteristics using modern Haskell type system
+-- features, in order to provide compile time checks for (partial) standard
+-- compliance.
+module Data.ByteString.IsoBaseFileFormat.Box where
+
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.Singletons.Prelude.List (type (++),
+ Length)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString as B
+
+-- * Box Type Classes
+-- | Base class for all (abstract/phantom/normal-) types that represent boxes
+class (KnownSymbol (BoxTypeSymbol t), IsBoxContent (BoxContent t))
+ => IsBox (t :: Type) where
+ type BoxContent t
+ type BoxContent t = t
+ toBoxType :: proxy t -> BoxType
+ toBoxType _ = parseBoxType (Proxy :: Proxy (BoxTypeSymbol t))
+
+-- | A type family used by the type-level consistency checks. It is required
+-- that an instance of this type family exists for every 'IsBox' instance.
+-- This family could not be associative since it is used by type families that
+-- cannot have type class constraints.
+type family BoxTypeSymbol (t :: k) :: Symbol
+
+-- | Types that go into a box. A box content is a piece of data that can be
+-- reused in different instances of 'IsBox'. It has no 'BoxType' and hence
+-- defines no box.
+class IsBoxContent a where
+ boxSize :: a -> BoxSize
+ boxBuilder :: a -> Builder
+
+-- * Box Contents
+-- TODO move all IsBoxContent stuff to BoxContent.hs
+
+-- | A type that wraps the contents of a box and the box type.
+data Box b where
+ Box ::
+ !(BoxContent b) -> Box b
+
+instance IsBox b => IsBox (Box b) where
+ type BoxContent (Box b) = BoxContent b
+ toBoxType _ = toBoxType (Proxy :: Proxy b)
+
+type instance BoxTypeSymbol (Box b) = BoxTypeSymbol b
+
+instance IsBox cnt => IsBoxContent (Box cnt) where
+ boxBuilder b@(Box cnt) = sB <> tB <> sExtB <> tExtB <> cntB
+ where s = boxSize b
+ t = toBoxType b
+ sB = boxBuilder s
+ sExtB = boxBuilder (BoxSizeExtension s)
+ tB = boxBuilder t
+ tExtB = boxBuilder (BoxTypeExtension t)
+ cntB = boxBuilder cnt
+ boxSize b@(Box cnt) = sPayload + boxSize (BoxSizeExtension sPayload)
+ where sPayload =
+ boxSize (BoxSize undefined) + boxSize t + boxSize cnt +
+ boxSize (BoxTypeExtension t)
+ t = toBoxType b
+
+instance (Default (BoxContent b)) => Default (Box b) where
+ def = Box def
+
+-- | Compose 'BoxContent' and 'Boxes' under the Constraint that they are
+-- composable.
+data ContainerBox b (bs :: [Type]) where
+ ContainerBox :: IsBox b => !(BoxContent b) -> !(Boxes bs) -> ContainerBox b bs
+
+instance (IsBox b) => IsBox (ContainerBox b bs)
+
+type instance BoxTypeSymbol (ContainerBox b bs) = BoxTypeSymbol b
+
+instance IsBoxContent (ContainerBox b bs) where
+ boxSize (ContainerBox c bs) = boxSize (c :+ bs)
+ boxBuilder (ContainerBox c bs) = boxBuilder (c :+ bs)
+
+-- | A heterogenous collection of boxes.
+data Boxes (boxTypes :: [Type]) where
+ NoBoxes :: Boxes '[]
+ (:.) :: IsBox l => !(Box l) -> !(Boxes r) -> Boxes (Box l ': r)
+ -- | Create a 'Boxes' collection from two 'Box'es
+ (:<>) :: !(Boxes l) -> !(Boxes r) -> Boxes (l ++ r)
+ (:|) :: (IsBox l, IsBox r) => !(Box l) -> !(Box r) -> Boxes '[Box l, Box r]
+
+infixr 1 :<>
+infixr 2 :.
+infixr 2 :|
+infixr 3 $:
+
+-- | Apply a function to a 'Boxes' collection containing only a single 'Box'.
+($:) :: IsBox l => (Boxes '[Box l] -> r) -> Box l -> r
+($:) f = f . singletonBox
+
+-- | Create a 'Boxes' collection with a single 'Box'.
+singletonBox :: IsBox l => Box l -> Boxes '[Box l]
+singletonBox b = b :. NoBoxes
+
+-- | Get the elements in a type level array
+typeListLength :: forall a proxy (ts :: [k]) . (KnownNat (Length ts), Num a)
+ => proxy ts -> a
+typeListLength _ = fromIntegral (natVal (Proxy :: Proxy (Length ts)))
+
+instance IsBoxContent (Boxes bs) where
+ boxSize NoBoxes = 0
+ boxSize (l :. r) = boxSize l + boxSize r
+ boxSize (l :| r) = boxSize l + boxSize r
+ boxSize (l :<> r) = boxSize l + boxSize r
+ boxBuilder NoBoxes = mempty
+ boxBuilder (l :. r) = boxBuilder l <> boxBuilder r
+ boxBuilder (l :| r) = boxBuilder l <> boxBuilder r
+ boxBuilder (l :<> r) = boxBuilder l <> boxBuilder r
+
+-- | A box that contains no fields, but nested boxes.
+containerBox :: (IsBox t)
+ => BoxContent t -> Boxes ts -> Box (ContainerBox t ts)
+containerBox c bs = Box (ContainerBox c bs)
+
+-- * Box Size and Type
+-- | The size of the box. If the size is limited to a (fixed) value, it can be
+-- provided as a 'Word64' which will be represented as either a 32bit compact
+-- size or as 64 bit /largesize/. If 'UnlimitedSize' is used, the box extends to
+-- the end of the file.
+data BoxSize
+ = UnlimitedSize
+ | BoxSize !Word64
+ deriving (Show,Eq)
+
+fromBoxSize :: Num a => a -> BoxSize -> a
+fromBoxSize !fallback UnlimitedSize = fallback
+fromBoxSize _fallback (BoxSize !s) = fromIntegral s
+
+instance IsBoxContent BoxSize where
+ boxSize _ = BoxSize 4
+ boxBuilder UnlimitedSize = word32BE 0
+ boxBuilder (BoxSize n) =
+ word32BE $
+ if n < (4294967296 :: Word64)
+ then fromIntegral n
+ else 1
+
+instance Num BoxSize where
+ (+) UnlimitedSize _ = UnlimitedSize
+ (+) _ UnlimitedSize = UnlimitedSize
+ (+) (BoxSize l) (BoxSize r) = BoxSize (l + r)
+ (-) UnlimitedSize _ = UnlimitedSize
+ (-) _ UnlimitedSize = UnlimitedSize
+ (-) (BoxSize l) (BoxSize r) = BoxSize (l - r)
+ (*) UnlimitedSize _ = UnlimitedSize
+ (*) _ UnlimitedSize = UnlimitedSize
+ (*) (BoxSize l) (BoxSize r) = BoxSize (l * r)
+ abs UnlimitedSize = UnlimitedSize
+ abs (BoxSize n) = BoxSize (abs n)
+ signum UnlimitedSize = UnlimitedSize
+ signum (BoxSize n) = BoxSize (signum n)
+ fromInteger n = BoxSize $ fromInteger n
+
+-- | The 'BoxSize' can be > 2^32 in which case an 'BoxSizeExtension' must be
+-- added after the type field.
+newtype BoxSizeExtension =
+ BoxSizeExtension BoxSize
+
+instance IsBoxContent BoxSizeExtension where
+ boxBuilder (BoxSizeExtension UnlimitedSize) = mempty
+ boxBuilder (BoxSizeExtension (BoxSize n)) =
+ if n < 4294967296
+ then mempty
+ else word64BE n
+ boxSize (BoxSizeExtension UnlimitedSize) = 0
+ boxSize (BoxSizeExtension (BoxSize n)) =
+ BoxSize $
+ if n < 4294967296
+ then 0
+ else 8
+
+-- | A box has a /type/, this is the value level representation for the box type.
+data BoxType
+ =
+ -- | `FourCc` can be used as @boxType@ in `Box`, standard four letter character
+ -- code, e.g. @ftyp@
+ StdType !FourCc
+ |
+ -- | CustomBoxType defines custom @boxType@s in `Box`es.
+ CustomBoxType !String
+ deriving (Show,Eq)
+
+-- | Create a box type from a 'Symbol'. Parse the symbol value, if it's a four
+-- charachter code, then return that as 'StdType' otherwise parse a UUID (TODO)
+-- and return a 'CustomBoxType'.
+parseBoxType :: KnownSymbol t => proxy t -> BoxType
+parseBoxType px = StdType (fromString (symbolVal px))
+
+-- | A type containin a printable four letter character code. TODO replace impl with U32Text
+newtype FourCc =
+ FourCc (Char,Char,Char,Char)
+ deriving (Show,Eq)
+
+instance IsString FourCc where
+ fromString !str
+ | length str == 4 =
+ let [!a,!b,!c,!d] = str
+ in FourCc (a,b,c,d)
+ | otherwise =
+ error ("cannot make a 'FourCc' of a String which isn't exactly 4 bytes long: " ++
+ show str ++ " has a length of " ++ show (length str))
+
+instance IsBoxContent FourCc where
+ boxSize _ = 4
+ boxBuilder (FourCc (!a,!b,!c,!d)) = putW a <> putW b <> putW c <> putW d
+ where putW = word8 . fromIntegral . fromEnum
+
+instance IsBoxContent BoxType where
+ boxSize _ = boxSize (FourCc undefined)
+ boxBuilder t =
+ case t of
+ StdType x -> boxBuilder x
+ CustomBoxType _ -> boxBuilder (FourCc ('u','u','i','d'))
+
+-- | When using custom types extra data must be written after the extra size
+-- information. Since the box type and the optional custom box type are not
+-- guaranteed to be consequtive, this type handles the /second/ part seperately.
+newtype BoxTypeExtension =
+ BoxTypeExtension BoxType
+
+instance IsBoxContent BoxTypeExtension where
+ boxSize (BoxTypeExtension !(StdType _)) = 0
+ boxSize (BoxTypeExtension !(CustomBoxType _)) = 16 * 4
+ boxBuilder (BoxTypeExtension !(StdType _)) = mempty
+ boxBuilder (BoxTypeExtension !(CustomBoxType str)) =
+ mconcat (map (word8 . fromIntegral . fromEnum)
+ (take (16 * 4) str) ++
+ repeat (word8 0))
+
+-- * 'IsBoxContent' instances
+-- | An empty box content can by represented by @()@ (i.e. /unit/).
+instance IsBoxContent () where
+ boxSize _ = 0
+ boxBuilder _ = mempty
+
+-- | Trivial instance for 'ByteString'
+instance IsBoxContent B.ByteString where
+ boxSize = fromIntegral . B.length
+ boxBuilder = byteString-- -- | A list, a maybe, and every other 'Foldable' of contents is a content.
+ -- instance (Foldable f, IsBoxContent t) => IsBoxContent (f t) where
+ -- boxSize = foldr' (\e acc -> acc + boxSize e) 0
+ -- boxBuilder = foldMap boxBuilder
+
+-- | This 'Text' instance writes a null terminated UTF-8 string.
+instance IsBoxContent T.Text where
+ boxSize = (1+) . fromIntegral . T.length
+ boxBuilder txt = boxBuilder (T.encodeUtf8 txtNoNulls) <> word8 0
+ where txtNoNulls = T.map (\c -> if c == '\0' then ' ' else c) txt
+
+-- | This instance writes zero bytes for 'Nothing' and delegates on 'Just'.
+instance IsBoxContent a => IsBoxContent (Maybe a) where
+ boxSize = maybe 0 boxSize
+ boxBuilder = maybe mempty boxBuilder
+
+-- * Box concatenation
+
+-- | Box content composition
+data a :+ b = !a :+ !b
+
+infixr 3 :+
+
+instance (IsBoxContent p,IsBoxContent c) => IsBoxContent (p :+ c) where
+ boxSize (p :+ c) = boxSize p + boxSize c
+ boxBuilder (p :+ c) = boxBuilder p <> boxBuilder c
+
+instance (Default a, Default b) => Default (a :+ b) where
+ def = def :+ def
+
+-- * Tagged boxes
+
+instance IsBoxContent c => IsBoxContent (Tagged s c) where
+ boxSize = boxSize . untag
+ boxBuilder = boxBuilder . untag
+
+-- * List Box Content
+
+-- | A list of things that renders to a size field with the number of elements
+-- and the sequence of elements. This type is index with the size field type.
+newtype ListContent sizeType contentType =
+ ListContent [contentType]
+
+instance (Num sizeType, IsBoxContent sizeType, IsBoxContent contentType)
+ => IsBoxContent (ListContent sizeType contentType) where
+ boxSize (ListContent es) =
+ boxSize (fromIntegral (length es) :: sizeType) + sum (boxSize <$> es)
+ boxBuilder (ListContent es) =
+ boxBuilder (fromIntegral (length es) :: sizeType)
+ <> fold (boxBuilder <$> es)
+
+instance Default (ListContent sizeTupe contentType) where
+ def = ListContent []
+
+-- * Words and Integer
+
+instance IsBoxContent Word8 where
+ boxSize _ = 1
+ boxBuilder = word8
+
+instance IsBoxContent Word16 where
+ boxSize _ = 2
+ boxBuilder = word16BE
+
+instance IsBoxContent Word32 where
+ boxSize _ = 4
+ boxBuilder = word32BE
+
+instance IsBoxContent Word64 where
+ boxSize _ = 8
+ boxBuilder = word64BE
+
+instance IsBoxContent Int8 where
+ boxSize _ = 1
+ boxBuilder = int8
+
+instance IsBoxContent Int16 where
+ boxSize _ = 2
+ boxBuilder = int16BE
+
+instance IsBoxContent Int32 where
+ boxSize _ = 4
+ boxBuilder = int32BE
+
+instance IsBoxContent Int64 where
+ boxSize _ = 8
+ boxBuilder = int64BE
+
+-- * Boxes of Bits
+
+instance IsBoxContent BuilderBox where
+ boxSize (MkBuilderBox !s _) = fromIntegral s
+ boxBuilder (MkBuilderBox _ !b) = b
+
+-- * Type Layout Rule Matchers
+
+-- | Mandatory, container box, exactly one
+type OM b bs = ContainerBox b bs
+-- | Optional, container box, zero or one
+type OO b bs = OnceOptionalX (ContainerBox b bs)
+-- | Mandatory, container box, one or more
+type SM b bs = SomeMandatoryX (ContainerBox b bs)
+-- | Optional, container box, zero or more
+type SO b bs = SomeOptionalX (ContainerBox b bs)
+
+-- | Mandatory, exactly one, no children
+type OM_ b = Box b
+-- | Optional, zero or one, no children
+type OO_ b = OnceOptionalX (Box b)
+-- | Mandatory, one or more, no children
+type SM_ b = SomeMandatoryX (Box b)
+-- | Optional, zero or more, no children
+type SO_ b = SomeOptionalX (Box b)
+
+----
+type instance IsRuleConform (Box b) (Box r) = BoxTypeSymbol b == BoxTypeSymbol r
+----
+type instance IsRuleConform (Boxes bs) (Boxes rs) = IsRuleConform bs rs -- TODO
+----
+type instance IsRuleConform (Box b) (ContainerBox b' rules)
+ = IsContainerBox b
+ && IsRuleConform (Box b) (Box b')
+ && IsRuleConform (ChildBoxes b) (Boxes rules)
+type family IsContainerBox t :: Bool where
+ IsContainerBox (ContainerBox a as) = 'True
+ IsContainerBox b = 'False
+type family ChildBoxes c where
+ ChildBoxes (ContainerBox a as) = Boxes as
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs
@@ -0,0 +1,48 @@
+-- | This module re-exports all modules needed to build /ISOBMFF/ documents.
+module Data.ByteString.IsoBaseFileFormat.Boxes
+ ( module X)
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.AudioSampleEntry as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.ChunkOffset as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrl as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrn as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.DataInformation as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.DataReference as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.FileType as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.HintMediaHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.HintSampleEntry as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Language as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Media as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MediaData as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MediaHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MediaInformation as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MetaDataSampleEntry as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Movie as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MovieExtends as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MovieExtendsHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MovieFragment as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MovieFragmentHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.NullMediaHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleDescription as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleSize as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleTable as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleToChunk as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SegmentType as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Skip as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SoundMediaHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TimeToSample as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Track as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TrackExtends as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragBaseMediaDecodeTime as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragment as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragmentHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TrackRun as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.VisualSampleEntry as X
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/AudioSampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/AudioSampleEntry.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/AudioSampleEntry.hs
@@ -0,0 +1,30 @@
+-- | Detailed audio sample description.
+module Data.ByteString.IsoBaseFileFormat.Boxes.AudioSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Fields of audio sample entries
+newtype AudioSampleEntry b where
+ AudioSampleEntry
+ :: Constant (U32Arr "reserved" 2) '[0,0]
+ :+ Template (U16 "channelcount") 2
+ :+ Template (U16 "samplesize") 16
+ :+ U16 "pre_defined"
+ :+ Constant (U16 "reserved") 0
+ :+ Template (U32 "samplerate")
+ (DefaultSoundSamplerate * 65536) -- TODO implement fix point integer
+ :+ b
+ -> AudioSampleEntry b
+ deriving (Default, IsBoxContent)
+
+instance Functor AudioSampleEntry where
+ fmap fun (AudioSampleEntry (a :+ b :+ c :+ d :+ e :+ f :+ x)) =
+ AudioSampleEntry (a :+ b :+ c :+ d :+ e :+ f :+ fun x)
+
+type DefaultSoundSamplerate = 48000
+
+type instance GetHandlerType (AudioSampleEntry b) = 'AudioTrack
+type instance BoxTypeSymbol (AudioSampleEntry b) = BoxTypeSymbol b
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/ChunkOffset.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ChunkOffset.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ChunkOffset.hs
@@ -0,0 +1,52 @@
+-- | A table mapping chunks to *absolute* file offsets.
+-- Two variants exist: 32 or 64 bits.
+
+module Data.ByteString.IsoBaseFileFormat.Boxes.ChunkOffset where
+
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+
+-- | Create a hunk offset box for 32 bit entries (@stco@). If possible use
+-- this over 'ChunkOffset64'
+chunkOffset32 :: [StcoEntry32] -> Box ChunkOffset32
+chunkOffset32 = fullBox 0 . ChunkOffsetTable . ListContent
+
+-- | Create a hunk offset box for 64 bit entries (@stco@). If possible use
+-- 'ChunkOffset32'
+chunkOffset64 :: [StcoEntry64] -> Box ChunkOffset64
+chunkOffset64 = fullBox 0 . ChunkOffsetTable . ListContent
+
+-- | Chunk offset box for 32 bit entries (@stco@). If possible use
+-- this over 'ChunkOffset64'
+type ChunkOffset32 = FullBox ChunkOffsetTable32 0
+
+-- | Chunk offset box for 64 bit entries (@stco@). If possible use
+-- 'ChunkOffset32'
+type ChunkOffset64 = FullBox ChunkOffsetTable64 0
+
+-- | Alias for 'ChunkOffsetTable' for 32 bit entries (@stco@)
+type ChunkOffsetTable32 = ChunkOffsetTable StcoEntry32
+
+-- | Alias for 'ChunkOffsetTable' for 64 bit entries (@co64@)
+type ChunkOffsetTable64 = ChunkOffsetTable StcoEntry64
+
+-- | A list of 'StcoEntry32' or 'StcoEntry64' entries.
+newtype ChunkOffsetTable stcoEntry =
+ ChunkOffsetTable (ListContent (U32 "entry_count") stcoEntry)
+ deriving (Default, IsBoxContent)
+
+-- | An entry of the 'ChunkOffsetTable' contains just the absolute file offset
+-- to the chunk.
+type StcoEntry32 = U32 "chunk_offset"
+
+-- | An entry of the 'ChunkOffsetTable' contains just the absolute file offset
+-- to the chunk.
+type StcoEntry64 = U64 "chunk_offset"
+
+type instance BoxTypeSymbol ChunkOffsetTable32 = "stco"
+type instance BoxTypeSymbol ChunkOffsetTable64 = "co64"
+
+instance IsBox ChunkOffsetTable32
+instance IsBox ChunkOffsetTable64
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrl.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrl.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrl.hs
@@ -0,0 +1,33 @@
+-- | A data references URL.
+module Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrl
+ (DataEntryUrl()
+ ,localMediaDataEntryUrl
+ ,dataEntryUrl
+ )
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import qualified Data.Text as T
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | A container for a URL or an indicator for local only media
+newtype DataEntryUrl =
+ DataEntryUrl (Maybe T.Text)
+ deriving (Default,IsBoxContent)
+
+-- | Create a 'DataEntryUrl' box for local media entry with the flag set and
+-- empty content.
+localMediaDataEntryUrl
+ :: Box (FullBox DataEntryUrl 0)
+localMediaDataEntryUrl = dataEntryUrl True Nothing
+
+-- | Create a 'DataEntryUrl' box. The flag determines if the url is local, i.e.
+-- the media data is in the same file.
+dataEntryUrl
+ :: Bool -> Maybe T.Text -> Box (FullBox DataEntryUrl 0)
+dataEntryUrl isLocal Nothing = Box (FullBox (fromIntegral $ fromEnum isLocal) $ DataEntryUrl Nothing)
+dataEntryUrl isLocal murl = Box (FullBox (fromIntegral $ fromEnum isLocal) $ DataEntryUrl murl)
+
+instance IsBox DataEntryUrl
+type instance BoxTypeSymbol DataEntryUrl = "url "
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrn.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrn.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrn.hs
@@ -0,0 +1,24 @@
+-- | A table of data references (URN with optional URL.
+module Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrn
+ (DataEntryUrn()
+ ,dataEntryUrn
+ )
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import qualified Data.Text as T
+
+-- | A container for a URN and optionally a URL
+newtype DataEntryUrn =
+ DataEntryUrn (T.Text :+ T.Text)
+ deriving (IsBoxContent)
+
+-- | Create a 'DataEntryUrn' box. The flag determines if the url is local, i.e.
+-- the media data is in the same file.
+dataEntryUrn
+ :: Bool -> T.Text -> T.Text -> Box (FullBox DataEntryUrn 0)
+dataEntryUrn isLocal urn url = Box (FullBox (fromIntegral $ fromEnum isLocal) $ DataEntryUrn $ urn :+ url)
+
+instance IsBox DataEntryUrn
+type instance BoxTypeSymbol DataEntryUrn = "urn "
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs
@@ -0,0 +1,18 @@
+-- | Data information container declare the location of media information of a
+-- 'Track' the actual location are stored in 'DataReference's.
+module Data.ByteString.IsoBaseFileFormat.Boxes.DataInformation where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- | Data information box phantom type.
+data DataInformation
+
+-- | Compose a 'DataInformation' box.
+dataInformation
+ :: Boxes ts -> Box (ContainerBox DataInformation ts)
+dataInformation = containerBox ()
+
+instance IsBox DataInformation where
+ type BoxContent DataInformation = ()
+
+type instance BoxTypeSymbol DataInformation = "dinf"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs
@@ -0,0 +1,38 @@
+-- | A table of data references (URL/URNs). This tables is referred to by the
+-- 'SampleDescription' this supports splitting a file over several files. When a
+-- media file is split for transportation, this still counts as being in the
+-- same file as the.
+module Data.ByteString.IsoBaseFileFormat.Boxes.DataReference
+ (DataReference()
+ ,dataReference
+ ,localMediaDataReference
+ )
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrl
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.Singletons.Prelude.List (Length)
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | A container for 'DataEntryUrl's and 'DataEntryUrn's
+newtype DataReference =
+ DataReference (U32 "entry_count")
+ deriving (Default,IsBoxContent)
+
+-- | Create a 'DataReference' box.
+dataReference
+ :: KnownNat (Length ts)
+ => Boxes ts -> Box (ContainerBox (FullBox DataReference 0) ts)
+dataReference bs =
+ containerBox (FullBox 0 $ DataReference (typeListLength bs))
+ bs
+
+-- | Create a 'DataReference' box with a single local media entry.
+localMediaDataReference
+ :: Box (ContainerBox (FullBox DataReference 0) '[Box (FullBox DataEntryUrl 0)])
+localMediaDataReference = dataReference (singletonBox localMediaDataEntryUrl)
+
+instance IsBox DataReference
+type instance BoxTypeSymbol DataReference = "dref"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs
@@ -0,0 +1,25 @@
+module Data.ByteString.IsoBaseFileFormat.Boxes.FileType where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | File Type Box
+instance IsBox FileType where
+ type BoxContent FileType = FileType
+type instance BoxTypeSymbol FileType = "ftyp"
+
+-- | Create a 'FileTypeBox' from a major brand, a minor version and a list of
+-- compatible brands
+fileTypeBox :: FileType -> Box FileType
+fileTypeBox = Box
+
+-- | Contents of a 'ftyp' box are some 'FourCc' /brands/ and a version.
+data FileType =
+ FileType {majorBrand :: !FourCc -- TODO use U32String
+ ,minorVersion :: !Word32 -- TODO use U32String
+ ,compatibleBrands :: ![FourCc]} -- TODO use U32String
+
+instance IsBoxContent FileType where
+ boxSize (FileType maj _ver comps) = boxSize maj + 4 + sum (boxSize <$> comps)
+ boxBuilder (FileType maj ver comps) =
+ boxBuilder maj <> word32BE ver <> mconcat (boxBuilder <$> comps)
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | A 'Handler' box describes how a track is presentation and by which sensory
+-- process it is perceived, e.g. audio, video, text, see 'HandlerType'
+module Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+ (Handler()
+ ,handler
+ ,audioTrackHandler
+ ,namedAudioTrackHandler
+ ,videoTrackHandler
+ ,namedVideoTrackHandler
+ ,hintTrackHandler
+ ,namedHintTrackHandler
+ ,timedMetadataTrackHandler
+ ,namedTimedMetadataTrackHandler
+ ,auxilliaryVideoTrackHandler
+ ,namedAuxilliaryVideoTrackHandler
+ ,HandlerType(..)
+ ,GetHandlerType
+ ,HandlerTypeCode)
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import qualified Data.Text as T
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Handler box fields. A handler box may also contain a null terminated
+-- description text in UTF-8. The 'T.Text' parameter is a human readable name of
+-- the track type for debugging.
+newtype Handler (t :: HandlerType) where
+ Handler ::
+ Constant (U32 "pre_defined") 0 :+
+ Constant (U32Text "t") (HandlerTypeCode t) :+
+ Constant (U32Arr "reserved" 3) '[0, 0, 0] :+
+ Template T.Text "" -> Handler t
+
+deriving instance (KnownSymbol (HandlerTypeCode t)) => IsBoxContent (Handler t)
+deriving instance Default (Handler t)
+
+-- | A 'Handler' can be exactly one of these.
+data HandlerType
+ = VideoTrack
+ | AudioTrack
+ | HintTrack
+ | TimedMetaDataTrack
+ | AuxilliaryVideoTrack
+
+-- | Return 'HandlerType' for 'BoxLayout' checking.
+type family GetHandlerType t :: HandlerType
+
+type family HandlerTypeCode (handlertype :: HandlerType) :: Symbol where
+ HandlerTypeCode 'VideoTrack = "vide"
+ HandlerTypeCode 'AudioTrack = "soun"
+ HandlerTypeCode 'HintTrack = "hint"
+ HandlerTypeCode 'TimedMetaDataTrack = "meta"
+ HandlerTypeCode 'AuxilliaryVideoTrack = "auxv"
+
+-- | Create a 'Handler' box.
+handler
+ :: (KnownSymbol (HandlerTypeCode t))
+ => Handler t -> Box (FullBox (Handler t) 0)
+handler = fullBox 0
+
+-- | Create 'Handler' fields for 'AudioTrack's with @"Audio Track"@ as @name@.
+audioTrackHandler :: Handler 'AudioTrack
+audioTrackHandler = namedAudioTrackHandler "Audio Track"
+
+-- | Create 'Handler' fields for 'AudioTrack's, with the given name.
+namedAudioTrackHandler :: T.Text -> Handler 'AudioTrack
+namedAudioTrackHandler txt = Handler (def :+ def :+ def :+ Custom txt)
+
+-- | Create 'Handler' fields for 'VideoTrack's with @"Video Track"@ as @name@.
+videoTrackHandler :: Handler 'VideoTrack
+videoTrackHandler = namedVideoTrackHandler "Video Track"
+
+-- | Create 'Handler' fields for 'VideoTrack's, with the given name.
+namedVideoTrackHandler :: T.Text -> Handler 'VideoTrack
+namedVideoTrackHandler txt = Handler (def :+ def :+ def :+ Custom txt)
+
+-- | Create 'Handler' fields for 'HintTrack's with @"Hint Track"@ as @name@.
+hintTrackHandler :: Handler 'HintTrack
+hintTrackHandler = namedHintTrackHandler "Hint Track"
+
+-- | Create 'Handler' fields for 'HintTrack's, with the given name.
+namedHintTrackHandler :: T.Text -> Handler 'HintTrack
+namedHintTrackHandler txt = Handler (def :+ def :+ def :+ Custom txt)
+
+-- | Create 'Handler' fields for 'TimedMetadataTrack's with @"TimedMetadata
+-- Track"@ as @name@.
+timedMetadataTrackHandler :: Handler 'TimedMetaDataTrack
+timedMetadataTrackHandler =
+ namedTimedMetadataTrackHandler "Timed Metadata Track"
+
+-- | Create 'Handler' fields for 'TimedMetadataTrack's, with the given name.
+namedTimedMetadataTrackHandler :: T.Text -> Handler 'TimedMetaDataTrack
+namedTimedMetadataTrackHandler txt =
+ Handler (def :+ def :+ def :+ Custom txt)
+
+-- | Create 'Handler' fields for 'AuxilliaryVideoTrack's with
+-- @"AuxilliaryVideoTrack Track"@ as @name@.
+auxilliaryVideoTrackHandler :: Handler 'AuxilliaryVideoTrack
+auxilliaryVideoTrackHandler =
+ namedAuxilliaryVideoTrackHandler "Timed Metadata Track"
+
+-- | Create 'Handler' fields for 'AuxilliaryVideoTrack's, with the given name.
+namedAuxilliaryVideoTrackHandler :: T.Text -> Handler 'AuxilliaryVideoTrack
+namedAuxilliaryVideoTrackHandler txt =
+ Handler (def :+ def :+ def :+ (Custom txt))
+
+instance (KnownSymbol (HandlerTypeCode t)) => IsBox (Handler t)
+
+type instance BoxTypeSymbol (Handler t) = "hdlr"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintMediaHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintMediaHeader.hs
@@ -0,0 +1,29 @@
+-- | Media-independent properties of a hint tracks media content.
+module Data.ByteString.IsoBaseFileFormat.Boxes.HintMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+type instance MediaHeaderFor 'HintTrack = HintMediaHeader
+
+-- | Hint data box.
+newtype HintMediaHeader where
+ HintMediaHeader
+ :: U16 "maxPDUsize"
+ :+ U16 "avgPDUsize"
+ :+ U16 "maxbitrate"
+ :+ U16 "avgbitrate"
+ :+ U32 "reserved"
+ -> HintMediaHeader
+ deriving (Default, IsBoxContent)
+
+-- | Create a hint media header data box.
+hintMediaHeader :: HintMediaHeader -> Box (FullBox HintMediaHeader 0)
+hintMediaHeader = fullBox 0
+
+instance IsBox HintMediaHeader
+type instance BoxTypeSymbol HintMediaHeader = "hmhd"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Format of the hint track as well as streaming protocol settings.
+module Data.ByteString.IsoBaseFileFormat.Boxes.HintSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry ()
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- | Protocol specific data. To create 'HintSampleEntry's a protocol specific
+-- 'HintFields' instance must be provided
+newtype HintSampleEntry protocol where
+ HintSampleEntry :: protocol -> HintSampleEntry protocol
+
+type instance GetHandlerType (HintSampleEntry protocol) = 'HintTrack
+type instance BoxTypeSymbol (HintSampleEntry protocol) = BoxTypeSymbol protocol
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs
@@ -0,0 +1,39 @@
+-- | Boxfield indicating an ISO 639-2 alpha-3 language code.
+module Data.ByteString.IsoBaseFileFormat.Boxes.Language (Language, mkLanguage) where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | A Boxfield contains an ISO 639-2-T alpha-3 language code, which is encoded
+-- as a single bit followed by three 5 bit words, each representing the
+-- lower-case character from the language code subtracted by 0x60.
+-- If available, the code for /terminoligy/ purposes should be used (T-code).
+newtype Language = Language Word16 -- TODO use bitrecords
+
+-- | Create a 'Language', throw a runtime error when bad characters were given.
+-- The characters must be in @a - z@ (lower-case!), there must be exactly three
+-- characters.
+mkLanguage :: String -> Language
+mkLanguage [c0,c1,c2] |
+ c0 > toEnum 0x60 && c0 < toEnum 0x7b &&
+ c1 > toEnum 0x60 && c1 < toEnum 0x7b &&
+ c2 > toEnum 0x60 && c2 < toEnum 0x7b =
+ let
+ s :: Char -> Word16
+ s c = fromIntegral (fromEnum c) - 0x60
+ in Language (shiftL (s c0) 10 .|. shiftL (s c1) 5 .|. s c2)
+
+mkLanguage other =
+ error $
+ "Invalid ISO 639-2 language code: " ++ show other ++
+ ". The code must consist of three lower-case letters between 'a' .. 'z'."
+
+instance IsString Language where
+ fromString = mkLanguage
+
+instance Default Language where
+ def = mkLanguage "und"
+
+instance IsBoxContent Language where
+ boxSize _ = 2
+ boxBuilder (Language c) = word16BE c
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs
@@ -0,0 +1,16 @@
+-- | Track specific media information container box.
+module Data.ByteString.IsoBaseFileFormat.Boxes.Media where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- | Media data box
+data Media
+
+instance IsBox Media where
+ type BoxContent Media = ()
+
+type instance BoxTypeSymbol Media = "mdia"
+
+-- | Create a 'MediaDataBox' from a strict 'ByteString'
+media :: Boxes ts -> Box (ContainerBox Media ts)
+media = containerBox ()
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs
@@ -0,0 +1,19 @@
+-- | Media data box
+module Data.ByteString.IsoBaseFileFormat.Boxes.MediaData where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import qualified Data.ByteString as B
+
+-- | Media data box phantom type
+newtype MediaData = MediaData B.ByteString
+ deriving (Show, IsBoxContent)
+
+instance IsBox MediaData where
+ -- | Contents of a 'mdat' box are just bytes from a strict 'ByteString'
+ type BoxContent MediaData = MediaData
+
+type instance BoxTypeSymbol MediaData = "mdat"
+
+-- | Create a 'MediaDataBox' from a strict 'ByteString'
+mediaData :: MediaData -> Box MediaData
+mediaData = Box
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs
@@ -0,0 +1,29 @@
+-- | Media-independent properties of a tracks media content.
+module Data.ByteString.IsoBaseFileFormat.Boxes.MediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Language
+import Data.ByteString.IsoBaseFileFormat.Util.Time
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Media header data box.
+newtype MediaHeader (v :: Nat) where
+ MediaHeader
+ :: Timing v :+ Language :+ Constant (I16 "pre_defined") 0
+ -> MediaHeader v
+
+-- | Create a 'MediaHeader' box.
+mediaHeader
+ :: (KnownNat v)
+ => MediaHeader v -> Box (FullBox (MediaHeader v) v)
+mediaHeader = fullBox 0
+
+instance IsBox (MediaHeader v)
+
+type instance BoxTypeSymbol (MediaHeader v) = "mdhd"
+
+instance IsBoxContent (MediaHeader v) where
+ boxSize (MediaHeader c) = boxSize c
+ boxBuilder (MediaHeader c) = boxBuilder c
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs
@@ -0,0 +1,18 @@
+-- | Media information container for all boxes declaring the specific
+-- technicalities of the media data associated with a 'Track'.
+module Data.ByteString.IsoBaseFileFormat.Boxes.MediaInformation where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- | Media information box type.
+data MediaInformation
+
+-- | Compose a 'MediaInformation' box.
+mediaInformation
+ :: Boxes ts -> Box (ContainerBox MediaInformation ts)
+mediaInformation = containerBox ()
+
+instance IsBox MediaInformation where
+ type BoxContent MediaInformation = ()
+
+type instance BoxTypeSymbol MediaInformation = "minf"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MetaDataSampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MetaDataSampleEntry.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MetaDataSampleEntry.hs
@@ -0,0 +1,102 @@
+module Data.ByteString.IsoBaseFileFormat.Boxes.MetaDataSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import qualified Data.Text as T
+import qualified Data.ByteString as B
+import Data.Tagged ()
+import Data.Default ()
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- * Generat meta data sample entry
+
+type instance GetHandlerType (MetaDataCoding c) = 'TimedMetaDataTrack
+type instance BoxTypeSymbol (MetaDataCoding c) = c
+
+-- | A coproduct of meta data codings (XML, Text, ...)
+data family MetaDataCoding (c :: Symbol)
+
+-- * XML Meta Data
+
+-- | The xml meta data samples declaration
+newtype instance MetaDataCoding "metx" =
+ XMLMetaDataSampleEntry
+ ( Tagged "content_encoding" T.Text
+ :+ Tagged "namespace" T.Text
+ :+ Tagged "schema_location" T.Text
+ :+ Maybe (Box BitRate))
+ deriving (IsBoxContent, Default)
+
+-- * Text Meta Data
+
+-- | The plain text meta data samples declaration
+newtype instance MetaDataCoding "mett" =
+ TextMetaDataSampleEntry
+ ( Tagged "content_encoding" T.Text
+ :+ Tagged "mime_format" T.Text
+ :+ Maybe (Box BitRate))
+ deriving (IsBoxContent, Default)
+
+-- * URI based meta data
+
+-- | The URI meta data samples declaration
+newtype instance MetaDataCoding "urim" =
+ UriMetaDataSampleEntry
+ ( Tagged "the_label" (Box Uri)
+ :+ Tagged "init" (Maybe (Box UriInit))
+ :+ Maybe (Box BitRate))
+ deriving (IsBoxContent, Default)
+
+-- * Uri Box
+
+-- | Contents of a 'Uri' box.
+type Uri = FullBox UriField 0
+
+-- | The URI that's inside the box
+newtype UriField =
+ UriField (Tagged "theURI" T.Text)
+ deriving (Default, IsBoxContent)
+
+-- | Make box with a UTF-8 URI.
+uriBox :: T.Text -> Box Uri
+uriBox t = fullBox 0 (UriField (Tagged t))
+
+type instance BoxTypeSymbol UriField = "uri "
+
+instance IsBox UriField
+
+-- * Uri-Init Box
+
+-- | Opaque data for the applications processing 'Uri' meta data.
+newtype UriInitField =
+ UriInitField (Tagged "uri_initialization_data" B.ByteString)
+ deriving (Default, IsBoxContent)
+
+-- | A 'FullBox' an UriInitField.
+type UriInit = FullBox UriInitField 0
+
+-- | Make box an 'UriInitField'
+uriInitBox :: B.ByteString -> Box UriInit
+uriInitBox = fullBox 0 . UriInitField . Tagged
+
+type instance BoxTypeSymbol UriInitField = "uriI"
+
+instance IsBox UriInitField
+
+-- * Bit Rate Box
+
+-- | Create a box for bit rates. Every 'SampleEntry' instance for meta data
+-- may contain this box at the end.
+bitRateBox :: BitRate -> Box BitRate
+bitRateBox = Box
+
+-- | Bitrate info for meta data samples
+newtype BitRate =
+ BitRate (U32 "bufferSizeDB" :+ U32 "maxBitrate" :+ U32 "avgBitrate")
+ deriving (Default, IsBoxContent)
+
+type instance BoxTypeSymbol BitRate = "btrt"
+
+instance IsBox BitRate
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs
@@ -0,0 +1,18 @@
+-- | Meta data for a presentation of a /movie/.
+module Data.ByteString.IsoBaseFileFormat.Boxes.Movie where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- | Compose a set of boxes into a 'Movie'
+movie :: Boxes ts -> Box (ContainerBox Movie ts)
+movie = containerBox ()
+
+-- | The metadata for a presentation, a single 'Movie' which occurs only once
+-- and top-level. It is pretty empty on it's own, but it contains nested boxes
+-- with all the relevant meta data.
+data Movie
+
+instance IsBox Movie where
+ type BoxContent Movie = ()
+
+type instance BoxTypeSymbol Movie = "moov"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieExtends.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieExtends.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieExtends.hs
@@ -0,0 +1,22 @@
+-- | Indicate the possibility of 'MovieFragment' boxes in the current file; the
+-- total samples are comprised of those fragments, so they must be parsed by the
+-- player.
+module Data.ByteString.IsoBaseFileFormat.Boxes.MovieExtends where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- * @mvex@ Box
+
+-- | Indicate that the media fragmented; more detailed info is obtained by the
+-- extra boxes contained in this box, e.g. the 'MovieExtendsHeader' or the
+-- 'TrackExtends' boxes.
+movieExtends :: Boxes ts -> Box (ContainerBox MovieExtends ts)
+movieExtends = containerBox ()
+
+-- | Phantom type to indicate @mvex@ boxes, see ISO-14496-12 8.8.1
+data MovieExtends
+
+instance IsBox MovieExtends where
+ type BoxContent MovieExtends = ()
+
+type instance BoxTypeSymbol MovieExtends = "mvex"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieExtendsHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieExtendsHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieExtendsHeader.hs
@@ -0,0 +1,27 @@
+-- | Overall duration of fragmented media.
+module Data.ByteString.IsoBaseFileFormat.Boxes.MovieExtendsHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Util.Versioned
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- * @mehd@ Box
+
+-- | Construct a 'MovieHeader' box.
+movieExtendsHeader
+ :: (KnownNat version)
+ => MovieExtendsHeader version -> Box (FullBox (MovieExtendsHeader version) version)
+movieExtendsHeader = fullBox 0
+
+-- | Movie length incorporating all fragments.
+newtype MovieExtendsHeader (version :: Nat) where
+ MovieExtendsHeader ::
+ Versioned (U32 "fragment_duration") (U64 "fragment_duration") version
+ -> MovieExtendsHeader version
+ deriving (IsBoxContent)
+
+instance IsBox (MovieExtendsHeader version)
+
+type instance BoxTypeSymbol (MovieExtendsHeader v) = "mehd"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieFragment.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieFragment.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieFragment.hs
@@ -0,0 +1,20 @@
+-- | TODO: this box is a bit of a hack due to the deadline pressure...
+module Data.ByteString.IsoBaseFileFormat.Boxes.MovieFragment where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- | Compose a set of boxes into a 'MovieFragment'
+movieFragment :: Boxes ts -> Box (ContainerBox MovieFragment ts)
+movieFragment = containerBox ()
+
+-- | Movie Fragments
+data MovieFragment
+
+instance IsBox MovieFragment where
+ type BoxContent MovieFragment = ()
+
+type instance BoxTypeSymbol MovieFragment = "moof"
+
+-- | Return the static size of the empty box
+movieFragmentStaticSize :: Num a => a
+movieFragmentStaticSize = fromBoxSize 0 (boxSize (movieFragment NoBoxes))
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieFragmentHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieFragmentHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieFragmentHeader.hs
@@ -0,0 +1,28 @@
+-- | Meta data for a presentation of a /movie fragment/.
+module Data.ByteString.IsoBaseFileFormat.Boxes.MovieFragmentHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.Default
+
+-- * @mvhd@ Box
+
+-- | Construct a 'MovieFragmentHeader' box.
+movieFragmentHeader
+ :: MovieFragmentHeader-> Box (FullBox MovieFragmentHeader 0)
+movieFragmentHeader = fullBox 0
+
+-- | Movie fragment meta data
+-- The sequence number, just an increasing number, of this fragment
+newtype MovieFragmentHeader where
+ MovieFragmentHeader :: U32 "sequence_number" -> MovieFragmentHeader
+ deriving (IsBoxContent, Default)
+
+instance IsBox MovieFragmentHeader
+
+type instance BoxTypeSymbol MovieFragmentHeader = "mfhd"
+
+-- | Return the static size of the empty box
+movieFragmentHeaderStaticSize :: Num a => a
+movieFragmentHeaderStaticSize = fromBoxSize 0 (boxSize (movieFragmentHeader def))
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs
@@ -0,0 +1,66 @@
+-- | Meta data for a presentation of a /movie/.
+module Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Util.Time
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- * @mvhd@ Box
+
+-- | Construct a 'MovieHeader' box.
+movieHeader
+ :: (KnownNat version)
+ => MovieHeader version -> Box (FullBox (MovieHeader version) version)
+movieHeader = fullBox 0
+
+-- | Movie meta data, indexed by a version.
+--
+-- The @rate@ field is a 16.16 fix point number, 1.0 indicates the preferred
+-- normal playback rate. @volume@ is also a fix point number, albeit smaller
+-- with only 8.8. A volume of 1.0 is the full (loudest) volume. @matrix@ is the
+-- video image transformation matrix. The @next_track_ID@ indicates the next
+-- available track id, if the track ID is (0xFFFFFFFF) then the system must
+-- search through all tracks associated with this presentation and figure it
+-- out, 0 is not allowed.
+newtype MovieHeader (version :: Nat) where
+ MovieHeader ::
+ Timing version
+ :+ Template (I32 "rate") 0x00010000
+ :+ Template (I16 "volume") 0x0100
+ :+ Constant (I16 "reserved") 0
+ :+ Constant (I32Arr "reserved" 2) '[0,0]
+ :+ Template (I32Arr "matrix" 9)
+ '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824]
+ :+ Template (U32Arr "pre_defined" 6) '[0,0,0,0,0,0]
+ :+ Template (U32 "next_track_ID") 0xFFFFFFFF
+ -> MovieHeader version
+ deriving (IsBoxContent)
+
+-- | Time and timing information about a movie (32bit version).
+type MovieHeaderTimesV0 = MovieHeaderTimes
+ (Scalar Word32)
+ (Template (U32 "duration") 0xffffffff)
+
+-- | Time and timing information about a movie (64bit version).
+type MovieHeaderTimesV1 = MovieHeaderTimes
+ (Scalar Word64)
+ (Template (U64 "duration") 0xffffffffffffffff)
+
+-- | Time and timing information about a movie.
+--
+-- The creation/modification times are in seconds since midnight, Jan. 1, 1904,
+-- in UTC time. Time scale declares the time coordinate system, it specifies the
+-- number of time units that pass one second. The time coordinate system is used
+-- by e.g. the duration field, which by the way contains the duration of the
+-- longest track, if known, or simply the equivalent of 1s.
+type MovieHeaderTimes uint dur =
+ uint "creation_time"
+ :+ uint "modification_time"
+ :+ TimeScale
+ :+ dur
+
+instance IsBox (MovieHeader version)
+
+type instance BoxTypeSymbol (MovieHeader v) = "mvhd"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/NullMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/NullMediaHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/NullMediaHeader.hs
@@ -0,0 +1,22 @@
+-- | Indicate that a tracks media content is /null/ or /dummy/ media.
+module Data.ByteString.IsoBaseFileFormat.Boxes.NullMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Null header data box.
+data NullMediaHeader = NullMediaHeader
+
+-- | Create a null media header data box.
+nullMediaHeader :: Box (FullBox NullMediaHeader 0)
+nullMediaHeader = fullBox 0 NullMediaHeader
+
+instance IsBox NullMediaHeader
+type instance BoxTypeSymbol NullMediaHeader = "nmhd"
+
+instance Default NullMediaHeader where
+ def = NullMediaHeader
+instance IsBoxContent NullMediaHeader where
+ boxSize _ = 0
+ boxBuilder _ = mempty
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs
@@ -0,0 +1,24 @@
+module Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+
+-- | A Box with progressive download information
+data ProgressiveDownload
+
+instance IsBox ProgressiveDownload where
+ type BoxContent ProgressiveDownload = ProgressiveDownloadContent
+
+type instance BoxTypeSymbol ProgressiveDownload = "pdin"
+
+-- | Information for progressive media data download/playback encompasses the
+-- delay for initial playback and expected download bit rate.
+type ProgressiveDownloadContent = U32 "rate" :+ U32 "delay"
+
+-- | Construct a @pdin@ box.
+pdinBox
+ :: ProgressiveDownloadContent
+ -> Box (FullBox ProgressiveDownload 0)
+pdinBox = fullBox 0
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleDescription.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleDescription.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleDescription.hs
@@ -0,0 +1,28 @@
+-- | Detailed information about the coced, as well as coding specific
+-- initialization. Depending on the 'Trak' media type different kinds of sample
+-- entry boxes are entailed.
+module Data.ByteString.IsoBaseFileFormat.Boxes.SampleDescription where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.Singletons.Prelude.List (Length)
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | A sample table contains no fieds.
+newtype SampleDescription =
+ SampleDescription (U32 "entry_count")
+ deriving (Default,IsBoxContent)
+
+-- | Create a hint media header data box.
+sampleDescription
+ :: (KnownNat (Length ts))
+ => Boxes ts
+ -> Box (ContainerBox (FullBox SampleDescription 0) ts)
+sampleDescription bs =
+ containerBox (FullBox 0 $ SampleDescription (typeListLength bs))
+ bs
+
+instance IsBox SampleDescription
+
+type instance BoxTypeSymbol SampleDescription = "stsd"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleEntry.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleEntry.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Connect a sample description to a data reference via an index into the data
+-- reference entry table.
+module Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Create a 'SampleEntry' 'Box' from the data reference index and the
+-- 'HandlerType' specific 'SampleEntry' instance.
+sampleEntry
+ :: U16 "data_reference_index"
+ -> handlerSpecific
+ -> Box (SampleEntry handlerSpecific)
+sampleEntry i se = Box (SampleEntry (Constant :+ i :+ se))
+
+-- | A common header for all specific sample entries, the 'BoxContent' of the
+-- abstract 'SampleEntry' is @SampleEntry (SampleEntry h f)@.
+newtype SampleEntry handlerSpecific where
+ SampleEntry
+ :: Constant (U8Arr "reserved" 6) '[0,0,0,0,0,0]
+ :+ U16 "data_reference_index"
+ :+ handlerSpecific
+ -> SampleEntry handlerSpecific
+
+deriving instance IsBoxContent handlerSpecific =>
+ IsBoxContent (SampleEntry handlerSpecific)
+
+deriving instance Default handlerSpecific =>
+ Default (SampleEntry handlerSpecific)
+
+-- | Use this in 'IsMediaFileFormat's 'BoxLayout' to range over any specific
+-- 'SampleEntry', disregarding the second parameter (that indicates low-level
+-- format, protocol or codec characteristics). Add a 'GetHandlerType' instance for
+-- 'MatchSampleEntry' to match a sample type specific entry.
+data MatchSampleEntry :: HandlerType -> Type
+
+type instance
+ IsRuleConform (Box (SampleEntry handlerSpecificEntry))
+ (MatchSampleEntry handlerType) =
+ HandlerTypeCode (GetHandlerType handlerSpecificEntry) == HandlerTypeCode handlerType
+
+-- | The 'BoxTypeSymbol' of sample entry is exactly the @format@ type index of
+-- the 'SampleEntry' family.
+type instance
+ BoxTypeSymbol (SampleEntry handlerSpecific) = BoxTypeSymbol handlerSpecific
+
+instance (IsBoxContent handlertype
+ ,KnownSymbol (BoxTypeSymbol handlertype))
+ => IsBox (SampleEntry handlertype)
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleSize.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleSize.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleSize.hs
@@ -0,0 +1,42 @@
+-- | A box containing the sample count and sample size table.
+module Data.ByteString.IsoBaseFileFormat.Boxes.SampleSize where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Content type of the 'FullBox' containing the 'SampleSize'.
+type SampleSize = FullBox SampleSizeTable 0
+
+-- | Create a 'SampleSize' box for the case where all sample sizes are equal, no
+-- table with the size of each sample is required.
+fixedSampleSize :: Word32 -> Word32 -> Box SampleSize
+fixedSampleSize sampleSize sampleCount =
+ fullBox 0 $ FixedSampleSize sampleSize sampleCount
+
+-- | Create a 'SampleSize' box for the case where samples have different sizes.
+-- The list MUST contain an entry for **every sample** in the media file.
+individualSampleSizes :: [Word32] -> Box SampleSize
+individualSampleSizes sampleSizes =
+ fullBox 0 $
+ SampleSizeTable (ListContent sampleSizes)
+
+-- | The 'SampleSize' box content. If @sampleSize == 0@ then each sample has its
+-- own size and the @table@ field contains an entry for **every** sample, the
+-- number of entries is stored in @sampleCount@. Otherwise the samples are
+-- assumed to all have the same size: @sampleSize@.
+data SampleSizeTable =
+ FixedSampleSize { sampleSize :: !Word32, sampleCount :: !Word32 }
+ | SampleSizeTable !(ListContent Word32 Word32)
+
+instance IsBox SampleSizeTable
+
+type instance BoxTypeSymbol SampleSizeTable = "stsz"
+
+instance IsBoxContent SampleSizeTable where
+ boxSize (FixedSampleSize _ _) = 8
+ boxSize (SampleSizeTable entries) = 4 + boxSize entries
+ boxBuilder (FixedSampleSize size count) = word32BE size <> word32BE count
+ boxBuilder (SampleSizeTable entries) = word32BE 0 <> boxBuilder entries
+
+-- TODO implement compact sample size box (stz2)
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleTable.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleTable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleTable.hs
@@ -0,0 +1,19 @@
+-- | Time and indexing information for the media samples in a track,a sample
+-- table can reference 'DataReference' boxes via a 'SampleTableDescription'.
+--
+-- **NOTE** A /sample/ referes to a **frame** e.g. a video frame frame or a
+-- block of audio samples.
+module Data.ByteString.IsoBaseFileFormat.Boxes.SampleTable where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- | A sample table contains no fieds.
+data SampleTable = SampleTable
+
+-- | Create a hint media header data box.
+sampleTable :: Boxes ts -> Box (ContainerBox SampleTable ts)
+sampleTable = containerBox ()
+
+instance IsBox SampleTable where
+ type BoxContent SampleTable = ()
+type instance BoxTypeSymbol SampleTable = "stbl"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleToChunk.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleToChunk.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleToChunk.hs
@@ -0,0 +1,32 @@
+-- | The chunks into which samples are grouped, can vary in size, as can the
+-- samples within a chunk. This compact table contains the info to find the
+-- chunk and offset within of a sample.
+module Data.ByteString.IsoBaseFileFormat.Boxes.SampleToChunk where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | An alias for the box content type.
+type SampleToChunk = FullBox SampleToChunkTable 0
+
+-- | Define an entry of the compact table. An entry represents a group of chunks
+-- of the same size and the same 'SampleDescription'. The @first_chunk@ is an
+-- index of the first chunk in a sequence of chunks correspondiing to an entry.
+-- The very first entry has an index of 1.
+type StscEntry =
+ U32 "first_chunk" :+ U32 "samples_per_chunk" :+ U32 "sample_description_index"
+
+-- | A compact table to map decoding time to sample number.
+newtype SampleToChunkTable =
+ SampleToChunkTable (ListContent (U32 "entry_count") StscEntry)
+ deriving (Default, IsBoxContent)
+
+-- | Create a hint media header data box.
+sampleToChunk :: [StscEntry] -> Box SampleToChunk
+sampleToChunk = fullBox 0 . SampleToChunkTable . ListContent
+
+instance IsBox SampleToChunkTable
+
+type instance BoxTypeSymbol SampleToChunkTable = "stsc"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SegmentType.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SegmentType.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SegmentType.hs
@@ -0,0 +1,25 @@
+module Data.ByteString.IsoBaseFileFormat.Boxes.SegmentType where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Segment Type Box
+instance IsBox SegmentType where
+ type BoxContent SegmentType = SegmentType
+type instance BoxTypeSymbol SegmentType = "styp"
+
+-- | Create a 'SegmentTypeBox' from a major brand, a minor version and a list of
+-- compatible brands
+segmentTypeBox :: SegmentType -> Box SegmentType
+segmentTypeBox = Box
+
+-- | Contents of a 'styp' box are some 'FourCc' /brands/ and a version.
+data SegmentType =
+ SegmentType {majorBrand :: !FourCc -- TODO use U32String
+ ,minorVersion :: !Word32 -- TODO use U32String
+ ,compatibleBrands :: ![FourCc]} -- TODO use U32String
+
+instance IsBoxContent SegmentType where
+ boxSize (SegmentType maj _ver comps) = boxSize maj + 4 + sum (boxSize <$> comps)
+ boxBuilder (SegmentType maj ver comps) =
+ boxBuilder maj <> word32BE ver <> mconcat (boxBuilder <$> comps)
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs
@@ -0,0 +1,22 @@
+-- | A filler box with a specific size.
+module Data.ByteString.IsoBaseFileFormat.Boxes.Skip where
+
+import qualified Data.ByteString as B
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | Contents of a 'skip' box are just any number of filler bytes.
+newtype Skip = Skip B.ByteString
+
+instance IsBox Skip where
+ type BoxContent Skip = Skip
+
+type instance BoxTypeSymbol Skip = "skip"
+
+-- | Create a 'Skip' with a given size.
+skipBox :: Skip -> Box Skip
+skipBox = Box
+
+instance IsBoxContent Skip where
+ boxSize (Skip bs) = fromIntegral $ B.length bs
+ boxBuilder (Skip bs) = byteString bs
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SoundMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SoundMediaHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SoundMediaHeader.hs
@@ -0,0 +1,26 @@
+-- | Media-independent properties of a tracks sound content.
+module Data.ByteString.IsoBaseFileFormat.Boxes.SoundMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+type instance MediaHeaderFor 'AudioTrack = SoundMediaHeader
+
+-- | Sound header data box.
+newtype SoundMediaHeader where
+ SoundMediaHeader
+ :: Template (I16 "balance") 0
+ :+ Constant (U16 "reserved") 0
+ -> SoundMediaHeader
+ deriving (Default, IsBoxContent)
+
+-- | Create a sound media header data box.
+soundMediaHeader :: SoundMediaHeader -> Box (FullBox SoundMediaHeader 0)
+soundMediaHeader = fullBox 0
+
+instance IsBox SoundMediaHeader
+type instance BoxTypeSymbol SoundMediaHeader = "smhd"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs
@@ -0,0 +1,11 @@
+-- | Select the specific media header from the 'HandlerType'
+module Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader where
+
+--
+-- import Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+--
+
+-- | An open type family to select the specific media header from the
+-- 'HandlerType'
+type family MediaHeaderFor (t :: HandlerType)
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TimeToSample.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TimeToSample.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TimeToSample.hs
@@ -0,0 +1,28 @@
+-- | A table assigns each video frame or audio sample block, this is useful for
+-- seeking in complex media files.
+module Data.ByteString.IsoBaseFileFormat.Boxes.TimeToSample where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | An alias for the box content type.
+type TimeToSample = FullBox TimeToSampleTable 0
+
+-- | Define an entry of the compact table, that specifes the namber of samples
+-- with the same time delta. (All this to help random seeking in media).
+type SttsEntry = U32 "sample_count" :+ U32 "sample_delta"
+
+-- | A compact table to map decoding time to sample number.
+newtype TimeToSampleTable =
+ TimeToSampleTable (ListContent (U32 "entry_count") SttsEntry)
+ deriving (Default, IsBoxContent)
+
+-- | Create a hint media header data box.
+timeToSample :: [SttsEntry] -> Box TimeToSample
+timeToSample = fullBox 0 . TimeToSampleTable . ListContent
+
+instance IsBox TimeToSampleTable
+
+type instance BoxTypeSymbol TimeToSampleTable = "stts"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs
@@ -0,0 +1,18 @@
+-- | Meta data for a presentation of a /movie/.
+module Data.ByteString.IsoBaseFileFormat.Boxes.Track where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- * @trak@ Box
+-- | Compose a 'Track' box from the given boxes.
+track
+ :: Boxes ts -> Box (ContainerBox Track ts)
+track = containerBox ()
+
+-- | Container box for tracks.
+data Track
+
+instance IsBox Track where
+ type BoxContent Track = ()
+
+type instance BoxTypeSymbol Track = "trak"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackExtends.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackExtends.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackExtends.hs
@@ -0,0 +1,62 @@
+-- | Default values for duration, size and other metadata of track fragments.
+-- This might allow a more efficient transfer and decoding of media.
+module Data.ByteString.IsoBaseFileFormat.Boxes.TrackExtends where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- * @trex@ Box
+
+-- | Construct a 'TrackExtends' box, with all durations and sizes set to @0@.
+-- Only the track index and the index into the sample description table is
+-- passed set.
+trackExtendsUnknownDuration :: Word32 -> Word32 -> Box (FullBox TrackExtends 0)
+trackExtendsUnknownDuration trackId descrIndex = trackExtends trackId descrIndex
+ 0 0 0 0 0 0 0 False 0
+
+-- | Construct a 'TrackExtends' box from all its parameters
+trackExtends
+ :: Word32 -- ^ Track ID
+ -> Word32 -- ^ Sample Description Index
+ -> Word32 -- ^ Sample Duration
+ -> Word32 -- ^ Sample Size
+ -> B 2 -- ^ is leading
+ -> B 2 -- ^ sample depends on
+ -> B 2 -- ^ sample is depended on
+ -> B 2 -- ^ sample has redundancy
+ -> B 3 -- ^ padding value
+ -> Bool -- ^ is non sync sample
+ -> Word16 -- ^ sample degradation priority
+ -> Box (FullBox TrackExtends 0)
+trackExtends =
+ wrapBitBuilderBox (fullBox 0 . MkTrackExtends) (Proxy @TrackExtendsBody)
+
+
+newtype TrackExtends where
+ MkTrackExtends :: BuilderBox -> TrackExtends
+ deriving (IsBoxContent)
+
+instance IsBox TrackExtends
+
+type instance BoxTypeSymbol TrackExtends = "trex"
+
+-- | Defaults for movie fragment - the content
+type TrackExtendsBody =
+ "track_ID" @: FieldU32
+ .+: "default_sample_description_index" @: FieldU32
+ .+: "default_sample_duration" @: FieldU32
+ .+: "default_sample_size" @: FieldU32
+ .+: TrackExtendsDefaultSampleFlags
+
+type TrackExtendsDefaultSampleFlags =
+ "reserved" @: Field 4 := 0
+ .+: "is_leading" @: Field 2
+ .+: "sample_depends_on" @: Field 2
+ .+: "sample_is_depended_on" @: Field 2
+ .+: "sample_has_redundancy" @: Field 2
+ .+: "sample_padding_value" @: Field 3
+ .+: "sample_is_non_sync_sample" @: Flag
+ .+: "sample_degradation_priority" @: FieldU16
+ .+: 'EmptyBitRecord
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragBaseMediaDecodeTime.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragBaseMediaDecodeTime.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragBaseMediaDecodeTime.hs
@@ -0,0 +1,32 @@
+-- | Sum of the total base media time in the timescale from the movie header box.
+module Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragBaseMediaDecodeTime where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Util.Time
+import GHC.TypeLits
+
+-- * @tfdt@ Box
+
+-- | Construct a 'TrackFragBaseMediaDecodeTime box.
+trackFragBaseMediaDecodeTime -- TODO allow 64 bit variant
+ :: KnownNat version
+ => TS version "track-fragment-base-media-decode-time"
+ -> Box (FullBox (TrackFragBaseMediaDecodeTime version) version)
+trackFragBaseMediaDecodeTime = fullBox 0 . TrackFragBaseMediaDecodeTime
+
+-- | Track fragment media base decode time
+newtype TrackFragBaseMediaDecodeTime (version :: Nat) where
+ TrackFragBaseMediaDecodeTime
+ :: TS version "track-fragment-base-media-decode-time"
+ -> TrackFragBaseMediaDecodeTime version
+ deriving (IsBoxContent)
+
+instance IsBox (TrackFragBaseMediaDecodeTime v)
+
+type instance BoxTypeSymbol (TrackFragBaseMediaDecodeTime v) = "tfdt"
+
+-- | Return the static size of the empty box
+trackFragBaseMediaDecodeTimeStaticSize64 :: Num a => a
+trackFragBaseMediaDecodeTimeStaticSize64 =
+ fromBoxSize 0 (boxSize (trackFragBaseMediaDecodeTime (TSv1 0)))
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragment.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragment.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragment.hs
@@ -0,0 +1,23 @@
+-- | Meta data for fragments of a track inside a movie fragment.
+module Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragment where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+
+-- * @traf@ Box
+
+-- | Compose a 'TrackFragment' box from the given boxes.
+trackFragment
+ :: Boxes ts -> Box (ContainerBox TrackFragment ts)
+trackFragment = containerBox ()
+
+-- | Container box for tracks.
+data TrackFragment
+
+instance IsBox TrackFragment where
+ type BoxContent TrackFragment = ()
+
+type instance BoxTypeSymbol TrackFragment = "traf"
+
+-- | Return the static size of the empty box
+trackFragmentStaticSize :: Num a => a
+trackFragmentStaticSize = fromBoxSize 0 (boxSize (trackFragment NoBoxes))
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragmentHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragmentHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackFragmentHeader.hs
@@ -0,0 +1,33 @@
+-- | Meta data for a presentation of a /movie fragment/.
+module Data.ByteString.IsoBaseFileFormat.Boxes.TrackFragmentHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.Default
+
+-- * @tfhd@ Box
+
+-- | Construct a 'TrackFragmentHeader' box.
+
+trackFragmentHeader -- TODO allow 64 bit variant
+ :: TrackFragmentHeader -> Box (FullBox TrackFragmentHeader 0)
+trackFragmentHeader =
+ fullBox 0x020000 -- TODO box is hard coded for file offset calculations in the 'trun' box
+
+-- | Track fragment meta data
+-- TODO box is hard coded for file offset calculations in the 'trun' box
+newtype TrackFragmentHeader where
+ TrackFragmentHeader ::
+ Template (U32 "track_ID") 0x001
+ -> TrackFragmentHeader
+ -- TODO all optional fields currently omitted for offset calculations in the 'trun' box
+ deriving (IsBoxContent, Default)
+
+instance IsBox TrackFragmentHeader
+
+type instance BoxTypeSymbol TrackFragmentHeader = "tfhd"
+
+-- | Return the static size of the empty box
+trackFragmentHeaderStaticSize :: Num a => a
+trackFragmentHeaderStaticSize = fromBoxSize 0 (boxSize (trackFragmentHeader def))
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs
@@ -0,0 +1,71 @@
+-- | Track header box
+module Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader
+ (trackHeader, TrackHeader(..), TrackHeaderFlags(..)
+ , type TrackHeaderTimes , type TrackHeaderTimesV0 , type TrackHeaderTimesV1 ) where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Util.Versioned
+import Data.ByteString.IsoBaseFileFormat.Util.Time
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- * @tkhd@ Box
+-- | Create a 'TrackHeader' box.
+trackHeader
+ :: forall version . ( KnownNat version )
+ => TrackHeaderFlags
+ -> TrackHeader version
+ -> Box (FullBox (TrackHeader version) version)
+trackHeader flags = fullBox flags'
+ where
+ flags' = case flags of
+ TrackDisabled -> 0
+ TrackEnabled -> 1
+ TrackInMovie -> 3
+ TrackInMovieAndPreview -> 7
+
+data TrackHeaderFlags =
+ TrackDisabled
+ | TrackEnabled
+ | TrackInMovie
+ | TrackInMovieAndPreview
+
+
+-- | Track meta data, indexed by a version.
+newtype TrackHeader (version :: Nat) where
+ TrackHeader ::
+ Versioned TrackHeaderTimesV0 TrackHeaderTimesV1 version
+ :+ Constant (I32Arr "reserved" 2) '[0, 0]
+ :+ Template (I16 "layer") 0
+ :+ Template (I16 "alternate_group") 0
+ :+ Template (I16 "volume") 256
+ :+ Constant (I16 "reserved") 0
+ :+ Template (I32Arr "matrix" 9)
+ '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824]
+ :+ I32 "width"
+ :+ I32 "height"
+ -> TrackHeader version
+ deriving (IsBoxContent)
+
+-- | Time and timing information about a track (32bit version).
+type TrackHeaderTimesV0 = TrackHeaderTimes
+ (Scalar Word32)
+ (TS32 "duration")
+
+-- | Time and timing information about a track (64bit version).
+type TrackHeaderTimesV1 = TrackHeaderTimes
+ (Scalar Word64)
+ (TS64 "duration")
+
+-- | Time and timing information about a track.
+type TrackHeaderTimes uint dur =
+ uint "creation_time"
+ :+ uint "modification_time"
+ :+ U32 "track_ID"
+ :+ Constant (U32 "reserved") 0
+ :+ dur
+
+instance IsBox (TrackHeader v)
+
+type instance BoxTypeSymbol (TrackHeader v) = "tkhd"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackRun.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackRun.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackRun.hs
@@ -0,0 +1,80 @@
+-- | A list of sample offsets and sizes of a track. This tells the decoder where
+-- stuff inside an 'mdat' box is, and also where the 'mdat' box /starts/, which
+-- is the reason why currently there are several TODOs concercning the offset
+-- calculation.
+module Data.ByteString.IsoBaseFileFormat.Boxes.TrackRun (trackRunIso5, TrackRun) where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import qualified Data.ByteString as BS
+
+-- | Create a track run box. First parameter is the accumulated offset to the
+-- /moof/ box. This is needed for data offset calculation. Then follows a list
+-- of __sample-duration__ and __sample-sizes__. All samples are flagged
+-- /independent/.
+trackRunIso5 :: Int32 -> [(Word32, BS.ByteString)] -> Box TrackRun
+trackRunIso5 !mdatOffset !samples = Box c
+ where
+ !c = TrackRun (header <> body)
+ where
+ !header = h (fromIntegral sampleCount) dataOffset
+ where
+ !dataOffset = 8 -- box size field + fourcc code of this very box
+ + mdatOffset + 8 -- +8 because we want to skip the box header od the mdat box
+ + fromIntegral
+ ((headerStaticSize `div` 8)
+ + sampleCount * (sampleStaticSize `div` 8))
+ !h = bitBuilderBox (Proxy @(Header TrackRunFlagsIso5))
+ !headerStaticSize = (natVal (Proxy @(BitRecordSize (Header TrackRunFlagsIso5))))
+ !sampleStaticSize = (natVal (Proxy @(BitRecordSize (Sample TrackRunFlagsIso5))))
+ !sampleCount = fromIntegral (length samples)
+
+ !body = mconcat $ s <$> samples
+ where
+ s (!duration, !bs) = bitBuilderBox (Proxy @(Sample TrackRunFlagsIso5)) duration size
+ where
+ !size = fromIntegral (BS.length bs)
+
+newtype TrackRun where
+ TrackRun :: BuilderBox -> TrackRun
+ deriving (IsBoxContent)
+
+instance IsBox TrackRun
+type instance BoxTypeSymbol TrackRun = "trun"
+
+-- class MkTrackRunArgs (t :: IsA (TrackRunFlags sop fsp sdp ssp sfp sop)) where
+-- data TrRunArgs (t :: IsA (TrackRunFlags sop fsp sdp ssp sfp sop))
+
+data TrackRunFlags
+ (dataOffsetPresent :: Bool)
+ (firstSampleFlagsPresent :: Bool)
+ (sampleDurationPresent :: Bool)
+ (sampleSizePresent :: Bool)
+ (sampleFlagsPresent :: Bool)
+ (sampleCompositionTimeOffsetPresent :: Bool)
+
+data TrackRunFlagsIso5
+ :: IsA (TrackRunFlags 'True 'False 'True 'True 'True 'False)
+
+type Header (t :: IsA (TrackRunFlags dop fsp sdp ssp sfp sctop)) =
+ "version" @: FieldU8 := 0 -- TODO allow version 1
+ .+: Field 12 := 0
+ .+: "sample-scto-present" @: Flag := sctop
+ .+: "sample-flags-present" @: Flag := sfp
+ .+: "sample-size-present" @: Flag := ssp
+ .+: "sample-duration-present" @: Flag := sdp
+ .+: Field 5 := 0
+ .+: "first-sample-flag-present" @: Flag := fsp
+ .+: Flag := 'False
+ .+: "data-offset-preset" @: Flag := dop
+ .+: "sample-count" @: FieldU32
+ .+: WhenR dop
+ ('BitRecordMember ("data-offset" @: FieldI32))
+ :+: WhenR fsp
+ ('BitRecordMember ("first-sample-flags" @: FieldU32))
+
+
+type Sample (t :: IsA (TrackRunFlags dop fsp sdp ssp sfp sctop)) =
+ WhenR sdp ('BitRecordMember ("sample-duration" @: FieldU32))
+ :+: WhenR ssp ('BitRecordMember ("sample-size" @: FieldU32))
+ :+: WhenR sfp ('BitRecordMember ("sample-flags" @: FieldU32 := 0x02000000)) -- TODO allow flags as in TrackExtends
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/VideoMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VideoMediaHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VideoMediaHeader.hs
@@ -0,0 +1,26 @@
+-- | Media-independent properties of a tracks video content.
+module Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+type instance MediaHeaderFor 'VideoTrack = VideoMediaHeader
+
+-- | Video header data box.
+newtype VideoMediaHeader where
+ VideoMediaHeader
+ :: Template (U16 "graphicsmode") 0
+ :+ Template (U16Arr "opcolor" 3) '[0,0,0]
+ -> VideoMediaHeader
+ deriving (Default, IsBoxContent)
+
+-- | Create a video media header data box.
+videoMediaHeader :: VideoMediaHeader -> Box (FullBox VideoMediaHeader 0)
+videoMediaHeader = fullBox 1
+
+instance IsBox VideoMediaHeader
+type instance BoxTypeSymbol VideoMediaHeader = "vmhd"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/VisualSampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VisualSampleEntry.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VisualSampleEntry.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Detailed visual sample description.
+module Data.ByteString.IsoBaseFileFormat.Boxes.VisualSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import qualified Data.Text as T
+
+-- | Fields if visual sample entries.
+-- A @depth@ of 0x0018 means colour image with no alpha.
+-- The @horizresolution@ and @vertresolution@ of 0x00480000 means 72 dpi.
+-- The @frame_count@ indicates the number of video frames per sample.
+newtype VideoSampleEntry c where
+ VideoSampleEntry
+ :: U16 "pre_defined"
+ :+ Constant (U16 "reserved") 0
+ :+ U16 "width"
+ :+ U16 "height"
+ :+ Template (U32 "horizresolution") 0x00480000 -- TODO fix point
+ :+ Template (U32 "vertresolution") 0x00480000 -- TODO fix point
+ :+ Constant (U32 "reserved") 0
+ :+ Template (U16 "frame_count") 1
+ :+ FixSizeText 32 "compressorname"
+ :+ Template (U16 "depth") 0x0018
+ :+ Template (I16 "pre_defined") 65535
+ :+ Maybe (Box CleanAperture)
+ :+ Maybe (Box PixelAspectRatio)
+ :+ [Box SomeColourInformation]
+ :+ c
+ -> VideoSampleEntry c
+ deriving (IsBoxContent, Default)
+
+type instance GetHandlerType (VideoSampleEntry c) = 'VideoTrack
+type instance BoxTypeSymbol (VideoSampleEntry c) = BoxTypeSymbol c
+
+instance IsBoxContent [Box SomeColourInformation] where
+ boxSize = sum . fmap boxSize
+ boxBuilder = fold . fmap boxBuilder
+
+-- * Clean Aperture sub box
+
+-- | Construct a 'CleanAperture' (sub-) 'Box'
+cleanAperture :: CleanAperture -> Box CleanAperture
+cleanAperture = Box
+
+-- | The clean aperture settings
+newtype CleanAperture where
+ CleanAperture
+ :: U32 "cleanApertureWidthN"
+ :+ U32 "cleanApertureWidthD"
+ :+ U32 "cleanApertureHeightN"
+ :+ U32 "cleanApertureHeightD"
+ :+ U32 "horizOffN"
+ :+ U32 "horizOffD"
+ :+ U32 "vertOffN"
+ :+ U32 "vertOffD"
+ -> CleanAperture
+ deriving (Default, IsBoxContent)
+
+type instance BoxTypeSymbol CleanAperture = "clap"
+instance IsBox CleanAperture
+
+-- * Pixel aspect ratio sub box
+
+-- | Construct a 'PixelAspectRatio' (sub-) 'Box'
+pixelAspectRatio :: PixelAspectRatio -> Box PixelAspectRatio
+pixelAspectRatio = Box
+
+-- | The pixel aspect ratio.
+newtype PixelAspectRatio where
+ PixelAspectRatio
+ :: U32 "hSpacing"
+ :+ U32 "vSpacing"
+ -> PixelAspectRatio
+ deriving (Default, IsBoxContent)
+
+type instance BoxTypeSymbol PixelAspectRatio = "pasp"
+instance IsBox PixelAspectRatio
+
+-- * Colour information sub box
+
+-- | Construct a 'ColourInformation' (sub-) 'Box'
+colourInformation
+ :: ColourType p -> ColourInformation p
+colourInformation = ColourInformation . (Constant :+)
+
+-- | Construct a 'ColourInformation' (sub-) 'Box' from 'OnScreenColours'
+onScreenColourInformation
+ :: ColourType 'OnScreenColours -> ColourInformation 'OnScreenColours
+onScreenColourInformation = colourInformation
+
+-- | Construct a 'ColourInformation' (sub-) 'Box' from 'RestrictedICCProfile'
+restrictedICCProfileColourInformation
+ :: ColourType 'RestrictedICCProfile -> ColourInformation 'RestrictedICCProfile
+restrictedICCProfileColourInformation = colourInformation
+
+-- | Construct a 'ColourInformation' (sub-) 'Box' from 'UnrestrictedICCProfile'
+unrestrictedICCProfileColourInformation
+ :: ColourType 'UnrestrictedICCProfile -> ColourInformation 'UnrestrictedICCProfile
+unrestrictedICCProfileColourInformation = colourInformation
+
+type instance BoxTypeSymbol SomeColourInformation = "pasp"
+instance IsBox SomeColourInformation
+
+-- | A wrapper that hides the concrete 'ColourTypeProfile' of a
+-- 'ColourInformation'.
+data SomeColourInformation where
+ SomeColourInformation
+ :: forall (profile :: ColourTypeProfile)
+ . IsBoxContent (ColourInformation profile)
+ => !(ColourInformation profile)
+ -> SomeColourInformation
+instance IsBoxContent SomeColourInformation where
+ boxSize (SomeColourInformation c) = boxSize c
+ boxBuilder (SomeColourInformation c) = boxBuilder c
+
+-- | Profile dependent colour information
+newtype ColourInformation (profile :: ColourTypeProfile) where
+ ColourInformation
+ :: Constant (U32Text "colour_type") (ColourTypeCode profile)
+ :+ ColourType profile
+ -> ColourInformation profile
+
+deriving instance
+ (Default (ColourType profile))
+ => Default (ColourInformation profile)
+deriving instance
+ (KnownSymbol (ColourTypeCode profile),IsBoxContent (ColourType profile))
+ => IsBoxContent (ColourInformation profile)
+
+-- | Colour type profiles
+data ColourTypeProfile =
+ -- | PTM_COLOR_INFO from A.7.2 of ISO/IEC 29199-2, mind the full range flag.
+ OnScreenColours |
+ -- | A restricted ICC.1 (2010) profile
+ RestrictedICCProfile |
+ -- | An unrestricted IEC ISO-15076 part 1, ICC.1 (2010) profile
+ UnrestrictedICCProfile
+
+-- | Profile dependent colour information family
+type family
+ ColourType (p :: ColourTypeProfile) where
+ ColourType 'OnScreenColours =
+ U16 "colour_primaries"
+ :+ U16 "transfer_characteristics"
+ :+ U16 "matrix_coefficients"
+ :+ FullRangeFlag
+ ColourType 'RestrictedICCProfile =
+ T.Text -- TODO
+ ColourType 'UnrestrictedICCProfile =
+ T.Text -- TODO
+
+-- | The full range flag, note the different bit layout compared to
+-- PTM_COLOR_INFO in ISO 29199-2.
+data FullRangeFlag = IsFullRange | IsNotFullRange
+instance IsBoxContent FullRangeFlag where
+ boxSize _ = 1
+ boxBuilder IsFullRange = word8 128
+ boxBuilder IsNotFullRange = word8 0
+instance Default FullRangeFlag where
+ def = IsFullRange
+
+-- | Return the color type four letter code for a 'ColourTypeProfile'.
+type family
+ ColourTypeCode (p :: ColourTypeProfile) :: Symbol where
+ ColourTypeCode 'OnScreenColours = "nclx"
+ ColourTypeCode 'RestrictedICCProfile = "rICC"
+ ColourTypeCode 'UnrestrictedICCProfile = "prof"
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs b/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Predefined Box composition matching the @dash@ brand. TODO this is an
+-- incomplete, special-purpose variant of this brand, serving my personal,
+-- educational, current need.
+-- This is a convenient way of building documents of that kind.
+module Data.ByteString.IsoBaseFileFormat.Brands.Dash
+ (Dash, dash)
+ where
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.MediaFile
+import Data.ByteString.IsoBaseFileFormat.Boxes
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+
+-- TODO rename dash to iso5
+-- | A phantom type to indicate this branding. Version can be 0 or 1 it is used
+-- in some boxes to switch between 32/64 bits.
+data Dash (version :: Nat)
+
+-- | A constant to indicate the 'Dash' brand with version 0
+dash :: Proxy (Dash 0)
+dash = Proxy
+
+-- | A 'BoxLayout' which contains the stuff needed for the 'dash' brand.
+-- TODO add iso1 iso2 iso3 iso5 isom formats
+instance IsMediaFileFormat (Dash v) where
+ type BoxLayout (Dash v) =
+ OneOf '[ MovieLayout v
+ , SegmentLayout]
+
+type MovieLayout v =
+ Boxes
+ '[ OM_ FileType
+ , OM_ Skip
+ , OM Movie
+ '[ OM_ (MovieHeader v)
+ , SomeMandatoryX
+ (OneOf '[ TrackLayout v 'VideoTrack
+ , TrackLayout v 'AudioTrack
+ , TrackLayout v 'HintTrack
+ , TrackLayout v 'TimedMetaDataTrack
+ , TrackLayout v 'AuxilliaryVideoTrack])
+ , OO MovieExtends
+ '[ OO_ (MovieExtendsHeader v)
+ , OM_ TrackExtends ]
+ ]
+ ]
+
+type TrackLayout version handlerType =
+ (ContainerBox Track
+ '[ OM_ (TrackHeader version)
+ , OM Media
+ '[ OM_ (MediaHeader version)
+ , OM_ (Handler handlerType)
+ , OM MediaInformation
+ '[ OneOf '[ OM_ (MediaHeaderFor handlerType)
+ , OM_ NullMediaHeader]
+ , OM DataInformation
+ '[ OM DataReference
+ '[ SomeMandatoryX
+ (OneOf '[ OM_ DataEntryUrl
+ , OM_ DataEntryUrn])]]
+ , OM SampleTable
+ '[ OM SampleDescription
+ '[ SomeMandatoryX (MatchSampleEntry handlerType) ]
+ , OM_ TimeToSample
+ , OM_ SampleToChunk
+ , OM_ SampleSize
+ , OneOf '[ OM_ ChunkOffset32
+ , OM_ ChunkOffset64 ]
+ ]
+ ]
+ ]
+ ])
+
+type SegmentLayout =
+ Boxes '[ OM_ SegmentType
+ , OM MovieFragment
+ '[ OM_ MovieFragmentHeader
+ , OM TrackFragment
+ '[ OM_ TrackFragmentHeader
+ , OO_ (TrackFragBaseMediaDecodeTime 1)
+ , SO_ TrackRun
+ ]
+ ]
+ , SM_ MediaData
+ ]
diff --git a/src/Data/ByteString/IsoBaseFileFormat/MediaFile.hs b/src/Data/ByteString/IsoBaseFileFormat/MediaFile.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/MediaFile.hs
@@ -0,0 +1,18 @@
+-- | Brand/Box-validation
+module Data.ByteString.IsoBaseFileFormat.MediaFile
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- TODO move this to general module merge with Box.hs
+-- | A class that describes (on the type level) how a box can be nested into
+-- other boxes (see 'Boxes).
+class IsMediaFileFormat brand where
+ -- | The layout that an IsBoxContent instance has to have, before 'packMedia' accepts it
+ type BoxLayout brand
+ mediaBuilder
+ :: forall t proxy . (IsBoxContent t, IsRuleConform t (BoxLayout brand) ~ 'True)
+ => proxy brand -> t -> Builder
+ mediaBuilder _ t = boxBuilder t
diff --git a/src/Data/ByteString/IsoBaseFileFormat/ReExports.hs b/src/Data/ByteString/IsoBaseFileFormat/ReExports.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/ReExports.hs
@@ -0,0 +1,41 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- | A module of re-exports and orphan instances
+module Data.ByteString.IsoBaseFileFormat.ReExports (module X) where
+
+
+import Data.Bits as X
+import qualified Data.ByteString as B
+import Data.ByteString.Builder as X
+import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout as X
+import Data.Default as X
+import Data.Foldable as X (fold)
+import Data.Int as X
+import Data.Kind as X (Constraint,
+ Type)
+import Data.Kind.Extra as X
+import Data.Maybe as X
+import Data.Monoid as X
+import Data.Proxy as X
+import Data.String as X
+import Data.Tagged as X
+import qualified Data.Text as T
+import Data.Type.Bool as X
+import Data.Type.BitRecords as X
+import Data.Type.Equality as X
+import Data.Type.Pretty as X
+import Data.Word as X
+import GHC.TypeLits as X
+import Test.TypeSpecCrazy as X hiding
+ (type Not)
+import Text.Printf as X
+import Debug.Trace as X
+
+instance Default B.ByteString where
+ def = mempty
+
+instance Default T.Text where
+ def = ""
+
+instance Default c => Default (Tagged s c) where
+ def = Tagged def
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Util/BoxFields.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/BoxFields.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Util/BoxFields.hs
@@ -0,0 +1,305 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Mini EDSL for labelled box fields. The boxfields can be 'Scalar' or
+-- 'ScalarArray's.
+module Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.Singletons
+
+import Data.Singletons.Prelude.List
+import qualified Data.Vector as Vec
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString as B
+import Numeric.Natural
+
+
+-- * Scalar box fields
+
+type U64 label = Scalar Word64 label
+
+type I64 label = Scalar Int64 label
+
+u64 :: Word64 -> U64 label
+u64 = Scalar
+
+i64 :: Int64 -> I64 label
+i64 = Scalar
+
+type U32 label = Scalar Word32 label
+type I32 label = Scalar Int32 label
+
+u32 :: Word32 -> U32 label
+u32 = Scalar
+
+i32 :: Int32 -> I32 label
+i32 = Scalar
+
+type U16 label = Scalar Word16 label
+
+type I16 label = Scalar Int16 label
+
+u16 :: Word16 -> U16 label
+u16 = Scalar
+
+i16 :: Int16 -> I16 label
+i16 = Scalar
+
+type U8 label = Scalar Word8 label
+
+type I8 label = Scalar Int8 label
+
+u8 :: Word8 -> U8 label
+u8 = Scalar
+
+i8 :: Int8 -> I8 label
+i8 = Scalar
+
+-- | A numeric box field with a type level label. Note that it has a 'Num'
+-- instance. Use the type aliases above, e.g.
+-- 'U8','I8','U16','I16','U32','I32','U64','I64' from above. Use either the
+-- smart constructors, e.g. 'u8','i8','u16','i16','u32','i32','u64','i64' or the
+-- 'Num' instance, whereas the constructors might give a bit more safety.
+newtype Scalar scalartype (label :: k) =
+ Scalar {fromScalar :: scalartype}
+ deriving (Show, Read, Ord, Eq, Num, Default)
+
+-- | Relabel a scalar value, e.g. convert a @Scalar U32 "foo"@ to a @Scalar U32
+-- "bar"@.
+relabelScalar :: Scalar t l -> Scalar t l'
+relabelScalar (Scalar !x) = Scalar x
+
+instance IsBoxContent (Scalar Word8 label) where
+ boxSize _ = 1
+ boxBuilder (Scalar !v) = word8 v
+
+instance IsBoxContent (Scalar Word16 label) where
+ boxSize _ = 2
+ boxBuilder (Scalar !v) = word16BE v
+
+instance IsBoxContent (Scalar Word32 label) where
+ boxSize _ = 4
+ boxBuilder (Scalar !v) = word32BE v
+
+instance IsBoxContent (Scalar Word64 label) where
+ boxSize _ = 8
+ boxBuilder (Scalar !v) = word64BE v
+
+instance IsBoxContent (Scalar Int8 label) where
+ boxSize _ = 1
+ boxBuilder (Scalar !v) = int8 v
+
+instance IsBoxContent (Scalar Int16 label) where
+ boxSize _ = 2
+ boxBuilder (Scalar !v) = int16BE v
+
+instance IsBoxContent (Scalar Int32 label) where
+ boxSize _ = 4
+ boxBuilder (Scalar !v) = int32BE v
+
+instance IsBoxContent (Scalar Int64 label) where
+ boxSize _ = 8
+ boxBuilder (Scalar !v) = int64BE v
+
+instance (KnownNat scalar,Num o) => FromTypeLit (Scalar o label) scalar where
+ fromTypeLit _ = Scalar $ fromIntegral $ natVal (Proxy :: Proxy scalar)
+
+-- * Array fields
+
+type U64Arr label size = ScalarArray label size Word64
+
+u64Arr :: (KnownNat size,KnownSymbol label)
+ => [Word64] -> U64Arr label size
+u64Arr = fromList
+
+type I64Arr label size = ScalarArray label size Int64
+
+i64Arr :: (KnownNat size,KnownSymbol label)
+ => [Int64] -> I64Arr label size
+i64Arr = fromList
+
+type U32Arr label size = ScalarArray label size Word32
+
+u32Arr :: (KnownNat size,KnownSymbol label)
+ => [Word32] -> U32Arr label size
+u32Arr = fromList
+
+type I32Arr label size = ScalarArray label size Int32
+
+i32Arr :: (KnownNat size,KnownSymbol label)
+ => [Int32] -> I32Arr label size
+i32Arr = fromList
+
+type U16Arr label size = ScalarArray label size Word16
+
+u16Arr :: (KnownNat size,KnownSymbol label)
+ => [Word16] -> U16Arr label size
+u16Arr = fromList
+
+type I16Arr label size = ScalarArray label size Int16
+
+i16Arr :: (KnownNat size,KnownSymbol label)
+ => [Int16] -> I16Arr label size
+i16Arr = fromList
+
+type U8Arr label size = ScalarArray label size Word8
+
+u8Arr :: (KnownNat size,KnownSymbol label)
+ => [Word8] -> U8Arr label size
+u8Arr = fromList
+
+type I8Arr label size = ScalarArray label size Int8
+
+i8Arr :: (KnownNat size,KnownSymbol label)
+ => [Int8] -> I8Arr label size
+i8Arr = fromList
+
+-- | A box field that is an array of 'Scalar's with a type level label. Use the
+-- type aliases, e.g.
+-- 'U8Arr','I8Arr','U16Arr','I16Arr','U32Arr','I32Arr','U64Arr','I64Arr' from
+-- above. Use the smart constructors, e.g.
+-- 'u8Arr','i8Arr','u16Arr','i16Arr','u32Arr','i32Arr','u64Arr','i64Arr' .
+newtype ScalarArray (label :: k) (len :: Nat) o where
+ ScalarArray :: Vec.Vector o -> ScalarArray label n o
+ deriving (Show,Eq)
+
+instance (Default o,KnownNat (len :: Nat))
+ => Default (ScalarArray label len o) where
+ def = ScalarArray $ Vec.replicate (fromIntegral (natVal (Proxy @len))) def
+
+instance (Num o,IsBoxContent (Scalar o label))
+ => IsBoxContent (ScalarArray label len o) where
+ boxSize (ScalarArray !vec) =
+ fromIntegral (Vec.length vec) * boxSize (Scalar 0 :: Scalar o label)
+ boxBuilder (ScalarArray !vec) =
+ Vec.foldl' mappend
+ mempty
+ (Vec.map (boxBuilder . mkScalar) vec)
+ where mkScalar :: o -> Scalar o label
+ !mkScalar = Scalar
+
+-- | Internal function
+fromList :: forall label n o.
+ (KnownSymbol label,KnownNat n)
+ => [o] -> ScalarArray label n o
+fromList l =
+ ScalarArray $
+ if natVal (Proxy @n) /= toInteger (length l)
+ then
+ error $ printf "Invalid number of array elements for array %s. Got length: %d elments, expected %d."
+ (show (symbolVal (Proxy :: Proxy label)))
+ (length l)
+ (natVal (Proxy :: Proxy n))
+ else
+ Vec.fromList l
+
+-- * Constant fields
+
+-- | Wrapper around a field, e.g. a 'Scalar' or 'ScalarArray', with a type level
+-- value. The wrapped content must implement 'FromTypeLit'. To get the value of
+-- a 'Constant' use 'fromTypeLit'.
+data Constant o v where
+ Constant :: Constant o v
+
+instance (IsBoxContent o,FromTypeLit o v) => IsBoxContent (Constant o v) where
+ boxSize = boxSize . fromTypeLit
+ boxBuilder = boxBuilder . fromTypeLit
+
+instance Default (Constant o v) where
+ def = Constant
+
+-- * Template Fields
+
+-- | Fields with default values that can be overriden with custom value. Like
+-- 'Constant' this is a wrapper around a field, e.g. a 'Scalar' or
+-- 'ScalarArray', with a type level default value. The wrapped content must
+-- implement 'FromTypeLit'.
+data Template o v where -- TODO replace with newtype and replace the 'Template'
+ -- case with the 'Default' instance.
+ Template :: Template o v
+ Custom :: !o -> Template o v
+
+instance Default (Template o v) where
+ def = Template
+
+-- | Get a value from a 'Template'.
+templateValue :: FromTypeLit o v => Template o v -> o
+templateValue d@Template = fromTypeLit d
+templateValue (Custom !v) = v
+
+instance (IsBoxContent o,FromTypeLit o v) => IsBoxContent (Template o v) where
+ boxSize = boxSize . templateValue
+ boxBuilder = boxBuilder . templateValue
+
+-- * Conversion from type-level numbers and lists to values
+
+-- | Types that can be constructed from type level value representations.
+class FromTypeLit o v where
+ fromTypeLit :: proxy o v -> o
+
+instance forall arr o len (label :: Symbol) .
+ (KnownSymbol label,SingI arr,Num o,SingKind [Nat],KnownNat len,len ~ Length arr)
+ => FromTypeLit (ScalarArray label len o) (arr :: [Nat]) where
+ fromTypeLit _ =
+ let s = sing :: Sing arr
+ vs :: [Natural]
+ !vs = fromSing s
+ vs' :: [o]
+ !vs' = fromIntegral <$> vs
+ in (fromList vs' :: ScalarArray label len o)
+
+instance KnownSymbol str => FromTypeLit T.Text (str :: Symbol) where
+ fromTypeLit = T.pack . symbolVal
+
+-- * String/Text field types
+
+-- | A fixed size string, the first byte is the string length, after the String,
+-- the field is padded with @0@ bytes. The string must be in UTF8 format.
+newtype FixSizeText (len :: Nat) (label :: Symbol) where
+ FixSizeText :: T.Text -> FixSizeText len label
+
+-- | A constraint that matches type level numbers that are valid text sizes for
+-- 'FixSizeText's.
+type IsTextSize len = (KnownNat len, 1 <= len, len <= 255)
+
+instance IsTextSize len => IsBoxContent (FixSizeText len label) where
+ boxSize _ = fromIntegral (natVal (Proxy :: Proxy len))
+ boxBuilder (FixSizeText !t) =
+ let
+ -- leave room for the size byte
+ !maxSize = fromIntegral (natVal (Proxy :: Proxy len) - 1)
+ !displayableText = B.take maxSize (T.encodeUtf8 t)
+ !displayableTextSize = B.length displayableText
+ !paddingSize = max 0 (maxSize - displayableTextSize)
+ in word8 (fromIntegral displayableTextSize)
+ <> byteString displayableText
+ <> fold (replicate paddingSize (word8 0))
+
+instance IsTextSize len => Default (FixSizeText len label) where
+ def = FixSizeText ""
+
+-- | Four character strings embedded in a uint32.
+newtype U32Text (label :: Symbol) where
+ U32Text :: Word32 -> U32Text label
+
+instance IsString (U32Text label) where
+ fromString !str = U32Text $
+ let cw !s !c = (0xFF .&. fromIntegral (fromEnum c)) `shiftL` s
+ in case str of
+ [] -> 0x20202020
+ [!a] -> cw 24 a .|. 0x00202020
+ [!a,!b] -> cw 24 a .|. cw 16 b .|. 0x00002020
+ [!a,!b,!c] -> cw 24 a .|. cw 16 b .|. cw 8 c .|. 0x20
+ (!a : (!b) : (!c) : (!d) :_) -> cw 24 a .|. cw 16 b .|. cw 8 c .|. cw 0 d
+
+instance IsBoxContent (U32Text label) where
+ boxSize _ = 4
+ boxBuilder (U32Text !t) = word32BE t
+
+instance KnownSymbol str => FromTypeLit (U32Text label) (str :: Symbol) where
+ fromTypeLit = fromString . symbolVal
+
+instance Default (U32Text label) where
+ def = U32Text 0x20202020
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Util/FullBox.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/FullBox.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Util/FullBox.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Full Boxes
+module Data.ByteString.IsoBaseFileFormat.Util.FullBox
+ (FullBox(..), fullBox, BoxFlags(..))
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- | A 'FullBox' contains an extra version and a flags field. In this
+-- implementation it is wrapped around the rest of the box content. This
+-- enforces that the 'FullBox' header fields are always at the beginning - at
+-- least as long as this module hides the 'FullBox' constructor ;)
+data FullBox t (version :: Nat) where
+ FullBox :: (KnownNat version, IsBox t)
+ => !(BoxFlags 24)
+ -> !(BoxContent t)
+ -> FullBox t version
+
+instance (KnownNat version, IsBox t, Default (BoxContent t))
+ => Default (FullBox t version) where
+ def = FullBox 0 def
+
+instance (KnownNat v, IsBox t) => IsBox (FullBox t v) where
+ type BoxContent (FullBox t v) = FullBox t v
+
+type instance BoxTypeSymbol (FullBox t v) = BoxTypeSymbol t
+
+instance (IsBox t, KnownNat v) => IsBoxContent (FullBox t v) where
+ boxSize (FullBox f c) = 1 + boxSize f + boxSize c
+ boxBuilder (FullBox f c) =
+ word8 (fromIntegral (natVal (Proxy :: Proxy v)))
+ <> boxBuilder f
+ <> boxBuilder c
+
+-- | Create a 'FullBox' from a 'BoxVersion' and 'BoxFlags'
+fullBox
+ :: (KnownNat v, IsBox t)
+ => BoxFlags 24 -> BoxContent t -> Box (FullBox t v)
+fullBox f c = Box (FullBox f c)
+
+-- | In addition to a version there can be 24 bits for custom flags etc in
+-- a 'FullBox'.
+newtype BoxFlags bits =
+ BoxFlags Integer
+ deriving (Eq,Show,Num)
+
+-- | Internal function that creates a bit mask with all bits in a 'BoxFlags' set
+-- to 1.
+boxFlagBitMask :: KnownNat bits
+ => BoxFlags bits -> Integer
+boxFlagBitMask px = 2 ^ natVal px - 1
+
+-- | Internal function that masks-out all bits higher than 'bits'.
+cropBits :: KnownNat bits
+ => BoxFlags bits -> BoxFlags bits
+cropBits f@(BoxFlags b) = BoxFlags (b .&. boxFlagBitMask f)
+
+-- | Get the number of bytes required to store a number of bits.
+instance KnownNat bits => IsBoxContent (BoxFlags bits) where
+ boxSize f =
+ let minBytes = fromInteger $ natVal f `div` 8
+ modBytes = fromInteger $ natVal f `mod` 8
+ in BoxSize $ minBytes + signum modBytes
+ boxBuilder f@(BoxFlags b) =
+ let bytes =
+ let (BoxSize bytes') = boxSize f
+ in fromIntegral bytes'
+ wordSeq n
+ | n <= bytes =
+ word8 (fromIntegral (shiftR b ((bytes - n) * 8) .&. 255)) <>
+ wordSeq (n + 1)
+ | otherwise = mempty
+ in wordSeq 1
+
+instance KnownNat bits => Bits (BoxFlags bits) where
+ (.&.) (BoxFlags l) (BoxFlags r) = cropBits $ BoxFlags $ l .&. r
+ (.|.) (BoxFlags l) (BoxFlags r) = cropBits $ BoxFlags $ l .&. r
+ xor (BoxFlags l) (BoxFlags r) = cropBits $ BoxFlags $ xor l r
+ complement (BoxFlags x) = cropBits $ BoxFlags $ complement x
+ shift (BoxFlags x) = cropBits . BoxFlags . shift x
+ rotateL = error "TODO rotateL"
+ rotateR = error "TODO rotateR"
+ bitSize = fromInteger . natVal
+ bitSizeMaybe = Just . fromInteger . natVal
+ isSigned _ = False
+ testBit f n =
+ let (BoxFlags b) = cropBits f
+ in testBit b n
+ bit = cropBits . BoxFlags . bit
+ popCount f =
+ let (BoxFlags b) = cropBits f
+ in popCount b
+ zeroBits = BoxFlags 0
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Util/Time.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Util/Time.hs
@@ -0,0 +1,140 @@
+-- | Time and timing utilities.
+module Data.ByteString.IsoBaseFileFormat.Util.Time
+ (referenceTime, utcToMp4, mp4CurrentTime, durationFromSeconds,
+ oneSecond32, oneSecond64, diffTimeToTicks,ticksToDiffTime,
+ TimeScale(..), Timing, TS(..), type TS32, type TS64, Ticks(..), Ticks32(..))
+ where
+
+import Data.Time.Clock
+import Data.Time.Calendar
+import Data.Ratio
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Util.Versioned
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.Typeable
+import Foreign.Storable
+
+-- * Absolute Dates
+-- | According to the standard, fields with absolute dates and times are in
+-- seconds since 1904/01/01 at midnight (UTC). This is this reference time.
+referenceTime :: UTCTime
+referenceTime =
+ let startDay = fromGregorian 1904 1 1
+ startTime = 0
+ in UTCTime startDay startTime
+
+-- | Convert a 'UTCTime' to a number of seconds since 'referenceTime'.
+utcToMp4 :: Num t
+ => UTCTime -> t
+utcToMp4 u =
+ let picoSecondsDiff = toRational $ diffUTCTime u referenceTime
+ picoSecondsDiffNumerator = numerator picoSecondsDiff
+ picoSecondsDiffDenominator = denominator picoSecondsDiff
+ secondsSinceReferenceTime =
+ div picoSecondsDiffNumerator picoSecondsDiffDenominator
+ in fromIntegral secondsSinceReferenceTime
+
+
+-- | Convert a 'NominalDiffTime' to the number of 'Ticks' with respect
+-- to a given 'TimeScale'.
+diffTimeToTicks :: Integral t
+ => NominalDiffTime -> TimeScale -> t
+diffTimeToTicks !diff (TimeScale !scale) =
+ round (diff * (fromIntegral scale))
+
+-- | Convert a 'NominalDiffTime' to the number of 'Ticks' with respect
+-- to a given 'TimeScale'.
+ticksToDiffTime :: Integral t
+ => t -> TimeScale -> NominalDiffTime
+ticksToDiffTime !t (TimeScale !scale) =
+ fromRational (toInteger t % toInteger scale)
+
+
+-- | Get the current time as number of seconds since 'referenceTime'
+mp4CurrentTime :: Num t
+ => IO t
+mp4CurrentTime = utcToMp4 <$> getCurrentTime
+
+-- * Time-Scale and Durations
+-- | Default time-scale value
+-- Based on history and tradition this value is @90000@.
+-- MPEG-2 TS defines a single clock for each program, running at 27MHz. The
+-- timescale of MPEG-2 TS Hint Tracks should be divisable by 90000.
+newtype TimeScale = TimeScale {fromTimeScale :: Word32}
+ deriving (Show,Eq,Num,Bounded,Ord,Bits,Integral,Typeable,Storable,Enum,Real)
+
+instance Default TimeScale where
+ def = TimeScale 90000
+
+instance IsBoxContent TimeScale where
+ boxSize = boxSize . fromTimeScale
+ boxBuilder = boxBuilder . fromTimeScale
+
+-- | Utility function to convert seconds (Integers) to any 'Num' using a
+-- 'TimeScale', Since 'Scalar' has a 'Num' instance this can be used to generate
+-- @duration@ fields.
+durationFromSeconds :: Num t
+ => TimeScale -> Integer -> t
+durationFromSeconds timeScale seconds =
+ let timeScaleI = fromIntegral timeScale
+ in timeScaleI * fromInteger seconds
+
+-- | Utility function to generate the equivalent of one second (@1 s@)
+oneSecond32 = Scalar . flip durationFromSeconds 1
+oneSecond32 :: TimeScale -> TS32 label
+
+-- | Utility function to generate the equivalent of one second (@1 s@)
+oneSecond64 :: TimeScale -> TS64 label
+oneSecond64 = Scalar . flip durationFromSeconds 1
+
+-- | A type that denotes a time relative to a 'TimeScale' which is included in
+-- its type. 'Ticks' is the number of time units passed, where each time unit
+-- has a physical duration of @timescale * 1/s@ i.e. @timescale@ 'Ticks' last
+-- about @1 s@.
+-- TODO use this instead of raw Word32s
+newtype Ticks (timeScale :: Nat) = MkTicks {fromTicks :: Word64}
+ deriving (Show,Eq,Num,Bounded,Ord,Bits,Integral,Typeable,Storable,Enum,Real)
+
+instance IsBoxContent (Ticks n) where
+ boxSize = boxSize . fromTicks
+ boxBuilder = boxBuilder . fromTicks
+
+newtype Ticks32 (timeScale :: Nat) = MkTicks32 {fromTicks32 :: Word32}
+ deriving (Show,Eq,Num,Bounded,Ord,Bits,Integral,Typeable,Storable,Enum,Real)
+
+instance IsBoxContent (Ticks32 n) where
+ boxSize = boxSize . fromTicks32
+ boxBuilder = boxBuilder . fromTicks32
+
+-- | Time and timing information about a movie.
+--
+-- The creation/modification times are in seconds since midnight, Jan. 1, 1904,
+-- in UTC time. Time scale declares the time coordinate system, it specifies the
+-- number of time units that pass one second. The time coordinate system is used
+-- by e.g. the duration field, which by the way contains the duration of the
+-- longest track, if known, or simply the equivalent of 1s.
+type Timing (version :: Nat) = Versioned TimingV0 TimingV1 version
+
+type TS32 = Scalar Word32
+type TS64 = Scalar Word64
+
+data TS (version :: Nat) (label :: Symbol) where
+ TSv0 :: !Word32 -> TS 0 label
+ TSv1 :: !Word64 -> TS 1 label
+
+instance IsBoxContent (TS v n) where
+ boxSize (TSv0 _t) = 4
+ boxSize (TSv1 _t) = 8
+ boxBuilder (TSv0 !t) = word32BE t
+ boxBuilder (TSv1 !t) = word64BE t
+
+type TimingV0 = TimingImpl (Scalar Word32) (TS 0 "duration")
+
+type TimingV1 = TimingImpl (Scalar Word64) (TS 1 "duration")
+
+type TimingImpl uint dur =
+ uint "creation_time"
+ :+ uint "modification_time"
+ :+ TimeScale
+ :+ dur
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Util/TypeLayout.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/TypeLayout.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Util/TypeLayout.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.ByteString.IsoBaseFileFormat.Util.TypeLayout where
+
+import Data.Kind
+import Data.Type.Bool
+import Data.Type.Equality
+import GHC.TypeLits
+
+----
+type family IsRuleConform (b :: k) (r :: l) :: Bool
+----
+data TopLevel :: Type -> Type
+type instance IsRuleConform t (TopLevel rule) = IsRuleConform t rule
+----
+data OneOf :: [Type] -> Type
+type instance IsRuleConform t (OneOf '[]) = 'False
+type instance IsRuleConform t (OneOf (r ': rs)) =
+ IsRuleConform t r || IsRuleConform t (OneOf rs)
+----
+data MatchSymbol :: Symbol -> Type
+type instance IsRuleConform b (MatchSymbol fourcc) = ToSymbol b == fourcc
+type family ToSymbol t :: Symbol
+----
+data OnceOptionalX t
+data SomeOptionalX t
+data SomeMandatoryX t
+type instance IsRuleConform (bs :: [Type]) (sq :: [Type]) = IsSequence bs sq
+type family
+ IsSequence (bs :: [k]) (rs :: [j]) :: Bool
+ where
+ IsSequence '[] '[] = 'True
+ IsSequence (b ': bs) '[] = 'False
+ --
+ IsSequence '[] (OnceOptionalX r ': rs) = IsSequence '[] rs
+ IsSequence (b ': bs) (OnceOptionalX r ': rs) =
+ If (IsRuleConform b r)
+ (IsSequence bs rs)
+ (IsSequence (b ': bs) rs)
+ --
+ IsSequence '[] (SomeOptionalX r ': rs) = IsSequence '[] rs
+ IsSequence (b ': bs) (SomeOptionalX r ': rs) =
+ If (IsRuleConform b r)
+ (IsSequence bs (SomeOptionalX r ': rs))
+ (IsSequence (b ': bs) rs )
+ --
+ IsSequence '[] (SomeMandatoryX r ': rs) = 'False
+ IsSequence (b ': bs) (SomeMandatoryX r ': rs) =
+ IsRuleConform b r && IsSequence bs (SomeOptionalX r ': rs)
+ --
+ IsSequence '[] (r ': rs) = 'False
+ IsSequence (b ': bs) (r ': rs) =
+ IsRuleConform b r && IsSequence bs rs
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Util/Versioned.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/Versioned.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Util/Versioned.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | A binary version 0/1 field with seperate content for each version.
+module Data.ByteString.IsoBaseFileFormat.Util.Versioned
+ (Versioned(..))
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- TODO rewrite/cleanup the versioned mess
+
+-- | Two alternative representations based on a /version/ index.
+-- Use this for box content that can be either 32 or 64 bit.
+data Versioned v0 v1 (version :: Nat) where
+ V0 :: IsBoxContent v0 => !v0 -> Versioned v0 v1 0
+ V1 :: IsBoxContent v1 => !v1 -> Versioned v0 v1 1
+
+instance (version ~ 0,IsBoxContent v0,Default v0) => Default (Versioned v0 v1 (version :: Nat)) where
+ def = V0 def
+
+instance IsBoxContent (Versioned v0 v1 version) where
+ boxSize (V0 c) = boxSize c
+ boxSize (V1 c) = boxSize c
+ boxBuilder (V0 c) = boxBuilder c
+ boxBuilder (V1 c) = boxBuilder c
diff --git a/src/Data/ByteString/Mp4/AacInitSegment.hs b/src/Data/ByteString/Mp4/AacInitSegment.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/AacInitSegment.hs
@@ -0,0 +1,102 @@
+-- | A single-track AAC audio streaming utility wrapping 'AudioFile' for
+-- streaming via e.g. DASH.
+module Data.ByteString.Mp4.AacInitSegment
+ ( AacInitSegment(..)
+ , BinaryAacInitSegment(..)
+ , buildAacInitSegment
+ ) where
+
+import qualified Data.ByteString as BS
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes
+import Data.ByteString.IsoBaseFileFormat.Brands.Dash as X
+import Data.ByteString.IsoBaseFileFormat.MediaFile as X
+import Data.ByteString.IsoBaseFileFormat.ReExports as X
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields as X
+import Data.ByteString.IsoBaseFileFormat.Util.Time
+import Data.ByteString.IsoBaseFileFormat.Util.Versioned
+import qualified Data.ByteString.Lazy as BL
+import Data.ByteString.Mp4.Boxes.AudioSpecificConfig
+import Data.ByteString.Mp4.Boxes.Mp4AudioSampleEntry as X
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+
+-- | Initialisation segment parameters of an aac audio stream mp4 file.
+data AacInitSegment = AacInitSegment
+ { creationTime :: !(TS32 "creation_time")
+ , trackName :: !String
+ , useHeAac :: !Bool
+ , sampleRate :: !SamplingFreqTable
+ , channelConfig :: !ChannelConfigTable
+ }
+
+instance Show BinaryAacInitSegment where
+ show (BinaryAacInitSegment !d) =
+ printf "INIT SEGMENT - size: %14d" (BS.length d)
+
+-- | Encoded, binary MP4 AAC init segment (strict).
+newtype BinaryAacInitSegment = BinaryAacInitSegment
+ { fromBinaryAacInitSegment :: BS.ByteString
+ }
+
+-- | Convert an 'AacInitSegment' record to a generic 'BinaryAacInitSegment'.
+buildAacInitSegment :: AacInitSegment -> BinaryAacInitSegment
+buildAacInitSegment =
+ BinaryAacInitSegment . BL.toStrict . toLazyByteString . build
+
+-- | Convert an 'AacInitSegment' record to a generic 'BinaryAacInitSegment'.
+build :: AacInitSegment -> Builder
+build AacInitSegment {..} =
+ let timeScaleForSampleRate = TimeScale (sampleRateToNumber sampleRate)
+ in mediaBuilder dash $
+ -- TODO must be iso5 for the way we use elementary stream descriptors
+ fileTypeBox (FileType "iso5" 0 ["isom", "iso5", "dash", "mp42"]) :.
+ skipBox
+ (Skip
+ (TE.encodeUtf8
+ (T.pack "Lindenbaum GmbH, isobmff, Sven Heyll 2019"))) :|
+ movie
+ (movieHeader
+ (MovieHeader $
+ V0 (creationTime :+ relabelScalar creationTime :+ def :+ TSv0 0) :+
+ def :+
+ def :+
+ def :+
+ def :+
+ def :+
+ def :+
+ Custom (Scalar 2)) :.
+ track
+ (trackHeader
+ TrackInMovieAndPreview
+ (TrackHeader $
+ V0
+ (creationTime :+ relabelScalar creationTime :+ 1 :+ Constant :+
+ 0) :+
+ def) :|
+ media
+ (mediaHeader
+ (MediaHeader $
+ V0
+ (creationTime :+ relabelScalar creationTime :+
+ timeScaleForSampleRate :+
+ TSv0 0) :+
+ def) :.
+ handler (namedAudioTrackHandler (T.pack trackName)) :|
+ mediaInformation
+ (soundMediaHeader (SoundMediaHeader def) :.
+ (dataInformation $: localMediaDataReference) :|
+ sampleTable
+ ((sampleDescription $:
+ audioSampleEntry
+ 1
+ (aacAudioSampleEntrySimple
+ useHeAac
+ sampleRate
+ channelConfig
+ (Scalar 16)) :.
+ timeToSample [] :.
+ sampleToChunk [] :.
+ fixedSampleSize 0 0 :|
+ chunkOffset32 []))))) :|
+ (movieExtends $: trackExtendsUnknownDuration 1 1))
diff --git a/src/Data/ByteString/Mp4/AudioStreaming.hs b/src/Data/ByteString/Mp4/AudioStreaming.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/AudioStreaming.hs
@@ -0,0 +1,216 @@
+-- | A single-track AAC audio streaming utility wrapping 'AudioFile' for
+-- streaming via e.g. DASH.
+module Data.ByteString.Mp4.AudioStreaming
+ ( Segment(..)
+ , StreamingContext
+ , AacMp4TrackFragment(..)
+ , numberOfChannels
+ , buildAacMp4TrackFragment
+ , getStreamConfig, getStreamBaseTime, getStreamSequence
+ , addToBaseTime, getSegmentDuration
+ , streamInitINTERNAL_TESTING, streamInitUtc, streamNextSample, streamFlush
+ , module X)
+
+where
+
+import Data.Time.Clock
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes
+import Data.ByteString.IsoBaseFileFormat.Brands.Dash as X
+import Data.ByteString.IsoBaseFileFormat.MediaFile as X
+import Data.ByteString.IsoBaseFileFormat.ReExports as X
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields as X
+import Data.ByteString.IsoBaseFileFormat.Util.Time as X
+import Data.ByteString.Mp4.Boxes.AudioSpecificConfig as X
+import Data.ByteString.Mp4.Boxes.Mp4AudioSampleEntry as X
+import Data.ByteString.Mp4.AacInitSegment as X
+
+-- | Contains the configuration and state for the creation of a DASH audio
+-- stream.
+data StreamingContext =
+ StreamingContext { acConfig :: !AacInitSegment
+ , acSegmentDuration :: !Word64 -- (in ticks)
+ , acSequence :: !Word32
+ , acBaseTime :: !Word64
+ , acSegments :: ![(Word32, BS.ByteString)]
+ }
+
+-- | Contains a sample in the ISO14496 style interpretation, i.e.
+-- a smallish buffer of e.g. 20ms audio data or a single video frame.
+-- A sample has some kind of time or at least order associated to it.
+-- TODO not right now, add it
+--
+-- Also a sample has a duration measured as the sampleCount. TODO make this a
+-- real data type, and possible refactor this to be a seperate issue from
+-- filling stream gaps and determining the offsets and the decoding time stamp.
+data Segment =
+ Segment
+ { segmentSequence :: !Word32
+ , segmentTime :: !Word64
+ , segmentData :: !BS.ByteString
+ }
+
+-- | Media fragment segment parameters of an aac audio stream mp4 file.
+data AacMp4TrackFragment =
+ AacMp4TrackFragment { fragmentSampleSequence :: !Word32
+ , fragmentBaseMediaDecodeTime :: !Word64
+ , fragmentSamples :: ![(Word32, BS.ByteString)]
+ }
+
+numberOfChannels :: Num a => StreamingContext -> a
+numberOfChannels = channelConfigToNumber . channelConfig . acConfig
+
+addToBaseTime :: StreamingContext -> NominalDiffTime -> StreamingContext
+addToBaseTime !sc !dt =
+ sc { acSequence = newSequence
+ , acBaseTime = diffTimeToTicks newBaseTime timeScale}
+ where
+ !timeScale = getAacMp4StreamConfigTimeScale (acConfig sc)
+ !newSequence = round (newBaseTime / segmentDuration)
+ where
+ !segmentDuration = ticksToDiffTime (acSegmentDuration sc) timeScale
+ !newBaseTime = dt + baseTime
+ where
+ !baseTime = ticksToDiffTime (acBaseTime sc) timeScale
+
+
+-- | Return the 'AacInitSegment' from an 'StreamingContext'
+getStreamConfig :: StreamingContext -> AacInitSegment
+getStreamConfig StreamingContext{..} = acConfig
+
+-- | Return the current base decoding time
+getStreamBaseTime :: StreamingContext -> Word64
+getStreamBaseTime StreamingContext{..} = acBaseTime
+
+-- | Return the current sequence number
+getStreamSequence :: StreamingContext -> Word32
+getStreamSequence StreamingContext{..} = acSequence
+
+instance Show Segment where
+ show (Segment !s !t !d) =
+ printf "SEGMENT - seq: %14d - time: %14d - size: %14d" s t (BS.length d)
+
+
+getSegmentDuration :: StreamingContext -> NominalDiffTime
+getSegmentDuration !sc = segmentDuration
+ where
+ !segmentDuration = ticksToDiffTime (acSegmentDuration sc) timeScale
+ !timeScale = getAacMp4StreamConfigTimeScale (acConfig sc)
+
+sampleCountDuration :: AacInitSegment -> Word32 -> Word64
+sampleCountDuration (AacInitSegment _ _ _ _ _c) r =
+ fromIntegral r -- `div` channelConfigToNumber c TODO clean this whole mess up and remove all Word32/Word64
+
+getAacMp4StreamConfigTimeScale :: AacInitSegment -> TimeScale
+getAacMp4StreamConfigTimeScale AacInitSegment{..} =
+ TimeScale (sampleRateToNumber sampleRate)
+
+-- | Initiate the 'StreamingContext' and create the /MP4 init segment/.
+-- This lives in 'IO' because it read the current time from the real world.
+streamInitINTERNAL_TESTING
+ :: String
+ -> NominalDiffTime
+ -> Bool
+ -> SamplingFreqTable
+ -> ChannelConfigTable
+ -> IO (BinaryAacInitSegment, StreamingContext)
+streamInitINTERNAL_TESTING !trackTitle !segmentDuration !sbr !rate !channels = do
+ t <- mp4CurrentTime
+ let !cfg = AacInitSegment t trackTitle sbr rate channels
+ !dur = diffTimeToTicks segmentDuration timeScale
+ !timeScale = getAacMp4StreamConfigTimeScale cfg
+ return ( buildAacInitSegment cfg
+ , StreamingContext cfg dur 0 0 [])
+
+-- | Initiate the 'StreamingContext' and create the /MP4 init segment/.
+-- This lives in 'IO' because it read the current time from the real world.
+streamInitUtc -- TODO remove 'streamInit' in favor of this ??
+ :: String
+ -> UTCTime
+ -> UTCTime
+ -> NominalDiffTime
+ -> Bool
+ -> SamplingFreqTable
+ -> ChannelConfigTable
+ -> (BinaryAacInitSegment, StreamingContext)
+streamInitUtc !trackTitle !availabilityStartTime !refTime !segmentDuration !sbr !rate !channels =
+ let !cfg = AacInitSegment t0 trackTitle sbr rate channels
+ !t0 = utcToMp4 availabilityStartTime
+ !secondsSinceRef = diffUTCTime availabilityStartTime refTime
+ !dur = diffTimeToTicks segmentDuration timeScale
+ !timeScale = getAacMp4StreamConfigTimeScale cfg
+ in ( buildAacInitSegment cfg
+ , addToBaseTime (StreamingContext cfg dur 0 0 []) secondsSinceRef)
+
+-- | Enqueue a sample, if enough samples are accumulated, generate the next segment
+streamNextSample
+ :: Word32
+ -> BS.ByteString
+ -> StreamingContext
+ -> (Maybe Segment, StreamingContext)
+streamNextSample !sampleCount !sample !ctx@StreamingContext{..} =
+ let !segments = (sampleCount, sample) : acSegments
+ !currentEndTime = sampleCountDuration acConfig (sum (fst <$> segments)) + acBaseTime
+ !nextBaseTime = (fromIntegral acSequence + 1) * acSegmentDuration64
+ !acSegmentDuration64 = fromIntegral acSegmentDuration
+ in
+ if currentEndTime >= nextBaseTime then
+ let !ctx' =
+ ctx { acSequence = fromIntegral (currentEndTime `div` acSegmentDuration64)
+ , acBaseTime = currentEndTime
+ , acSegments = []
+ }
+ -- Output to write into fragment:
+ !tf = buildAacMp4TrackFragment $
+ AacMp4TrackFragment acSequence acBaseTime (reverse segments)
+
+ in (Just (Segment acSequence acBaseTime (BL.toStrict (toLazyByteString tf))), ctx')
+ else
+ (Nothing, ctx{ acSegments = segments })
+
+-- | Enqueue a sample, if enough samples are accumulated, generate the next segment
+streamFlush
+ :: StreamingContext
+ -> (Maybe Segment, StreamingContext)
+streamFlush !ctx@StreamingContext{..} =
+ let currentEndTime =
+ sampleCountDuration acConfig (sum (fst <$> acSegments)) + acBaseTime
+ in
+ if not (null acSegments) then
+ let !tf = buildAacMp4TrackFragment $
+ AacMp4TrackFragment acSequence acBaseTime (reverse acSegments)
+ !ctx' = ctx { acSequence = fromIntegral
+ (currentEndTime `div` fromIntegral acSegmentDuration)
+ , acBaseTime = currentEndTime
+ , acSegments = []}
+ in (Just (Segment acSequence acBaseTime (BL.toStrict (toLazyByteString tf))), ctx')
+ else (Nothing, ctx)
+
+-- | Convert a 'AacMp4TrackFragment record to a generic 'Boxes' collection.
+buildAacMp4TrackFragment
+ :: AacMp4TrackFragment -> Builder
+buildAacMp4TrackFragment AacMp4TrackFragment{..} =
+ mediaBuilder dash
+ ( styp
+ :. movieFragment
+ ( mfhd
+ :| trackFragment
+ ( tfhd
+ :. tfdt
+ :| trun))
+ :| mdat)
+ where
+ !styp = segmentTypeBox (SegmentType "msdh" 0 ["msdh","dash"])
+ !mfhd = movieFragmentHeader (MovieFragmentHeader (Scalar fragmentSampleSequence))
+ !tfhd = trackFragmentHeader def
+ !tfdt = trackFragBaseMediaDecodeTime (TSv1 fragmentBaseMediaDecodeTime)
+ !trun = trackRunIso5 mdatOffset fragmentSamples
+ where
+ !mdatOffset = movieFragmentStaticSize
+ + movieFragmentHeaderStaticSize
+ + trackFragmentStaticSize
+ + trackFragmentHeaderStaticSize
+ + trackFragBaseMediaDecodeTimeStaticSize64
+ !mdat = mediaData (MediaData (BS.concat (snd <$> fragmentSamples)))
diff --git a/src/Data/ByteString/Mp4/Boxes/AudioSpecificConfig.hs b/src/Data/ByteString/Mp4/Boxes/AudioSpecificConfig.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/AudioSpecificConfig.hs
@@ -0,0 +1,301 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | @mp4a@ Audio sample entry according to ISO 14496-14
+module Data.ByteString.Mp4.Boxes.AudioSpecificConfig where
+
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.Mp4.Boxes.DecoderSpecificInfo
+
+-- * Decoder Configuration for ISO 14496-3 (Audio)
+
+-- | A audio config using 'AudioConfigAacMinimal' for AAC-LC.
+type AudioConfigAacLc freq channels =
+ AudioConfigAacMinimal 'AacLc DefaultGASpecificConfig freq channels
+
+-- | A audio config using 'AudioConfigSbrExplicitHierachical' for HE-AAC (v1) in
+-- dual rate mode.
+type AudioConfigHeAac freq channels =
+ AudioConfigSbrExplicitHierachical
+ 'AacLc DefaultGASpecificConfig freq channels freq
+
+-- | A minimalistic audio config without sync and error protection
+data AudioConfigAacMinimal
+ :: AudioObjectTypeId
+ -> IsAn AudioSubConfig
+ -> IsAn (EnumOf SamplingFreqTable)
+ -> IsAn (EnumOf ChannelConfigTable)
+ -> IsA (DecoderSpecificInfo 'AudioIso14496_3 'AudioStream)
+
+type instance
+ Eval (AudioConfigAacMinimal
+ aoId
+ subCfg
+ freq
+ channels) =
+ ('MkDecoderSpecificInfo
+ (AudioConfigCommon aoId freq channels (BitRecordOfAudioSubConfig subCfg)))
+
+-- | A audio config with SBR signalled explicit and hierachical
+data AudioConfigSbrExplicitHierachical
+ :: AudioObjectTypeId
+ -> IsAn AudioSubConfig
+ -> IsAn (EnumOf SamplingFreqTable)
+ -> IsAn (EnumOf ChannelConfigTable)
+ -> IsAn (EnumOf SamplingFreqTable) -- extension SamplingFrequency
+ -> IsA (DecoderSpecificInfo 'AudioIso14496_3 'AudioStream)
+
+type instance
+ Eval
+ (AudioConfigSbrExplicitHierachical aoId subCfg freq channels
+ extFreq)
+ =
+ 'MkDecoderSpecificInfo
+ (AudioConfigCommon 'Sbr freq channels
+ (BitRecordOfEnum extFreq :+:
+ AudioObjectTypeRec aoId :+: BitRecordOfAudioSubConfig subCfg))
+
+-- | Common header for audio specific config
+type AudioConfigCommon aoId samplingFrequencyIndex channels rest =
+ AudioObjectTypeRec aoId
+ :+: BitRecordOfEnum samplingFrequencyIndex
+ :+: BitRecordOfEnum channels
+ :+: rest
+
+-- ** Audio Object Type
+
+data AudioObjectTypeId =
+ AacMain -- ^ ISO 14496-4 subpart 4
+ | AacLc -- ^ ISO 14496-4 subpart 4
+ | AacSsr -- ^ ISO 14496-4 subpart 4
+ | AacLtp -- ^ ISO 14496-4 subpart 4
+ | Sbr -- ^ ISO 14496-4 subpart 4
+ | AacScalable -- ^ ISO 14496-4 subpart 4
+ | TwinVq -- ^ ISO 14496-4 subpart 4
+ | Celp -- ^ ISO 14496-4 subpart 3
+ | Hvxc -- ^ ISO 14496-4 subpart 2
+ | AoReserved1
+ | AoReserved2
+ | Ttsi -- ^ ISO 14496-4 subpart 6
+ | MainSunthetic -- ^ ISO 14496-4 subpart 5
+ | WavetableSynthesis -- ^ ISO 14496-4 subpart 5
+ | GeneralMidi -- ^ ISO 14496-4 subpart 5
+ | AlgorithmicSynthesisAndAudioFx -- ^ ISO 14496-4 subpart 5
+ | ErAacLc -- ^ ISO 14496-4 subpart 4
+ | AoReserved3
+ | ErAacLtp -- ^ ISO 14496-4 subpart 4
+ | ErAacScalable -- ^ ISO 14496-4 subpart 4
+ | ErTwinVq -- ^ ISO 14496-4 subpart 4
+ | ErBsac -- ^ ISO 14496-4 subpart 4
+ | ErAacLd -- ^ ISO 14496-4 subpart 4
+ | ErCelp -- ^ ISO 14496-4 subpart 3
+ | ErHvxc -- ^ ISO 14496-4 subpart 2
+ | ErHiln -- ^ ISO 14496-4 subpart 7
+ | ErParametric -- ^ ISO 14496-4 subpart 2 or 7
+ | Ssc -- ^ ISO 14496-4 subpart 8
+ | AoReserved4
+ | AoReserved5
+ | AoCustom
+ | AoLayer1 -- ^ ISO 14496-4 subpart 9
+ | AoLayer2 -- ^ ISO 14496-4 subpart 9
+ | AoLayer3 -- ^ ISO 14496-4 subpart 9
+ | AoDst -- ^ ISO 14496-4 subpart 10
+ | AotInvalid
+
+type instance FromEnum AudioObjectTypeId 'AotInvalid = 0
+type instance FromEnum AudioObjectTypeId 'AacMain = 1
+type instance FromEnum AudioObjectTypeId 'AacLc = 2
+type instance FromEnum AudioObjectTypeId 'AacSsr = 3
+type instance FromEnum AudioObjectTypeId 'AacLtp = 4
+type instance FromEnum AudioObjectTypeId 'Sbr = 5
+type instance FromEnum AudioObjectTypeId 'AacScalable = 6
+type instance FromEnum AudioObjectTypeId 'TwinVq = 7
+type instance FromEnum AudioObjectTypeId 'Celp = 8
+type instance FromEnum AudioObjectTypeId 'Hvxc = 9
+type instance FromEnum AudioObjectTypeId 'AoReserved1 = 10
+type instance FromEnum AudioObjectTypeId 'AoReserved2 = 11
+type instance FromEnum AudioObjectTypeId 'Ttsi = 12
+type instance FromEnum AudioObjectTypeId 'MainSunthetic = 13
+type instance FromEnum AudioObjectTypeId 'WavetableSynthesis = 14
+type instance FromEnum AudioObjectTypeId 'GeneralMidi = 15
+type instance FromEnum AudioObjectTypeId 'AlgorithmicSynthesisAndAudioFx = 16
+type instance FromEnum AudioObjectTypeId 'ErAacLc = 17
+type instance FromEnum AudioObjectTypeId 'AoReserved3 = 18
+type instance FromEnum AudioObjectTypeId 'ErAacLtp = 19
+type instance FromEnum AudioObjectTypeId 'ErAacScalable = 20
+type instance FromEnum AudioObjectTypeId 'ErTwinVq = 21
+type instance FromEnum AudioObjectTypeId 'ErBsac = 22
+type instance FromEnum AudioObjectTypeId 'ErAacLd = 23
+type instance FromEnum AudioObjectTypeId 'ErCelp = 24
+type instance FromEnum AudioObjectTypeId 'ErHvxc = 25
+type instance FromEnum AudioObjectTypeId 'ErHiln = 26
+type instance FromEnum AudioObjectTypeId 'ErParametric = 27
+type instance FromEnum AudioObjectTypeId 'Ssc = 28
+type instance FromEnum AudioObjectTypeId 'AoReserved4 = 29
+type instance FromEnum AudioObjectTypeId 'AoReserved5 = 30
+type instance FromEnum AudioObjectTypeId 'AoCustom = 31
+type instance FromEnum AudioObjectTypeId 'AoLayer1 = 32
+type instance FromEnum AudioObjectTypeId 'AoLayer2 = 33
+type instance FromEnum AudioObjectTypeId 'AoLayer3 = 34
+type instance FromEnum AudioObjectTypeId 'AoDst = 35
+
+type AudioObjectTypeRec n =
+ AudioObjectTypeField1 (FromEnum AudioObjectTypeId n)
+ .+: AudioObjectTypeField2 (FromEnum AudioObjectTypeId n)
+
+type family AudioObjectTypeField1 (n :: Nat)
+ :: IsA (BitRecordField ('MkFieldBits :: BitField (B 5) Nat 5)) where
+ AudioObjectTypeField1 n =
+ If (n <=? 30) (Field 5 := n) (Field 5 := 31)
+
+type family AudioObjectTypeField2 (n :: Nat) :: BitRecord where
+ AudioObjectTypeField2 n =
+ If (n <=? 30) 'EmptyBitRecord ('BitRecordMember (Field 6 := (n - 31)))
+
+-- *** Sampling Frequency
+
+type SamplingFreq = ExtEnum SamplingFreqTable 4 'SFCustom (Field 24)
+
+data SamplingFreqTable =
+ SF96000
+ | SF88200
+ | SF64000
+ | SF48000
+ | SF44100
+ | SF32000
+ | SF24000
+ | SF22050
+ | SF16000
+ | SF12000
+ | SF11025
+ | SF8000
+ | SF7350
+ | SFReserved1
+ | SFReserved2
+ | SFCustom
+
+type instance FromEnum SamplingFreqTable 'SF96000 = 0
+type instance FromEnum SamplingFreqTable 'SF88200 = 1
+type instance FromEnum SamplingFreqTable 'SF64000 = 2
+type instance FromEnum SamplingFreqTable 'SF48000 = 3
+type instance FromEnum SamplingFreqTable 'SF44100 = 4
+type instance FromEnum SamplingFreqTable 'SF32000 = 5
+type instance FromEnum SamplingFreqTable 'SF24000 = 6
+type instance FromEnum SamplingFreqTable 'SF22050 = 7
+type instance FromEnum SamplingFreqTable 'SF16000 = 8
+type instance FromEnum SamplingFreqTable 'SF12000 = 9
+type instance FromEnum SamplingFreqTable 'SF11025 = 0xa
+type instance FromEnum SamplingFreqTable 'SF8000 = 0xb
+type instance FromEnum SamplingFreqTable 'SF7350 = 0xc
+type instance FromEnum SamplingFreqTable 'SFReserved1 = 0xd
+type instance FromEnum SamplingFreqTable 'SFReserved2 = 0xe
+type instance FromEnum SamplingFreqTable 'SFCustom = 0xf
+
+sampleRateToNumber :: Num a => SamplingFreqTable -> a
+sampleRateToNumber SF96000 = 96000
+sampleRateToNumber SF88200 = 88200
+sampleRateToNumber SF64000 = 64000
+sampleRateToNumber SF48000 = 48000
+sampleRateToNumber SF44100 = 44100
+sampleRateToNumber SF32000 = 32000
+sampleRateToNumber SF24000 = 24000
+sampleRateToNumber SF22050 = 22050
+sampleRateToNumber SF16000 = 16000
+sampleRateToNumber SF12000 = 12000
+sampleRateToNumber SF11025 = 11025
+sampleRateToNumber SF8000 = 8000
+sampleRateToNumber SF7350 = 7350
+sampleRateToNumber _ = 0
+
+sampleRateToEnum :: SamplingFreqTable -> EnumValue SamplingFreqTable
+sampleRateToEnum SF96000 = MkEnumValue (Proxy @'SF96000)
+sampleRateToEnum SF88200 = MkEnumValue (Proxy @'SF88200)
+sampleRateToEnum SF64000 = MkEnumValue (Proxy @'SF64000)
+sampleRateToEnum SF48000 = MkEnumValue (Proxy @'SF48000)
+sampleRateToEnum SF44100 = MkEnumValue (Proxy @'SF44100)
+sampleRateToEnum SF32000 = MkEnumValue (Proxy @'SF32000)
+sampleRateToEnum SF24000 = MkEnumValue (Proxy @'SF24000)
+sampleRateToEnum SF22050 = MkEnumValue (Proxy @'SF22050)
+sampleRateToEnum SF16000 = MkEnumValue (Proxy @'SF16000)
+sampleRateToEnum SF12000 = MkEnumValue (Proxy @'SF12000)
+sampleRateToEnum SF11025 = MkEnumValue (Proxy @'SF11025)
+sampleRateToEnum SF8000 = MkEnumValue (Proxy @'SF8000)
+sampleRateToEnum SF7350 = MkEnumValue (Proxy @'SF7350)
+sampleRateToEnum SFReserved1 = MkEnumValue (Proxy @'SFReserved1)
+sampleRateToEnum SFReserved2 = MkEnumValue (Proxy @'SFReserved2)
+sampleRateToEnum SFCustom = MkEnumValue (Proxy @'SFCustom)
+
+-- *** Channel Config (Mono, Stereo, 7-1 Surround, ...)
+
+type ChannelConfig = FixedEnum ChannelConfigTable 4
+
+data ChannelConfigTable =
+ GasChannelConfig
+ | SingleChannel
+ | ChannelPair
+ | SinglePair
+ | SinglePairSingle
+ | SinglePairPair
+ | SinglePairPairLfe
+ | SinglePairPairPairLfe
+
+type instance FromEnum ChannelConfigTable 'GasChannelConfig = 0
+type instance FromEnum ChannelConfigTable 'SingleChannel = 1
+type instance FromEnum ChannelConfigTable 'ChannelPair = 2
+type instance FromEnum ChannelConfigTable 'SinglePair = 3
+type instance FromEnum ChannelConfigTable 'SinglePairSingle = 4
+type instance FromEnum ChannelConfigTable 'SinglePairPair = 5
+type instance FromEnum ChannelConfigTable 'SinglePairPairLfe = 6
+type instance FromEnum ChannelConfigTable 'SinglePairPairPairLfe = 7
+
+channelConfigToNumber :: Num a => ChannelConfigTable -> a
+channelConfigToNumber GasChannelConfig = 0
+channelConfigToNumber SingleChannel = 1
+channelConfigToNumber ChannelPair = 2
+channelConfigToNumber SinglePair = 3
+channelConfigToNumber SinglePairSingle = 4
+channelConfigToNumber SinglePairPair = 5
+channelConfigToNumber SinglePairPairLfe = 6
+channelConfigToNumber SinglePairPairPairLfe = 7
+
+channelConfigToEnum :: ChannelConfigTable -> EnumValue ChannelConfigTable
+channelConfigToEnum GasChannelConfig = MkEnumValue (Proxy @'GasChannelConfig)
+channelConfigToEnum SingleChannel = MkEnumValue (Proxy @'SingleChannel)
+channelConfigToEnum ChannelPair = MkEnumValue (Proxy @'ChannelPair)
+channelConfigToEnum SinglePair = MkEnumValue (Proxy @'SinglePair)
+channelConfigToEnum SinglePairSingle = MkEnumValue (Proxy @'SinglePairSingle)
+channelConfigToEnum SinglePairPair = MkEnumValue (Proxy @'SinglePairPair)
+channelConfigToEnum SinglePairPairLfe = MkEnumValue (Proxy @'SinglePairPairLfe)
+channelConfigToEnum SinglePairPairPairLfe = MkEnumValue (Proxy @'SinglePairPairPairLfe)
+
+-- ** More Specific audio decoder config
+
+data AudioSubConfig :: Type
+
+type family BitRecordOfAudioSubConfig (x :: IsA AudioSubConfig) :: BitRecord
+
+data GASpecificConfig
+ (frameLenFlag :: IsA (FieldValue "frameLenFlag" Bool))
+ (coreCoderDelay :: Maybe (IsA (FieldValue "coreCoderDelay" Nat)))
+ (extension :: IsA GASExtension)
+ :: IsA AudioSubConfig
+
+type DefaultGASpecificConfig =
+ GASpecificConfig (StaticFieldValue "frameLenFlag" 'False) 'Nothing MkGASExtension
+
+type instance Eval (GASpecificConfig fl cd ext)
+ = TypeError ('Text "AudioSubConfig is abstract!")
+
+
+type instance
+ BitRecordOfAudioSubConfig (GASpecificConfig fl cd ext) =
+ ( Flag :~ fl
+ .+: FlagJust cd
+ .+: Field 14 :+? cd
+ :+: BitRecordOfGASExtension ext
+ )
+
+-- | TODO implment that GAS extensions
+data GASExtension
+data MkGASExtension :: IsA GASExtension
+
+type BitRecordOfGASExtension (x :: IsA GASExtension) =
+ 'BitRecordMember ("has-gas-extension" @: Flag := 'False)
diff --git a/src/Data/ByteString/Mp4/Boxes/BaseDescriptor.hs b/src/Data/ByteString/Mp4/Boxes/BaseDescriptor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/BaseDescriptor.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.ByteString.Mp4.Boxes.BaseDescriptor where
+
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.Mp4.Boxes.Expandable
+
+-- * Static base constructor
+
+-- | Abstract class of /descriptors/ as recognized by ISO/IEC 14496-1 (Systems).
+-- A specifc descriptor is identified by the 'ClassTag'.
+data Descriptor :: ClassTag n -> Type where
+ MkDescriptor :: BitRecord -> Descriptor tag
+
+-- TODO ok... this fixed the current problem in DecoderSpecificInfo .. but remove this instances ... or the above ... or ... I dunno
+
+data BitRecordOfDescriptor :: IsA (Descriptor c :-> BitRecord)
+
+type instance
+ BitRecordOfDescriptor $~ ('MkDescriptor body :: Descriptor (tag :: ClassTag tagInd)) =
+ FieldU8 := tagInd
+ .+: Eval (StaticExpandableContent body)
+
+type family GetClassTag (c :: ClassTag n) :: Nat where
+ GetClassTag (c :: ClassTag n) = n
+
+-- | Base Descriptor Class Tags TODO rename to xxxTag
+data ClassTag (tag :: Nat) where
+ ObjectDescr :: ClassTag 0x01
+ InitialObjectDescr :: ClassTag 0x02
+ ES_Descr :: ClassTag 0x03
+ DecoderConfigDescr :: ClassTag 0x04
+ DecSpecificInfo :: ClassTag 0x05
+ SLConfigDescr :: ClassTag 0x06
+ ContentIdentDescr :: ClassTag 0x07
+ SupplContentIdentDescr :: ClassTag 0x08
+ IPI_DescrPointer :: ClassTag 0x09
+ IPMP_DescrPointer :: ClassTag 0x0A
+ IPMP_Descr :: ClassTag 0x0B
+ QoS_Descr :: ClassTag 0x0C
+ RegistrationDescr :: ClassTag 0x0D
+ ES_ID_Ref :: ClassTag 0x0F
+ MP4_IOD_ :: ClassTag 0x10
+ MP4_OD_ :: ClassTag 0x11
+ IPL_DescrPointerRef :: ClassTag 0x12
+ ExtensionProfileLevelDescr :: ClassTag 0x13
+ ProfileLevelIndicationIndexDescr :: ClassTag 0x14
+ ContentClassificationDescr :: ClassTag 0x40
+ KeyWordDescr :: ClassTag 0x41
+ RatingDescr :: ClassTag 0x42
+ LanguageDescr :: ClassTag 0x43
+ ShortTextualDescr :: ClassTag 0x44
+ ExpandedTextualDescr :: ClassTag 0x45
+ ContentCreatorNameDescr :: ClassTag 0x46
+ ContentCreationDateDescr :: ClassTag 0x47
+ OCICreatorNameDescr :: ClassTag 0x48
+ OCICreationDateDescr :: ClassTag 0x49
+ SmpteCameraPositionDescr :: ClassTag 0x4A
+ SegmentDescr :: ClassTag 0x4B
+ MediaTimeDescr :: ClassTag 0x4C
+ IPMP_ToolsListDescr :: ClassTag 0x60
+ IPMP_Tool :: ClassTag 0x61
+ M4MuxTimingDescr :: ClassTag 0x62
+ M4MuxCodeTableDescr :: ClassTag 0x63
+ ExtSLConfigDescr :: ClassTag 0x64
+ M4MuxBufferSizeDescr :: ClassTag 0x65
+ M4MuxIdentDescr :: ClassTag 0x66
+ DependencyPointer :: ClassTag 0x67
+ DependencyMarker :: ClassTag 0x68
+ M4MuxChannelDescr :: ClassTag 0x69
+ ExtDescrTag :: forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n
+ OCIDescrTag :: forall (n :: Nat) . (0x40 <= n, n <= 0x5F) => ClassTag n
diff --git a/src/Data/ByteString/Mp4/Boxes/DecoderConfigDescriptor.hs b/src/Data/ByteString/Mp4/Boxes/DecoderConfigDescriptor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/DecoderConfigDescriptor.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.ByteString.Mp4.Boxes.DecoderConfigDescriptor where
+
+import Data.ByteString.Mp4.Boxes.BaseDescriptor
+import Data.ByteString.Mp4.Boxes.DecoderSpecificInfo
+import Data.Type.BitRecords
+import Data.Kind.Extra
+import GHC.TypeLits
+
+-- | Information about what decoder is required for the an elementary stream.
+-- The stream type indicates the general category of the stream and.
+data DecoderConfigDescriptor
+ (ot :: ObjectTypeIndication)
+ (st :: StreamType)
+ :: [IsA (DecoderSpecificInfo ot st)]
+ -> [IsA (Descriptor 'ProfileLevelIndicationIndexDescr)]
+ -> IsA (Descriptor 'DecoderConfigDescr)
+
+type instance Eval (DecoderConfigDescriptor ot st di ps) =
+ 'MkDescriptor (DecoderConfigDescriptorBody ot st di ps)
+
+type family
+ DecoderConfigDescriptorBody
+ ot st
+ (di :: [IsA (DecoderSpecificInfo ot st)])
+ (ps :: [IsA (Descriptor 'ProfileLevelIndicationIndexDescr)])
+ :: BitRecord
+ where
+ DecoderConfigDescriptorBody ot st di ps =
+ BitRecordOfEnum (SetEnum "objectTypeIndication" ObjectTypeIndicationEnum ot)
+ :+: BitRecordOfEnum (SetEnum "objectTypeIndication" StreamTypeEnum st)
+ :+: "upstream" @: Flag
+ .+: "reserved" @: Field 1 := 1
+ .+: "bufferSizeDB" @: Field 24
+ .+: "maxBitrate" @: FieldU32
+ .+: "avgBitrate" @: FieldU32
+ .+: Eval (BitRecordOfList
+ (DescriptorOfDecoderSpecificInfo
+ :^>>>: BitRecordOfDescriptor)
+ (di ?:: LengthIn 0 1))
+ :+: Eval (BitRecordOfList
+ (Extract :>>>: BitRecordOfDescriptor)
+ (ps ?:: LengthIn 0 255))
+
+-- ** 'ProfileLevelIndicationIndexDescriptor'
+
+data ProfileLevelIndicationIndexDescriptor
+ :: IsA (FieldValue "profileLevelIndicationIndex" Nat)
+ -> IsA (Descriptor 'ProfileLevelIndicationIndexDescr)
+
+type instance Eval (ProfileLevelIndicationIndexDescriptor val) =
+ 'MkDescriptor
+ ('BitRecordMember (FieldU8 :~ val))
diff --git a/src/Data/ByteString/Mp4/Boxes/DecoderSpecificInfo.hs b/src/Data/ByteString/Mp4/Boxes/DecoderSpecificInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/DecoderSpecificInfo.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.ByteString.Mp4.Boxes.DecoderSpecificInfo where
+
+import Data.ByteString.Mp4.Boxes.BaseDescriptor
+import Data.Type.BitRecords
+import Data.Kind.Extra
+import Data.Kind (type Type)
+
+-- * Abstract class for opaque object- and stream type dependent decoder
+-- settings.
+
+-- | Base type of decoders
+data DecoderSpecificInfo :: ObjectTypeIndication -> StreamType -> Type where
+ MkDecoderSpecificInfo :: BitRecord -> DecoderSpecificInfo o s
+
+data DescriptorOfDecoderSpecificInfo
+ :: IsA (DecoderSpecificInfo ot st :-> Descriptor 'DecSpecificInfo)
+
+type instance DescriptorOfDecoderSpecificInfo $~ 'MkDecoderSpecificInfo body =
+ 'MkDescriptor body
+
+type ObjectTypeIndicationEnum = FixedEnum ObjectTypeIndication 8
+
+data ObjectTypeIndication =
+ SystemsIso14496_1_a
+ | SystemsIso14496_1_b
+ | InteractionStreamObjInd
+ | SystemsIso14496_1_ExtendedBifs
+ | SystemsIso14496_1_Afx
+ | FontDataStream
+ | SynthesizedTextureStream
+ | StreamingTextStream
+ | VisualIso14496_2
+ | VisualH264
+ | VisualH264ParameterSets
+ | AudioIso14496_3
+ | VisualIso13818_2_SimpleProfile
+ | VisualIso13818_2_MainProfile
+ | VisualIso13818_2_SnrProfile
+ | VisualIso13818_2_SpatialProfile
+ | VisualIso13818_2_HighProfile
+ | VisualIso13818_2_422Profile
+ | AudioIso13818_7_MainProfile
+ | AudioIso13818_7_LowComplexityProfile
+ | AudioIso13818_7_ScalableSamplingRateProfile
+ | AudioIso13818_3
+ | VisualIso11172_2
+ | AudioIso11172_3
+ | VisualIso10918_1
+ | VisualIso15444_1
+ | NoObjectTypeSpecified
+
+type instance FromEnum ObjectTypeIndication 'SystemsIso14496_1_a = 0x01
+type instance FromEnum ObjectTypeIndication 'SystemsIso14496_1_b = 0x02
+type instance FromEnum ObjectTypeIndication 'InteractionStreamObjInd = 0x03
+type instance FromEnum ObjectTypeIndication 'SystemsIso14496_1_ExtendedBifs = 0x04
+type instance FromEnum ObjectTypeIndication 'SystemsIso14496_1_Afx = 0x05
+type instance FromEnum ObjectTypeIndication 'FontDataStream = 0x06
+type instance FromEnum ObjectTypeIndication 'SynthesizedTextureStream = 0x07
+type instance FromEnum ObjectTypeIndication 'StreamingTextStream = 0x08
+type instance FromEnum ObjectTypeIndication 'VisualIso14496_2 = 0x20
+type instance FromEnum ObjectTypeIndication 'VisualH264 = 0x21
+type instance FromEnum ObjectTypeIndication 'VisualH264ParameterSets = 0x22
+type instance FromEnum ObjectTypeIndication 'AudioIso14496_3 = 0x40
+type instance FromEnum ObjectTypeIndication 'VisualIso13818_2_SimpleProfile = 0x60
+type instance FromEnum ObjectTypeIndication 'VisualIso13818_2_MainProfile = 0x61
+type instance FromEnum ObjectTypeIndication 'VisualIso13818_2_SnrProfile = 0x62
+type instance FromEnum ObjectTypeIndication 'VisualIso13818_2_SpatialProfile = 0x63
+type instance FromEnum ObjectTypeIndication 'VisualIso13818_2_HighProfile = 0x64
+type instance FromEnum ObjectTypeIndication 'VisualIso13818_2_422Profile = 0x65
+type instance FromEnum ObjectTypeIndication 'AudioIso13818_7_MainProfile = 0x66
+type instance FromEnum ObjectTypeIndication 'AudioIso13818_7_LowComplexityProfile = 0x67
+type instance FromEnum ObjectTypeIndication 'AudioIso13818_7_ScalableSamplingRateProfile = 0x68
+type instance FromEnum ObjectTypeIndication 'AudioIso13818_3 = 0x69
+type instance FromEnum ObjectTypeIndication 'VisualIso11172_2 = 0x6A
+type instance FromEnum ObjectTypeIndication 'AudioIso11172_3 = 0x6B
+type instance FromEnum ObjectTypeIndication 'VisualIso10918_1 = 0x6C
+type instance FromEnum ObjectTypeIndication 'VisualIso15444_1 = 0x6E
+type instance FromEnum ObjectTypeIndication 'NoObjectTypeSpecified = 0xFF
+
+-- * Stream Type
+
+type family
+ GetStreamType (t :: k) :: StreamType
+
+type StreamTypeEnum = FixedEnum StreamType 6
+
+data StreamType =
+ ObjectDescriptorStream
+ | ClockReferenceStream
+ | SceneDescriptionStream_Iso14496_11
+ | VisualStream
+ | AudioStream
+ | Mpeg7Stream
+ | IpmpStream
+ | ObjectContentInfoStream
+ | MpegJStream
+ | InteractionStream
+ | IpmpToolStream_Iso14496_13
+
+type instance FromEnum StreamType 'ObjectDescriptorStream = 1
+type instance FromEnum StreamType 'ClockReferenceStream = 2
+type instance FromEnum StreamType 'SceneDescriptionStream_Iso14496_11 = 3
+type instance FromEnum StreamType 'VisualStream = 4
+type instance FromEnum StreamType 'AudioStream = 5
+type instance FromEnum StreamType 'Mpeg7Stream = 6
+type instance FromEnum StreamType 'IpmpStream = 7
+type instance FromEnum StreamType 'ObjectContentInfoStream = 8
+type instance FromEnum StreamType 'MpegJStream = 9
+type instance FromEnum StreamType 'InteractionStream = 0xa
+type instance FromEnum StreamType 'IpmpToolStream_Iso14496_13 = 0xb
diff --git a/src/Data/ByteString/Mp4/Boxes/ElementaryStreamDescriptor.hs b/src/Data/ByteString/Mp4/Boxes/ElementaryStreamDescriptor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/ElementaryStreamDescriptor.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+module Data.ByteString.Mp4.Boxes.ElementaryStreamDescriptor where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Util.FullBox
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.Mp4.Boxes.BaseDescriptor
+import Data.ByteString.Mp4.Boxes.SyncLayerConfigDescriptor
+
+-- * Esd Box
+
+type EsdBox = Box (FullBox Esd 0)
+newtype Esd = Esd BuilderBox deriving (IsBoxContent)
+instance IsBox Esd
+
+type instance BoxTypeSymbol Esd = "esds"
+
+esdBox :: forall (record :: IsA (Descriptor 'ES_Descr)) (rendered :: BitRecord) .
+ ( BitStringBuilderHoley (Proxy rendered) EsdBox
+ , rendered ~ (RenderEsDescr record))
+ => Proxy record -> ToBitStringBuilder (Proxy rendered) EsdBox
+esdBox =
+ toFunction
+ . esdBoxHoley
+
+esdBoxHoley :: forall (record :: IsA (Descriptor 'ES_Descr)) r (rendered :: BitRecord) .
+ ( BitStringBuilderHoley (Proxy rendered) r
+ , rendered ~ (RenderEsDescr record)
+ )
+ => Proxy record -> FunctionBuilder EsdBox r (ToBitStringBuilder (Proxy rendered) r)
+esdBoxHoley _p =
+ mapAccumulator (fullBox 0 . Esd) $
+ bitBuilderBoxHoley (Proxy @rendered)
+
+type RenderEsDescr (d :: IsA (Descriptor 'ES_Descr)) =
+ BitRecordOfDescriptor $~ (Eval d)
+
+-- * Esd Record
+
+data ESDescriptor
+ :: IsA (FieldValue "esId" Nat)
+ -> Maybe (IsA (FieldValue "depEsId" Nat))
+ -- TODO Improve the custom field and also the sizedstring API
+ -> Maybe (IsA (BitRecordField ('MkFieldCustom :: BitField ASizedString ASizedString (urlSize :: Nat))))
+ -> Maybe (IsA (FieldValue "ocrEsId" Nat))
+ -> IsA (FieldValue "streamPrio" Nat)
+ -> IsA (Descriptor 'DecoderConfigDescr)
+ -> IsA (Descriptor 'SLConfigDescr)
+ -> IsA (Descriptor 'ES_Descr)
+
+-- | ISO-14496-14 section 3.1.2 defines restrictions of the elementary stream
+-- descriptor.
+-- TODO seperate this and other modules so theres the same seperation as in between
+-- the parts of the standard.
+type ESDescriptorMp4File esId decConfigDescr =
+ ESDescriptor esId 'Nothing 'Nothing
+ 'Nothing DefaultStreamPrio
+ decConfigDescr Mp4SyncLayerDescriptor
+
+type DefaultEsId = StaticFieldValue "esId" 1
+type DefaultStreamPrio = StaticFieldValue "streamPrio" 0
+
+type instance
+ Eval (ESDescriptor esId depEsId url ocrEsId streamPrio decConfig slConfig) =
+ 'MkDescriptor
+ ("esId" @: FieldU16 :~ esId
+ .+: "depEsIdFlag" @: FlagJust depEsId
+ .+: "urlFlag" @: FlagJust url
+ .+: "ocrEsIdFlag" @: FlagJust ocrEsId
+ .+: "streamPriority" @: Field 5 :~ streamPrio
+ .+: ("depEsId" @: FieldU16 :+? depEsId)
+ :+: (Eval (OptionalRecordOf (Fun1 RecordField) url))
+ :+: ("ocrEsId" @: FieldU16 :+? ocrEsId)
+ :+: (BitRecordOfDescriptor $~ Eval decConfig)
+ :+: (BitRecordOfDescriptor $~ Eval slConfig)
+
+ -- TODO add the rest of the ESDescriptor
+ )
diff --git a/src/Data/ByteString/Mp4/Boxes/Expandable.hs b/src/Data/ByteString/Mp4/Boxes/Expandable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/Expandable.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Data.ByteString.Mp4.Boxes.Expandable where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.ReExports
+
+-- * Static Expandable
+
+data StaticExpandableContent :: BitRecord -> IsA BitRecord
+
+type StaticExpandableContentMaxBits = 32
+
+type instance Eval (StaticExpandableContent record) =
+ (ExpandableSize
+ (ShiftR StaticExpandableContentMaxBits (BitRecordSize record) 3))
+ :+: record
+
+type family ExpandableSize (s :: Nat) :: BitRecord where
+ ExpandableSize 0 = 'EmptyBitRecord
+ ExpandableSize s =
+ If (s <=? 127)
+ (ExpandableSizeLastChunk s)
+ (ExpandableSizeNext (ShiftR StaticExpandableContentMaxBits s 7)
+ :+: ExpandableSizeLastChunk s)
+
+type ExpandableSizeLastChunk (s :: Nat) = Field 1 := 0 .+. Field 7 := s
+
+type family ExpandableSizeNext (s :: Nat) :: BitRecord where
+ ExpandableSizeNext 0 = 'EmptyBitRecord
+ ExpandableSizeNext s =
+ If (s <=? 127)
+ (ExpandableSizeNextChunk s)
+ (ExpandableSizeNext (ShiftR StaticExpandableContentMaxBits s 7)
+ :+: ExpandableSizeNextChunk s)
+
+type ExpandableSizeNextChunk (s :: Nat) = Field 1 := 1 .+. Field 7 := s
+
+
+-- * Runtime-value Expandable
+-- TODO remove "runtime" Expandable?
+newtype Expandable t where
+ Expandable :: t -> Expandable t
+
+instance IsBoxContent t => IsBoxContent (Expandable t) where
+ boxSize (Expandable x) = expandableSizeSize (boxSize x) + boxSize x
+ boxBuilder (Expandable x) = expandableSizeBuilder (boxSize x) <> boxBuilder x
+
+expandableSizeSize :: BoxSize -> BoxSize
+expandableSizeSize UnlimitedSize = error "Unlimited size not supported by expandable"
+expandableSizeSize (BoxSize s)
+ | s >= 2^(28 :: Int) = error "Expandable size >= 2^(28 :: Int)"
+ | s >= 2^(21 :: Int) = 4
+ | s >= 2^(14 :: Int) = 3
+ | s >= 2^(7 :: Int) = 2
+ | otherwise = 1
+
+expandableSizeBuilder :: BoxSize -> Builder
+expandableSizeBuilder UnlimitedSize = error "Unlimited size not supported by expandable"
+expandableSizeBuilder (BoxSize s)
+ | s >= 2 ^( 28 :: Int) = error "Expandable size >= 2^(28 :: Int)"
+ | s >= 2 ^( 21 :: Int) = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 21))) <>
+ word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 14) .&. 0x7F))) <>
+ word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 7) .&. 0x7F))) <>
+ word8 (fromIntegral (s .&. 0x7F))
+ | s >= 2 ^( 14 :: Int) = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 14))) <>
+ word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 7) .&. 0x7F))) <>
+ word8 (fromIntegral (s .&. 0x7F))
+ | s >= 2 ^( 7 :: Int) = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 7))) <>
+ word8 (fromIntegral (s .&. 0x7F))
+ | otherwise = word8 (fromIntegral s)
diff --git a/src/Data/ByteString/Mp4/Boxes/Mp4AudioSampleEntry.hs b/src/Data/ByteString/Mp4/Boxes/Mp4AudioSampleEntry.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/Mp4AudioSampleEntry.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | @mp4a@ Audio sample entry according to ISO 14496-14
+module Data.ByteString.Mp4.Boxes.Mp4AudioSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.IsoBaseFileFormat.Util.BoxFields
+import Data.ByteString.Mp4.Boxes.ElementaryStreamDescriptor
+import Data.ByteString.Mp4.Boxes.DecoderSpecificInfo
+import Data.ByteString.Mp4.Boxes.DecoderConfigDescriptor
+import Data.ByteString.Mp4.Boxes.AudioSpecificConfig
+
+-- | A /body/ for 'AudioSampleEntry'. This 'IsBoxContent' with an
+-- 'ElementaryStreamDescriptor' for ISO-14496-3 audio, with audio decoder
+-- specific info.
+
+-- | Create an 'AudioSampleEntry' with an 'AudioEsd'
+audioSampleEntry
+ :: U16 "data_reference_index"
+ -> AudioSampleEntry AudioEsd
+ -> Box (SampleEntry (AudioSampleEntry AudioEsd))
+audioSampleEntry drefIndex ase =
+ sampleEntry drefIndex ase
+
+type instance BoxTypeSymbol AudioEsd = "mp4a"
+
+-- | Create an mp4 audio elementary stream descriptor full box
+aacAudioSampleEntrySimple
+ :: Bool
+ -> SamplingFreqTable
+ -> ChannelConfigTable
+ -> U16 "samplesize"
+ -> AudioSampleEntry AudioEsd
+aacAudioSampleEntrySimple sbr sf cc sampleSize =
+ AudioSampleEntry
+ (Constant
+ :+ Custom (Scalar (channelConfigToNumber cc))
+ :+ Custom sampleSize
+ :+ 0
+ :+ Constant
+ :+ Custom (Scalar (sampleRateToNumber sf * 65536))
+ :+ mkAudioEsdAacLcOrHeAac sbr sf cc)
+
+mkAudioEsdAacLcOrHeAac
+ :: Bool
+ -> SamplingFreqTable
+ -> ChannelConfigTable
+ -> AudioEsd
+mkAudioEsdAacLcOrHeAac False sf cc =
+ AudioEsd
+ (esdBox
+ (Proxy @Mp4AacLcEsDescriptor)
+ False 0 0 0
+ (sampleRateToEnum sf)
+ (channelConfigToEnum cc))
+mkAudioEsdAacLcOrHeAac True sf cc =
+ AudioEsd
+ (esdBox
+ (Proxy @Mp4HeAacEsDescriptor)
+ False 0 0 0
+ (sampleRateToEnum sf)
+ (channelConfigToEnum cc)
+ (sampleRateToEnum sf))
+
+-- | Consists of an 'ElementaryStreamDescriptor' derived from a 'DecoderSpecificInfo'.
+newtype AudioEsd =
+ AudioEsd EsdBox
+ deriving (IsBoxContent)
+
+type Mp4AacLcEsDescriptor =
+ ESDescriptorMp4File DefaultEsId
+ (Mp4AacAudioDecoderConfigDescriptor
+ (AudioConfigAacLc
+ (EnumParam "samplingFreq" SamplingFreq)
+ (EnumParam "channelConfig" ChannelConfig)))
+
+type Mp4HeAacEsDescriptor =
+ ESDescriptorMp4File DefaultEsId
+ (Mp4AacAudioDecoderConfigDescriptor
+ (AudioConfigHeAac
+ (EnumParam "samplingFreq" SamplingFreq)
+ (EnumParam "channelConfig" ChannelConfig)))
+
+type Mp4AacAudioDecoderConfigDescriptor cfg =
+ DecoderConfigDescriptor
+ 'AudioIso14496_3
+ 'AudioStream
+ '[cfg]
+ '[]
diff --git a/src/Data/ByteString/Mp4/Boxes/SyncLayerConfigDescriptor.hs b/src/Data/ByteString/Mp4/Boxes/SyncLayerConfigDescriptor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Mp4/Boxes/SyncLayerConfigDescriptor.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.ByteString.Mp4.Boxes.SyncLayerConfigDescriptor where
+
+import Data.ByteString.IsoBaseFileFormat.ReExports
+import Data.ByteString.Mp4.Boxes.BaseDescriptor
+
+data Mp4SyncLayerDescriptor :: IsA (Descriptor 'SLConfigDescr)
+
+-- | In the holy scripture, ISO-14496-14 section 3.1.2, it is written that there
+-- shall be restrictions on the elementary stream descriptor, in there it says:
+-- Thou shall use only __two__ as the value for the __predefined__ field in the
+-- blessed __SLDescriptor__. Not one, this is a value not big enough, nor three,
+-- this value is too much. The righteous one ever only uses __two__. Only a fool
+-- will use __256__.
+type instance Eval Mp4SyncLayerDescriptor =
+ 'MkDescriptor ('BitRecordMember ("predefined" @: FieldU8 := 0x02))
diff --git a/src/Data/Kind/Extra.hs b/src/Data/Kind/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Kind/Extra.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Kind-level utilities to guide and simplify programming at the type level
+module Data.Kind.Extra
+ ( type A(..)
+ , type IsA
+ , type IsAn
+ , type Return
+ , type Pure
+ , type Eval
+ , type (:->)
+ , type Id
+ , type Apply
+ , type (^*^)
+ , type ($~)
+ , type (:>>=:)
+ , type (:>>>:)
+ , type (:^>>>:)
+ , type (:>>>^:)
+ , type (:^>>>^:)
+ , type Extract
+ , type Optional
+ , type FoldMap
+ , type Fun1
+ , type Fun2
+ , type Fun3
+ , type Fun4
+ ) where
+
+import Data.Kind (type Type)
+
+-- * Open Promoted Types
+
+-- | A group of types that all 'Eval' into the same type. This
+-- is an /open/ and /extensible/ alternative to defining an algebraic data type
+-- and using the promoted constructors. 'A' goes hand-in-hand with 'IsA' for
+-- better readability.
+--
+-- For example:
+--
+-- @
+-- data PrettyPrinter c where
+-- RenderText :: Symbol -> PrettyPrinter Symbol
+-- WithColor :: Color -> PrettyPrinter c -> PrettyPrinter c
+--
+-- data Color = Black | White
+--
+-- data ColoredText :: Color -> Symbol -> 'IsA' (PrettyPrinter Symbol)
+--
+-- type instance 'Eval' (ColoredText c txt) = 'WithColor c ('RenderText txt)
+-- @
+data A :: forall foo . foo -> Type where
+ MkA :: A foo
+
+-- | Type alias for 'A' such that @data Point2 x y :: A Vec2 -> Type@ becomes
+-- @data Point2 x y :: IsA Vec2@
+type IsA (foo :: k) = (A foo -> Type :: Type)
+
+-- | An alias to 'IsA'
+type IsAn (oo :: k) = (IsA oo :: Type)
+
+-- | An open type family to turn /symbolic/ type representations created with
+-- 'A' or 'IsA' into the actual types.
+type family Eval (t :: A foo -> Type) :: foo
+
+-- | A type @foo@, @'IsA' foo@.
+data Pure (f :: o) :: IsAn o
+type instance Eval (Pure f) = f
+type Return f = Pure f
+
+-- | A symbolic type-level function.
+data (:->) foo bar
+
+-- | An open family of functions from @foo@ to @bar@
+type family (f :: IsA (foo :-> bar)) $~ (x :: foo) :: bar
+infixl 0 $~
+
+-- | An alias for '$~'
+type Apply f x = f $~ x
+
+-- | Identity
+data Id :: IsA (foo :-> foo)
+type instance Id $~ x = x
+
+-- | Symbolic function application
+type (^*^) (f :: IsA (foo :-> bar)) (x :: IsA foo) = f $~ (Eval x)
+infixl 0 ^*^
+
+-- | Compose functions
+data (:>>>:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (good :-> best)
+infixl 1 :>>>:
+type instance (f :>>>: g) $~ x = g $~ (f $~ x)
+
+-- | Eval Input & Compose
+data (:^>>>:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (IsA good :-> best)
+infixl 1 :^>>>:
+type instance (f :^>>>: g) $~ x = g $~ (f $~ Eval x)
+
+-- | Compose and 'Return'
+data (:>>>^:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (good :-> IsA best)
+infixl 1 :>>>^:
+type instance (f :>>>^: g) $~ x = Return (g $~ (f $~ x))
+
+-- | Eval compose and return
+data (:^>>>^:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (IsA good :-> IsA best)
+infixl 1 :^>>>^:
+type instance (f :^>>>^: g) $~ x = Return (g $~ (f $~ Eval x))
+
+-- | A function that applies 'Eval'
+data Extract :: IsA (IsA x :-> x)
+type instance Extract $~ x = Eval x
+
+-- | Eval and ApplyCompose functions
+data (:>>=:) :: IsA foo -> IsA (foo :-> IsA bar) -> IsA bar
+infixl 1 :>>=:
+type instance Eval (x :>>=: f) = Eval (f $~ Eval x)
+
+-- | Either use the value from @Just@ or return a fallback value(types(kinds))
+data Optional :: IsA t -> IsA (s :-> IsA t) -> IsA (Maybe s :-> IsA t)
+
+type instance (Optional fallback f) $~ ('Just s) = f $~ s
+type instance (Optional fallback f) $~ 'Nothing = fallback
+
+-- | Map over the elements of a list and fold the result.
+type family
+ FoldMap
+ (append :: IsA (bar :-> IsA (bar :-> bar)))
+ (zero :: bar)
+ (f :: IsA (foo :-> bar))
+ (xs :: [(foo :: Type)]) :: (bar :: Type) where
+ FoldMap append zero f '[] = zero
+ FoldMap append zero f (x ': xs) = append $~ (f $~ x) $~ FoldMap append zero f xs
+
+-- TODONT safe coercions (with undecidable instances) could be done only with a
+-- type-level equivilant of a type class dictionary, A good place for that
+-- might be 'A'. For now I only had trouble with 'CoerceTo' because it is open
+-- and the compiler often used up __all__ main memory when an instance was
+-- missing.
+
+-- | Like @TyCon1@ from Data.Singletons
+data Fun1 :: (a -> IsA b)
+ -> IsA (a :-> IsA b)
+type instance (Fun1 f) $~ x = (f x)
+
+data Fun2 :: (a -> b -> IsA c)
+ -> IsA (a :-> IsA (b :-> IsA c))
+type instance (Fun2 f) $~ x = Fun1 (f x)
+
+data Fun3 :: (a -> b -> c -> IsA d)
+ -> IsA (a :-> IsA (b :-> IsA (c :-> IsA d)))
+type instance (Fun3 f) $~ x = Fun2 (f x)
+
+data Fun4 :: (a -> b -> c -> d -> IsAn e)
+ -> IsA (a :-> IsA (b :-> IsA (c :-> IsA (d :-> IsAn e))))
+type instance (Fun4 f) $~ x = Fun3 (f x)
diff --git a/src/Data/Type/BitRecords.hs b/src/Data/Type/BitRecords.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords.hs
@@ -0,0 +1,22 @@
+module Data.Type.BitRecords
+ ( module Data.Type.BitRecords.Arithmetic
+ , module Data.Type.BitRecords.Assert
+ , module Data.Type.BitRecords.Builder.BitBuffer
+ , module Data.FunctionBuilder
+ , module Data.Type.BitRecords.Builder.LazyByteStringBuilder
+ , module Data.Type.BitRecords.Core
+ , module Data.Type.BitRecords.Enum
+ , module Data.Type.BitRecords.Sized
+ , module Data.Type.BitRecords.SizedString
+ )
+where
+
+import Data.Type.BitRecords.Arithmetic
+import Data.Type.BitRecords.Assert
+import Data.Type.BitRecords.Builder.BitBuffer
+import Data.FunctionBuilder
+import Data.Type.BitRecords.Builder.LazyByteStringBuilder
+import Data.Type.BitRecords.Core
+import Data.Type.BitRecords.Enum
+import Data.Type.BitRecords.Sized
+import Data.Type.BitRecords.SizedString
diff --git a/src/Data/Type/BitRecords/Arithmetic.hs b/src/Data/Type/BitRecords/Arithmetic.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/Arithmetic.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Type.BitRecords.Arithmetic where
+
+import Data.Type.Bool
+import GHC.TypeLits
+
+-- | Efficient 'Mod' operation for power of 2 values. Note that x must be
+-- representable by 'ModPow2Bits' bits.
+type ModPow2 value power = FromBits (TakeLastN power (ToBits value ModPow2Bits))
+
+type TakeLastN n xs = TakeLastNImplRev n xs '[]
+
+type family TakeLastNImplRev (n :: Nat) (xs :: [t]) (acc :: [t]) :: [t] where
+ TakeLastNImplRev n '[] acc = TakeLastNImplTakeNRev n acc '[]
+ TakeLastNImplRev n (x ': xs) acc =
+ TakeLastNImplRev n xs (x ': acc)
+
+type family TakeLastNImplTakeNRev (n :: Nat) (rs :: [t]) (acc :: [t]) :: [t] where
+ TakeLastNImplTakeNRev n '[] acc = acc
+ TakeLastNImplTakeNRev 0 rs acc = acc
+ TakeLastNImplTakeNRev n (r ': rs) acc = TakeLastNImplTakeNRev (n-1) rs (r ': acc)
+
+
+-- | Maximum number of bits an argument @x@ of 'ModPow2' may occupy.
+type ModPow2Bits = 32
+
+-- * Bit manipulation
+
+type family TestHighBit (x :: Nat) (n :: Nat) :: Bool where
+ TestHighBit x n = ((2 ^ n) <=? x) -- x > 2^n
+
+type ToBits x n = ToBits_ x n 'False
+type family ToBits_ (x :: Nat) (n :: Nat) (started :: Bool) :: [Bool] where
+ ToBits_ x 0 started = '[]
+ ToBits_ x n started = ToBitsInner (TestHighBit x (n - 1)) x (n - 1) started
+type family
+ ToBitsInner (highBitSet :: Bool) (x :: Nat) (n :: Nat) (started :: Bool) :: [Bool] where
+ ToBitsInner 'True x n started = 'True ': ToBits_ (x - 2^n) n 'True
+ ToBitsInner 'False x n 'False = ToBits_ x n 'False
+ ToBitsInner 'False x n 'True = 'False ': ToBits_ x n 'True
+
+type FromBits bits = FromBits_ bits 0
+type family FromBits_ (bits :: [Bool]) (acc :: Nat) :: Nat where
+ FromBits_ '[] acc = acc
+ FromBits_ ('False ': rest) acc = FromBits_ rest (acc + acc)
+ FromBits_ ('True ': rest) acc = FromBits_ rest (1 + acc + acc)
+
+type family
+ ShiftBitsR (bits :: [Bool]) (n :: Nat) :: [Bool] where
+ ShiftBitsR bits 0 = bits
+ ShiftBitsR '[] n = '[]
+ ShiftBitsR '[e] 1 = '[]
+ ShiftBitsR (e ': rest) 1 = e ': ShiftBitsR rest 1
+ ShiftBitsR (e ': rest) n = ShiftBitsR (ShiftBitsR (e ': rest) 1) (n - 1)
+
+type family
+ GetMostSignificantBitIndex (highestBit :: Nat) (n :: Nat) :: Nat where
+ GetMostSignificantBitIndex 0 n = 1
+ GetMostSignificantBitIndex highestBit n =
+ If (2 ^ (highestBit + 1) <=? n)
+ (TypeError ('Text "number to big: "
+ ':<>: 'ShowType n
+ ':<>: 'Text " >= "
+ ':<>: 'ShowType (2 ^ (highestBit + 1))))
+ (If (2 ^ highestBit <=? n)
+ highestBit
+ (GetMostSignificantBitIndex (highestBit - 1) n))
+
+-- | Shift a type level natural to the right. This useful for division by powers
+-- of two.
+type family
+ ShiftR (xMaxBits :: Nat) (x :: Nat) (bits :: Nat) :: Nat where
+ ShiftR xMaxBits x n =
+ FromBits
+ (ShiftBitsR
+ (ToBits x
+ (1 + GetMostSignificantBitIndex xMaxBits x))
+ n)
diff --git a/src/Data/Type/BitRecords/Assert.hs b/src/Data/Type/BitRecords/Assert.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/Assert.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Type - level assertion utility leveraging custom 'TypeError's
+module Data.Type.BitRecords.Assert
+ ( type Assert, type Assertion, type Check
+ , type (?::)
+ , type (@&&)
+ , type NatLE
+ , type NatGE
+ , type NatIn
+ , type LengthIn
+ , type CountElementsForLengthIn
+ ) where
+
+import GHC.TypeLits
+import Data.Kind (type Type)
+import Data.Type.Bool
+
+-- | Assert that a given type satisfies some condition defined via 'Check'
+-- instances. This is only an alias for 'Assert'
+type (?::) x cond = Assert cond x
+infixr 0 ?::
+
+-- | Apply an 'Assertion' to some value and return that value if the assertion
+-- holds, otherwise throw a 'TypeError'.
+type family Assert (cond :: Assertion a) (x :: a) :: a where
+ Assert cond x = ProcessCheckResult (Check cond x) x
+
+-- | Make an assertion by creating a phantom data type which contains @TyFun a
+-- (Maybe ErrorMessage)@ as last parameter. 'Check' is used by 'Assert' the
+-- /apply/ the 'TyFun's which are specialized in this definition to have the
+-- return type @Maybe ErrorMessage@.
+type Assertion a = TyFun a (Maybe ErrorMessage) -> Type
+
+-- | Apply 'Assertion's to the actual values.
+type family Check (f :: Assertion a) (x :: a) :: Maybe ErrorMessage
+
+type family ProcessCheckResult (r :: Maybe ErrorMessage) (x :: a) :: a where
+ ProcessCheckResult 'Nothing x = x
+ ProcessCheckResult ('Just blah) x =
+ TypeError ('Text "Assertion on value " ':<>: 'ShowType x ':<>: 'Text " failed:" ':$$: blah)
+
+-- | Shamelessly stolen from the singletons library.
+data TyFun :: Type -> Type -> Type
+
+-- | Assert that two assertions both hold
+data (@&&) :: Assertion a -> Assertion a -> Assertion a
+
+type instance Check (a1 @&& a2) x =
+ (ProcessCheckResult (Check a2 x)
+ (ProcessCheckResult (Check a1 x) x))
+
+-- | Assert that a 'Nat' is greater than or equal to an other 'Nat'.
+data NatGE :: Nat -> Assertion Nat
+
+type instance Check (NatGE n) x =
+ If (n <=? x) 'Nothing ('Just ( 'Text "Natural too small: " ':<>: 'ShowType x
+ ':$$: 'Text "Required: >=" ':<>: 'ShowType n))
+
+-- | Assert that a 'Nat' is less than or equal to an other 'Nat'.
+data NatLE :: Nat -> Assertion Nat
+
+type instance Check (NatLE n) x =
+ If (x <=? n) 'Nothing ('Just ( 'Text "Natural too big: " ':<>: 'ShowType x
+ ':$$: 'Text "Required: <=" ':<>: 'ShowType n))
+
+
+-- | Assert that a 'Nat' is in a specific range.
+data NatIn :: Nat -> Nat -> Assertion Nat
+
+type instance Check (NatIn from to) n =
+ CheckNatInRange (n <=? to) (from <=? n) from to n
+
+type family
+ CheckNatInRange
+ (lt :: Bool) (gt :: Bool) (from :: Nat) (to :: Nat) (n :: Nat) :: Maybe ErrorMessage where
+ CheckNatInRange 'True 'True from to x = 'Nothing
+ CheckNatInRange c1 c2 from to x =
+ 'Just ('Text "Natural out of range: " ':<>: 'ShowType x
+ ':<>: 'Text " not in "
+ ':<>: 'ShowType from ':<>: 'Text " .. " ':<>: 'ShowType to)
+
+-- | Assert that a list's length falls into a given range.
+-- This is generalized from actual lists; everything with a 'CountElementsForLengthIn'
+-- instance can be asserted.
+data LengthIn :: Nat -> Nat -> Assertion a
+
+type instance Check (LengthIn from to) xs = Check (NatIn from to) (CountElementsForLengthIn xs)
+
+type family CountElementsForLengthIn (xs :: k) :: Nat
+type instance CountElementsForLengthIn ('[]) = 0
+type instance CountElementsForLengthIn (x ': xs) = 1 + CountElementsForLengthIn xs
diff --git a/src/Data/Type/BitRecords/Builder/BitBuffer.hs b/src/Data/Type/BitRecords/Builder/BitBuffer.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/Builder/BitBuffer.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+module Data.Type.BitRecords.Builder.BitBuffer
+ ( type BitStringMaxLength
+ , type ModuloBitStringMaxLength
+ , bitStringMaxLength
+ , bitStringMaxLengthBytes
+ , BitString()
+ , bitStringContent
+ , bitStringLength
+ , isBitStringEmpty
+ , bitStringSpaceLeft
+ , bitString
+ , emptyBitString
+ , bitStringProxyLength
+ , BitStringBuilderChunk()
+ , bitStringBuilderChunkContent
+ , bitStringBuilderChunkLength
+ , isBitStringBuilderChunkEmpty
+ , bitStringBuilderChunkSpaceLeft
+ , bitStringBuilderChunk
+ , emptyBitStringBuilderChunk
+ , bufferBits
+ , type KnownChunkSize
+ ) where
+
+import Data.Proxy
+import Data.Bits
+import Data.Word
+import Data.Kind ( Constraint )
+import GHC.TypeLits
+
+-- | The maximum number of bits a 'BitBuffer' can hold.
+type BitStringMaxLength = 64
+
+-- | Calculate the modulus of a number and the 'BitStringMaxLength'.
+type family ModuloBitStringMaxLength (len :: Nat) :: Nat where
+ ModuloBitStringMaxLength len = len `Mod` BitStringMaxLength
+
+-- | The maximum number of bits a 'BitBuffer' can hold.
+bitStringMaxLength :: Num a => a
+bitStringMaxLength = 64
+
+-- | The maximum number of bytes a 'BitBuffer' can hold.
+bitStringMaxLengthBytes :: Word64
+bitStringMaxLengthBytes = 8
+
+-- | A string of bits with a given length (but always @<= 'bitStringMaxLength'@.
+-- The number of bits must be smaller that 'bitStringMaxLength'.
+data BitString = BitString !Word64 !Int
+
+bitStringContent :: BitString -> Word64
+bitStringContent (BitString !c _) =
+ c
+
+bitStringLength :: BitString -> Int
+bitStringLength (BitString _ !len) =
+ len
+
+isBitStringEmpty :: BitString -> Bool
+isBitStringEmpty (BitString _ !len) =
+ len == 0
+
+bitStringSpaceLeft :: BitString -> Int
+bitStringSpaceLeft (BitString _ !len) =
+ bitStringMaxLength - len
+
+-- | Create a 'BitString' containing @len@ bits from LSB to MSB, properly
+-- masked, such that only @len@ least significant bits are kept..
+bitString :: Int -> Word64 -> BitString
+bitString !len !b = BitString (let !s = bitStringMaxLength - len in ((b `unsafeShiftL` s) `unsafeShiftR` s)) len
+
+-- | Create an empty 'BitString'.
+emptyBitString :: BitString
+emptyBitString = BitString 0 0
+
+-- | A buffer for 64 bits, such that the bits are written MSB to LSB.
+--
+-- > type TwoFields = "f0" @: Field m .+. "f1" @: Field n
+--
+-- Writes:
+-- @ MSB LSB
+-- Bit: |k .. k-(m+1)|k-m .. k-(m+n+1)|k-(m+n) .. 0|
+-- Value: |------f0------|--------f1--------|XXXXXXXXXXXXXX|
+-- @
+--
+-- Where @k@ is the current bit offset.
+-- The input values are expected to be in the order of the fields, i.e.:
+--
+-- @
+-- toFunction $ bitStringBuilderHoley (Proxy :: Proxy TwoFields) 1 2
+-- @
+--
+-- Will result in:
+-- @ MSB LSB
+-- Bit: |k .. k-(m+1)|k-m .. k-(m+n+1)| k-(m+n) .. 0|
+-- Value: |0 .. 1|0 .. 10| X .. X|
+-- @
+data BitStringBuilderChunk = BitStringBuilderChunk !Word64 !Int
+
+bitStringBuilderChunkContent :: BitStringBuilderChunk -> Word64
+bitStringBuilderChunkContent (BitStringBuilderChunk !c _) =
+ c
+
+bitStringBuilderChunkLength :: BitStringBuilderChunk -> Int
+bitStringBuilderChunkLength (BitStringBuilderChunk _ !len) =
+ len
+
+isBitStringBuilderChunkEmpty :: BitStringBuilderChunk -> Bool
+isBitStringBuilderChunkEmpty (BitStringBuilderChunk _ !len) =
+ len == 0
+
+bitStringBuilderChunkSpaceLeft :: BitStringBuilderChunk -> Int
+bitStringBuilderChunkSpaceLeft (BitStringBuilderChunk _ !len) =
+ bitStringMaxLength - len
+
+-- | Create a 'BitStringBuilderChunk' containing @len@ bits from LSB to MSB, properly
+-- masked, such that only @len@ least significant bits are kept..
+bitStringBuilderChunk :: Word64 -> Int -> BitStringBuilderChunk
+bitStringBuilderChunk !b !len = BitStringBuilderChunk b len
+
+-- | Create an empty 'BitStringBuilderChunk'.
+emptyBitStringBuilderChunk :: BitStringBuilderChunk
+emptyBitStringBuilderChunk = BitStringBuilderChunk 0 0
+
+-- | Create a 'BitStringBuilderChunk' with a length given by a 'Proxy' to a type level
+-- 'Nat'.
+bitStringProxyLength :: (KnownChunkSize n) => Proxy n -> Word64 -> BitString
+bitStringProxyLength !plen !v = bitString fieldLen v
+ where
+ !fieldLen = fromIntegral (natVal plen)
+
+
+-- | Copy bits starting at a specific offset from one @a@ the the other.
+-- Set bits starting from the most significant bit to the least.
+-- For example @writeBits m 1 <> writeBits n 2@ would result in:
+--
+-- @
+-- MSB LSB
+-- Bit: |k .. k-(m+1)|k-m .. k-(m+n+1)| k-(m+n) .. 0|
+-- Value: |0 .. 1|0 .. 10| ... |
+-- -> -> -> (direction of writing)
+-- @
+--
+bufferBits :: BitString -- ^ The value to write (in the lower @length@ bits).
+ -> BitStringBuilderChunk -- ^ The input to write to
+ -> (BitString, BitStringBuilderChunk) -- ^ The remaining bits that did not fit
+ -- in the buffer and the output buffer.
+bufferBits (BitString !bits !len) (BitStringBuilderChunk !buff !offset) =
+ let !spaceAvailable = bitStringMaxLength - offset
+ !writeLen = min spaceAvailable len
+ !writeOffset = spaceAvailable - writeLen
+ !restLen = len - writeLen
+ !restBits = bits .&. (1 `unsafeShiftL` restLen - 1)
+ !buff' = buff .|.
+ (bits `unsafeShiftR` restLen `unsafeShiftL` writeOffset)
+ in
+ (BitString restBits restLen, BitStringBuilderChunk buff' (offset + writeLen))
+
+type family KnownChunkSize (s :: Nat) :: Constraint where
+ KnownChunkSize size = (KnownNat size, size <= BitStringMaxLength)
diff --git a/src/Data/Type/BitRecords/Builder/LazyByteStringBuilder.hs b/src/Data/Type/BitRecords/Builder/LazyByteStringBuilder.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/Builder/LazyByteStringBuilder.hs
@@ -0,0 +1,315 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+module Data.Type.BitRecords.Builder.LazyByteStringBuilder where
+
+import Data.Type.BitRecords.Builder.BitBuffer
+import Data.FunctionBuilder
+import Data.Type.BitRecords.Core
+import Data.Word
+import Data.Int
+import Data.Bits
+import Data.Kind.Extra
+import Data.Proxy
+import GHC.TypeLits
+import Data.Monoid
+import Control.Category
+import Prelude hiding ((.), id)
+import qualified Data.ByteString.Builder as SB
+import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString as SB
+import Text.Printf
+
+-- | A wrapper around a builder derived from a 'BitStringBuilderState'
+data BuilderBox where
+ MkBuilderBox :: !Word64 -> !SB.Builder -> BuilderBox
+
+instance Semigroup BuilderBox where
+ (MkBuilderBox !ls !lb) <> (MkBuilderBox !rs !rb) =
+ MkBuilderBox (ls + rs) (lb <> rb)
+
+instance Monoid BuilderBox where
+ mempty = MkBuilderBox 0 mempty
+
+-- | Create a 'SB.Builder' from a 'BitRecord' and store it in a 'BuilderBox'
+bitBuilderBox ::
+ forall (record :: BitRecord) .
+ BitStringBuilderHoley (Proxy record) BuilderBox
+ => Proxy record
+ -> ToBitStringBuilder (Proxy record) BuilderBox
+bitBuilderBox = toFunction . bitBuilderBoxHoley
+
+-- | Like 'bitBuilderBox', but 'toFunction' the result and accept as an additional
+-- parameter a wrapper function to wrap the final result (the 'BuilderBox') and
+-- 'toFunction' the whole machiner.
+wrapBitBuilderBox ::
+ forall (record :: BitRecord) wrapped .
+ BitStringBuilderHoley (Proxy record) wrapped
+ => (BuilderBox -> wrapped)
+ -> Proxy record
+ -> ToBitStringBuilder (Proxy record) wrapped
+wrapBitBuilderBox !f !p = toFunction (mapAccumulator f (bitBuilderBoxHoley p))
+
+-- | Create a 'SB.Builder' from a 'BitRecord' and store it in a 'BuilderBox';
+-- return a 'FunctionBuilder' monoid that does that on 'toFunction'
+bitBuilderBoxHoley ::
+ forall (record :: BitRecord) r .
+ BitStringBuilderHoley (Proxy record) r
+ => Proxy record
+ -> FunctionBuilder BuilderBox r (ToBitStringBuilder (Proxy record) r)
+bitBuilderBoxHoley !p =
+ let fromBitStringBuilder !h =
+ let (BitStringBuilderState !builder _ !wsize) =
+ flushBitStringBuilder
+ $ appBitStringBuilder h initialBitStringBuilderState
+ !out = MkBuilderBox wsize builder
+ in out
+ in mapAccumulator fromBitStringBuilder (bitStringBuilderHoley p)
+
+-- * Low-level interface to building 'BitRecord's and other things
+
+newtype BitStringBuilder =
+ BitStringBuilder {unBitStringBuilder :: Dual (Endo BitStringBuilderState)}
+ deriving (Monoid, Semigroup)
+
+runBitStringBuilder
+ :: BitStringBuilder -> SB.Builder
+runBitStringBuilder !w =
+ getBitStringBuilderStateBuilder $
+ flushBitStringBuilder $ appBitStringBuilder w initialBitStringBuilderState
+
+bitStringBuilder :: (BitStringBuilderState -> BitStringBuilderState)
+ -> BitStringBuilder
+bitStringBuilder = BitStringBuilder . Dual . Endo
+
+appBitStringBuilder :: BitStringBuilder
+ -> BitStringBuilderState
+ -> BitStringBuilderState
+appBitStringBuilder !w = appEndo (getDual (unBitStringBuilder w))
+
+data BitStringBuilderState where
+ BitStringBuilderState ::
+ !SB.Builder -> !BitStringBuilderChunk -> !Word64 -> BitStringBuilderState
+
+getBitStringBuilderStateBuilder
+ :: BitStringBuilderState -> SB.Builder
+getBitStringBuilderStateBuilder (BitStringBuilderState !builder _ _) = builder
+
+initialBitStringBuilderState
+ :: BitStringBuilderState
+initialBitStringBuilderState =
+ BitStringBuilderState mempty emptyBitStringBuilderChunk 0
+
+-- | Write the partial buffer contents using any number of 'word8' The unwritten
+-- parts of the bittr buffer are at the top. If the
+--
+-- > 63 ... (63-off-1)(63-off) ... 0
+-- > ^^^^^^^^^^^^^^^^^^^
+-- > Relevant bits start to the top!
+--
+flushBitStringBuilder
+ :: BitStringBuilderState -> BitStringBuilderState
+flushBitStringBuilder (BitStringBuilderState !bldr !buff !totalSize) =
+ BitStringBuilderState (writeRestBytes bldr 0)
+ emptyBitStringBuilderChunk
+ totalSize'
+ where !off = bitStringBuilderChunkLength buff
+ !off_ = (fromIntegral off :: Word64)
+ !totalSize' = totalSize + signum (off_ `rem` 8) + (off_ `div` 8)
+ !part = bitStringBuilderChunkContent buff
+ -- write bytes from msb to lsb until the offset is reached
+ -- > 63 ... (63-off-1)(63-off) ... 0
+ -- > ^^^^^^^^^^^^^^^^^^^
+ -- > AAAAAAAABBBBBBBBCCC00000
+ -- > |byte A| byte B| byte C|
+ writeRestBytes !bldr' !flushOffset =
+ if off <= flushOffset
+ then bldr'
+ else let !flushOffset' = flushOffset + 8
+ !bldr'' =
+ bldr' <>
+ SB.word8 (fromIntegral
+ ((part `unsafeShiftR`
+ (bitStringMaxLength - flushOffset')) .&.
+ 0xFF))
+ in writeRestBytes bldr'' flushOffset'
+
+-- | Write all the bits, in chunks, filling and writing the 'BitString'
+-- in the 'BitStringBuilderState' as often as necessary.
+appendBitString :: BitString -> BitStringBuilder
+appendBitString !x' =
+ bitStringBuilder $
+ \(BitStringBuilderState !builder !buff !totalSizeIn) -> go x' builder buff totalSizeIn
+ where go !x !builder !buff !totalSize
+ | bitStringLength x == 0 = BitStringBuilderState builder buff totalSize
+ | otherwise =
+ let (!rest, !buff') = bufferBits x buff
+ in if bitStringBuilderChunkSpaceLeft buff' > 0
+ then BitStringBuilderState builder buff' totalSize
+ else let !nextBuilder =
+ builder <>
+ SB.word64BE (bitStringBuilderChunkContent buff')
+ !totalSize' = totalSize + bitStringMaxLengthBytes
+ in go rest nextBuilder emptyBitStringBuilderChunk totalSize'
+
+-- | Write all the b*y*tes, into the 'BitStringBuilderState' this allows general
+-- purposes non-byte aligned builders.
+appendStrictByteString :: SB.ByteString -> BitStringBuilder
+appendStrictByteString !sb =
+ foldMap (appendBitString . bitString 8 . fromIntegral) (SB.unpack sb)
+
+runBitStringBuilderHoley
+ :: FunctionBuilder BitStringBuilder SB.Builder a -> a
+runBitStringBuilderHoley (FB !x) = x runBitStringBuilder
+
+-- * 'BitString' construction from 'BitRecord's
+
+class BitStringBuilderHoley a r where
+ type ToBitStringBuilder a r
+ type ToBitStringBuilder a r = r
+ bitStringBuilderHoley :: a -> FunctionBuilder BitStringBuilder r (ToBitStringBuilder a r)
+
+instance BitStringBuilderHoley BitString r where
+ bitStringBuilderHoley = immediate . appendBitString
+
+-- ** 'BitRecordField' instances
+
+type family UnsignedDemoteRep i where
+ UnsignedDemoteRep Int8 = Word8
+ UnsignedDemoteRep Int16 = Word16
+ UnsignedDemoteRep Int32 = Word32
+ UnsignedDemoteRep Int64 = Word64
+
+-- *** Labbeled Fields
+
+instance
+ forall nested l a .
+ ( BitStringBuilderHoley (Proxy nested) a )
+ => BitStringBuilderHoley (Proxy (LabelF l nested)) a where
+ type ToBitStringBuilder (Proxy (LabelF l nested)) a =
+ ToBitStringBuilder (Proxy nested) a
+ bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @nested)
+
+-- **** Bool
+
+instance forall f a . (BitRecordFieldSize f ~ 1) =>
+ BitStringBuilderHoley (Proxy (f := 'True)) a where
+ bitStringBuilderHoley _ = immediate (appendBitString (bitString 1 1))
+
+instance forall f a . (BitRecordFieldSize f ~ 1) =>
+ BitStringBuilderHoley (Proxy (f := 'False)) a where
+ bitStringBuilderHoley _ = immediate (appendBitString (bitString 1 0))
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldFlag)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldFlag)) a = Bool -> a
+ bitStringBuilderHoley _ =
+ addParameter (appendBitString . bitString 1 . (\ !t -> if t then 1 else 0))
+
+-- **** Bits
+
+instance forall (s :: Nat) a . (KnownChunkSize s) =>
+ BitStringBuilderHoley (Proxy (MkField ('MkFieldBits :: BitField (B s) Nat s))) a where
+ type ToBitStringBuilder (Proxy (MkField ('MkFieldBits :: BitField (B s) Nat s))) a = B s -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitStringProxyLength (Proxy @s) . unB)
+
+-- **** Naturals
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldU64)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldU64)) a = Word64 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 64)
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldU32)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldU32)) a = Word32 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 32 . fromIntegral)
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldU16)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldU16)) a = Word16 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 16 . fromIntegral)
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldU8)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldU8)) a = Word8 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 8 . fromIntegral)
+
+-- **** Signed
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldI64)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldI64)) a = Int64 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 64 . fromIntegral @Int64 @Word64)
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldI32)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldI32)) a = Int32 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 32 . fromIntegral . fromIntegral @Int32 @Word32)
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldI16)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldI16)) a = Int16 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 16 . fromIntegral . fromIntegral @Int16 @Word16)
+
+instance forall a .
+ BitStringBuilderHoley (Proxy (MkField 'MkFieldI8)) a where
+ type ToBitStringBuilder (Proxy (MkField 'MkFieldI8)) a = Int8 -> a
+ bitStringBuilderHoley _ = addParameter (appendBitString . bitString 8 . fromIntegral . fromIntegral @Int8 @Word8)
+
+
+instance forall (f :: IsA (BitRecordField (t :: BitField rt Nat len))) (v :: Nat) a . (KnownNat v, BitStringBuilderHoley (Proxy f) a, ToBitStringBuilder (Proxy f) a ~ (rt -> a), Num rt) =>
+ BitStringBuilderHoley (Proxy (f := v)) a where
+ bitStringBuilderHoley _ = fillParameter (bitStringBuilderHoley (Proxy @f)) (fromIntegral (natVal (Proxy @v)))
+
+instance forall v f a x . (KnownNat v, BitStringBuilderHoley (Proxy f) a, ToBitStringBuilder (Proxy f) a ~ (x -> a), Num x) =>
+ BitStringBuilderHoley (Proxy (f := ('PositiveNat v))) a where
+ bitStringBuilderHoley _ = fillParameter (bitStringBuilderHoley (Proxy @f)) (fromIntegral (natVal (Proxy @v)))
+
+
+instance forall v f a x . (KnownNat v, BitStringBuilderHoley (Proxy f) a, ToBitStringBuilder (Proxy f) a ~ (x -> a), Num x) =>
+ BitStringBuilderHoley (Proxy (f := ('NegativeNat v))) a where
+ bitStringBuilderHoley _ = fillParameter (bitStringBuilderHoley (Proxy @f)) (fromIntegral (-1 * (natVal (Proxy @v))))
+
+-- ** 'BitRecord' instances
+
+instance forall (r :: IsA BitRecord) a . BitStringBuilderHoley (Proxy (Eval r)) a =>
+ BitStringBuilderHoley (Proxy r) a where
+ type ToBitStringBuilder (Proxy r) a =
+ ToBitStringBuilder (Proxy (Eval r)) a
+ bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @(Eval r))
+
+-- *** 'BitRecordMember'
+
+instance forall f a . BitStringBuilderHoley (Proxy f) a => BitStringBuilderHoley (Proxy ('BitRecordMember f)) a where
+ type ToBitStringBuilder (Proxy ('BitRecordMember f)) a = ToBitStringBuilder (Proxy f) a
+ bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @f)
+
+-- *** 'AppendedBitRecords'
+
+instance forall l r a .
+ (BitStringBuilderHoley (Proxy l) (ToBitStringBuilder (Proxy r) a)
+ , BitStringBuilderHoley (Proxy r) a)
+ => BitStringBuilderHoley (Proxy ('BitRecordAppend l r)) a where
+ type ToBitStringBuilder (Proxy ('BitRecordAppend l r)) a =
+ ToBitStringBuilder (Proxy l) (ToBitStringBuilder (Proxy r) a)
+ bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @l) . bitStringBuilderHoley (Proxy @r)
+
+-- *** 'EmptyBitRecord' and '...Pretty'
+
+instance BitStringBuilderHoley (Proxy 'EmptyBitRecord) a where
+ bitStringBuilderHoley _ = id
+
+-- ** Tracing/Debug Printing
+
+-- | Print a 'SB.Builder' to a space seperated series of hexa-decimal bytes.
+printBuilder :: SB.Builder -> String
+printBuilder b =
+ ("<< " ++) $
+ (++ " >>") $ unwords $ printf "%0.2x" <$> B.unpack (SB.toLazyByteString b)
+
+bitStringPrinter
+ :: BitStringBuilderHoley a String
+ => a -> ToBitStringBuilder a String
+bitStringPrinter =
+ toFunction . mapAccumulator (printBuilder . runBitStringBuilder) . bitStringBuilderHoley
diff --git a/src/Data/Type/BitRecords/Core.hs b/src/Data/Type/BitRecords/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/Core.hs
@@ -0,0 +1,345 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Type.BitRecords.Core where
+
+import Data.Int
+import Data.Kind (Type)
+import Data.Kind.Extra
+import Data.Proxy
+import Data.Type.Pretty
+import Data.Word
+import Data.Bits
+import GHC.TypeLits
+import Text.Printf
+
+-- * Bit-Records
+
+-- ** Bit-Record Type
+
+-- | 'BitRecordField's assembly
+data BitRecord where
+ EmptyBitRecord :: BitRecord
+ BitRecordMember :: IsA (BitRecordField t) -> BitRecord
+ BitRecordAppend :: BitRecord -> BitRecord -> BitRecord
+ -- TODO MissingBitRecord :: ErrorMessage -> BitRecord
+
+-- | A conditional 'BitRecord'
+type family WhenR (b :: Bool) (x :: BitRecord) :: BitRecord where
+ WhenR 'False r = 'EmptyBitRecord
+ WhenR 'True r = r
+
+-- *** Basic Accessor
+
+-- | Get the number of bits in a 'BitRecord'
+type family BitRecordSize (x :: BitRecord) :: Nat where
+ BitRecordSize 'EmptyBitRecord = 0
+ BitRecordSize ('BitRecordMember f) = BitRecordFieldSize f
+ BitRecordSize ('BitRecordAppend l r) = BitRecordSize l + BitRecordSize r
+
+-- | Get the total number of members in a record.
+type family BitRecordMemberCount (b :: BitRecord) :: Nat where
+ BitRecordMemberCount 'EmptyBitRecord = 0
+ BitRecordMemberCount ('BitRecordMember f) = 1
+ BitRecordMemberCount ('BitRecordAppend l r) = BitRecordMemberCount l + BitRecordMemberCount r
+
+-- | Get the size of the record.
+getRecordSizeFromProxy
+ :: forall px (rec :: BitRecord) . KnownNat (BitRecordSize rec) => px rec -> Integer
+getRecordSizeFromProxy _ = natVal (Proxy :: Proxy (BitRecordSize rec))
+
+-- | Either use the value from @Just@ or return a 'EmptyBitRecord' value(types(kinds))
+type OptionalRecordOf (f :: IsA (s :-> IsA BitRecord)) (x :: Maybe s) =
+ (Optional (Pure 'EmptyBitRecord) f $~ x :: IsA BitRecord)
+
+-- ** Record composition
+
+-- | Combine two 'BitRecord's to form a new 'BitRecord'. If the parameters are
+-- not of type 'BitRecord' they will be converted.
+data (:+^) (l :: BitRecord) (r :: IsA BitRecord) :: IsA BitRecord
+infixl 3 :+^
+type instance Eval (l :+^ r) = l `Append` Eval r
+
+-- | Combine two 'BitRecord's to form a new 'BitRecord'. If the parameters are
+-- not of type 'BitRecord' they will be converted.
+data (:^+) (l :: IsA BitRecord) (r :: BitRecord) :: IsA BitRecord
+infixl 3 :^+
+type instance Eval (l :^+ r) = Eval l `Append` r
+
+-- | Combine two 'BitRecord's to form a new 'BitRecord'. If the parameters are
+-- not of type 'BitRecord' they will be converted.
+type (:+:) (l :: BitRecord) (r :: BitRecord) = ((l `Append` r) :: BitRecord)
+infixl 3 :+:
+
+type family Append (l :: BitRecord) (r :: BitRecord) :: BitRecord where
+ Append l 'EmptyBitRecord = l
+ Append 'EmptyBitRecord r = r
+ Append l r = 'BitRecordAppend l r
+
+-- | Append a 'BitRecord' and a 'BitRecordField'
+type (:+.) (r :: BitRecord)
+ (f :: IsA (BitRecordField t1))
+ = Append r ('BitRecordMember f)
+infixl 6 :+.
+
+-- | Append a 'BitRecordField' and a 'BitRecord'
+type (.+:) (f :: IsA (BitRecordField t1))
+ (r :: BitRecord)
+ = Append ('BitRecordMember f) r
+infixr 6 .+:
+
+-- | Append a 'BitRecordField' and a 'BitRecordField' forming a 'BitRecord' with
+-- two members.
+type (.+.) (l :: IsA (BitRecordField t1))
+ (r :: IsA (BitRecordField t2))
+ = Append ('BitRecordMember l) ('BitRecordMember r)
+infixr 6 .+.
+
+-- | Set a field to either a static, compile time, value or a dynamic, runtime value.
+type family (:~)
+ (field :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))
+ (value :: IsA (FieldValue (label :: Symbol) st))
+ :: IsA (BitRecordField t) where
+ fld :~ StaticFieldValue l v = (l @: fld) := v
+ fld :~ RuntimeFieldValue l = l @: fld
+infixl 7 :~
+
+-- | Like ':~' but for a 'Maybe' parameter. In case of 'Just' it behaves like ':~'
+-- in case of 'Nothing' it return an 'EmptyBitRecord'.
+type family (:~?)
+ (fld :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))
+ (value :: Maybe (IsA (FieldValue (label :: Symbol) st)))
+ :: IsA BitRecord where
+ fld :~? ('Just v) = RecordField (fld :~ v)
+ fld :~? 'Nothing = Pure 'EmptyBitRecord
+infixl 7 :~?
+
+-- | Like ':~' but for a 'Maybe' parameter. In case of 'Just' it behaves like ':~'
+-- in case of 'Nothing' it return an 'EmptyBitRecord'.
+type family (:+?)
+ (fld :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))
+ (value :: Maybe (IsA (FieldValue (label :: Symbol) st)))
+ :: BitRecord where
+ fld :+? ('Just v) = 'BitRecordMember (fld :~ v)
+ fld :+? 'Nothing = 'EmptyBitRecord
+infixl 7 :+?
+
+-- | The field value parameter for ':~', either a static, compile time, value or
+-- a dynamic, runtime value.
+data FieldValue :: Symbol -> staticRep -> Type
+data StaticFieldValue (label :: Symbol) :: staticRep -> IsA (FieldValue label staticRep)
+data RuntimeFieldValue (label :: Symbol) :: IsA (FieldValue label staticRep)
+
+-- *** Record Arrays and Repitition
+
+-- | An array of records with a fixed number of elements, NOTE: this type is
+-- actually not really necessary since 'ReplicateRecord' exists, but this allows
+-- to have a different 'showRecord' output.
+data RecArray :: BitRecord -> Nat -> IsA BitRecord
+
+type r ^^ n = RecArray r n
+infixl 5 ^^
+
+type instance Eval (RecArray (r :: BitRecord) n ) = RecArrayToBitRecord r n
+
+-- | Repeat a bit record @n@ times.
+type family RecArrayToBitRecord (r :: BitRecord) (n :: Nat) :: BitRecord where
+ RecArrayToBitRecord r 0 = 'EmptyBitRecord
+ RecArrayToBitRecord r 1 = r
+ RecArrayToBitRecord r n = Append r (RecArrayToBitRecord r (n - 1))
+
+-- *** Lists of Records
+
+-- | Let type level lists also be records
+data
+ BitRecordOfList
+ (f :: IsA (foo :-> BitRecord))
+ (xs :: [foo])
+ :: IsA BitRecord
+
+type instance Eval (BitRecordOfList f xs) =
+ FoldMap BitRecordAppendFun 'EmptyBitRecord f xs
+
+type BitRecordAppendFun = Fun1 BitRecordAppendFun_
+data BitRecordAppendFun_ :: BitRecord -> IsA (BitRecord :-> BitRecord)
+type instance (BitRecordAppendFun_ l) $~ r = Append l r
+
+-- *** Maybe Record
+
+-- | Either use the value from @Just@ or return a 'EmptyBitRecord' value(types(kinds))
+data OptionalRecord :: Maybe BitRecord -> IsA BitRecord
+type instance Eval (OptionalRecord ('Just t)) = t
+type instance Eval (OptionalRecord 'Nothing) = 'EmptyBitRecord
+
+-- ** Field ADT
+
+-- | A family of bit fields.
+--
+-- A bit field always has a size, i.e. the number of bits it uses, as well as a
+-- term level value type and a type level value type. It also has an optional
+-- label, and an optional value assigned to it.
+data BitRecordField :: BitField rt st len -> Type
+
+-- | A bit record field with a number of bits
+data MkField t :: IsA (BitRecordField t)
+
+-- **** Setting a Label
+
+-- | A bit record field with a number of bits
+data LabelF :: Symbol -> IsA (BitRecordField t) -> IsA (BitRecordField t)
+
+-- | A field with a label assigned to it.
+type
+ (l :: Symbol) @:(f :: IsA (BitRecordField (t :: BitField rt (st :: stk) size)))
+ = (LabelF l f :: IsA (BitRecordField t))
+infixr 8 @:
+
+-- **** Assignment
+
+-- | A field with a value set at compile time.
+data (:=) :: forall st (t :: BitField rt st size) .
+ IsA (BitRecordField t)
+ -> st
+ -> IsA (BitRecordField t)
+infixl 7 :=
+
+-- | Types of this kind define the basic type of a 'BitRecordField'. Sure, this
+-- could have been an open type, but really, how many actual useful field types
+-- exist? Well, from a global perspective, uncountable infinite, but the focus
+-- of this library is to blast out bits over the network, using usual Haskell
+-- libraries, and hence, there is actually only very little reason to
+-- differentiate types of record fields, other than what low-level library
+-- function to apply and how to pretty print the field.
+data BitField
+ (runtimeRep :: Type)
+ (staticRep :: k)
+ (bitCount :: Nat)
+ where
+ MkFieldFlag :: BitField Bool Bool 1
+ MkFieldBits :: forall (n :: Nat) . BitField (B n) Nat n
+ MkFieldBitsXXL :: forall (n :: Nat) . BitField Integer Nat n
+ MkFieldU8 :: BitField Word8 Nat 8
+ MkFieldU16 :: BitField Word16 Nat 16
+ MkFieldU32 :: BitField Word32 Nat 32
+ MkFieldU64 :: BitField Word64 Nat 64
+ MkFieldI8 :: BitField Int8 SignedNat 8
+ MkFieldI16 :: BitField Int16 SignedNat 16
+ MkFieldI32 :: BitField Int32 SignedNat 32
+ MkFieldI64 :: BitField Int64 SignedNat 64
+ -- TODO refactor this MkFieldCustom, it caused a lot of trouble!
+ MkFieldCustom :: BitField rt st n
+
+type Flag = MkField 'MkFieldFlag
+type Field n = MkField ('MkFieldBits :: BitField (B n) Nat n)
+type FieldU8 = MkField 'MkFieldU8
+type FieldU16 = MkField 'MkFieldU16
+type FieldU32 = MkField 'MkFieldU32
+type FieldU64 = MkField 'MkFieldU64
+type FieldI8 = MkField 'MkFieldI8
+type FieldI16 = MkField 'MkFieldI16
+type FieldI32 = MkField 'MkFieldI32
+type FieldI64 = MkField 'MkFieldI64
+
+-- | A data type for 'Field' and 'MkFieldBits', that is internally a 'Word64'.
+-- It carries the number of relevant bits in its type.
+newtype B (size :: Nat) = B {unB :: Word64}
+ deriving (Read,Show,Num,Integral,Bits,FiniteBits,Eq,Ord,Bounded,Enum,Real)
+
+instance (PrintfArg Word64, n <= 64) => PrintfArg (B n) where
+ formatArg (B x) = formatArg x
+ parseFormat (B x) = parseFormat x
+
+-- | A signed field value.
+data SignedNat where
+ PositiveNat :: Nat -> SignedNat
+ NegativeNat :: Nat -> SignedNat
+
+-- *** Composed Fields
+
+-- | A Flag (1-bit) that is true if the type level maybe is 'Just'.
+type family FlagJust (a :: Maybe (v :: Type)) :: IsA (BitRecordField 'MkFieldFlag) where
+ FlagJust ('Just x) = Flag := 'True
+ FlagJust 'Nothing = Flag := 'False
+
+-- | A Flag (1-bit) that is true if the type level maybe is 'Nothing'.
+type family FlagNothing (a :: Maybe (v :: Type)) :: IsA (BitRecordField 'MkFieldFlag) where
+ FlagNothing ('Just x) = Flag := 'False
+ FlagNothing 'Nothing = Flag := 'True
+
+-- | An optional field in a bit record
+data MaybeField :: Maybe (IsA (BitRecordField t)) -> IsA BitRecord
+type instance Eval (MaybeField ('Just fld)) = 'BitRecordMember fld
+type instance Eval (MaybeField 'Nothing) = 'EmptyBitRecord
+
+-- | A 'BitRecordField' can be used as 'BitRecordMember'
+data RecordField :: IsA (BitRecordField t) -> IsA BitRecord
+type instance Eval (RecordField f) = 'BitRecordMember f
+
+-- | Calculate the size as a number of bits from a 'BitRecordField'
+type family BitRecordFieldSize (x :: IsA (BitRecordField t)) where
+ BitRecordFieldSize (x :: IsA (BitRecordField (t :: BitField rt st size))) = size
+
+
+-- * Field and Record PrettyType Instances
+
+-- | Render @rec@ to a pretty, human readable form. Internally this is a wrapper
+-- around 'ptShow' using 'PrettyRecord'.
+showARecord
+ :: forall proxy (rec :: IsA BitRecord) . PrettyTypeShow (PrettyRecord (Eval rec))
+ => proxy rec -> String
+showARecord _ = showPretty (Proxy :: Proxy (PrettyRecord (Eval rec)))
+
+-- | Render @rec@ to a pretty, human readable form. Internally this is a wrapper
+-- around 'ptShow' using 'PrettyRecord'.
+showRecord
+ :: forall proxy (rec :: BitRecord) . PrettyTypeShow (PrettyRecord rec)
+ => proxy rec -> String
+showRecord _ = showPretty (Proxy :: Proxy (PrettyRecord rec))
+
+type instance ToPretty (rec :: BitRecord) = PrettyRecord rec
+
+type family PrettyRecord (rec :: BitRecord) :: PrettyType where
+ PrettyRecord ('BitRecordMember m) = PrettyField m
+ PrettyRecord ' EmptyBitRecord = 'PrettyNewline
+ PrettyRecord ('BitRecordAppend l r) = PrettyRecord l <$$> PrettyRecord r
+
+type instance ToPretty (f :: IsA (BitRecordField t)) = PrettyField f
+
+type family PrettyField (f :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: Type) (size :: Nat)))) :: PrettyType where
+ PrettyField (MkField t) = PrettyFieldType t
+ PrettyField ((f :: IsA (BitRecordField t)) := v) =
+ PrettyField f <+> PutStr ":=" <+> PrettyFieldValue t v
+ PrettyField (LabelF l f) = l <:> PrettyField f
+
+type family PrettyFieldType (t :: BitField (rt :: Type) (st :: Type) (size :: Nat)) :: PrettyType where
+ PrettyFieldType ('MkFieldFlag) = PutStr "boolean"
+ PrettyFieldType ('MkFieldBits :: BitField (B (s :: Nat)) Nat s) = PutStr "bits" <++> PrettyParens (PutNat s)
+ PrettyFieldType ('MkFieldBitsXXL :: BitField Integer Nat (s :: Nat)) = PutStr "bits-XXL" <++> PrettyParens (PutNat s)
+ PrettyFieldType ('MkFieldU64) = PutStr "U64"
+ PrettyFieldType ('MkFieldU32) = PutStr "U32"
+ PrettyFieldType ('MkFieldU16) = PutStr "U16"
+ PrettyFieldType ('MkFieldU8) = PutStr "U8"
+ PrettyFieldType ('MkFieldI64) = PutStr "I64"
+ PrettyFieldType ('MkFieldI32) = PutStr "I32"
+ PrettyFieldType ('MkFieldI16) = PutStr "I16"
+ PrettyFieldType ('MkFieldI8) = PutStr "I8"
+ PrettyFieldType ('MkFieldCustom :: BitField rt ct size) = ToPretty rt <++> PrettyParens (PutNat size)
+
+type family PrettyFieldValue (t :: BitField (rt :: Type) (st :: Type) (size :: Nat)) (v :: st) :: PrettyType where
+ PrettyFieldValue ('MkFieldFlag) 'True = PutStr "yes"
+ PrettyFieldValue ('MkFieldFlag) 'False = PutStr "no"
+ PrettyFieldValue ('MkFieldBits :: BitField (B (s :: Nat)) Nat s) v =
+ 'PrettyNat 'PrettyUnpadded ('PrettyPrecision s) 'PrettyBit v <+> PrettyParens (("hex" <:> PutHex v) <+> ("dec" <:> PutNat v))
+ PrettyFieldValue ('MkFieldU8) v = ("hex" <:> PutHex8 v) <+> PrettyParens ("dec" <:> PutNat v)
+ PrettyFieldValue ('MkFieldU16) v = ("hex" <:> PutHex16 v) <+> PrettyParens ("dec" <:> PutNat v)
+ PrettyFieldValue ('MkFieldU32) v = ("hex" <:> PutHex32 v) <+> PrettyParens ("dec" <:> PutNat v)
+ PrettyFieldValue ('MkFieldU64) v = ("hex" <:> PutHex64 v) <+> PrettyParens ("dec" <:> PutNat v)
+ PrettyFieldValue ('MkFieldI8) ('PositiveNat v) = ("hex" <:> (PutStr "+" <++> PutHex8 v)) <+> PrettyParens ("dec" <:> (PutStr "+" <++> PutNat v))
+ PrettyFieldValue ('MkFieldI16) ('PositiveNat v) = ("hex" <:> (PutStr "+" <++> PutHex16 v)) <+> PrettyParens ("dec" <:> (PutStr "+" <++> PutNat v))
+ PrettyFieldValue ('MkFieldI32) ('PositiveNat v) = ("hex" <:> (PutStr "+" <++> PutHex32 v)) <+> PrettyParens ("dec" <:> (PutStr "+" <++> PutNat v))
+ PrettyFieldValue ('MkFieldI64) ('PositiveNat v) = ("hex" <:> (PutStr "+" <++> PutHex64 v)) <+> PrettyParens ("dec" <:> (PutStr "+" <++> PutNat v))
+ PrettyFieldValue ('MkFieldI8) ('NegativeNat v) = ("hex" <:> (PutStr "-" <++> PutHex8 v)) <+> PrettyParens ("dec" <:> (PutStr "-" <++> PutNat v))
+ PrettyFieldValue ('MkFieldI16) ('NegativeNat v) = ("hex" <:> (PutStr "-" <++> PutHex16 v)) <+> PrettyParens ("dec" <:> (PutStr "-" <++> PutNat v))
+ PrettyFieldValue ('MkFieldI32) ('NegativeNat v) = ("hex" <:> (PutStr "-" <++> PutHex32 v)) <+> PrettyParens ("dec" <:> (PutStr "-" <++> PutNat v))
+ PrettyFieldValue ('MkFieldI64) ('NegativeNat v) = ("hex" <:> (PutStr "-" <++> PutHex64 v)) <+> PrettyParens ("dec" <:> (PutStr "-" <++> PutNat v))
+ PrettyFieldValue ('MkFieldCustom :: BitField rt ct size) v = PrettyCustomFieldValue rt ct size v
+
+type family PrettyCustomFieldValue (rt :: Type) (st :: Type) (size :: Nat) (v :: st) :: PrettyType
diff --git a/src/Data/Type/BitRecords/Enum.hs b/src/Data/Type/BitRecords/Enum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/Enum.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Type.BitRecords.Enum where
+
+import Data.Type.BitRecords.Core
+import Data.Type.BitRecords.Builder.BitBuffer
+import Data.FunctionBuilder
+import Data.Type.BitRecords.Builder.LazyByteStringBuilder
+import Data.Proxy
+import Data.Word
+import Data.Kind ( Type )
+import GHC.TypeLits
+import Data.Kind.Extra
+import Data.Type.Pretty
+
+-- * BitRecordFields containing /enum/-like types
+
+-- | Wrapper around a type that can be represented as a short number, indexing
+-- the clauses of the (sum) type.
+data EnumOf enum where
+ MkEnumOf
+ ::IsAn (EnumField enum size)
+ -> IsA (FieldValue label enum)
+ -> BitRecord
+ -> EnumOf enum
+
+type BitRecordOfEnum (e :: IsAn (EnumOf enum))
+ = (RenderEnumOf (Eval e) :: BitRecord)
+
+type family RenderEnumOf (e :: EnumOf enum) :: BitRecord where
+ RenderEnumOf ('MkEnumOf mainField mainFieldVal extra) =
+ (BitRecordFieldOfEnumField mainField) :~ mainFieldVal .+: extra
+
+-- | Physical representation of an 'EnumOf', this is an abstract type
+data EnumField (enum :: Type) (size :: Nat)
+
+type BitRecordFieldOfEnumField (x :: IsA (EnumField e s))
+ = MkField ( 'MkFieldCustom :: BitField (EnumValue e) e s)
+
+-- | A fixed size 'EnumField'
+data FixedEnum (enum :: Type) (size :: Nat) :: IsAn (EnumField enum size)
+
+-- | An enum that can be extended with an additional 'BitRecordField', following
+-- the regular enum field; the extension is optional, i.e. only if the
+-- /regular/ field contains a special value (e.g. 0xff).
+data ExtEnum (enum :: Type)
+ (size :: Nat)
+ (extInd :: enum)
+ (extField :: IsA (BitRecordField (t :: BitField rt0 (st0 :: k0) len0)))
+ :: IsAn (EnumField enum size)
+
+-- | Create an 'EnumOf' that sets an enum to a static value.
+data SetEnum (l :: Symbol) (ef :: IsAn (EnumField enum size)) (v :: enum) :: IsAn (EnumOf enum)
+
+type instance Eval (SetEnum (l :: Symbol) (ei :: IsAn (EnumField enum size)) value) =
+ 'MkEnumOf
+ ei
+ (StaticFieldValue l value)
+ 'EmptyBitRecord
+
+-- | Create an 'EnumOf' that sets the enum to a runtime value.
+data EnumParam
+ (label :: Symbol)
+ (ef :: IsAn (EnumField (enum :: Type) (size :: Nat)))
+ :: IsAn (EnumOf enum)
+type instance Eval (EnumParam label (ei :: IsAn (EnumField enum size))) =
+ 'MkEnumOf
+ ei
+ (RuntimeFieldValue label)
+ 'EmptyBitRecord
+
+-- | Create an 'EnumOf' that sets an extended enum to an extended static value.
+data SetEnumAlt (l :: Symbol) (ef :: IsAn (EnumField (enum :: Type) (size :: Nat))) (v :: k)
+ :: IsAn (EnumOf enum)
+
+type instance Eval (SetEnumAlt (l :: Symbol) (ExtEnum enum size extInd extField) value) =
+ -- TODO maybe enrich the demoteRep type of 'MkField??
+ 'MkEnumOf
+ (ExtEnum enum size extInd extField)
+ (StaticFieldValue l extInd)
+ ('BitRecordMember (extField := value))
+
+type instance Eval (SetEnumAlt (l :: Symbol) (FixedEnum enum size) value) =
+ TypeError ('Text "Cannot assign an 'extended' value to the 'FixedEnum' "
+ ':<>: 'ShowType enum)
+
+-- | Create an 'EnumOf' that sets the extended enum to a runtime value.
+data EnumParamAlt
+ (label :: Symbol)
+ (ef :: IsAn (EnumField (enum :: Type) (size :: Nat)))
+ :: IsAn (EnumOf enum)
+
+type instance Eval (EnumParamAlt label (ExtEnum enum size extInd extField)) =
+ 'MkEnumOf
+ (ExtEnum enum size extInd extField)
+ (StaticFieldValue label extInd)
+ ('BitRecordMember (extField :~ RuntimeFieldValue label))
+
+type instance Eval (EnumParamAlt label (FixedEnum enum size)) =
+ TypeError ('Text "Cannot assign an extension value to the FixedEnum "
+ ':<>: 'ShowType enum)
+
+-- ** Composing BitRecords with enum fields
+
+-- | Return the numeric /index/ of an entry in a table. This emulates 'fromEnum' a bit.
+type family FromEnum enum (entry :: enum) :: Nat
+
+-- | An enum value supplied at runtime.
+data EnumValue e where
+ MkEnumValue ::KnownNat (FromEnum e v) => Proxy (v :: e) -> EnumValue e
+
+-- | Create an 'EnumValue' from a 'Proxy'. TODO remove?
+enumValueProxy :: KnownNat (FromEnum e v) => Proxy (v :: e) -> EnumValue e
+enumValueProxy = MkEnumValue
+
+fromEnumValue :: EnumValue e -> Word64
+fromEnumValue (MkEnumValue p) = enumValue p
+ where
+ enumValue
+ :: forall proxy (v :: enum)
+ . KnownNat (FromEnum enum v)
+ => proxy v
+ -> Word64
+ enumValue _ = fromIntegral (natVal (Proxy @(FromEnum enum v)))
+
+instance
+ forall (size :: Nat) r e (v :: e) (f :: IsA (BitRecordField ('MkFieldCustom :: BitField (EnumValue e) e size))) .
+ (KnownNat (FromEnum e v), KnownChunkSize size) =>
+ BitStringBuilderHoley (Proxy (f := v)) r where
+ bitStringBuilderHoley _ = immediate
+ (appendBitString
+ (bitStringProxyLength (Proxy @size)
+ (fromIntegral (natVal (Proxy @(FromEnum e v))))
+ )
+ )
+
+instance
+ forall (size :: Nat) r e .
+ (KnownChunkSize size) =>
+ BitStringBuilderHoley (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size))) r
+ where
+ type ToBitStringBuilder (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size))) r =
+ EnumValue e -> r
+ bitStringBuilderHoley _ = addParameter
+ (appendBitString . bitStringProxyLength (Proxy @size) . fromEnumValue)
+
+type instance ToPretty (EnumValue e) = PutStr "<>"
+type instance PrettyCustomFieldValue (EnumValue e) e size (v :: e) =
+ PutNat (FromEnum e v) <+> ("hex" <:> PutHex (FromEnum e v)) <+> ("bin" <:> PutBits (FromEnum e v))
diff --git a/src/Data/Type/BitRecords/Sized.hs b/src/Data/Type/BitRecords/Sized.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/Sized.hs
@@ -0,0 +1,73 @@
+-- | Size Fields
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Type.BitRecords.Sized
+ ( type Sized, type Sized8, type Sized16, type Sized32, type Sized64
+ , type SizedField, type SizedField8, type SizedField16, type SizedField32, type SizedField64
+ , type SizeFieldValue)
+ where
+
+import Data.Type.Pretty
+import Data.Type.BitRecords.Core
+import Data.Word
+import GHC.TypeLits
+import Data.Kind.Extra
+import Data.Kind (type Type)
+
+-- | A record with a /size/ member, and a nested record that can be counted
+-- using 'SizeFieldValue'.
+data Sized
+ (sf :: IsA (BitRecordField (t :: BitField (rt :: Type) Nat (size :: Nat))))
+ (r :: BitRecord)
+ :: IsA BitRecord
+type instance Eval (Sized sf r) =
+ "size" @: sf := SizeFieldValue r .+: r
+
+-- | A convenient alias for a 'Sized' with an 'FieldU8' size field.
+type Sized8 t = Sized FieldU8 t
+
+-- | A convenient alias for a 'Sized' with an 'FieldU16' size field.
+type Sized16 t = Sized FieldU16 t
+
+-- | A convenient alias for a 'Sized' with an 'FieldU32' size field.
+type Sized32 t = Sized FieldU32 t
+
+-- | A convenient alias for a 'Sized' with an 'FieldU64' size field.
+type Sized64 t = Sized FieldU64 t
+
+-- | A record with a /size/ member, and a nested field that can be counted
+-- using 'SizeFieldValue'.
+data SizedField
+ (sf :: IsA (BitRecordField (t :: BitField (rt :: Type) Nat (size :: Nat))))
+ (r :: IsA (BitRecordField (u :: BitField (rt' :: Type) (st' :: k0) (len0 :: Nat))))
+ :: IsA BitRecord
+type instance Eval (SizedField sf r) =
+ "size" @: sf := SizeFieldValue r .+. r
+
+-- | A convenient alias for a 'SizedField' with an 'FieldU8' size field.
+type SizedField8 t = SizedField FieldU8 t
+
+-- | A convenient alias for a 'SizedField' with an 'FieldU16' size field.
+type SizedField16 t = SizedField FieldU16 t
+
+-- | A convenient alias for a 'SizedField' with an 'FieldU32' size field.
+type SizedField32 t = SizedField FieldU32 t
+
+-- | A convenient alias for a 'SizedField' with an 'FieldU64' size field.
+type SizedField64 t = SizedField FieldU64 t
+
+-- | For something to be augmented by a size field there must be an instance of
+-- this family to generate the value of the size field, e.g. by counting the
+-- elements.
+type family SizeFieldValue (c :: k) :: Nat
+
+type instance SizeFieldValue (b :: BitRecord) = BitRecordMemberCount b
+type instance SizeFieldValue (f := v) = SizeFieldValue v
+type instance SizeFieldValue (LabelF l f) = SizeFieldValue f
+type instance SizeFieldValue (MkField (t :: BitField (rt:: Type) (st::k) (size::Nat))) = size
+
+type family PrintHexIfPossible t (s :: Nat) :: PrettyType where
+ PrintHexIfPossible Word64 s = PutHex64 s
+ PrintHexIfPossible Word32 s = PutHex32 s
+ PrintHexIfPossible Word16 s = PutHex16 s
+ PrintHexIfPossible Word8 s = PutHex8 s
+ PrintHexIfPossible x s = TypeError ('Text "Invalid size field type: " ':<>: 'ShowType x)
diff --git a/src/Data/Type/BitRecords/SizedString.hs b/src/Data/Type/BitRecords/SizedString.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Type/BitRecords/SizedString.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Type.BitRecords.SizedString
+ (SizedString()
+ ,ASizedString()
+ ,utf8)
+ where
+
+import Data.Type.BitRecords.Core
+import Data.Type.BitRecords.Sized
+import Data.FunctionBuilder
+import Data.Type.BitRecords.Builder.LazyByteStringBuilder
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Quote as TH
+import GHC.TypeLits
+import Data.Type.Pretty
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
+import Data.Proxy
+import Data.Kind (type Type)
+import Data.Kind.Extra
+
+-- TODO Refactor
+
+-- * String Fields
+
+-- | A type level symbol paired with a type level length, that determines how
+-- many characters of the symbol may be used. The first parameter defines the
+-- length field.
+type SizedString str bytes =
+ MkField ('MkFieldCustom :: BitField ASizedString ASizedString (8 * bytes)) := 'MkASizedString str bytes
+
+data ASizedString where
+ MkASizedString :: Symbol -> Nat -> ASizedString
+
+type instance
+ SizeFieldValue ('MkASizedString str byteCount) = byteCount
+
+type instance
+ ToPretty ASizedString = PutStr "utf-8"
+
+type instance PrettyCustomFieldValue ASizedString ASizedString s sr =
+ ToPretty sr
+
+type instance
+ ToPretty ('MkASizedString str byteCount) =
+ PrettySurrounded (PutStr "<<") (PutStr ">>") (PutStr str)
+ <+> PutStr "[" <++> PutNat byteCount <++> PutStr " Bytes]"
+
+-- | Create a 'SizedString' from a utf-8 string
+utf8 :: TH.QuasiQuoter
+utf8 = TH.QuasiQuoter undefined undefined mkSizedStr undefined
+ where mkSizedStr :: String -> TH.Q TH.Type
+ mkSizedStr str =
+ do let strT = TH.LitT (TH.StrTyLit str)
+ byteCount =
+ fromIntegral (B.length (E.encodeUtf8 (T.pack str)))
+ byteCountT = TH.LitT (TH.NumTyLit byteCount)
+ return $
+ TH.PromotedT ''SizedString `TH.AppT` strT `TH.AppT` byteCountT
+
+instance
+ forall (size :: Nat)
+ (str :: Symbol)
+ (bytes :: Nat)
+ (r :: Type)
+ (f :: IsA (BitRecordField ('MkFieldCustom :: BitField ASizedString ASizedString size))) .
+ (KnownSymbol str)
+ => BitStringBuilderHoley (Proxy (f := 'MkASizedString str bytes)) r
+ where
+ bitStringBuilderHoley _ =
+ immediate (appendStrictByteString
+ (E.encodeUtf8 (T.pack (symbolVal (Proxy @str)))))
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,13 @@
+resolver: lts-13.3
+
+packages:
+- '.'
+
+extra-deps:
+- pretty-types-0.3.0.1
+- type-spec-0.4.0.0
+- function-builder-0.1.0.1
+
+flags: {}
+
+extra-package-dbs: []